diff --git a/.Rbuildignore b/.Rbuildignore index be973333f..ed2d16c7a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -10,5 +10,6 @@ ^.claude ^data-raw$ ^docs$ +^dev$ ^air.toml ^inst/prototype diff --git a/.github/environment/pixi.toml b/.github/environment/pixi.toml index 76ed456d5..3bb6da8c2 100644 --- a/.github/environment/pixi.toml +++ b/.github/environment/pixi.toml @@ -25,14 +25,18 @@ dependencies = {"r-base" = "4.5.*"} [environments] r45 = {features = ["r45"]} +[target.linux-64.dependencies] +"gcc" = "*" + [dependencies] "air" = "*" "bioconductor-bioccheck" = "*" "bioconductor-plyranges" = "*" "bioconductor-tidysummarizedexperiment" = "*" -"gcc" = "*" "r-covr" = "*" +"r-decor" = "*" "r-devtools" = "*" +"r-goodpractice" = "*" "r-knitr" = "*" "r-lintr" = "*" "r-markdown" = "*" diff --git a/.github/recipe/recipe.yaml b/.github/recipe/recipe.yaml index b294c9095..99b9fa5f6 100644 --- a/.github/recipe/recipe.yaml +++ b/.github/recipe/recipe.yaml @@ -41,6 +41,7 @@ requirements: - r-base - r-bglr - r-bigsnpr + - r-checkmate - r-coda - r-coloc - r-colocboost @@ -48,7 +49,6 @@ requirements: - r-cpp11 - r-cpp11armadillo - r-ctwas - - r-decor - r-dplyr - r-flashier - r-fsusier @@ -109,6 +109,7 @@ requirements: - r-base - r-bglr - r-bigsnpr + - r-checkmate - r-coda - r-coloc - r-colocboost @@ -116,7 +117,6 @@ requirements: - r-cpp11 - r-cpp11armadillo - r-ctwas - - r-decor - r-dplyr - r-flashier - r-fsusier diff --git a/DESCRIPTION b/DESCRIPTION index 4459d282f..74440d4e1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,6 +28,7 @@ Imports: BiocGenerics, BiocParallel, Biostrings, + checkmate, coloc, colocboost, DelayedArray, @@ -136,20 +137,25 @@ Collate: 'LdEigen.R' 'LdScore.R' 'MashPrior.R' + 'MethodOptions.R' + 'MethodParam.R' 'QtlDataset.R' 'MultiStudyQtlDataset.R' 'QtlFineMappingResult.R' 'SldscData.R' 'causalInferencePipeline.R' - 'colocPipeline.R' + 'gwasSumStats.R' 'qtlSumStats.R' + 'fineMappingPipeline.R' + 'ld.R' + 'colocPipeline.R' 'colocboostPipeline.R' 'cpp11.R' 'crossValidation.R' 'ctwasPipeline.R' + 'ctwasWrapper.R' + 'enloc.R' 'exampleData.R' - 'gwasSumStats.R' - 'fineMappingPipeline.R' 'fineMappingRow.R' 'fineMappingWrappers.R' 'genotypeIo.R' @@ -157,14 +163,13 @@ Collate: 'h2EstimationWrappers.R' 'jointEngine.R' 'jointSpecification.R' - 'ld.R' 'sumstatsQc.R' 'variantId.R' 'manifestLoaders.R' 'mashPipeline.R' 'mashWrapper.R' 'overlapTopLoci.R' - 'pvalCombine.R' + 'pvalCombineWrappers.R' 'qtlAssociationPostprocess.R' 'qtlEnrichmentPipeline.R' 'regularizedRegressionWrappers.R' diff --git a/NAMESPACE b/NAMESPACE index 09b8093d3..31edc915f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,22 +14,105 @@ S3method(postprocessFinemappingFit,susie) S3method(postprocessFinemappingFit,susieInf) S3method(postprocessFinemappingFit,susieRss) export(AnnotationMatrix) +export(AspuOptions) +export(BglrOptions) +export(BoundaryMergeParam) export(ColocBoostResult) +export(ColocLbfFilterParam) +export(ColocOptions) +export(ColocPriorParam) export(ColocResult) +export(ColocboostOptions) +export(CorShrinkOptions) +export(CovCanonicalOptions) +export(CovEdOptions) +export(CovFlashOptions) +export(CovMcdOptions) +export(CovPcaOptions) +export(CovUdrOptions) +export(CredibleSetParam) +export(CrossValidationParam) +export(CtwasOptions) +export(CtwasPriorParam) export(CtwasResult) export(CtwasResultEntry) +export(DentistParam) +export(DprOptions) +export(EnsembleParam) +export(FineMappingMethodsParam) +export(FsusieOptions) +export(GbjOmniOptions) +export(GbjOptions) +export(GenotypeFilterParam) +export(GlmnetOptions) +export(GwasFineMappingParam) export(GwasFineMappingResult) export(GwasSumStats) +export(KrigingOptions) +export(L0learnOptions) +export(LassosumOptions) export(LdData) export(LdEigen) +export(LdPruningOptions) export(LdScore) +export(MashComponentParam) +export(MashCorEmOptions) +export(MashCorSimpleOptions) +export(MashDataOptions) +export(MashOptions) +export(MashPosteriorOptions) export(MashPrior) +export(MashPriorParam) +export(MrParam) +export(MrashOptions) +export(MrashRssOptions) +export(MrmashCanonicalCovsOptions) +export(MrmashExpandCovsOptions) +export(MrmashOptions) +export(MrmashPriorParam) +export(MrmashRssOptions) export(MultiStudyQtlDataset) +export(MvsusieOptions) +export(MvsusieRssOptions) +export(NcvregOptions) +export(PanelFilterParam) +export(PenalizedRssOptions) +export(PlinkQcOptions) +export(PoolrOptions) +export(PrsCsOptions) +export(PvalMethodsParam) +export(QggOptions) export(QtlDataset) +export(QtlEnrichmentParam) export(QtlFineMappingResult) export(QtlSumStats) +export(QvalueOptions) +export(RaissParam) +export(RelatednessColumnsParam) +export(RelatednessPruningParam) +export(ResidualizationParam) +export(RmaOptions) +export(SdprOptions) +export(SerOptions) +export(SignalScreenParam) +export(SlalomParam) export(SldscData) +export(SumstatsCleaningParam) +export(SumstatsFilterParam) +export(SusieAshOptions) +export(SusieAshRssOptions) +export(SusieInfOptions) +export(SusieInfRssOptions) +export(SusieOptions) +export(SusieRssControlOptions) +export(SusieRssOptions) +export(SusieRssParam) export(TwasWeights) +export(TwasWeightsMethodsParam) +export(UdFitOptions) +export(UdInitOptions) +export(VariantPruningParam) +export(WeightSelectionParam) export(asCtwasResult) export(asGranges) export(assembleCtwasInputs) @@ -59,7 +142,6 @@ export(combineQtlSumStats) export(combineTwasWeights) export(computeCoefficientsGlasso) export(computeCovDiag) -export(computeCovFlash) export(computeCsCorrelation) export(computeCsTables) export(computeLd) @@ -76,8 +158,9 @@ export(dprWeights) export(effectiveN) export(enetWeights) export(enforceDesignFullRank) +export(enlocClusterProbabilities) export(ensembleWeights) -export(estCtwasParam) +export(estCtwasGroupPriors) export(estimateH2) export(estimateSparsity) export(extractCsInfo) @@ -101,6 +184,7 @@ export(fsusieCredibleBand) export(fsusieGetCs) export(fsusieWeights) export(fsusieWrapper) +export(getAddSusieInf) export(getAf) export(getAnnotCols) export(getAnnotData) @@ -116,16 +200,20 @@ export(getColocVariants) export(getComputingTime) export(getContexts) export(getCorrelation) +export(getCoverage) +export(getCredibleSetArgs) export(getCredibleSetSummary) export(getCs) -export(getCtwasParam) +export(getCtwasGroupPriors) export(getCvFits) export(getCvResult) export(getDataType) export(getEigenList) export(getEnrichment) +export(getFineMappingMethods) export(getFineMappingResult) export(getFinemap) +export(getFitRetention) export(getFits) export(getFrqData) export(getFullFit) @@ -136,27 +224,34 @@ export(getH2) export(getH2Se) export(getImissCutoff) export(getInSample) +export(getIncludeAllCs) export(getIntercept) export(getInterceptSe) export(getKeepIndel) export(getKeepVariants) +export(getL) export(getLbf) export(getLdBlocks) export(getLdMatrixList) export(getLdScoreWeights) export(getLdScores) export(getLdSketch) +export(getLgreedy) export(getLocal) export(getMacCutoff) export(getMaf) export(getMafCutoff) export(getMarginalEffects) +export(getMedianAbsCorr) export(getMethodNames) +export(getMinAbsCorr) export(getMixtureWeights) export(getN) export(getNRef) export(getNSnps) export(getP) +export(getPanelFilterArgs) +export(getPerCsColumns) export(getPhenotypeCovariates) export(getPhenotypes) export(getPip) @@ -170,9 +265,12 @@ export(getRegionVcp) export(getResidualizedGenotypes) export(getResidualizedPhenotypes) export(getRetainedMass) +export(getRssArgs) export(getScaleResiduals) export(getScoreStats) export(getSe) +export(getSecondaryCoverage) +export(getSignalCutoff) export(getSignificantQtls) export(getSnpIdx) export(getStandardized) @@ -276,6 +374,20 @@ export(scoreFromCs) export(screenCtwasRegions) export(sdpr) export(sdprWeights) +export(serWeights) +export(setAddSusieInf) +export(setCoverage) +export(setCredibleSetArgs) +export(setFineMappingMethods) +export(setFitRetention) +export(setIncludeAllCs) +export(setMedianAbsCorr) +export(setMinAbsCorr) +export(setPanelFilterArgs) +export(setPerCsColumns) +export(setRssArgs) +export(setSecondaryCoverage) +export(setSignalCutoff) export(slalom) export(sldscPostprocessingPipeline) export(sldscSubsetMeta) @@ -299,13 +411,24 @@ export(updateMashModelCov) export(waldTestPval) export(writeSumStatsVcf) exportClasses(AnnotationMatrix) +exportClasses(BoundaryMergeParam) exportClasses(ColocBoostResult) +exportClasses(ColocLbfFilterParam) +exportClasses(ColocPriorParam) exportClasses(ColocResult) exportClasses(ColocResultBase) +exportClasses(CredibleSetParam) +exportClasses(CrossValidationParam) +exportClasses(CtwasPriorParam) exportClasses(CtwasResult) exportClasses(CtwasResultEntry) +exportClasses(DentistParam) +exportClasses(EnsembleParam) +exportClasses(FineMappingMethodsParam) exportClasses(FineMappingResultBase) exportClasses(FineMappingRow) +exportClasses(GenotypeFilterParam) +exportClasses(GwasFineMappingParam) exportClasses(GwasFineMappingResult) exportClasses(GwasSumStats) exportClasses(H2Estimate) @@ -313,21 +436,45 @@ exportClasses(LdData) exportClasses(LdEigen) exportClasses(LdScore) exportClasses(LdStatistic) +exportClasses(MashComponentParam) exportClasses(MashPrior) +exportClasses(MashPriorParam) +exportClasses(MethodOptions) +exportClasses(MethodParam) +exportClasses(MethodsSelectionParam) +exportClasses(MrParam) +exportClasses(MrmashPriorParam) exportClasses(MultiStudyQtlDataset) +exportClasses(PanelFilterParam) +exportClasses(PvalMethodsParam) exportClasses(QtlDataset) +exportClasses(QtlEnrichmentParam) exportClasses(QtlFineMappingResult) exportClasses(QtlSumStats) +exportClasses(RaissParam) exportClasses(RangedTupleList) +exportClasses(RelatednessColumnsParam) +exportClasses(RelatednessPruningParam) +exportClasses(ResidualizationParam) +exportClasses(SignalScreenParam) +exportClasses(SlalomParam) exportClasses(SldscData) exportClasses(SumStatsBase) +exportClasses(SumstatsCleaningParam) +exportClasses(SumstatsFilterParam) +exportClasses(SusieRssParam) exportClasses(TwasWeights) +exportClasses(TwasWeightsMethodsParam) exportClasses(TwasWeightsRow) +exportClasses(VariantPruningParam) +exportClasses(WeightSelectionParam) exportMethods("$") exportMethods("$<-") exportMethods("[") +exportMethods("[[") exportMethods("[[<-") exportMethods(as.data.frame) +exportMethods(as.list) exportMethods(bindROWS) exportMethods(colnames) exportMethods(colocboostPipeline) @@ -352,7 +499,7 @@ exportMethods(getContexts) exportMethods(getCorrelation) exportMethods(getCredibleSetSummary) exportMethods(getCs) -exportMethods(getCtwasParam) +exportMethods(getCtwasGroupPriors) exportMethods(getCvFits) exportMethods(getCvResult) exportMethods(getDataType) @@ -430,8 +577,10 @@ exportMethods(getXvarCutoff) exportMethods(getZ) exportMethods(hasGenotypes) exportMethods(intersectVariants) +exportMethods(length) exportMethods(longForm) exportMethods(nSnps) +exportMethods(names) exportMethods(ncol) exportMethods(nrow) exportMethods(overlapTopLoci) @@ -447,6 +596,8 @@ exportMethods(writeSumStatsVcf) importClassesFrom(GenomicRanges,GRanges) importClassesFrom(MultiAssayExperiment,MultiAssayExperiment) importClassesFrom(S4Vectors,DataFrame) +importClassesFrom(S4Vectors,SimpleList) +importClassesFrom(S4Vectors,character_OR_NULL) importClassesFrom(SummarizedExperiment,RangedSummarizedExperiment) importFrom(BiocGenerics, colnames, @@ -457,7 +608,7 @@ importFrom(BiocParallel, MulticoreParam, bplapply, bpparam, - bpworkers + multicoreWorkers ) importFrom(Biostrings, DNAStringSet, @@ -486,11 +637,13 @@ importFrom(Rsamtools, importFrom(S4Arrays,extract_array) importFrom(S4Vectors, "mcols<-", + "metadata<-", DataFrame, SimpleList, bindROWS, endoapply, mcols, + metadata, queryHits, subjectHits ) @@ -500,6 +653,41 @@ importFrom(SummarizedExperiment, rowRanges ) importFrom(archive,archive_read) +importFrom(checkmate, + assert, + assertCharacter, + assertClass, + assertCount, + assertDataFrame, + assertDirectoryExists, + assertFileExists, + assertFlag, + assertInt, + assertList, + assertLogical, + assertMatrix, + assertMultiClass, + assertNames, + assertNumber, + assertNumeric, + assertScalar, + assertString, + assertSubset, + assertVector, + checkAtomicVector, + checkCharacter, + checkClass, + checkDataFrame, + checkFileExists, + checkList, + checkMatrix, + checkNames, + checkNull, + checkNumeric, + checkString, + checkSubset, + makeAssertCollection +) importFrom(dplyr, across, add_count, @@ -533,6 +721,7 @@ importFrom(magrittr,is_in) importFrom(matrixStats,colSds) importFrom(metafor,rma) importFrom(methods, + "slot<-", as, is, new, @@ -540,27 +729,37 @@ importFrom(methods, setGeneric, setMethod, show, + slot, + slotNames, validObject ) importFrom(purrr, compact, + detect, + discard, exec, imap, keep, + list_assign, list_c, list_flatten, list_modify, list_rbind, map, map2, + map2_lgl, map_chr, map_dbl, map_dfr, map_int, map_lgl, partial, + possibly, reduce, - set_names + set_names, + walk, + walk2, + zap ) importFrom(quadprog,solve.QP) importFrom(readr, @@ -574,8 +773,11 @@ importFrom(rlang, .data, abort, arg_match, + arg_match0, cnd_signal, inform, + is_named, + try_fetch, warn ) importFrom(stats, @@ -583,7 +785,6 @@ importFrom(stats, coef, complete.cases, cor, - cov2cor, cutree, hclust, lm, @@ -653,7 +854,6 @@ importFrom(tools, importFrom(utils, combn, head, - modifyList, read.table, tail ) diff --git a/R/AllClasses.R b/R/AllClasses.R index 80c6aedb2..8b8a15b56 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -25,7 +25,7 @@ NULL # is only true until someone puts something else in it. #' @importClassesFrom SummarizedExperiment RangedSummarizedExperiment setClassUnion( - "LdSketchOrNULL", + "LdSketch_OR_NULL", c("RangedSummarizedExperiment", "NULL") ) @@ -65,13 +65,9 @@ setClassUnion("LdCorrelation", c("matrix", "list", "NULL")) # constructor coerces to integer, so a caller may pass doubles. setClassUnion("LdSnpIndex", c("integer", "NULL")) -# Block boundaries, as ranges or as a table. Not nullable: every LdData is -# built for some block, and the constructor has always required it. +# Mixing proportions, one per panel, when `genotypeHandle` is a list. #' @importClassesFrom GenomicRanges GRanges #' @importClassesFrom S4Vectors DataFrame -setClassUnion("LdBlockMetadata", c("GRanges", "data.frame", "DataFrame")) - -# Mixing proportions, one per panel, when `genotypeHandle` is a list. setClassUnion("LdMixtureWeights", c("numeric", "NULL")) # ============================================================================= @@ -115,7 +111,7 @@ setClass( "SumStatsBase", contains = c("VIRTUAL", "RangedTupleList"), representation( - ldSketch = "LdSketchOrNULL", + ldSketch = "LdSketch_OR_NULL", qcInfo = "list" ) ) @@ -192,8 +188,7 @@ setClass( if (length(GenomeInfoDb::seqlevels(object)) == 0L) { return(NULL) } - build <- unique(GenomeInfoDb::genome(object)) - build <- build[!is.na(build)] + build <- discard(unique(GenomeInfoDb::genome(object)), is.na) if (length(build) == 1L && str_length(build) > 0L) { return(NULL) } @@ -212,13 +207,12 @@ setClass( #' data(qtlSumStatsExample) #' getGenome(qtlSumStatsExample) #' @export -setMethod("getGenome", "SumStatsBase", function(x, ...) { +setMethod("getGenome", "SumStatsBase", function(x) { # The build lives in seqinfo, exactly as it does on LdStatistic: a # GRangesList already has somewhere to keep it, and a parallel `genome` # slot went stale against it (getGenome() said hg19 while genome(x) said # NA, so every Bioconductor path that reads genome(x) saw nothing). - build <- unique(GenomeInfoDb::genome(x)) - build <- build[!is.na(build)] + build <- discard(unique(GenomeInfoDb::genome(x)), is.na) if (length(build) == 0L) NA_character_ else build[[1L]] }) @@ -227,14 +221,14 @@ setMethod("getGenome", "SumStatsBase", function(x, ...) { #' data(qtlSumStatsExample) #' getQcInfo(qtlSumStatsExample) #' @export -setMethod("getQcInfo", "SumStatsBase", function(x, ...) x@qcInfo) +setMethod("getQcInfo", "SumStatsBase", function(x) x@qcInfo) #' @rdname getQcDiagnostics #' @examples #' data(qtlSumStatsExample) #' getQcDiagnostics(qtlSumStatsExample) #' @export -setMethod("getQcDiagnostics", "SumStatsBase", function(x, entry = 1L, ...) { +setMethod("getQcDiagnostics", "SumStatsBase", function(x, entry = 1L) { qc <- x@qcInfo if (length(qc) == 0L) { return(NULL) @@ -271,7 +265,7 @@ setMethod("getQcDiagnostics", "SumStatsBase", function(x, entry = 1L, ...) { #' data(qtlSumStatsExample) #' getLdSketch(qtlSumStatsExample) #' @export -setMethod("getLdSketch", "SumStatsBase", function(x, ...) x@ldSketch) +setMethod("getLdSketch", "SumStatsBase", function(x) x@ldSketch) #' @rdname getStudy #' @examples @@ -288,14 +282,54 @@ setMethod("getStudy", "SumStatsBase", function(x) unique(as.character(x$study))) #' data(qtlSumStatsExample) #' getZ(qtlSumStatsExample) #' @export -setMethod("getZ", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$Z) +setMethod( + "getZ", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + mcols(exec(getSumStats, x, !!!sel))$Z + } +) #' @rdname getN #' @examples #' data(qtlSumStatsExample) #' getN(qtlSumStatsExample) #' @export -setMethod("getN", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$N) +setMethod( + "getN", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + mcols(exec(getSumStats, x, !!!sel))$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 @@ -306,42 +340,136 @@ setMethod("getN", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$N) #' data(qtlSumStatsExample) #' getP(qtlSumStatsExample) #' @export -setMethod("getP", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$P) +setMethod( + "getP", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + mcols(exec(getSumStats, x, !!!sel))$P + } +) #' @rdname getBeta #' @examples #' data(qtlSumStatsExample) #' getBeta(qtlSumStatsExample) #' @export -setMethod("getBeta", "SumStatsBase", function(x, ...) { - mcols(getSumStats(x, ...))$BETA -}) +setMethod( + "getBeta", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + mcols(exec(getSumStats, x, !!!sel))$BETA + } +) #' @rdname getSe #' @examples #' data(qtlSumStatsExample) #' getSe(qtlSumStatsExample) #' @export -setMethod("getSe", "SumStatsBase", function(x, ...) { - mcols(getSumStats(x, ...))$SE -}) +setMethod( + "getSe", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + mcols(exec(getSumStats, x, !!!sel))$SE + } +) #' @rdname getMaf #' @examples #' data(qtlDatasetExample) #' getMaf(qtlDatasetExample) #' @export -setMethod("getMaf", "SumStatsBase", function(x, ...) { - mc <- mcols(getSumStats(x, ...)) - if (is_in("MAF", colnames(mc))) mc$MAF else NULL -}) +setMethod( + "getMaf", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + mc <- mcols(exec(getSumStats, x, !!!sel)) + if (is_in("MAF", colnames(mc))) mc$MAF else NULL + } +) #' @rdname nSnps #' @examples #' data(qtlSumStatsExample) #' nSnps(qtlSumStatsExample) #' @export -setMethod("nSnps", "SumStatsBase", function(x, ...) length(getSumStats(x, ...))) +setMethod( + "nSnps", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + length(exec(getSumStats, x, !!!sel)) + } +) # ============================================================================= # FineMappingResultBase @@ -369,7 +497,7 @@ setMethod("nSnps", "SumStatsBase", function(x, ...) length(getSumStats(x, ...))) setClass( "FineMappingResultBase", contains = c("VIRTUAL", "RangedTupleList"), - representation(ldSketch = "LdSketchOrNULL") + representation(ldSketch = "LdSketch_OR_NULL") ) #' @rdname getStudy @@ -380,7 +508,7 @@ setMethod("getStudy", "FineMappingResultBase", function(x) { #' @rdname getLdSketch #' @export -setMethod("getLdSketch", "FineMappingResultBase", function(x, ...) x@ldSketch) +setMethod("getLdSketch", "FineMappingResultBase", function(x) x@ldSketch) #' @rdname getMethodNames #' @examples @@ -395,7 +523,7 @@ setMethod("getMethodNames", "FineMappingResultBase", function(x) { setMethod( "adjustPips", "FineMappingResultBase", - function(x, keepVariants, ...) { + function(x, keepVariants) { if (nrow(x) == 0L) { return(x) } @@ -432,22 +560,38 @@ setMethod( adjusted <- map( .collectionEntries(out), adjustPips, - keepVariants = keepVariants, - ... + keepVariants = keepVariants ) .fmrFromEntries(out, adjusted) } ) +# The collection's identity columns plus the per-entry payload columns. +# @noRd +.withEntryPayload <- function(md, entries) { + # `[[<-` not cbind(): the collection may already carry these columns, and + # they must be REPLACED -- cbind would append a second copy of each, which + # every reader then shadows with the stale one. + withFit <- `[[<-`( + md, + "susieFit", + value = S4Vectors::SimpleList(map(entries, getSusieFit)) + ) + `[[<-`( + withFit, + "cvResult", + value = S4Vectors::SimpleList(map(entries, getCvResult)) + ) +} + # Rebuild a fine-mapping collection from adjusted entries, keeping every # identity column and collection-level slot. # @noRd .fmrFromEntries <- function(x, entries) { - grl <- GenomicRanges::GRangesList(map(entries, rowVariants)) - md <- mcols(x, use.names = FALSE) - md$susieFit <- S4Vectors::SimpleList(map(entries, getSusieFit)) - md$cvResult <- S4Vectors::SimpleList(map(entries, getCvResult)) - mcols(grl) <- md + grl <- `mcols<-`( + GenomicRanges::GRangesList(map(entries, rowVariants)), + value = .withEntryPayload(mcols(x, use.names = FALSE), entries) + ) new(class(x), grl, ldSketch = .asLdSketch(getLdSketch(x))) } @@ -482,14 +626,14 @@ setMethod( setMethod( "intersectVariants", signature(x = "FineMappingResultBase", y = "FineMappingResultBase"), - function(x, y, oneSided = FALSE, ...) { + function(x, y, oneSided = FALSE) { shared <- .rcShared(x, y) if (isTRUE(oneSided)) { - return(adjustPips(x, shared, ...)) + return(adjustPips(x, shared)) } list( - x = adjustPips(x, shared, ...), - y = adjustPips(y, shared, ...) + x = adjustPips(x, shared), + y = adjustPips(y, shared) ) } ) @@ -530,12 +674,11 @@ setMethod( #' @rdname getRetainedMass #' @export -setMethod("getRetainedMass", "FineMappingResultBase", function(x, ...) { +setMethod("getRetainedMass", "FineMappingResultBase", function(x) { if (nrow(x) == 0L) { return(.rcEmptyMass(x)) } - parts <- map(seq_len(nrow(x)), .rcMassForRow, x = x) - parts <- compact(parts) + parts <- compact(map(seq_len(nrow(x)), .rcMassForRow, x = x)) if (length(parts) == 0L) { return(.rcEmptyMass(x)) } @@ -639,8 +782,7 @@ setMethod( method = NULL, region = NULL, coverage = 0.95, - minPurity = NULL, - ... + minPurity = NULL ) { # Selectors pinning one entry -> that entry's bare credible-set table; # no / @@ -656,15 +798,17 @@ setMethod( method = method, region = region, perEntry = .fmrRowCs, - coverage = coverage, - minPurity = minPurity + viewArgs = list( + coverage = coverage, + minPurity = minPurity + ) ) } ) #' @rdname getLbf #' @export -setMethod("getLbf", "FineMappingResultBase", function(x, ...) { +setMethod("getLbf", "FineMappingResultBase", function(x) { .fmrAggregateView(x, perEntry = .fmrRowLbf) }) @@ -673,26 +817,26 @@ setMethod("getLbf", "FineMappingResultBase", function(x, ...) { setMethod( "getCredibleSetSummary", "FineMappingResultBase", - function(x, coverage = 0.95, ...) { + function(x, coverage = 0.95) { .fmrAggregateView( x, perEntry = .fmrRowCredibleSetSummary, - coverage = coverage + viewArgs = list(coverage = coverage) ) } ) #' @rdname fsusieCredibleBand #' @export -setMethod("fsusieCredibleBand", "FineMappingResultBase", function(x, ...) { +setMethod("fsusieCredibleBand", "FineMappingResultBase", function(x) { .fmrAggregateView(x, perEntry = .fmrRowFsusieCredibleBand) }) #' @rdname fsusieAffectedRegions #' @export -setMethod("fsusieAffectedRegions", "FineMappingResultBase", function(x, ...) { - grs <- map(seq_len(nrow(x)), .fsusieEntryAffectedRegions, x = x) - grs <- grs[lengths(grs) > 0L] +setMethod("fsusieAffectedRegions", "FineMappingResultBase", function(x) { + perRow <- map(seq_len(nrow(x)), .fsusieEntryAffectedRegions, x = x) + grs <- perRow[lengths(perRow) > 0L] if (length(grs) == 0L) { return(GenomicRanges::GRanges()) } @@ -714,43 +858,92 @@ setMethod( method = NULL, region = NULL, minPurity = NULL, - ... + raw = FALSE ) { type <- arg_match(type) + # The five selectors travel together to every branch, so they are + # named once and spliced rather than relisted three times. + sel <- list( + study = study, + context = context, + trait = trait, + method = method, + region = region + ) + if (isTRUE(raw)) { + return(.fmrbTopLociRaw(x, sel, type)) + } # type = "GRanges" is honored only for a single pinned entry; the # aggregate (identity-prefixed) form is data.frame-only. if (type == "GRanges") { - return(.fmrbTopLociGranges( + return(exec( + .fmrbTopLociGranges, x, - study, - context, - trait, - method, - region, + !!!sel, signalCutoff, minPurity )) } # data.frame: bare per-variant table when selectors pin one entry, else # the matching rows' per-variant tables stacked with row-identity cols. - .fmrAggregateView( + exec( + .fmrbTopLociTable, x, - study = study, - context = context, - trait = trait, - method = method, - region = region, - perEntry = .fmrRowTopLoci, - type = "data.frame", - signalCutoff = signalCutoff, - minPurity = minPurity + !!!sel, + list( + type = "data.frame", + signalCutoff = signalCutoff, + minPurity = minPurity + ) ) } ) +# raw = TRUE hands back the stored canonical table verbatim, so the +# posterior-view projection and the type switch do not apply -- and there +# is no GRanges form of it to hand back. +# @noRd +.fmrbTopLociRaw <- function(x, sel, type) { + if (type == "GRanges") { + abort(glue( + "getTopLoci: `raw = TRUE` returns the stored table ", + "verbatim, which has no GRanges form. Use ", + "type = \"data.frame\"." + )) + } + exec(.fmrbTopLociTable, x, !!!sel, list(raw = TRUE)) +} + +# The per-variant top-loci table, in whichever of its two table forms the +# caller asked for: the stored table verbatim (raw) or the projected +# data.frame view. Both stack with row-identity columns when the selectors +# match more than one entry, so they differ only in `viewArgs`. +# @noRd +.fmrbTopLociTable <- function( + x, + study, + context, + trait, + method, + region, + viewArgs +) { + .fmrAggregateView( + x, + study = study, + context = context, + trait = trait, + method = method, + region = region, + perEntry = .fmrRowTopLoci, + viewArgs = viewArgs + ) +} + # Resolve the single pinned entry and return its GRanges view (aggregating # across multiple entries requires type = "data.frame"). # @noRd +#' @importFrom rlang try_fetch .fmrbTopLociGranges <- function( x, study, @@ -761,7 +954,7 @@ setMethod( signalCutoff, minPurity ) { - sel <- tryCatch( + sel <- try_fetch( .fmrSelectEntry( x, study = study, @@ -770,7 +963,7 @@ setMethod( method = method, region = region ), - error = function(e) e + error = function(cnd) cnd ) if (inherits(sel, "error")) { msg <- glue( @@ -799,8 +992,7 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL, - ... + region = NULL ) { # Selectors pinning one entry -> that entry's bare marginal table; no / # partial selectors -> aggregate every matching entry's marginals, @@ -813,7 +1005,7 @@ setMethod( method = method, region = region, perEntry = .fmrRowMarginalEffects, - maxPval = maxPval + viewArgs = list(maxPval = maxPval) ) } ) @@ -823,7 +1015,7 @@ setMethod( #' data(qtlFineMappingExample) #' getRegion(qtlFineMappingExample) #' @export -setMethod("getRegion", "FineMappingResultBase", function(x, ...) { +setMethod("getRegion", "FineMappingResultBase", function(x) { .getRegionColumn(x) }) @@ -832,7 +1024,7 @@ setMethod("getRegion", "FineMappingResultBase", function(x, ...) { #' data(qtlDatasetExample) #' getTraitPosition(qtlDatasetExample) #' @export -setMethod("getTraitPosition", "FineMappingResultBase", function(x, ...) { +setMethod("getTraitPosition", "FineMappingResultBase", function(x) { .getTraitPosColumn(x) }) @@ -847,8 +1039,7 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL, - ... + region = NULL ) { .fmrPartsSusieFit(.fmrSelectEntry( x, @@ -863,12 +1054,34 @@ setMethod( #' @rdname resolveWeights #' @export -setMethod("resolveWeights", "FineMappingResultBase", function(x, ...) { - # The per-variant weight of the row a selector pins. Defined on the - # collection because that is what getFineMappingResult() now returns; the - # body is the per-row primitive, so the two cannot drift. - .fmrRowResolveWeights(.fmrSelectEntry(x, ...), ...) -}) +setMethod( + "resolveWeights", + "FineMappingResultBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + method = NULL, + region = NULL + ) { + # The per-variant weight of the row a selector pins. Defined on the + # collection because that is what getFineMappingResult() now + # returns; the body is the per-row primitive, so they cannot drift. + # + # The selectors are named, not absorbed by `...`: .fmrSelectEntry is the + # only consumer, and each concrete class refuses the ones it does not + # index by (a QtlFineMappingResult has no `region` axis). + .fmrRowResolveWeights(.fmrSelectEntry( + x, + study = study, + context = context, + trait = trait, + method = method, + region = region + )) + } +) #' @rdname getVariantIds #' @export @@ -881,8 +1094,7 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL, - ... + region = NULL ) { .fmrPartsVariantIds(.fmrSelectEntry( x, @@ -897,16 +1109,33 @@ setMethod( #' @rdname getVariantIds #' @export -setMethod("getVariantIds", "SumStatsBase", function(x, ...) { - # One method covers GwasSumStats and QtlSumStats: each class's own - # getSumStats() knows its selectors (study, or study/context/trait) and - # raises the ambiguity error when a multi-row collection is addressed - # without one, so `...` carries them through untouched. - # - # Rendered with the same .grVariantIds() the row classes use, so an id - # means the same string whichever object produced it. - .grVariantIds(getSumStats(x, ...)) -}) +setMethod( + "getVariantIds", + "SumStatsBase", + function( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + # One method covers GwasSumStats and QtlSumStats. The selectors are the + # union: GwasSumStats reads only `study` / `ranges` and refuses the + # QtlSumStats-only ones rather than accepting and ignoring them. + # + # Rendered with the same .grVariantIds() the row classes use, so an id + # means the same string whichever object produced it. + sel <- list( + study = study, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + .grVariantIds(exec(getSumStats, x, !!!sel)) + } +) #' @rdname subsetChr #' @export diff --git a/R/AllGenerics.R b/R/AllGenerics.R index f69815b4c..33c3de52c 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -50,6 +50,8 @@ NULL #' @param annotations An \code{AnnotationMatrix} object, or NULL for #' unstratified estimation. #' @param local Logical, whether to compute per-block local estimates. +#' @param estimatorArgs Optional named list of estimator-specific options +#' (\code{lambda} for lder / gldsc / hdl, \code{nIter} for sldsc). #' @param ... Additional method-specific arguments. #' @param study Character (length 1) or \code{NULL}. Restrict the selection to #' this study; \code{NULL} matches all studies. @@ -139,6 +141,27 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { #' inferred from file extension. #' @param ... The keyword source arguments described above, plus any further #' arguments forwarded to the format-specific reader. +#' @param plink1Prefix,plink2Prefix Character. Stem of a plink1 +#' (\code{.bed}/\code{.bim}/\code{.fam}) or plink2 +#' (\code{.pgen}/\code{.pvar}/\code{.psam}) triplet, without the extension. +#' @param bed,bim,fam Character. Explicit paths to the three files of a plink1 +#' triplet, when they do not share a stem. +#' @param pgen,pvar,psam Character. Explicit paths to the three files of a +#' plink2 triplet, when they do not share a stem. +#' @param genoMeta One-file-per-chromosome specification: a path to a +#' \code{#chr,path} meta file, or a named character vector (names = +#' chromosomes, values = payload paths / prefixes). +#' @param chroms Optional character vector of chromosomes. Only the +#' \code{genoMeta} shards whose chromosome is listed are read; chromosome +#' labels are compared canonically. Meaningful only with \code{genoMeta}. +#' @param ldMeta Path to an LD-meta TSV (columns \code{chrom}, \code{start}, +#' \code{end}, \code{path}). Requires \code{region}: the row covering it is +#' resolved and the file it names is read with the matching backend. +#' @param region Region to resolve out of \code{ldMeta}: a +#' \code{"chr:start-end"} string, or a one-row data.frame with +#' \code{chrom}, \code{start}, \code{end}. +#' @param vcfArgs Optional named list of arguments forwarded to +#' \code{VariantAnnotation::readVcf} when the source is a VCF. #' @return A \code{RangedSummarizedExperiment} of variants x samples. #' @seealso \code{\link{computeLd}} #' @examples @@ -229,6 +252,16 @@ setGeneric("getScoreStats", function(object) standardGeneric("getScoreStats")) #' @param ... Class-specific selection arguments (e.g., \code{study} for #' \code{GwasSumStats}; \code{study}, \code{context}, \code{trait} for #' \code{QtlSumStats}). +#' @param study Character (length 1) or \code{NULL}. Restrict the selection to +#' this study; \code{NULL} matches all studies. +#' @param context Character (length 1) or \code{NULL}. Restrict the selection to +#' this context; \code{NULL} matches all contexts. +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of z-scores. #' @export setGeneric("getZ", function(x, ...) standardGeneric("getZ")) @@ -238,6 +271,16 @@ setGeneric("getZ", function(x, ...) standardGeneric("getZ")) #' \code{QtlSumStats} entry, selected by its identity tuple. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Class-specific selection arguments. +#' @param study Character (length 1) or \code{NULL}. Restrict the selection to +#' this study; \code{NULL} matches all studies. +#' @param context Character (length 1) or \code{NULL}. Restrict the selection to +#' this context; \code{NULL} matches all contexts. +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of sample sizes. #' @export setGeneric("getN", function(x, ...) standardGeneric("getN")) @@ -249,6 +292,16 @@ setGeneric("getN", function(x, ...) standardGeneric("getN")) #' \code{\link{getZ}} / \code{\link{getBeta}} / \code{\link{getSe}}. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Class-specific selection arguments. +#' @param study Character (length 1) or \code{NULL}. Restrict the selection to +#' this study; \code{NULL} matches all studies. +#' @param context Character (length 1) or \code{NULL}. Restrict the selection to +#' this context; \code{NULL} matches all contexts. +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of p-values, or \code{NULL} if not available. #' @export setGeneric("getP", function(x, ...) standardGeneric("getP")) @@ -259,6 +312,16 @@ setGeneric("getP", function(x, ...) standardGeneric("getP")) #' tuple. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Class-specific selection arguments. +#' @param study Character (length 1) or \code{NULL}. Restrict the selection to +#' this study; \code{NULL} matches all studies. +#' @param context Character (length 1) or \code{NULL}. Restrict the selection to +#' this context; \code{NULL} matches all contexts. +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of effect sizes, or \code{NULL} if not available. #' @export setGeneric("getBeta", function(x, ...) standardGeneric("getBeta")) @@ -269,6 +332,16 @@ setGeneric("getBeta", function(x, ...) standardGeneric("getBeta")) #' tuple. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Class-specific selection arguments. +#' @param study Character (length 1) or \code{NULL}. Restrict the selection to +#' this study; \code{NULL} matches all studies. +#' @param context Character (length 1) or \code{NULL}. Restrict the selection to +#' this context; \code{NULL} matches all contexts. +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of standard errors, or \code{NULL} if not available. #' @export setGeneric("getSe", function(x, ...) standardGeneric("getSe")) @@ -278,6 +351,16 @@ setGeneric("getSe", function(x, ...) standardGeneric("getSe")) #' @param x A \code{GwasSumStats} or \code{QtlDataset} object. #' @param ... Class-specific selection arguments (e.g., \code{region}, #' \code{cisWindow} for \code{QtlDataset}). +#' @param study Character (length 1) or \code{NULL}. Restrict the selection to +#' this study; \code{NULL} matches all studies. +#' @param context Character (length 1) or \code{NULL}. Restrict the selection to +#' this context; \code{NULL} matches all contexts. +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @param region Character (length 1, \code{"chr:start-end"}) or \code{NULL}. #' Restrict variants to this region; \code{NULL} uses the full cis window / #' all regions. @@ -320,6 +403,16 @@ setGeneric("getAf", function(x, ...) standardGeneric("getAf")) #' entry, selected by its identity tuple. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Class-specific selection arguments. +#' @param study Character (length 1) or \code{NULL}. Restrict the selection to +#' this study; \code{NULL} matches all studies. +#' @param context Character (length 1) or \code{NULL}. Restrict the selection to +#' this context; \code{NULL} matches all contexts. +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Integer. #' @export setGeneric("nSnps", function(x, ...) standardGeneric("nSnps")) @@ -349,8 +442,9 @@ setGeneric("nSnps", function(x, ...) standardGeneric("nSnps")) #' }) #' qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), #' trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", -#' n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), -#' p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G)) +#' extraCols = list( +#' n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), +#' p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G))) #' qtlAssociationPostprocess(qss) #' @export setGeneric("qtlAssociationPostprocess", function(x, ...) { @@ -381,8 +475,9 @@ setGeneric("qtlAssociationPostprocess", function(x, ...) { #' }) #' qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), #' trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", -#' n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), -#' p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G)) +#' extraCols = list( +#' n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), +#' p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G))) #' pp <- qtlAssociationPostprocess(qss) #' getSignificantQtls(pp) #' @export @@ -628,7 +723,8 @@ setGeneric("getQcInfo", function(x, ...) standardGeneric("getQcInfo")) #' @title Get SLALOM / DENTIST Diagnostics #' @description Return the per-variant LD-mismatch diagnostics table (SLALOM or #' DENTIST output) attached to a sumstats entry by -#' \code{\link{summaryStatsQc}} when \code{zMismatchQc} was not \code{"none"}. +#' \code{\link{summaryStatsQc}} when \code{ldMismatchQcMethod} was not +#' \code{"none"}. #' Convenience accessor over #' \code{getQcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. @@ -739,6 +835,10 @@ setGeneric("hasGenotypes", function(x) standardGeneric("hasGenotypes")) #' @param region Character (length 1, \code{"chr:start-end"}) or \code{NULL}. #' Restrict variants to this region; \code{NULL} uses the full cis window / #' all regions. +#' @param annotateSignificance Optional correction-method name passed through to +#' \code{\link{getSumStats}} (QTL only); \code{NULL} applies none. +#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the +#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Character vector of variant IDs. #' @examples #' data(qtlFineMappingExample) @@ -766,6 +866,10 @@ setGeneric("getVariantIds", function(x, ...) standardGeneric("getVariantIds")) #' \code{"keep"} or \code{"drop"}. #' @param outlierPvalThreshold Numeric. Two-sided p-value threshold for flagging #' phenotype outliers. Default \code{1e-3}. +#' @param outlierArgs Extra arguments for \code{robustbase::covMcd()}, the +#' robust covariance estimator the outlier rule is built on, supplied with +#' \code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only +#' consulted when \code{outlierAction = "drop"}. #' @return A named list of phenotype matrices or \code{SummarizedExperiment} #' objects. #' @examples @@ -899,10 +1003,27 @@ setGeneric("getSusieFit", function(x, ...) standardGeneric("getSusieFit")) #' fe <- getFineMappingResult(qtlFineMappingPairedExample) #' computeCsCorrelation(fe, qtlSumStatsExample) #' @export -setGeneric( - "computeCsCorrelation", - function(x, ldSource, ...) standardGeneric("computeCsCorrelation") -) +setGeneric("computeCsCorrelation", function(x, ldSource, ...) { + # The accepted `ldSource` classes are known, so this is a validity check + # rather than an ANY method: running it here means the message survives + # whatever else the call passed, and no method needs `...` to catch it. + .csCorrAssertLdSource(ldSource) + standardGeneric("computeCsCorrelation") +}) + +# @noRd +.csCorrAssertLdSource <- function(ldSource) { + ok <- !missing(ldSource) && + any(map_lgl(c("QtlDataset", "SumStatsBase"), is, object = ldSource)) + if (ok) { + return(invisible(NULL)) + } + abort(glue( + "computeCsCorrelation() requires a QtlDataset, QtlSumStats, or ", + "GwasSumStats as `ldSource`: the between-credible-set correlation ", + "is derived from that object's LD and is never stored on the fit." + )) +} #' @title Get Cross-Validation Result #' @description Extract the cross-validation payload stored on a @@ -987,6 +1108,10 @@ setGeneric("getMarginalEffects", function(x, maxPval = NULL, ...) { #' all regions. #' @param minPurity Numeric or \code{NULL}. Minimum credible-set purity to #' retain; \code{NULL} applies no purity filter. +#' @param raw Logical (length 1). \code{FALSE} (default) returns the posterior +#' view described above. \code{TRUE} hands back the stored canonical table +#' verbatim, so neither the projection nor \code{signalCutoff} applies and +#' \code{type = "GRanges"} is an error. #' @return A \code{data.frame} or a \code{GRanges}. #' @examples #' data(qtlFineMappingExample) @@ -1061,6 +1186,9 @@ setGeneric("getWeights", function(x, ...) standardGeneric("getWeights")) #' @param study,context,trait,method Optional length-1 selectors pinning one #' row of a collection, as elsewhere; each \code{NULL} (default) leaves that #' part of the tuple unconstrained. Ignored when \code{x} is already a row. +#' @param region Character (length 1, \code{"chr:start-end"}) or \code{NULL}. +#' A further selector for a \code{FineMappingResult}, whose rows also carry +#' a region; \code{NULL} (default) leaves it unconstrained. #' @param ... Reserved for future use. #' @return A \code{list} with \code{variantIds} (character) and \code{weights} #' (numeric) of equal length; both empty when no usable weights are present. @@ -1115,9 +1243,11 @@ setGeneric("getSusieAlpha", function(x, ...) standardGeneric("getSusieAlpha")) #' cre <- CtwasResultEntry( #' finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), #' susieAlpha = data.frame(id = c("g1", "g2"), alpha = c(0.9, 0.1))) -#' getCtwasParam(cre) +#' getCtwasGroupPriors(cre) #' @export -setGeneric("getCtwasParam", function(x, ...) standardGeneric("getCtwasParam")) +setGeneric("getCtwasGroupPriors", function(x, ...) { + standardGeneric("getCtwasGroupPriors") +}) #' @title Get Standardized Flag #' @description Check whether weights are on the standardized scale. @@ -1155,7 +1285,7 @@ setGeneric("getStandardized", function(x, ...) { #' @return Method-specific (typically a list). #' @examples #' data(ctwasWeightsExample) -#' # NULL unless the pipeline was run with `retainFit = TRUE` +#' # NULL unless the pipeline kept fits (fitRetention != "none") #' getFits(ctwasWeightsExample) #' @export setGeneric("getFits", function(x, ...) standardGeneric("getFits")) @@ -1353,23 +1483,13 @@ setGeneric("getTraitPosition", function(x, ...) { #' around the trait; \code{NULL} uses the dataset default. #' @param samples Character vector or \code{NULL}. Restrict to these sample IDs; #' \code{NULL} uses all samples. -#' @param phenotypeCovariatesToResidualize Character vector or \code{NULL}. -#' Phenotype covariate names to residualize; \code{NULL} uses the dataset -#' default set. -#' @param genotypeCovariatesToResidualize Character vector or \code{NULL}. -#' Genotype covariate names to residualize; \code{NULL} uses the dataset -#' default set. -#' @param residualizePhenotypeCovariates Logical. Whether to residualize the -#' phenotype covariates. Default \code{TRUE}. -#' @param residualizeGenotypeCovariates Logical. Whether to residualize the -#' genotype covariates. Default \code{TRUE}. -#' @param residualizePhenotypeCovariatesFromGenotypes Logical or \code{NULL}. -#' Whether to residualize phenotype covariates out of the genotype design; -#' \code{NULL} uses the default. -#' @param residualizeGenotypeCovariatesFromGenotypes Logical or \code{NULL}. -#' Whether to residualize genotype covariates out of the genotype design; -#' \code{NULL} uses the default. -#' @param covariateNaAction Character. How to handle missing covariate values. +#' @param residualizationArgs What the data is residualized on, built with +#' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and +#' \code{genotypeCovariates} choose the covariate sets, +#' \code{residualizePhenotype} / \code{residualizeGenotype} turn each +#' side on or off, and \code{covariateNaAction} says how missing +#' covariate values are handled. The same record the pipelines take, so a +#' setting means the same thing by either route. #' @return A numeric matrix (samples x variants). #' @examples #' data(qtlDatasetExample) @@ -1395,29 +1515,23 @@ setGeneric("getResidualizedGenotypes", function(x, ...) { #' @param region Character (length 1, \code{"chr:start-end"}) or \code{NULL}. #' Restrict variants to this region; \code{NULL} uses the full cis window / #' all regions. -#' @param phenotypeCovariatesToResidualize Character vector or \code{NULL}. -#' Phenotype covariate names to residualize; \code{NULL} uses the dataset -#' default set. -#' @param genotypeCovariatesToResidualize Character vector or \code{NULL}. -#' Genotype covariate names to residualize; \code{NULL} uses the dataset -#' default set. -#' @param residualizePhenotypeCovariates Logical. Whether to residualize the -#' phenotype covariates. Default \code{TRUE}. -#' @param residualizeGenotypeCovariates Logical. Whether to residualize the -#' genotype covariates. Default \code{TRUE}. -#' @param residualizePhenotypeCovariatesFromPhenotypes Logical or \code{NULL}. -#' Whether to residualize phenotype covariates out of the phenotype; -#' \code{NULL} uses the default. -#' @param residualizeGenotypeCovariatesFromPhenotypes Logical or \code{NULL}. -#' Whether to residualize genotype covariates out of the phenotype; -#' \code{NULL} uses the default. +#' @param residualizationArgs What the data is residualized on, built with +#' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and +#' \code{genotypeCovariates} choose the covariate sets, +#' \code{residualizePhenotype} / \code{residualizeGenotype} turn each +#' side on or off, and \code{covariateNaAction} says how missing +#' covariate values are handled. The same record the pipelines take, so a +#' setting means the same thing by either route. #' @param naAction Character. How to handle missing phenotype values: one of #' \code{"keep"}, \code{"drop"}, or \code{"impute"}. -#' @param covariateNaAction Character. How to handle missing covariate values. #' @param outlierAction Character. How to handle phenotype outliers: one of #' \code{"keep"} or \code{"drop"}. #' @param outlierPvalThreshold Numeric. Two-sided p-value threshold for flagging #' phenotype outliers. Default \code{1e-3}. +#' @param outlierArgs Extra arguments for \code{robustbase::covMcd()}, the +#' robust covariance estimator the outlier rule is built on, supplied with +#' \code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only +#' consulted when \code{outlierAction = "drop"}. #' @return A named list of numeric matrices keyed by context. #' @examples #' data(qtlDatasetExample) @@ -2233,3 +2347,205 @@ setGeneric("fsusieCredibleBand", function(x, ...) { setGeneric("fsusieAffectedRegions", function(x, ...) { standardGeneric("fsusieAffectedRegions") }) + +# ============================================================================= +# MethodParam accessor generics +# ----------------------------------------------------------------------------- +# Only two Param classes carry accessors, and both earn them by being records +# the user HOLDS rather than builds and forgets: +# +# CredibleSetParam postprocessFinemappingFits() and buildTopLoci() take +# an already-computed fit, so a stored fit is +# re-summarized under changed settings without +# refitting. `L` / `Lgreedy` are deliberately +# get-only: they are seeded onto each SuSiE-family +# token's own arguments, so changing one needs a +# refit and a setter would hand back a record that +# looks applied but is not. +# GwasFineMappingParam the only Param nesting others. Once CredibleSetParam +# is settable, the container has to let the nested +# record back in, or it could be read but not written. +# +# The other 24 Params are construct-and-pass -- handed to one pipeline +# argument and never seen again -- and get none, which is what Bioconductor's +# own PileupParam does with twelve slots. +# +# get*/set* rather than Rsamtools' bamWhich()/bamWhich<-() spelling: pecotmr +# already exports 95 get* accessors, and bare field names are not available +# anyway -- `coverage` is an IRanges generic for read depth and `methods` is +# utils::methods. +# ============================================================================= + +#' @rdname CredibleSetParam +#' @param x A \code{CredibleSetParam}. +#' @param ... Unused, present for generic consistency. +#' @export +setGeneric("getCoverage", function(x, ...) { + standardGeneric("getCoverage") +}) + +#' @rdname CredibleSetParam +#' @param value The replacement value for that setting. +#' @export +setGeneric("setCoverage", function(x, value, ...) { + standardGeneric("setCoverage") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getSecondaryCoverage", function(x, ...) { + standardGeneric("getSecondaryCoverage") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("setSecondaryCoverage", function(x, value, ...) { + standardGeneric("setSecondaryCoverage") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getSignalCutoff", function(x, ...) { + standardGeneric("getSignalCutoff") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("setSignalCutoff", function(x, value, ...) { + standardGeneric("setSignalCutoff") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getMinAbsCorr", function(x, ...) { + standardGeneric("getMinAbsCorr") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("setMinAbsCorr", function(x, value, ...) { + standardGeneric("setMinAbsCorr") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getMedianAbsCorr", function(x, ...) { + standardGeneric("getMedianAbsCorr") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("setMedianAbsCorr", function(x, value, ...) { + standardGeneric("setMedianAbsCorr") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getIncludeAllCs", function(x, ...) { + standardGeneric("getIncludeAllCs") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("setIncludeAllCs", function(x, value, ...) { + standardGeneric("setIncludeAllCs") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getPerCsColumns", function(x, ...) { + standardGeneric("getPerCsColumns") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("setPerCsColumns", function(x, value, ...) { + standardGeneric("setPerCsColumns") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getL", function(x, ...) { + standardGeneric("getL") +}) + +#' @rdname CredibleSetParam +#' @export +setGeneric("getLgreedy", function(x, ...) { + standardGeneric("getLgreedy") +}) + +#' @rdname GwasFineMappingParam +#' @param x A \code{GwasFineMappingParam}. +#' @param ... Unused, present for generic consistency. +#' @export +setGeneric("getFineMappingMethods", function(x, ...) { + standardGeneric("getFineMappingMethods") +}) + +#' @rdname GwasFineMappingParam +#' @param value The replacement value for that setting. +#' @export +setGeneric("setFineMappingMethods", function(x, value, ...) { + standardGeneric("setFineMappingMethods") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("getCredibleSetArgs", function(x, ...) { + standardGeneric("getCredibleSetArgs") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("setCredibleSetArgs", function(x, value, ...) { + standardGeneric("setCredibleSetArgs") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("getRssArgs", function(x, ...) { + standardGeneric("getRssArgs") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("setRssArgs", function(x, value, ...) { + standardGeneric("setRssArgs") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("getPanelFilterArgs", function(x, ...) { + standardGeneric("getPanelFilterArgs") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("setPanelFilterArgs", function(x, value, ...) { + standardGeneric("setPanelFilterArgs") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("getAddSusieInf", function(x, ...) { + standardGeneric("getAddSusieInf") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("setAddSusieInf", function(x, value, ...) { + standardGeneric("setAddSusieInf") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("getFitRetention", function(x, ...) { + standardGeneric("getFitRetention") +}) + +#' @rdname GwasFineMappingParam +#' @export +setGeneric("setFitRetention", function(x, value, ...) { + standardGeneric("setFitRetention") +}) diff --git a/R/AnnotationMatrix.R b/R/AnnotationMatrix.R index 2f100a298..b27d18707 100644 --- a/R/AnnotationMatrix.R +++ b/R/AnnotationMatrix.R @@ -38,26 +38,35 @@ setClass( # The tier/type vocabulary is the only thing left to check: the SNP-by- # annotation shape is now enforced by SummarizedExperiment itself. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames assertSubset .validateAnnotationMatrix <- function(object) { - errors <- character() + coll <- makeAssertCollection() cd <- SummarizedExperiment::colData(object) - required <- c("name", "tier", "type") - if (!all(is_in(required, colnames(cd)))) { - return("annotationMeta must have columns: name, tier, type") - } - if (!all(is_in(cd$tier, c("baseline", "candidate")))) { - errors <- c( - errors, - "annotationMeta$tier must be 'baseline' or 'candidate'" - ) - } - if (!all(is_in(cd$type, c("binary", "continuous")))) { - errors <- c( - errors, - "annotationMeta$type must be 'binary' or 'continuous'" - ) + assertNames( + colnames(cd), + must.include = c("name", "tier", "type"), + what = "colnames", + .var.name = "annotationMeta", + add = coll + ) + # The value checks below read those columns; without them they would + # report the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - if (length(errors) == 0) TRUE else errors + assertSubset( + cd$tier, + c("baseline", "candidate"), + .var.name = "annotationMeta$tier", + add = coll + ) + assertSubset( + cd$type, + c("binary", "continuous"), + .var.name = "annotationMeta$type", + add = coll + ) + coll$getMessages() } #' @rdname show-methods @@ -85,9 +94,11 @@ setMethod("show", "AnnotationMatrix", function(object) { #' @rdname getGenome #' @export -setMethod("getGenome", "AnnotationMatrix", function(x, ...) { - build <- unique(GenomeInfoDb::genome(SummarizedExperiment::rowRanges(x))) - build <- build[!is.na(build)] +setMethod("getGenome", "AnnotationMatrix", function(x) { + build <- discard( + unique(GenomeInfoDb::genome(SummarizedExperiment::rowRanges(x))), + is.na + ) if (length(build) == 0L) NA_character_ else build[[1L]] }) @@ -114,6 +125,7 @@ setMethod("getGenome", "AnnotationMatrix", function(x, ...) { if (!all(is_in(requiredCols, colnames(annotationMeta)))) { abort("annotationMeta must have columns: name, tier, type") } + # NOT assertMatrix: `annotations` may be a sparse Matrix, not a base one. if (ncol(annotations) != nrow(annotationMeta)) { abort(glue( "`annotations` has {ncol(annotations)} column(s) for ", @@ -150,21 +162,24 @@ AnnotationMatrix <- function( genome = "hg19" ) { .amCheckInputs(annotations, annotationMeta) - if (is.null(colnames(annotations))) { - colnames(annotations) <- annotationMeta$name - } + annotations <- `colnames<-`( + annotations, + colnames(annotations) %||% annotationMeta$name + ) if (nrow(annotations) != length(snpRanges)) { abort(glue( "`annotations` has {nrow(annotations)} row(s) for ", "{length(snpRanges)} SNP range(s); the rows must match." )) } - if (!is.null(genome) && length(genome) == 1L && !is.na(genome)) { - GenomeInfoDb::genome(snpRanges) <- genome + named <- if (!is.null(genome) && length(genome) == 1L && !is.na(genome)) { + GenomeInfoDb::`genome<-`(snpRanges, value = genome) + } else { + snpRanges } se <- SummarizedExperiment::SummarizedExperiment( assays = list(annotations = annotations), - rowRanges = snpRanges, + rowRanges = named, # Keyed off the assay's own colnames, not annotationMeta$name: # SummarizedExperiment requires the two to agree, and the previous # class let them diverge, so taking the name column would reject @@ -187,7 +202,9 @@ AnnotationMatrix <- function( # rows, the assay and the per-annotation table aligned, where the previous # implementation rebuilt the object from three separately-subset pieces. # @noRd +#' @importFrom checkmate assertClass .annotTier <- function(annot, tier) { + assertClass(annot, "AnnotationMatrix") annot[, SummarizedExperiment::colData(annot)$tier == tier] } diff --git a/R/ColocBoostResult.R b/R/ColocBoostResult.R index 203e23290..9d7d531ac 100644 --- a/R/ColocBoostResult.R +++ b/R/ColocBoostResult.R @@ -90,26 +90,25 @@ methods::setValidity("ColocBoostResult", function(object) { } # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames +#' @importFrom checkmate checkSubset .validateColocBoostResult <- function(object) { - errors <- .cbrCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- c( - .cbrCheckVcpColumn(object), - .cbrCheckOutcomeInfo(object) - ) - } - if (length(errors) == 0L) TRUE else errors -} - -# @noRd -.cbrCheckRequiredCols <- function(object) { - md <- mcols(object, use.names = FALSE) - have <- if (is.null(md)) character(0) else colnames(md) - missingCols <- setdiff(.cbrRequiredCols(), have) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + colnames(mcols(object, use.names = FALSE)) %||% character(0), + must.include = .cbrRequiredCols(), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.cbrCheckVcpColumn(object)) + coll$push(.cbrCheckOutcomeInfo(object)) + coll$getMessages() } # The per-variant layer is the point of the class, exactly as SNP.PP.H4 is for @@ -145,28 +144,23 @@ methods::setValidity("ColocBoostResult", function(object) { if (nrow(info) == 0L) { return(NULL) } - missingCols <- setdiff( - c("name", "study", "context", "trait", "dataForm"), - colnames(info) + cols <- checkNames( + colnames(info), + must.include = c("name", "study", "context", "trait", "dataForm"), + what = "colnames" ) - if (length(missingCols) > 0L) { - return(str_c( - "outcomeInfo is missing columns: ", - str_flatten(missingCols, ", ") - )) + if (!isTRUE(cols)) { + return(str_c("outcomeInfo is missing columns: ", cols)) } if (length(object) == 0L) { return(NULL) } named <- unique(unlist(mcols(object, use.names = FALSE)$outcomes)) - unknown <- setdiff(named, as.character(info$name)) - if (length(unknown) == 0L) { + resolved <- checkSubset(named, as.character(info$name)) + if (isTRUE(resolved)) { return(NULL) } - str_c( - "outcome(s) not present in outcomeInfo: ", - str_flatten(utils::head(unknown, 5L), ", ") - ) + str_c("outcome(s) not in outcomeInfo: ", resolved) } # ---- accessors -------------------------------------------------------------- @@ -256,8 +250,9 @@ ColocBoostResult <- function( analysis = analysis, gwasStudy = gwasStudy, includeUncolocalized = includeUncolocalized - ) - rows <- unlist(rows, recursive = FALSE, use.names = FALSE) + ) |> + list_flatten() |> + unname() .cbrAssemble( rows, outcomeInfo = as.data.frame(outcomeInfo), @@ -275,10 +270,12 @@ ColocBoostResult <- function( if (is.null(res)) { return(list()) } - out <- .cbrColocalizedRows(res, analysis[[i]], gwasStudy[[i]]) - if (isTRUE(includeUncolocalized)) { - out <- c(out, .cbrUncolocalizedRows(res, analysis[[i]], gwasStudy[[i]])) - } + out <- c( + .cbrColocalizedRows(res, analysis[[i]], gwasStudy[[i]]), + if (isTRUE(includeUncolocalized)) { + .cbrUncolocalizedRows(res, analysis[[i]], gwasStudy[[i]]) + } + ) out } @@ -381,15 +378,15 @@ ColocBoostResult <- function( # The cos_summary row for one set, or an empty tibble when absent. # @noRd .cbrSummaryFor <- function(res, id) { - s <- res$cos_summary - if (is.null(s) || nrow(s) == 0L || !is_in("cos_id", colnames(s))) { + raw <- res$cos_summary + if (is.null(raw) || nrow(raw) == 0L || !is_in("cos_id", colnames(raw))) { return(tibble( top_variable = NA_character_, top_variable_vcp = NA_real_, focal_outcome = NA )) } - s <- as.data.frame(s, stringsAsFactors = FALSE) + s <- as.data.frame(raw, stringsAsFactors = FALSE) hit <- which(as.character(s$cos_id) == id) if (length(hit) == 0L) { return(tibble( @@ -456,10 +453,13 @@ ColocBoostResult <- function( if (is.null(ids)) { next } - gr <- .variantIdsToGRanges(ids, what = "colocboost vcp names") - mcols(gr) <- cbind( - mcols(gr, use.names = FALSE), - S4Vectors::DataFrame(vcp = as.numeric(res$vcp)) + bare <- .variantIdsToGRanges(ids, what = "colocboost vcp names") + gr <- S4Vectors::`mcols<-`( + bare, + value = cbind( + mcols(bare, use.names = FALSE), + S4Vectors::DataFrame(vcp = as.numeric(res$vcp)) + ) ) return(gr) } @@ -475,8 +475,10 @@ ColocBoostResult <- function( computingTime ) { elements <- map(rows, .cbrElementFor) - grl <- GenomicRanges::GRangesList(elements) - mcols(grl) <- .cbrMcolsFor(rows) + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(elements), + value = .cbrMcolsFor(rows) + ) obj <- new( "ColocBoostResult", grl, @@ -492,33 +494,42 @@ ColocBoostResult <- function( # @noRd .cbrElementFor <- function(row) { v <- row$variants - gr <- .variantIdsToGRanges( + bare <- .variantIdsToGRanges( as.character(v$variant_id), what = "colocboost variant name" ) # Appended, not assigned: the A1 / A2 columns .variantIdsToGRanges() # attaches are the variant identity, and overwriting mcols would leave the # element unable to name its own variants. - mcols(gr) <- cbind( - mcols(gr, use.names = FALSE), - S4Vectors::DataFrame(vcp = as.numeric(v$vcp)) + gr <- S4Vectors::`mcols<-`( + bare, + value = cbind( + mcols(bare, use.names = FALSE), + S4Vectors::DataFrame(vcp = as.numeric(v$vcp)) + ) ) gr } # @noRd .cbrMcolsFor <- function(rows) { - if (length(rows) == 0L) { - md <- S4Vectors::DataFrame(.cbrEmptyMeta()) - md$outcomes <- IRanges::CharacterList() - return(md) - } - meta <- bind_rows(map(rows, "meta")) - md <- S4Vectors::DataFrame(meta, check.names = FALSE) # A CharacterList column, so a set of any size lives in one row instead of # being flattened to a delimited string a caller has to re-split. - md$outcomes <- IRanges::CharacterList(map(rows, "outcomes")) - md + if (length(rows) == 0L) { + return(cbind( + S4Vectors::DataFrame(.cbrEmptyMeta()), + S4Vectors::DataFrame(outcomes = IRanges::CharacterList()) + )) + } + cbind( + S4Vectors::DataFrame( + bind_rows(map(rows, "meta")), + check.names = FALSE + ), + S4Vectors::DataFrame( + outcomes = IRanges::CharacterList(map(rows, "outcomes")) + ) + ) } # @noRd @@ -542,18 +553,23 @@ ColocBoostResult <- function( #' @rdname colocViews #' @export -setMethod("getColocPairs", "ColocBoostResult", function(x, ...) { +setMethod("getColocPairs", "ColocBoostResult", function(x) { # Named "pairs" for symmetry with ColocResult, but a ColocBoost row is a # SET, not a pair: `outcomes` holds however many outcomes colocalized. md <- mcols(x, use.names = FALSE) if (is.null(md) || length(x) == 0L) { return(tibble()) } - flat <- as.data.frame(md[, setdiff(colnames(md), "outcomes")]) - out <- as_tibble(flat, .name_repair = "minimal") - out$outcomes <- map_chr(as.list(md$outcomes), str_flatten, collapse = "; ") - out$nOutcomes <- lengths(md$outcomes) - out + # `drop = FALSE` as in the sibling views: a single kept column would + # arrive as a vector and be named after the subscript text. + flat <- as.data.frame( + md[, setdiff(colnames(md), "outcomes"), drop = FALSE] + ) + mutate( + as_tibble(flat, .name_repair = "minimal"), + outcomes = map_chr(as.list(md$outcomes), str_flatten, collapse = "; "), + nOutcomes = lengths(md$outcomes) + ) }) #' @rdname colocViews @@ -561,7 +577,7 @@ setMethod("getColocPairs", "ColocBoostResult", function(x, ...) { setMethod( "getColocVariants", "ColocBoostResult", - function(x, pooled = FALSE, ...) { + function(x, pooled = FALSE) { long <- .cbrLongVariants(x) if (!isTRUE(pooled) || nrow(long) == 0L) { return(long) @@ -590,10 +606,11 @@ setMethod( n <- lengths(x) setIdx <- rep(seq_len(length(x)), n) flat <- unlist(x, use.names = FALSE) - out <- as_tibble(md[setIdx, , drop = FALSE], .name_repair = "minimal") - out$variant_id <- .grVariantIds(flat) - out$vcp <- as.numeric(mcols(flat, use.names = FALSE)$vcp) - out + mutate( + as_tibble(md[setIdx, , drop = FALSE], .name_repair = "minimal"), + variant_id = .grVariantIds(flat), + vcp = as.numeric(mcols(flat, use.names = FALSE)$vcp) + ) } #' @title ColocBoost Outcome View @@ -617,7 +634,7 @@ setGeneric("getColocBoostOutcomes", function(x, ...) { #' @rdname getColocBoostOutcomes #' @export -setMethod("getColocBoostOutcomes", "ColocBoostResult", function(x, ...) { +setMethod("getColocBoostOutcomes", "ColocBoostResult", function(x) { if (length(x) == 0L) { return(tibble()) } @@ -625,11 +642,13 @@ setMethod("getColocBoostOutcomes", "ColocBoostResult", function(x, ...) { outcomes <- as.list(md$outcomes) reps <- lengths(outcomes) flat <- as.data.frame(md[, setdiff(colnames(md), "outcomes"), drop = FALSE]) - out <- as_tibble( - flat[rep(seq_len(nrow(flat)), reps), , drop = FALSE], - .name_repair = "minimal" + out <- mutate( + as_tibble( + flat[rep(seq_len(nrow(flat)), reps), , drop = FALSE], + .name_repair = "minimal" + ), + outcome = unlist(outcomes, use.names = FALSE) ) - out$outcome <- unlist(outcomes, use.names = FALSE) info <- x@outcomeInfo if (nrow(info) == 0L) { return(out) @@ -677,7 +696,7 @@ setGeneric("getComputingTime", function(x, ...) { #' @rdname getComputingTime #' @export -setMethod("getComputingTime", "ColocBoostResult", function(x, ...) { +setMethod("getComputingTime", "ColocBoostResult", function(x) { x@computingTime }) @@ -696,4 +715,4 @@ setGeneric("getRegionVcp", function(x, ...) standardGeneric("getRegionVcp")) #' @rdname getRegionVcp #' @export -setMethod("getRegionVcp", "ColocBoostResult", function(x, ...) x@regionVcp) +setMethod("getRegionVcp", "ColocBoostResult", function(x) x@regionVcp) diff --git a/R/ColocResult.R b/R/ColocResult.R index 60b3fd18d..878e67309 100644 --- a/R/ColocResult.R +++ b/R/ColocResult.R @@ -54,13 +54,13 @@ NULL setClass( "ColocResultBase", contains = c("VIRTUAL", "RangedTupleList"), - representation(ldSketch = "LdSketchOrNULL"), + representation(ldSketch = "LdSketch_OR_NULL"), prototype(ldSketch = NULL) ) #' @rdname getLdSketch #' @export -setMethod("getLdSketch", "ColocResultBase", function(x, ...) x@ldSketch) +setMethod("getLdSketch", "ColocResultBase", function(x) x@ldSketch) #' @title Colocalization Result #' @description A collection of colocalization results, one element per tested @@ -78,15 +78,24 @@ methods::setValidity("ColocResult", function(object) { }) # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames .validateColocResult <- function(object) { - errors <- .crCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- c( - .crCheckPpColumns(object), - .crCheckVariantColumn(object) - ) + coll <- makeAssertCollection() + assertNames( + colnames(mcols(object, use.names = FALSE)) %||% character(0), + must.include = .crRequiredCols(), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - if (length(errors) == 0L) TRUE else errors + coll$push(.crCheckPpColumns(object)) + coll$push(.crCheckVariantColumn(object)) + coll$getMessages() } # @noRd @@ -112,28 +121,19 @@ methods::setValidity("ColocResult", function(object) { str_c("PP.H", 0:4, ".abf") } -# @noRd -.crCheckRequiredCols <- function(object) { - md <- mcols(object, use.names = FALSE) - have <- if (is.null(md)) character(0) else colnames(md) - missingCols <- setdiff(.crRequiredCols(), have) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) - } - NULL -} - +# The posterior columns are a distinct contract from the identity columns +# above, so they keep their own wording. # @noRd .crCheckPpColumns <- function(object) { - md <- mcols(object, use.names = FALSE) - missingCols <- setdiff(.crPpCols(), colnames(md)) - if (length(missingCols) > 0L) { - return(str_c( - "missing posterior columns: ", - str_flatten(missingCols, ", ") - )) + res <- checkNames( + colnames(mcols(object, use.names = FALSE)), + must.include = .crPpCols(), + what = "colnames" + ) + if (isTRUE(res)) { + return(NULL) } - NULL + str_c("missing posterior columns: ", res) } # The per-variant layer is the whole point of the class, so an element without @@ -227,13 +227,15 @@ ColocResult <- function(pairs, variants, ldSketch = NULL) { abort(msg) } elements <- map(variants, .crVariantsToGRanges) - grl <- GenomicRanges::GRangesList(elements) # Set unconditionally, including at zero rows: an empty result still has to # carry the column schema, or it fails validity and a caller reading # `result$PP.H4.abf` gets NULL exactly when there is nothing to report. - mcols(grl) <- exec( - S4Vectors::DataFrame, - !!!c(as.list(pairs), list(check.names = FALSE)) + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(elements), + value = exec( + S4Vectors::DataFrame, + !!!c(as.list(pairs), list(check.names = FALSE)) + ) ) obj <- new("ColocResult", grl, ldSketch = .asLdSketch(ldSketch)) validObject(obj) @@ -267,8 +269,10 @@ ColocResult <- function(pairs, variants, ldSketch = NULL) { S4Vectors::DataFrame, !!!c(as.list(v[keep]), list(check.names = FALSE)) ) - mcols(gr) <- cbind(mcols(gr, use.names = FALSE), extra) - gr + S4Vectors::`mcols<-`( + gr, + value = cbind(mcols(gr, use.names = FALSE), extra) + ) } # Pivot coloc.bf_bf's WIDE $results (one SNP.PP.H4.rowK column per $summary @@ -327,7 +331,7 @@ ColocResult <- function(pairs, variants, ldSketch = NULL) { #' @rdname colocViews #' @export -setMethod("getColocPairs", "ColocResult", function(x, ...) { +setMethod("getColocPairs", "ColocResult", function(x) { md <- mcols(x, use.names = FALSE) if (is.null(md) || length(x) == 0L) { return(tibble()) @@ -337,7 +341,7 @@ setMethod("getColocPairs", "ColocResult", function(x, ...) { #' @rdname colocViews #' @export -setMethod("getColocVariants", "ColocResult", function(x, pooled = FALSE, ...) { +setMethod("getColocVariants", "ColocResult", function(x, pooled = FALSE) { long <- .crLongVariants(x) if (!isTRUE(pooled) || nrow(long) == 0L) { return(long) @@ -357,11 +361,13 @@ setMethod("getColocVariants", "ColocResult", function(x, pooled = FALSE, ...) { n <- lengths(x) pairIdx <- rep(seq_len(length(x)), n) flat <- unlist(x, use.names = FALSE) - out <- as_tibble(md[pairIdx, , drop = FALSE], .name_repair = "minimal") - out$variant_id <- .grVariantIds(flat) - out$SNP.PP.H4 <- as.numeric(mcols(flat, use.names = FALSE)$SNP.PP.H4) - out$colocPp <- out$PP.H4.abf * out$SNP.PP.H4 - out + snpPp <- as.numeric(mcols(flat, use.names = FALSE)$SNP.PP.H4) + as_tibble(md[pairIdx, , drop = FALSE], .name_repair = "minimal") |> + mutate( + variant_id = .grVariantIds(flat), + SNP.PP.H4 = snpPp, + colocPp = .data$PP.H4.abf * snpPp + ) } # Pool per-variant posteriors to the gene tier, by the section 3.5 rule: sum @@ -404,7 +410,7 @@ setMethod("getColocVariants", "ColocResult", function(x, pooled = FALSE, ...) { #' @rdname colocViews #' @export -setMethod("getColocGenes", "ColocResult", function(x, ...) { +setMethod("getColocGenes", "ColocResult", function(x) { pairs <- getColocPairs(x) if (nrow(pairs) == 0L) { return(tibble()) @@ -440,8 +446,7 @@ setMethod( coverage = 0.95, minPp4 = NULL, minAbsCorr = 0.8, - requireMaxH4 = FALSE, - ... + requireMaxH4 = FALSE ) { keep <- .crPairFilter(x, minPp4, requireMaxH4) if (length(keep) == 0L) { @@ -450,14 +455,15 @@ setMethod( # Filtering happens BEFORE any LD work, so a stricter threshold costs # strictly less -- which is the reason purity lives on the accessor # rather than being precomputed at construction. - sets <- map(keep, .crCsForPair, x = x, coverage = coverage) - sets <- compact(sets) + sets <- compact(map(keep, .crCsForPair, x = x, coverage = coverage)) if (length(sets) == 0L) { return(tibble()) } out <- bind_rows(sets) - out$purity <- .crPuritiesFor(out, getLdSketch(x)) - .crApplyPurityFilter(out, minAbsCorr) + .crApplyPurityFilter( + mutate(out, purity = .crPuritiesFor(out, getLdSketch(x))), + minAbsCorr + ) } ) @@ -469,14 +475,18 @@ setMethod( return(integer(0)) } md <- as.data.frame(mcols(x, use.names = FALSE)) - ok <- rep(TRUE, nrow(md)) - if (!is.null(minPp4)) { - ok <- ok & md$PP.H4.abf >= minPp4 + byPp4 <- if (is.null(minPp4)) { + rep(TRUE, nrow(md)) + } else { + md$PP.H4.abf >= minPp4 } - if (isTRUE(requireMaxH4)) { + byMaxH4 <- if (isTRUE(requireMaxH4)) { pp <- as.matrix(md[, .crPpCols(), drop = FALSE]) - ok <- ok & (max.col(pp, ties.method = "first") == 5L) + max.col(pp, ties.method = "first") == 5L + } else { + TRUE } + ok <- byPp4 & byMaxH4 which(ok & !is.na(ok)) } @@ -499,13 +509,14 @@ setMethod( members <- ord[seq_len(nKeep)] ids <- .grVariantIds(g[members]) md <- as.data.frame(mcols(x, use.names = FALSE))[i, , drop = FALSE] - row <- as_tibble(md, .name_repair = "minimal") - row$csSize <- length(members) - row$csCoverage <- cum[[nKeep]] - row$leadVariant <- ids[[1L]] - row$leadPp <- pp[ord][[1L]] - row$csVariants <- list(ids) - row + mutate( + as_tibble(md, .name_repair = "minimal"), + csSize = length(members), + csCoverage = cum[[nKeep]], + leadVariant = ids[[1L]], + leadPp = pp[ord][[1L]], + csVariants = list(ids) + ) } # Index of the first cumulative value reaching `target`; the whole vector when @@ -532,19 +543,20 @@ setMethod( } # @noRd +#' @importFrom rlang try_fetch .crPurityOne <- function(ids, ldSketch) { # A singleton set has no pair to correlate, and susie treats it as pure. if (length(ids) < 2L) { return(1) } - ld <- tryCatch( + ld <- try_fetch( .ldFromSketch( ldSketch, ids, label = "getColocCredibleSets", onMissing = "drop" ), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(ld) || nrow(ld) < 2L) { return(NA_real_) diff --git a/R/CtwasResult.R b/R/CtwasResult.R index b14e89a04..9e05eeb1b 100644 --- a/R/CtwasResult.R +++ b/R/CtwasResult.R @@ -37,22 +37,23 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { # Collect all contract violations (empty vector = valid). Entry checks run only # once the required columns are present. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateCtwasResult <- function(object) { - errors <- .ctwasResCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- .ctwasResCheckEntries(object) - } - if (length(errors) == 0L) TRUE else errors -} - -# @noRd -.ctwasResCheckRequiredCols <- function(object) { - required <- c("gwasStudy", "study", "context", "method", "entry") - missingCols <- setdiff(required, names(object)) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + names(object), + must.include = c("gwasStudy", "study", "context", "method", "entry"), + what = "colnames", + .var.name = "columns", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.ctwasResCheckEntries(object)) + coll$getMessages() } # @noRd @@ -89,7 +90,7 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { # @noRd .ctwasResCheckJointCols <- function(object, jointCols) { - unlist(compact(map(jointCols, .ctwasResJointColError, object = object))) + list_c(compact(map(jointCols, .ctwasResJointColError, object = object))) } # @noRd @@ -123,6 +124,16 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { object[[cn]] } +# Each joint-provenance column must be one value per row. +# @noRd +.ctwasCheckJointColLength <- function(nm, val, n) { + if (length(val) == n) { + return(invisible(NULL)) + } + msg <- glue("`{nm}` must have the same length as `gwasStudy`.") + abort(msg) +} + #' @title Create a CtwasResult Collection #' @description Construct a \code{CtwasResult} DFrame-subclass collection of #' cTWAS runs from per-tuple vectors and a list of @@ -177,18 +188,16 @@ CtwasResult <- function( method = as.character(method), entry = S4Vectors::SimpleList(entry) ) - for (nm in c("jointStudies", "jointContexts")) { - val <- get(nm) - if (is.null(val)) { - next - } - if (length(val) != n) { - msg <- glue("`{nm}` must have the same length as `gwasStudy`.") - abort(msg) - } - cols[[nm]] <- as.character(val) - } - dfArgs <- c(cols, list(check.names = FALSE)) + supplied <- compact(list( + jointStudies = jointStudies, + jointContexts = jointContexts + )) + walk2(names(supplied), supplied, .ctwasCheckJointColLength, n = n) + dfArgs <- c( + cols, + map(supplied, as.character), + list(check.names = FALSE) + ) df <- exec(S4Vectors::DataFrame, !!!dfArgs) obj <- new("CtwasResult", df) validObject(obj) @@ -219,8 +228,9 @@ setMethod("getContexts", "CtwasResult", function(x) { if (n == 0L) { return(NULL) } - parts <- map(seq_len(n), .ctwasAggregateRow, x = x, getter = getter) - parts <- compact(parts) + parts <- compact( + map(seq_len(n), .ctwasAggregateRow, x = x, getter = getter) + ) if (length(parts) == 0L) { return(NULL) } @@ -229,13 +239,13 @@ setMethod("getContexts", "CtwasResult", function(x) { #' @rdname getFinemap #' @export -setMethod("getFinemap", "CtwasResult", function(x, ...) { +setMethod("getFinemap", "CtwasResult", function(x) { .ctwasAggregateRows(x, getFinemap) }) #' @rdname getSusieAlpha #' @export -setMethod("getSusieAlpha", "CtwasResult", function(x, ...) { +setMethod("getSusieAlpha", "CtwasResult", function(x) { .ctwasAggregateRows(x, getSusieAlpha) }) diff --git a/R/CtwasResultEntry.R b/R/CtwasResultEntry.R index a296af479..5784a587d 100644 --- a/R/CtwasResultEntry.R +++ b/R/CtwasResultEntry.R @@ -22,7 +22,8 @@ NULL #' (\code{ctwas::finemap_regions} \code{susie_alpha_res} shape) -- the #' fuller cTWAS output retained so the raw run is reconstructable, or #' \code{NULL}. -#' @slot param The estimated \code{group_prior} / \code{group_prior_var} for +#' @slot groupPriors The estimated \code{group_prior} / +#' \code{group_prior_var} for #' this run, or \code{NULL}. #' @slot regionInfo Per-region metadata, or \code{NULL}. #' @seealso \code{\link{CtwasResultEntry}} for the constructor. @@ -33,13 +34,13 @@ setClass( finemap = "ANY", # per-gene/SNP posterior summary (ctwas finemap_res) # per-effect susie alpha table (ctwas susie_alpha_res) susieAlpha = "ANY", - param = "ANY", # group_prior / group_prior_var for this run + groupPriors = "ANY", # group_prior / group_prior_var for this run regionInfo = "ANY" # per-region metadata (optional) ), prototype = prototype( finemap = NULL, susieAlpha = NULL, - param = NULL, + groupPriors = NULL, regionInfo = NULL ) ) @@ -55,7 +56,8 @@ setClass( #' @param susieAlpha The per-effect susie alpha table #' (\code{ctwas::finemap_regions} \code{susie_alpha_res} shape) -- the fuller #' cTWAS output retained so the raw run is reconstructable, or \code{NULL}. -#' @param param The estimated \code{group_prior} / \code{group_prior_var} for +#' @param groupPriors The estimated \code{group_prior} / +#' \code{group_prior_var} for #' this run, or \code{NULL}. #' @param regionInfo Per-region metadata, or \code{NULL}. #' @return A \code{CtwasResultEntry} object. @@ -68,26 +70,30 @@ setClass( CtwasResultEntry <- function( finemap = NULL, susieAlpha = NULL, - param = NULL, + groupPriors = NULL, regionInfo = NULL ) { new( "CtwasResultEntry", finemap = finemap, susieAlpha = susieAlpha, - param = param, + groupPriors = groupPriors, regionInfo = regionInfo ) } #' @rdname getFinemap #' @export -setMethod("getFinemap", "CtwasResultEntry", function(x, ...) x@finemap) +setMethod("getFinemap", "CtwasResultEntry", function(x) x@finemap) #' @rdname getSusieAlpha #' @export -setMethod("getSusieAlpha", "CtwasResultEntry", function(x, ...) x@susieAlpha) +setMethod("getSusieAlpha", "CtwasResultEntry", function(x) x@susieAlpha) -#' @rdname getCtwasParam +#' @rdname getCtwasGroupPriors #' @export -setMethod("getCtwasParam", "CtwasResultEntry", function(x, ...) x@param) +setMethod( + "getCtwasGroupPriors", + "CtwasResultEntry", + function(x) x@groupPriors +) diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index 8a5bc7c4e..229a96df9 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -49,36 +49,27 @@ setClass( chromPaths = character(0) ), validity = function(object) { - errors <- character() - if (length(object@path) != 1L) { - errors <- c(errors, "'path' must be a single character string") - } - valid_formats <- c("gds", "vcf", "plink1", "plink2") - if (!is_in(object@format, valid_formats)) { - errors <- c( - errors, + validFormats <- c("gds", "vcf", "plink1", "plink2") + nm <- names(object@chromPaths) + badChromPaths <- length(object@chromPaths) > 0L && + (is.null(nm) || any(str_length(nm) == 0L) || anyDuplicated(nm)) + errors <- c( + if (length(object@path) != 1L) { + "'path' must be a single character string" + }, + if (!is_in(object@format, validFormats)) { str_c( "'format' must be one of: ", - str_flatten(valid_formats, ", ") + str_flatten(validFormats, ", ") ) - ) - } - if (length(object@chromPaths) > 0L) { - nm <- names(object@chromPaths) - if ( - is.null(nm) || - any(str_length(nm) == 0L) || - anyDuplicated(nm) - ) { - errors <- c( - errors, - str_c( - "'chromPaths' must be a uniquely-named ", - "character vector (names = chromosomes)" - ) + }, + if (badChromPaths) { + str_c( + "'chromPaths' must be a uniquely-named ", + "character vector (names = chromosomes)" ) } - } + ) if (length(errors) == 0) TRUE else errors } ) @@ -166,7 +157,8 @@ setMethod("show", "GenotypeHandle", function(object) { #' shard is read (so the caller's own absence check can report the mismatch). #' Only meaningful with \code{genoMeta}; supplying it with any other source is #' an error (a single-file panel has no per-chromosome shards to skip). -#' @param ... Additional arguments forwarded to the format-specific reader. +#' @param vcfArgs Optional named list of arguments forwarded to +#' \code{VariantAnnotation::readVcf} when the source is a VCF. #' @return A \code{GenotypeHandle} object. #' @keywords internal GenotypeHandle <- function( @@ -183,47 +175,60 @@ GenotypeHandle <- function( region = NULL, genoMeta = NULL, chroms = NULL, - ... + format = NULL, + vcfArgs = list() ) { - p <- as.list(environment()) - flags <- .ghValidateArgs(p) - sources <- .ghResolveSources(p, flags) - if (sources[["path"]]) { - return(.readGenotypeHandle(path, ...)) - } - if (sources[["plink1Prefix"]]) { - return(.makePlink1Handle(plink1Prefix, ...)) - } - if (sources[["plink2Prefix"]]) { - return(.makePlink2Handle(plink2Prefix, ...)) - } - if (sources[["plink1Triplet"]]) { - return(.genotypeHandleFromPlink1Triplet(bed, bim, fam, ...)) - } - if (sources[["plink2Triplet"]]) { - return(.genotypeHandleFromPlink2Triplet(pgen, pvar, psam, ...)) - } - if (sources[["ldMeta"]]) { - return(.genotypeHandleFromLdMeta(ldMeta, region, ...)) - } - # nSources == 1 is enforced above, so the only remaining source is genoMeta. - .genotypeHandleFromChromMeta(genoMeta, chroms = chroms, ...) + flags <- .ghValidateArgs( + bed = bed, + bim = bim, + fam = fam, + pgen = pgen, + pvar = pvar, + psam = psam, + ldMeta = ldMeta, + region = region + ) + sources <- .ghResolveSources( + path = path, + plink1Prefix = plink1Prefix, + plink2Prefix = plink2Prefix, + ldMeta = ldMeta, + genoMeta = genoMeta, + chroms = chroms, + flags = flags + ) + # .ghResolveSources() has already enforced that exactly one is TRUE, so + # the chosen name is well defined and the switch is total. + switch( + names(sources)[which(sources)], + path = .readGenotypeHandle(path, format = format, vcfArgs = vcfArgs), + plink1Prefix = .makePlink1Handle(plink1Prefix), + plink2Prefix = .makePlink2Handle(plink2Prefix), + plink1Triplet = .genotypeHandleFromPlink1Triplet(bed, bim, fam), + plink2Triplet = .genotypeHandleFromPlink2Triplet(pgen, pvar, psam), + ldMeta = .genotypeHandleFromLdMeta(ldMeta, region, vcfArgs = vcfArgs), + genoMeta = .genotypeHandleFromChromMeta( + genoMeta, + chroms = chroms, + format = format + ) + ) } # Validate the bed/bim/fam + pgen/pvar/psam triplet completeness and the # ldMeta<->region coupling. Returns list(bedComplete, pgenComplete). # @noRd -.ghValidateArgs <- function(p) { - bedComplete <- .ghTrioComplete(p$bed, p$bim, p$fam, "bed/bim/fam") - pgenComplete <- .ghTrioComplete(p$pgen, p$pvar, p$psam, "pgen/pvar/psam") - if (!is.null(p$ldMeta) && is.null(p$region)) { +.ghValidateArgs <- function(bed, bim, fam, pgen, pvar, psam, ldMeta, region) { + bedComplete <- .ghTrioComplete(bed, bim, fam, "bed/bim/fam") + pgenComplete <- .ghTrioComplete(pgen, pvar, psam, "pgen/pvar/psam") + if (!is.null(ldMeta) && is.null(region)) { msg <- glue( "`ldMeta` requires a `region` (a 'chr:start-end' string or a ", "one-row data.frame with chrom/start/end)." ) abort(msg) } - if (is.null(p$ldMeta) && !is.null(p$region)) { + if (is.null(ldMeta) && !is.null(region)) { abort("`region` is only meaningful when `ldMeta` is supplied.") } list(bedComplete = bedComplete, pgenComplete = pgenComplete) @@ -246,15 +251,23 @@ GenotypeHandle <- function( # Build the exactly-one-source indicator vector; error unless exactly one input # source was supplied, and gate `chroms` to the genoMeta path. # @noRd -.ghResolveSources <- function(p, flags) { +.ghResolveSources <- function( + path, + plink1Prefix, + plink2Prefix, + ldMeta, + genoMeta, + chroms, + flags +) { sources <- c( - path = !is.null(p$path), - plink1Prefix = !is.null(p$plink1Prefix), - plink2Prefix = !is.null(p$plink2Prefix), + path = !is.null(path), + plink1Prefix = !is.null(plink1Prefix), + plink2Prefix = !is.null(plink2Prefix), plink1Triplet = flags$bedComplete, plink2Triplet = flags$pgenComplete, - ldMeta = !is.null(p$ldMeta), - genoMeta = !is.null(p$genoMeta) + ldMeta = !is.null(ldMeta), + genoMeta = !is.null(genoMeta) ) if (sum(sources) != 1L) { nSrc <- sum(sources) @@ -265,7 +278,7 @@ GenotypeHandle <- function( ) abort(msg) } - if (!is.null(p$chroms) && !sources[["genoMeta"]]) { + if (!is.null(chroms) && !sources[["genoMeta"]]) { msg <- glue( "`chroms` restricts which per-chromosome shards are read and is ", "only supported with `genoMeta` (a single-file panel has no ", @@ -276,9 +289,9 @@ GenotypeHandle <- function( sources } -.genotypeHandleFromLdMeta <- function(ldMeta, region, ...) { +.genotypeHandleFromLdMeta <- function(ldMeta, region, vcfArgs = list()) { ldPath <- .ghResolveLdPath(ldMeta, region) - .ghLdPathToHandle(ldPath, ...) + .ghLdPathToHandle(ldPath, vcfArgs = vcfArgs) } # Resolve the single genotype-payload path for `region` from an LD meta, @@ -320,24 +333,22 @@ GenotypeHandle <- function( # Dispatch a resolved genotype path to the format-specific reader by extension. # @noRd -.ghLdPathToHandle <- function(ldPath, ...) { +.ghLdPathToHandle <- function(ldPath, vcfArgs = list()) { lower <- str_to_lower(ldPath) if (str_detect(lower, "\\.vcf(\\.b?gz)?$") || str_ends(lower, "\\.bcf")) { - return(.readGenotypeHandle(ldPath, format = "vcf", ...)) + return(.readGenotypeHandle(ldPath, format = "vcf", vcfArgs = vcfArgs)) } if (str_ends(lower, "\\.gds")) { - return(.readGenotypeHandle(ldPath, format = "gds", ...)) + return(.readGenotypeHandle(ldPath, format = "gds")) } if (str_ends(lower, "\\.bed")) { return(.makePlink1Handle( - str_remove(ldPath, regex("\\.bed$", ignore_case = TRUE)), - ... + str_remove(ldPath, regex("\\.bed$", ignore_case = TRUE)) )) } if (str_ends(lower, "\\.pgen")) { return(.makePlink2Handle( - str_remove(ldPath, regex("\\.pgen$", ignore_case = TRUE)), - ... + str_remove(ldPath, regex("\\.pgen$", ignore_case = TRUE)) )) } msg <- glue( @@ -348,12 +359,11 @@ GenotypeHandle <- function( abort(msg) } -.genotypeHandleFromPlink1Triplet <- function(bed, bim, fam, ...) { - for (f in list(bed = bed, bim = bim, fam = fam)) { - if (!is.character(f) || length(f) != 1L) { - abort("Each of `bed`, `bim`, `fam` must be a single file path.") - } - } +#' @importFrom checkmate assertString +.genotypeHandleFromPlink1Triplet <- function(bed, bim, fam) { + assertString(bed) + assertString(bim) + assertString(fam) stems <- c( bed = file_path_sans_ext(bed), bim = file_path_sans_ext(bim), @@ -371,10 +381,10 @@ GenotypeHandle <- function( ) abort(msg) } - .makePlink1Handle(unname(stems[1L]), ...) + .makePlink1Handle(unname(stems[1L])) } -.genotypeHandleFromPlink2Triplet <- function(pgen, pvar, psam, ...) { +.genotypeHandleFromPlink2Triplet <- function(pgen, pvar, psam) { for (f in list(pgen = pgen, pvar = pvar, psam = psam)) { if (!is.character(f) || length(f) != 1L) { abort("Each of `pgen`, `pvar`, `psam` must be a single file path.") @@ -398,7 +408,7 @@ GenotypeHandle <- function( ) abort(msg) } - .makePlink2Handle(unname(stems[1L]), ...) + .makePlink2Handle(unname(stems[1L])) } # --------------------------------------------------------------------------- @@ -414,8 +424,10 @@ GenotypeHandle <- function( # pecotmr). Such objects have no `chromPaths` slot, so a direct `@` access # errors; treat them as single-file handles. #' @keywords internal +#' @importFrom purrr possibly .genotypeChromPaths <- function(handle) { - tryCatch(getChromPaths(handle), error = function(e) character(0)) + # A handle with no chromosome paths is an ordinary outcome, not a fault. + possibly(getChromPaths, otherwise = character(0))(handle) } # Case-insensitive match of the first of `aliases` present in `cols`; falls @@ -578,18 +590,21 @@ GenotypeHandle <- function( # the other per-chromosome files are never opened, which is the I/O win when a # genome-wide panel backs summary statistics on only a few chromosomes. #' @keywords internal -.genotypeHandleFromChromMeta <- function(genoMeta, chroms = NULL, ...) { - format <- list(...)$format +.genotypeHandleFromChromMeta <- function( + genoMeta, + chroms = NULL, + format = NULL +) { parsed <- .parseChromMeta(genoMeta) if (nrow(parsed) == 0L) { abort( "GenotypeHandle(genoMeta): no chromosomes found in the meta input." ) } - parsed <- .chromMetaSelect(parsed, chroms) - shards <- map(parsed$path, .resolveGenotypeShard, format = format) + selected <- .chromMetaSelect(parsed, chroms) + shards <- map(selected$path, .resolveGenotypeShard, format = format) sharedFormat <- .chromMetaCheckFormats(shards) - .chromMetaCheckSamples(shards, parsed) + .chromMetaCheckSamples(shards, selected) unifiedSnpInfo <- bind_rows(map(shards, .ghSnpInfo)) new( "GenotypeHandle", @@ -652,23 +667,36 @@ GenotypeHandle <- function( invisible(NULL) } +# One shard's chromosome -> path mapping. +# @noRd +.chromShardPaths <- function(shard) { + chroms <- unique(canonChrom(getSnpInfo(shard)$CHR)) + set_names(rep(getPath(shard), length(chroms)), chroms) +} + +# A chromosome may only come from one file; two shards claiming it means the +# panel is not split cleanly per chromosome. +# @noRd +.checkChromNotSplit <- function(ch, count) { + if (count <= 1L) { + return(invisible(NULL)) + } + msg <- glue( + "GenotypeHandle(genoMeta): chromosome '{ch}' appears ", + "in more than one per-chromosome file." + ) + abort(msg) +} + # Map each chromosome to its shard path, erroring if a chromosome spans files. -# (Sequential uniqueness accumulation -- kept as a loop.) # @noRd .chromMetaPaths <- function(shards) { - chromPaths <- character(0) - for (i in seq_along(shards)) { - for (ch in unique(canonChrom(getSnpInfo(shards[[i]])$CHR))) { - if (is_in(ch, names(chromPaths))) { - msg <- glue( - "GenotypeHandle(genoMeta): chromosome '{ch}' appears ", - "in more than one per-chromosome file." - ) - abort(msg) - } - chromPaths[[ch]] <- getPath(shards[[i]]) - } + if (length(shards) == 0L) { + return(character(0)) } + chromPaths <- list_c(map(shards, .chromShardPaths)) + counts <- table(names(chromPaths)) + walk2(names(counts), as.integer(counts), .checkChromNotSplit) chromPaths } @@ -693,7 +721,7 @@ setMethod("getPath", "GenotypeHandle", function(x) x@path) #' @rdname getChromPaths #' @keywords internal -setMethod("getChromPaths", "GenotypeHandle", function(x, ...) x@chromPaths) +setMethod("getChromPaths", "GenotypeHandle", function(x) x@chromPaths) # Resolve a portable bundled-resource reference of the form # "pecotmr://extdata/" to a concrete filesystem path via diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index 1792577f0..22ed1e54f 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -35,23 +35,23 @@ setClass( # ---- GwasFineMappingResult validity helpers -------------------------------- # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames .validateGwasFineMappingResult <- function(object) { - errors <- .gfmrCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- .gfmrCheckEntries(object) - } - errors <- c(errors, .gfmrCheckLdSketch(object)) - if (length(errors) == 0L) TRUE else errors -} - -# @noRd -.gfmrCheckRequiredCols <- function(object) { - required <- c("study", "method") - missingCols <- setdiff(required, .tupleColumnNames(object)) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + .tupleColumnNames(object), + must.include = c("study", "method"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.gfmrCheckEntries(object)) + coll$getMessages() } # @noRd @@ -67,23 +67,17 @@ setClass( .gfmrCheckEntryLength <- function(object) { # The variants and their topLoci ARE the elements now, so what is left to # check is that the fit payload columns are present and parallel. - missingCols <- setdiff( - c("susieFit", "cvResult"), - .tupleColumnNames(object) + res <- checkNames( + .tupleColumnNames(object), + must.include = c("susieFit", "cvResult"), + what = "colnames" ) - if (length(missingCols) > 0L) { - return(str_c( - "missing entry payload columns: ", - str_flatten(missingCols, ", ") - )) + if (isTRUE(res)) { + return(NULL) } - NULL + str_c("missing entry payload columns: ", res) } -# @noRd - -# @noRd - # @noRd .gfmrCheckTupleUniqueness <- function(object) { # Keyed on the element's RANGE rather than on a region_id label. The range @@ -99,8 +93,8 @@ setClass( keyTbl <- as_tibble(set_names( map(keyCols, .gfmrColOf, object = object), keyCols - )) - keyTbl$range <- .rtlRangeKeys(object) + )) |> + mutate(range = .rtlRangeKeys(object)) if (nrow(distinct(keyTbl)) < nrow(keyTbl)) { return("(study, method, range) tuple uniqueness violated") } @@ -112,12 +106,6 @@ setClass( .tupleColumn(object, cn) } -# @noRd -.gfmrCheckLdSketch <- function(object) { - # The slot's class union enforces the type; nothing to check. - NULL -} - #' @title Create a GwasFineMappingResult Collection #' @description Construct a \code{GwasFineMappingResult} collection from @@ -170,17 +158,19 @@ GwasFineMappingResult <- function( method = as.character(method), susieFit = S4Vectors::SimpleList(map(entry, getSusieFit)), cvResult = S4Vectors::SimpleList(map(entry, getCvResult)) - ) - cols <- .appendBlockIdCol(cols, blockId, n) - cols <- .appendTraitPosCol(cols, traitPos, n) + ) |> + .appendBlockIdCol(blockId, n) |> + .appendTraitPosCol(traitPos, n) dfArgs <- c(cols, list(check.names = FALSE)) # Each entry's variants become one ELEMENT, its topLoci that element's # inner mcols, and its fit/cv payload outer mcols. A multi-seqname entry # splits by chromosome with its metadata row replicated. split <- .rtlSplitBySeqname(map(entry, rowVariants)) - grl <- GenomicRanges::GRangesList(split$entry) md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md[split$fromIdx, , drop = FALSE] + ) obj <- new( "GwasFineMappingResult", grl, @@ -207,15 +197,17 @@ setMethod("getContexts", "GwasFineMappingResult", function(x) NULL) setMethod("getTraits", "GwasFineMappingResult", function(x) NULL) # Per-tuple lookup keyed by (study, method, blockId). The generic -# accepts the full set of selectors; context/trait args are ignored for -# GwasFineMappingResult. `region` (passed via `...`) is the per-block -# disambiguator for multi-block genome-wide collections. +# accepts the full set of selectors; `context` / `trait` are QTL-only and a +# GwasFineMappingResult refuses them rather than ignoring them, the same way +# getSumStats(GwasSumStats) does. `region` is the per-block disambiguator +# for multi-block genome-wide collections. #' @rdname getFineMappingResult #' @export setMethod( "getFineMappingResult", "GwasFineMappingResult", function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { + .gwasFmrRefuseQtlSelectors(context, trait) x[.tupleSelectRowGwasFmr(x, study, method)] } ) @@ -232,14 +224,55 @@ setMethod( trait = NULL, method = NULL, region = NULL, - returnList = FALSE, - ... + returnList = FALSE ) { + .gwasFmrRefuseQtlSelectors(context, trait) idx <- .tupleSelectRowGwasFmr(x, study, method, region) - .fmrRowPip(.fmrRowParts(x, idx)) + pip <- .fmrRowPip(.fmrRowParts(x, idx)) + if (!isTRUE(returnList)) { + return(pip) + } + # Documented as "a per-entry list keyed by identity tuple"; the QTL + # method has always honoured it and this one silently returned the + # flat vector. A GWAS row is keyed by (study, method). + set_names( + list(pip), + glue( + "{as.character(x$study)[idx]}|{as.character(x$method)[idx]}" + ) + ) } ) +# `context` / `trait` belong to the QTL axis. Naming them keeps the shared +# accessor signature, but a GWAS collection has no such axis, so asking for +# one is a mistake rather than a no-op. +# @noRd +.gwasFmrRefuseQtlSelectors <- function(context, trait) { + # NA counts as unset, not as a selection: callers that thread a whole + # (study, context, trait, method) record fill the axes a collection does + # not have with NA, and that is an absence rather than a request. + given <- c( + context = .gwasFmrSelectorGiven(context), + trait = .gwasFmrSelectorGiven(trait) + ) + if (!any(given)) { + return(invisible(NULL)) + } + bad <- names(given)[given] + abort(glue( + "GwasFineMappingResult has no context or trait axis, so ", + "{str_flatten(sprintf('`%s`', bad), ' and ')} ", + "{if (length(bad) == 1L) 'does' else 'do'} not select anything. ", + "Select with `study`, `method` and `region`." + )) +} + +# @noRd +.gwasFmrSelectorGiven <- function(v) { + !is.null(v) && !all(is.na(v)) +} + # Row selector for the base delegating accessors (getCs / getTopLoci / # getMarginalEffects / getSusieFit / getVariantIds live on # FineMappingResultBase, AllClasses.R). The Gwas selector threads `region`. @@ -252,9 +285,13 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL, - ... + region = NULL ) { + # No refusal here, unlike the public accessors: this is the blind + # delegation point for the shared base accessors, and callers such + # as the VCF writer thread a whole selector record through it + # without knowing the class. The user-facing entry points are where + # a QTL-only selector is a mistake worth reporting. .fmrRowParts(x, .tupleSelectRowGwasFmr(x, study, method, region)) } ) diff --git a/R/JointGroup.R b/R/JointGroup.R index 4c2ef6de9..33404b177 100644 --- a/R/JointGroup.R +++ b/R/JointGroup.R @@ -39,19 +39,17 @@ setClass( # one row per condition (Y/Z column) representation(conditions = "data.frame"), validity = function(object) { - errors <- character() - if ( + errors <- if ( !all(is_in( c("study", "context", "trait"), names(object@conditions) )) ) { - errors <- c( - errors, - "'conditions' must have columns 'study', 'context', 'trait'" - ) + "'conditions' must have columns 'study', 'context', 'trait'" } else if (nrow(object@conditions) < 1L) { - errors <- c(errors, "a group needs >= 1 condition (Y/Z column)") + "a group needs >= 1 condition (Y/Z column)" + } else { + character() } if (length(errors) == 0L) TRUE else errors } @@ -67,25 +65,23 @@ setClass( contains = "JointGroup", representation(X = "matrix", Y = "matrix", traitPos = "numeric"), validity = function(object) { - errors <- character() - if (nrow(object@X) != nrow(object@Y)) { - errors <- c(errors, "X and Y must share the sample (row) dimension") - } - if (ncol(object@Y) != nrow(object@conditions)) { - errors <- c(errors, "ncol(Y) must equal nrow(conditions)") - } - if ( - length(object@traitPos) > 0L && - length(object@traitPos) != ncol(object@Y) - ) { - errors <- c( - errors, + errors <- c( + if (nrow(object@X) != nrow(object@Y)) { + "X and Y must share the sample (row) dimension" + }, + if (ncol(object@Y) != nrow(object@conditions)) { + "ncol(Y) must equal nrow(conditions)" + }, + if ( + length(object@traitPos) > 0L && + length(object@traitPos) != ncol(object@Y) + ) { str_c( "when set, 'traitPos' must have one entry per TRAIT ", "(Y column), not per variant" ) - ) - } + } + ) if (length(errors) == 0L) TRUE else errors } ) @@ -99,21 +95,19 @@ setClass( # any of them is fitted. The sketch is a lazy panel, so the matrix is # derived once per group at fit time -- which is what the univariate RSS # path in fineMappingPipeline already does. - representation(Z = "matrix", ldSketch = "LdSketchOrNULL", N = "numeric"), + representation(Z = "matrix", ldSketch = "LdSketch_OR_NULL", N = "numeric"), validity = function(object) { - errors <- character() - if (ncol(object@Z) != nrow(object@conditions)) { - errors <- c(errors, "ncol(Z) must equal nrow(conditions)") - } - if (is.null(rownames(object@Z))) { - errors <- c( - errors, + errors <- c( + if (ncol(object@Z) != nrow(object@conditions)) { + "ncol(Z) must equal nrow(conditions)" + }, + if (is.null(rownames(object@Z))) { str_c( "'Z' must carry the variant ids as rownames: they are ", "what the LD matrix is derived over" ) - ) - } + } + ) if (length(errors) == 0L) TRUE else errors } ) @@ -129,24 +123,25 @@ setClass( ), # smallest fittable condition count (joint cells # use >= 2; the univariate cell uses 1) validity = function(object) { - errors <- character() - if ( - length(object@dataForm) != 1L || - !is_in(object@dataForm, c("individual", "sumstats")) - ) { - errors <- c(errors, "'dataForm' must be 'individual' or 'sumstats'") - } - if (length(object@minGroup) != 1L || object@minGroup < 1L) { - errors <- c(errors, "'minGroup' must be a single integer >= 1") - } + errors <- c( + if ( + length(object@dataForm) != 1L || + !is_in(object@dataForm, c("individual", "sumstats")) + ) { + "'dataForm' must be 'individual' or 'sumstats'" + }, + if (length(object@minGroup) != 1L || object@minGroup < 1L) { + "'minGroup' must be a single integer >= 1" + } + ) if (length(errors) == 0L) TRUE else errors } ) # ---- Pipeline markers ------------------------------------------------------- # Not empty: the `config` list carries the per-pipeline parameter tail -# (coverage/cvFolds/samplePartition/fitFullData/retainFit/... for fm; -# retainFit/retainFitDetail/cvFolds/... for twas), and dispatch on the concrete +# (coverage/cvFolds/samplePartition/fitFullData/fitRetention/... for fm; +# fitRetention/cvFolds/... for twas), and dispatch on the concrete # class selects the result type via `construct()`. setClass("JointPipeline", contains = "VIRTUAL", representation(config = "list")) diff --git a/R/LdBlocks.R b/R/LdBlocks.R index cef4a5128..25c2401b6 100644 --- a/R/LdBlocks.R +++ b/R/LdBlocks.R @@ -36,24 +36,25 @@ NULL # One block per row. `blockId` is carried into mcols when present so the key # survives; without it the splitter falls back to the block's coordinates. # @noRd +#' @importFrom checkmate assertNames .ldBlockTableToRanges <- function(df) { - missingCols <- setdiff(c("chrom", "start", "end"), colnames(df)) - if (length(missingCols) > 0L) { - msg <- glue( - "`ldBlocks` table is missing required column(s): ", - "{str_flatten(missingCols, ', ')}." - ) - abort(msg) - } - gr <- GenomicRanges::GRanges( + assertNames( + colnames(df), + must.include = c("chrom", "start", "end"), + what = "colnames", + .var.name = "ldBlocks table" + ) + exec( + GenomicRanges::GRanges, seqnames = as.character(df$chrom), ranges = IRanges::IRanges( start = as.integer(df$start), end = as.integer(df$end) - ) + ), + !!!compact(list( + blockId = if (is_in("blockId", colnames(df))) { + as.character(df$blockId) + } + )) ) - if (is_in("blockId", colnames(df))) { - mcols(gr)$blockId <- as.character(df$blockId) - } - gr } diff --git a/R/LdData.R b/R/LdData.R index bcefd8083..43ebc31ab 100644 --- a/R/LdData.R +++ b/R/LdData.R @@ -34,8 +34,13 @@ NULL #' @slot snpIdx Integer vector of 1-based SNP indices into the handle's #' \code{snpInfo}. NULL when correlation is pre-computed, or when the #' source is a matrix (which is already the subset). -#' @slot blockMetadata A \code{GRanges} of blocks or a \code{data.frame} with -#' block boundary information. +#' @slot blockMetadata A \code{GRanges} with one range per block: its +#' \code{seqnames} and range are the block's chromosome and genomic span, +#' and \code{mcols} carry \code{blockId}, \code{size}, \code{startIdx} +#' and \code{endIdx} -- the index range into the correlation matrix the +#' block addresses. Extra columns the caller supplied are kept as mcols. +#' A block whose index range is out of bounds has no span to derive and +#' gets a width-0 range. #' @slot nRef Integer, reference panel sample size. #' @slot mixtureWeights NULL when \code{genotypeHandle} is a single #' \code{GenotypeHandle}; a numeric vector of mixing proportions (one per @@ -51,59 +56,54 @@ setClass( correlation = "LdCorrelation", genotypeHandle = "LdGenotypeSource", snpIdx = "LdSnpIndex", - blockMetadata = "LdBlockMetadata", + blockMetadata = "GRanges", nRef = "integer", mixtureWeights = "LdMixtureWeights" ), validity = function(object) { - errors <- character() - if (is.null(object@correlation) && is.null(object@genotypeHandle)) { - errors <- c( - errors, + errors <- c( + if (is.null(object@correlation) && is.null(object@genotypeHandle)) { str_c( "At least one of 'correlation' or ", "'genotypeHandle' must be non-NULL" ) - ) - } - if (length(object) == 0) { - errors <- c(errors, "an LdData must cover >= 1 variant") - } - errors <- c(errors, .ldCheckGenotypeSource(object@genotypeHandle)) - errors <- c(errors, .ldCheckCorrelation(object@correlation)) - if (!is.null(object@mixtureWeights)) { - if (!is.list(object@genotypeHandle)) { - errors <- c( - errors, - str_c( - "'mixtureWeights' may only be set when ", - "'genotypeHandle' is a list of panels" - ) - ) - } else { - w <- object@mixtureWeights - if ( - !is.numeric(w) || length(w) != length(object@genotypeHandle) - ) { - errors <- c( - errors, - str_c( - "'mixtureWeights' must be numeric of length ", - "equal to the genotypeHandle list" - ) - ) - } else if (any(w < 0) || abs(sum(w) - 1) > 1e-6) { - errors <- c( - errors, - "'mixtureWeights' must be non-negative and sum to 1" - ) - } - } - } + }, + if (length(object) == 0) "an LdData must cover >= 1 variant", + .ldCheckGenotypeSource(object@genotypeHandle), + .ldCheckCorrelation(object@correlation), + .ldCheckMixtureWeights(object), + .ldCheckBlockMetadata(object) + ) if (length(errors) == 0) TRUE else errors } ) +# Mixture weights are only meaningful over a LIST of panels, and must then be +# a proper simplex over them. NULL weights are always valid. +# @noRd +.ldCheckMixtureWeights <- function(object) { + if (is.null(object@mixtureWeights)) { + return(NULL) + } + if (!is.list(object@genotypeHandle)) { + return(str_c( + "'mixtureWeights' may only be set when ", + "'genotypeHandle' is a list of panels" + )) + } + w <- object@mixtureWeights + if (!is.numeric(w) || length(w) != length(object@genotypeHandle)) { + return(str_c( + "'mixtureWeights' must be numeric of length ", + "equal to the genotypeHandle list" + )) + } + if (any(w < 0) || abs(sum(w) - 1) > 1e-6) { + return("'mixtureWeights' must be non-negative and sum to 1") + } + NULL +} + #' @describeIn LdData-class Refused. Subsetting would narrow the variants #' while \code{correlation} -- variant-by-variant, and \code{snpIdx}, which #' indexes the reference panel -- stayed as they were, leaving an LD matrix @@ -188,6 +188,266 @@ setMethod("show", "LdData", function(object) { )) } +# --- block metadata -------------------------------------------------------- +# +# Five paths used to build this table -- the two region loaders, the two +# bare-matrix wrappers, and callers handing over a bare genomic span -- and +# each emitted a different set of columns, so consumers read `startIdx`, +# `size` and `chrom` that were there by luck rather than by contract. One +# normaliser at the only door (LdData()) fills whatever is absent and stores +# a single shape, the way .ldDataGenotypeSource() does for the handle. +# +# These are the columns consumers actually read. `blockStart` / `blockEnd` +# are deliberately NOT required: the two region loaders record a block's +# genomic span, nothing reads it, and demanding it would reject every +# multi-block table built without it. Supplied columns are carried through. +# @noRd +.ldBlockColumns <- c("blockId", "chrom", "size", "startIdx", "endIdx") + +# What survives as mcols once chrom / blockStart / blockEnd become the +# GRanges itself. +# @noRd +.ldBlockMcols <- c("blockId", "size", "startIdx", "endIdx") + +# Supplied values are never replaced: a caller handing over deliberately +# out-of-range indices keeps them, because partitionLdMatrix() still has to +# reject those and substituting valid ones would hide the error. +# @noRd +.ldBlockMetadata <- function(blockMetadata, variants) { + if (length(variants) == 0L) { + # Nothing to derive a block from. Validity rejects the object for + # covering no variant; crashing here would pre-empt that message. + return(GenomicRanges::GRanges()) + } + tbl <- .ldBlockMetadataTibble(blockMetadata) + if (nrow(tbl) == 0L) { + # A placeholder table means "one block", not "no blocks": an LdData + # always covers at least one variant. + tbl <- tibble(blockId = 1L) + } + tbl <- .ldBlockMetadataIndices(tbl, length(variants)) + tbl <- .ldBlockMetadataOrder(.ldBlockMetadataDerive(tbl, variants)) + .ldBlockMetadataGRanges(tbl, variants) +} + +# The stored shape: one range per block, so the invariants the merge logic +# depends on are the ones GRanges already answers -- isDisjoint() for +# overlap, sort() for order, seqnames() for the same-chromosome guard. The +# index payload the matrix is addressed by rides along in mcols. +# @noRd +.ldBlockMetadataGRanges <- function(tbl, variants) { + span <- .ldBlockSpans(tbl, variants) + gr <- GenomicRanges::GRanges( + seqnames = tbl$chrom, + ranges = IRanges::IRanges(start = span$start, end = span$end) + ) + keep <- c( + intersect(.ldBlockMcols, names(tbl)), + setdiff(names(tbl), c(.ldBlockColumns, "blockStart", "blockEnd")) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + as.data.frame(select(tbl, all_of(keep))) + ) + gr +} + +# Each block's genomic span. Supplied blockStart / blockEnd win; otherwise +# the span is read off the variants the index range covers. +# +# A block whose index range is out of bounds has no span to read, and a +# GRanges cannot hold an NA one (seqnames reject NAs outright). It gets a +# WIDTH-0 range at the first variant instead: legal, and visibly not an +# interval, so nothing downstream mistakes it for a real span. +# partitionLdMatrix() rejects the block on its indices regardless. +# @noRd +.ldBlockSpans <- function(tbl, variants) { + if (is_in("blockStart", names(tbl)) && is_in("blockEnd", names(tbl))) { + return(list(start = tbl$blockStart, end = tbl$blockEnd)) + } + parts <- map( + seq_len(nrow(tbl)), + .ldBlockSpanAt, + tbl = tbl, + variants = variants + ) + list( + start = map_dbl(parts, "start"), + end = map_dbl(parts, "end") + ) +} + +# @noRd +.ldBlockSpanAt <- function(i, tbl, variants) { + s <- tbl$startIdx[[i]] + e <- tbl$endIdx[[i]] + if (.ldBlockRangeUsable(s, e, length(variants))) { + part <- variants[seq.int(s, e)] + return(list( + start = min(GenomicRanges::start(part)), + end = max(GenomicRanges::end(part)) + )) + } + anchor <- GenomicRanges::start(variants)[[1L]] + list(start = anchor, end = anchor - 1L) +} + +# @noRd +.ldBlockRangeUsable <- function(s, e, n) { + !is.na(s) && !is.na(e) && s >= 1L && e >= s && e <= n +} + +# Any accepted shape as a tibble. `start`/`end` is how a bare genomic span +# arrives; they name the BLOCK's span, so they become blockStart/blockEnd. +# @noRd +.ldBlockMetadataTibble <- function(x) { + if (!is(x, "GRanges") && !is.data.frame(x) && !is(x, "DataFrame")) { + # as.data.frame() would happily turn a string into a one-column + # table, so the shapes have to be named rather than coerced blindly. + abort(glue( + "`blockMetadata` must be a GRanges, a data.frame or a ", + "DataFrame; got {class(x)[[1L]]}" + )) + } + tbl <- if (is(x, "GRanges")) { + .ldBlockMetadataFromGranges(x) + } else { + as_tibble(as.data.frame(x)) + } + .ldBlockMetadataRenameSpan(tbl) +} + +# @noRd +.ldBlockMetadataFromGranges <- function(x) { + md <- as_tibble(as.data.frame(S4Vectors::mcols(x))) + # An LdBlocks-style GRanges carries chrom / blockStart / blockEnd in its + # mcols as well as in its ranges. The mcols win: binding both would + # duplicate the names and leave no column called `chrom` at all. + fromRanges <- tibble( + chrom = as.character(GenomicRanges::seqnames(x)), + blockStart = GenomicRanges::start(x), + blockEnd = GenomicRanges::end(x) + ) + bind_cols( + md, + select( + fromRanges, + all_of(setdiff(names(fromRanges), names(md))) + ) + ) +} + +# @noRd +.ldBlockMetadataRenameSpan <- function(tbl) { + if (!is_in("blockStart", names(tbl)) && is_in("start", names(tbl))) { + tbl <- rename(tbl, blockStart = "start") + } + if (!is_in("blockEnd", names(tbl)) && is_in("end", names(tbl))) { + tbl <- rename(tbl, blockEnd = "end") + } + tbl +} + +# The index range is the one thing that cannot be derived for several +# blocks: only the caller knows which variants each covers. A single block +# covers all of them. +# @noRd +.ldBlockMetadataIndices <- function(tbl, n) { + absent <- setdiff(c("startIdx", "endIdx"), names(tbl)) + if (length(absent) == 0L) { + return(tbl) + } + if (length(absent) == 1L) { + abort(glue( + "`blockMetadata` gives one of startIdx / endIdx but not the ", + "other; supply both or neither." + )) + } + if (is_in("size", names(tbl))) { + # Blocks are taken in order, so the sizes give the ranges. This is + # the LdBlocks shape: a block table that says how many variants each + # block holds but not where they sit in the matrix. + sizes <- as.integer(tbl$size) + ends <- cumsum(sizes) + return(mutate(tbl, startIdx = ends - sizes + 1L, endIdx = ends)) + } + if (nrow(tbl) > 1L) { + abort(glue( + "`blockMetadata` describes {nrow(tbl)} blocks but gives neither ", + "an index range nor `size`, so which variants each block covers ", + "cannot be determined." + )) + } + mutate(tbl, startIdx = 1L, endIdx = n) +} + +# `blockId`, `chrom` and `size` all follow from the index range, for one +# block or many. +# @noRd +.ldBlockMetadataDerive <- function(tbl, variants) { + absent <- setdiff(.ldBlockColumns, names(tbl)) + if (length(absent) == 0L) { + return(tbl) + } + derived <- tibble( + blockId = seq_len(nrow(tbl)), + chrom = .ldBlockChroms(tbl, variants), + size = as.integer(tbl$endIdx - tbl$startIdx + 1L), + startIdx = tbl$startIdx, + endIdx = tbl$endIdx + ) + bind_cols(tbl, select(derived, all_of(absent))) +} + +# @noRd +.ldBlockChroms <- function(tbl, variants) { + map_chr( + seq_len(nrow(tbl)), + .ldBlockChromAt, + tbl = tbl, + variants = variants + ) +} + +# An out-of-range block falls back to the data's own chromosome rather than +# NA: seqnames cannot hold NA, and partitionLdMatrix() rejects the block on +# its indices anyway. Its range is width 0 (see .ldBlockSpanAt). +# @noRd +.ldBlockChromAt <- function(i, tbl, variants) { + s <- tbl$startIdx[[i]] + e <- tbl$endIdx[[i]] + part <- if (.ldBlockRangeUsable(s, e, length(variants))) { + variants[seq.int(s, e)] + } else { + variants + } + as.character(GenomicRanges::seqnames(part))[[1L]] +} + +# Canonical columns first, anything the caller added after. +# @noRd +.ldBlockMetadataOrder <- function(tbl) { + select(tbl, all_of(.ldBlockColumns), everything()) +} + +# Every LdData describes at least one block, with the columns its consumers +# read. The normaliser guarantees both; this is the backstop that keeps a +# future construction path from quietly dropping one. +# @noRd +.ldCheckBlockMetadata <- function(object) { + bm <- object@blockMetadata + absent <- setdiff(.ldBlockMcols, names(S4Vectors::mcols(bm))) + if (length(absent) > 0L) { + return(str_c( + "'blockMetadata' is missing required column(s): ", + str_flatten(absent, ", ") + )) + } + if (length(bm) == 0L) { + return("'blockMetadata' must describe at least one block") + } + NULL +} + #' @title Create an LdData Object #' @description Construct an \code{LdData} from a correlation matrix and/or #' genotype handle, plus variant metadata as a GRanges. @@ -198,7 +458,12 @@ setMethod("show", "LdData", function(object) { #' @param snpIdx Vector of 1-based SNP indices, coerced to integer, or NULL. #' @param variants A GRanges with variant metadata (must have variant_id in #' mcols, plus A1, A2). -#' @param blockMetadata GRanges of blocks, or data.frame with block info. +#' @param blockMetadata Block boundaries: a \code{GRanges}, a +#' \code{data.frame} or a \code{DataFrame}. Whatever is absent for a +#' single block is derived from \code{variants}, so a bare genomic span +#' -- or nothing at all -- is enough; with several blocks either the index +#' columns or \code{size} must be supplied. Normalised on the way in and +#' stored as a \code{GRanges} (see the \code{blockMetadata} slot). #' @param nRef Integer, reference panel sample size. #' @param mixtureWeights Optional numeric vector of mixing proportions, one per #' panel in \code{genotypeHandle} when it is a list. Must be non-negative and @@ -214,6 +479,8 @@ setMethod("show", "LdData", function(object) { #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) #' ld +#' @importFrom checkmate assert checkMatrix checkList checkNull +#' @importFrom checkmate assertNumeric #' @export LdData <- function( correlation = NULL, @@ -224,13 +491,22 @@ LdData <- function( nRef = 0L, mixtureWeights = NULL ) { + # correlation is documented as a matrix OR a list of matrices OR NULL, + # so this must be an or-combination, not assertMatrix. + assert( + checkMatrix(correlation), + checkList(correlation), + checkNull(correlation), + .var.name = "correlation" + ) + assertNumeric(mixtureWeights, null.ok = TRUE) obj <- new( "LdData", variants, correlation = correlation, genotypeHandle = .ldDataGenotypeSource(genotypeHandle), snpIdx = if (is.null(snpIdx)) NULL else as.integer(snpIdx), - blockMetadata = blockMetadata, + blockMetadata = .ldBlockMetadata(blockMetadata, variants), nRef = as.integer(nRef), mixtureWeights = mixtureWeights ) @@ -255,14 +531,23 @@ LdData <- function( A2 = refPanel$A2 ) - optional <- c("allele_freq", "variance", "n_nomiss") - for (col in optional) { - if (is_in(col, names(refPanel))) { - mcolsData[[col]] <- refPanel[[col]] - } - } - mcols(gr) <- mcolsData - gr + optional <- intersect( + c("allele_freq", "variance", "n_nomiss"), + names(refPanel) + ) + `mcols<-`( + gr, + value = cbind( + mcolsData, + DataFrame(refPanel[optional], check.names = FALSE) + ) + ) +} + +# One panel scaled by its mixture weight. +# @noRd +.ldScalePanel <- function(w, panel) { + w * panel } #' @rdname getCorrelation @@ -293,20 +578,23 @@ setMethod("getCorrelation", "LdData", function(x) { ) abort(msg) } - w <- x@mixtureWeights - R <- matrix(0, nrow = dims[[1L]], ncol = dims[[1L]]) - for (k in seq_along(perPanel)) { - R <- R + w[[k]] * perPanel[[k]] - } - dimnames(R) <- dimnames(perPanel[[1L]]) - return(R) + # The mixture is a weighted sum over the panels, so it is a fold. + weighted <- map2(x@mixtureWeights, perPanel, .ldScalePanel) + return(`dimnames<-`( + reduce( + weighted, + `+`, + .init = matrix(0, nrow = dims[[1L]], ncol = dims[[1L]]) + ), + dimnames(perPanel[[1L]]) + )) } computeLd(.ldSourceDosages(x@genotypeHandle, x@snpIdx), method = "sample") }) #' @rdname getGenotypes #' @export -setMethod("getGenotypes", "LdData", function(x, ...) { +setMethod("getGenotypes", "LdData", function(x) { if (is.null(x@genotypeHandle)) { return(NULL) } @@ -326,7 +614,7 @@ setMethod("hasGenotypes", "LdData", function(x) { #' @rdname getVariantIds #' @export -setMethod("getVariantIds", "LdData", function(x, ...) { +setMethod("getVariantIds", "LdData", function(x) { mcols(x)$variant_id }) @@ -347,10 +635,11 @@ setMethod("getBlockMetadata", "LdData", function(x) { #' @rdname getRefPanel #' @export setMethod("getRefPanel", "LdData", function(x) { - mc <- as_tibble(as.data.frame(mcols(x))) - mc$chrom <- as.character(seqnames(x)) - mc$pos <- start(x) - mc + mutate( + as_tibble(as.data.frame(mcols(x))), + chrom = as.character(seqnames(x)), + pos = start(x) + ) }) #' @rdname getGenotypeHandle diff --git a/R/LdEigen.R b/R/LdEigen.R index 5b696c68c..1edb16617 100644 --- a/R/LdEigen.R +++ b/R/LdEigen.R @@ -40,26 +40,28 @@ setClass( ) # @noRd +#' @importFrom checkmate makeAssertCollection assertList .validateLdEigen <- function(object) { + coll <- makeAssertCollection() parentCheck <- .validateLdStatistic(object) - errors <- if (isTRUE(parentCheck)) character() else parentCheck - if (length(object@eigenList) != length(object@ldBlocks)) { - errors <- c( - errors, - "Length of 'eigenList' must match number of LD blocks" - ) + if (!isTRUE(parentCheck)) { + coll$push(parentCheck) } + assertList( + object@eigenList, + len = length(object@ldBlocks), + .var.name = "eigenList", + add = coll + ) + # checkmate has no exclusive lower bound, so (0, 1] stays a plain check. if ( length(object@eigenvalueTruncation) != 1L || object@eigenvalueTruncation <= 0 || object@eigenvalueTruncation > 1 ) { - errors <- c( - errors, - "'eigenvalueTruncation' must be a single value in (0, 1]" - ) + coll$push("'eigenvalueTruncation' must be a single value in (0, 1]") } - if (length(errors) == 0) TRUE else errors + coll$getMessages() } #' @title Create an LdEigen @@ -87,6 +89,7 @@ setClass( #' ldBlocks = blocks, nRef = 100L, genome = "hg19") #' length(le) #' length(getEigenList(le)) +#' @importFrom checkmate assertDataFrame assertList assertCount #' @export LdEigen <- function( snpInfo, @@ -97,6 +100,9 @@ LdEigen <- function( genome = NA_character_, eigenvalueTruncation = 1 ) { + assertDataFrame(snpInfo) + assertList(eigenList) + assertCount(nRef, positive = TRUE) obj <- methods::new( "LdEigen", .ldStatRanges(snpInfo, genome), @@ -110,6 +116,7 @@ LdEigen <- function( obj } +#' @importFrom checkmate assertCount assertFlag #' @title Build an LdEigen from loaded LD #' @description Eigendecompose already-loaded LD, block by block, into the #' \code{LdEigen} that \code{\link{estimateH2}} consumes for @@ -160,6 +167,8 @@ buildLdEigen <- function( genome = NA_character_, eigenvalueTruncation = 1 ) { + assertCount(nRef, positive = TRUE, null.ok = TRUE) + assertFlag(inSample) prep <- .ldRefPrepare(ldBlockData, nRef, genome) eigenList <- map2( prep$blocks, diff --git a/R/LdScore.R b/R/LdScore.R index 273a36220..1c1a7c09a 100644 --- a/R/LdScore.R +++ b/R/LdScore.R @@ -28,16 +28,21 @@ setClass( ) # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateLdScore <- function(object) { + coll <- makeAssertCollection() parentCheck <- .validateLdStatistic(object) - errors <- if (isTRUE(parentCheck)) character() else parentCheck - md <- S4Vectors::mcols(object, use.names = FALSE) - for (col in c("ldScores", "ldScoreWeights")) { - if (!is_in(col, colnames(md))) { - errors <- c(errors, glue("mcols must carry an '{col}' column")) - } + if (!isTRUE(parentCheck)) { + coll$push(parentCheck) } - if (length(errors) == 0) TRUE else errors + assertNames( + colnames(S4Vectors::mcols(object, use.names = FALSE)), + must.include = c("ldScores", "ldScoreWeights"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + coll$getMessages() } #' @title Create an LdScore @@ -65,6 +70,7 @@ setClass( #' inSample = FALSE, genome = "hg19") #' length(ls) #' head(getLdScores(ls)) +#' @importFrom checkmate assertMatrix assertNumeric #' @export LdScore <- function( snpInfo, @@ -78,25 +84,21 @@ LdScore <- function( ) { gr <- .ldStatRanges(snpInfo, genome) ldScores <- as.matrix(ldScores) - if (nrow(ldScores) != length(gr)) { - abort(glue( - "`ldScores` has {nrow(ldScores)} row(s) for {length(gr)} ", - "variant(s); they must be parallel." - )) - } - if (length(ldScoreWeights) != length(gr)) { - abort(glue( - "`ldScoreWeights` has {length(ldScoreWeights)} value(s) for ", - "{length(gr)} variant(s); they must be parallel." - )) - } - md <- S4Vectors::mcols(gr, use.names = FALSE) - md$ldScores <- ldScores - md$ldScoreWeights <- as.numeric(ldScoreWeights) - S4Vectors::mcols(gr) <- md + assertMatrix(ldScores, nrows = length(gr)) + assertNumeric(ldScoreWeights, len = length(gr)) + scored <- S4Vectors::`mcols<-`( + gr, + value = cbind( + S4Vectors::mcols(gr, use.names = FALSE), + S4Vectors::DataFrame( + ldScores = I(ldScores), + ldScoreWeights = as.numeric(ldScoreWeights) + ) + ) + ) obj <- methods::new( "LdScore", - gr, + scored, ldBlocks = .asLdBlockRanges(ldBlocks), nRef = as.integer(nRef), inSample = isTRUE(inSample), @@ -106,6 +108,7 @@ LdScore <- function( obj } +#' @importFrom checkmate assertCount assertFlag #' @title Build an LdScore from loaded LD #' @description Compute per-variant LD scores from already-loaded LD, block by #' block, into the \code{LdScore} that \code{\link{estimateH2}} consumes @@ -162,6 +165,9 @@ buildLdScore <- function( ldScoreWeights = NULL, keepLdMatrices = TRUE ) { + assertCount(nRef, positive = TRUE, null.ok = TRUE) + assertFlag(inSample) + assertFlag(keepLdMatrices) prep <- .ldRefPrepare(ldBlockData, nRef, genome) l2 <- .ldScoreVector(prep$blocks, prep$snpIdx, nrow(prep$snpInfo)) ldMatrixList <- if (isTRUE(keepLdMatrices)) { @@ -185,11 +191,21 @@ buildLdScore <- function( # reference order. # @noRd .ldScoreVector <- function(blocks, snpIdx, nVariants) { - l2 <- numeric(nVariants) - for (b in seq_along(blocks)) { - l2[snpIdx[[b]]] <- rowSums(blocks[[b]]$R^2) + if (length(blocks) == 0L) { + return(numeric(nVariants)) } - l2 + # The blocks partition the variants, so each variant's score lands in + # exactly one place; variants in no block stay zero. + replace( + numeric(nVariants), + list_c(snpIdx), + list_c(map(blocks, .ldScoreBlockSums)) + ) +} + +# @noRd +.ldScoreBlockSums <- function(block) { + rowSums(block$R^2) } # @noRd @@ -204,12 +220,7 @@ buildLdScore <- function( if (is.null(ldScoreWeights)) { return(1 / pmax(l2, 1)) } - if (length(ldScoreWeights) != length(l2)) { - abort(glue( - "`ldScoreWeights` has {length(ldScoreWeights)} value(s) for ", - "{length(l2)} variant(s)." - )) - } + assertNumeric(ldScoreWeights, len = length(l2)) as.numeric(ldScoreWeights) } diff --git a/R/LdStatistic.R b/R/LdStatistic.R index 60d82776d..722c8de42 100644 --- a/R/LdStatistic.R +++ b/R/LdStatistic.R @@ -38,18 +38,17 @@ setClass( ) # @noRd +#' @importFrom checkmate makeAssertCollection assertCount assertLogical .validateLdStatistic <- function(object) { - errors <- character() - if (length(object@nRef) != 1L || object@nRef <= 0L) { - errors <- c(errors, "'nRef' must be a single positive integer") - } - if (length(object@inSample) != 1L) { - errors <- c(errors, "'inSample' must be a single logical value") - } + coll <- makeAssertCollection() + assertCount(object@nRef, positive = TRUE, .var.name = "nRef", add = coll) + # assertLogical(len = 1) rather than assertFlag: the slot's declared type + # already excludes non-logicals, and NA is tolerated here as it was before. + assertLogical(object@inSample, len = 1L, .var.name = "inSample", add = coll) if (length(object) == 0L) { - errors <- c(errors, "an LdStatistic must carry at least one variant") + coll$push("an LdStatistic must carry at least one variant") } - if (length(errors) == 0) TRUE else errors + coll$getMessages() } # The variants of an LD reference, as the GRanges every subclass is built on. @@ -69,15 +68,28 @@ setClass( seqnames = withChrPrefix(as.character(snpInfo$CHR)), ranges = IRanges::IRanges(as.integer(snpInfo$BP), width = 1L) ) - names(gr) <- as.character(snpInfo$SNP) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - select(snpInfo, -any_of(c("CHR", "BP"))), - row.names = NULL + labelled <- S4Vectors::`mcols<-`( + `names<-`(gr, as.character(snpInfo$SNP)), + value = S4Vectors::DataFrame( + select(snpInfo, -any_of(c("CHR", "BP"))), + row.names = NULL + ) + ) + .withGenomeBuild( + labelled, + !is.null(genome) && length(genome) == 1L && nzchar(genome), + genome ) - if (!is.null(genome) && length(genome) == 1L && nzchar(genome)) { - GenomeInfoDb::genome(gr) <- genome +} + +# The ranges carrying `genome` as their seqinfo build, when the caller named +# one. GRanges has no constructor argument for it, so it is written back. +# @noRd +.withGenomeBuild <- function(gr, named, genome) { + if (!named) { + return(gr) } - gr + GenomeInfoDb::`genome<-`(gr, value = genome) } # ============================================================================= @@ -149,14 +161,10 @@ setClass( } # @noRd +#' @importFrom checkmate assertMatrix .ldRefOneBlock <- function(R, gr) { R <- as.matrix(R) - if (nrow(R) != length(gr)) { - abort(glue( - "an LD block's correlation matrix is {nrow(R)}x{ncol(R)} but ", - "covers {length(gr)} variant(s)." - )) - } + assertMatrix(R, nrows = length(gr), .var.name = "LD block correlation") list(R = R, gr = gr) } @@ -173,9 +181,12 @@ setClass( )) } md <- getBlockMetadata(x) - hasIdx <- is.data.frame(md) && - all(is_in(c("startIdx", "endIdx"), names(md))) && - nrow(md) == length(R) + # blockMetadata is a GRanges: the index payload is in mcols. + hasIdx <- all(is_in( + c("startIdx", "endIdx"), + names(S4Vectors::mcols(md)) + )) && + length(md) == length(R) if (hasIdx) { return(map2(as.integer(md$startIdx), as.integer(md$endIdx), seq.int)) } @@ -266,10 +277,7 @@ setClass( end = map_int(blocks, .ldRefBlockEnd) ) ) - if (.ldRefNamedGenome(genome)) { - GenomeInfoDb::genome(gr) <- genome - } - gr + .withGenomeBuild(gr, .ldRefNamedGenome(genome), genome) } # An LD block is within-chromosome by construction, and .ldRefBlockRanges() @@ -309,8 +317,7 @@ setClass( if (!is.null(nRef)) { return(as.integer(nRef)) } - found <- unique(map_int(dataList, .ldRefNRefOf)) - found <- found[!is.na(found)] + found <- discard(unique(map_int(dataList, .ldRefNRefOf)), is.na) if (length(found) == 0L) { abort(glue( "`nRef` is required: none of the supplied LdData records a ", @@ -337,15 +344,13 @@ setClass( if (.ldRefNamedGenome(genome)) { return(genome) } - found <- unique(map_chr(dataList, .ldRefGenomeOf)) - found <- found[!is.na(found)] + found <- discard(unique(map_chr(dataList, .ldRefGenomeOf)), is.na) if (length(found) == 1L) found[[1L]] else NA_character_ } # @noRd .ldRefGenomeOf <- function(x) { - g <- unique(GenomeInfoDb::genome(as(x, "GRanges"))) - g <- g[!is.na(g)] + g <- discard(unique(GenomeInfoDb::genome(as(x, "GRanges"))), is.na) if (length(g) == 1L) g[[1L]] else NA_character_ } @@ -363,10 +368,9 @@ setMethod("getLdBlocks", "LdStatistic", function(x) x@ldBlocks) #' @rdname getGenome #' @export -setMethod("getGenome", "LdStatistic", function(x, ...) { +setMethod("getGenome", "LdStatistic", function(x) { # The build lives in seqinfo, not a slot: a GRanges already has somewhere # to keep it, and storing it twice is what the retired LdBlocks class did. - build <- unique(GenomeInfoDb::genome(x)) - build <- build[!is.na(build)] + build <- discard(unique(GenomeInfoDb::genome(x)), is.na) if (length(build) == 0L) NA_character_ else build[[1L]] }) diff --git a/R/MashPrior.R b/R/MashPrior.R index dab2ef504..84254723e 100644 --- a/R/MashPrior.R +++ b/R/MashPrior.R @@ -126,8 +126,10 @@ setClass( #' U <- list(shared = diag(3), singleton = matrix(0.3, 3, 3) + diag(0.7, 3)) #' mp <- MashPrior(fullFit = list(U = U, w = c(0.5, 0.5))) #' mp +#' @importFrom checkmate assertList #' @export MashPrior <- function(fullFit = NULL, cvFits = NULL) { + assertList(cvFits, null.ok = TRUE) obj <- new("MashPrior", fullFit = fullFit, cvFits = cvFits) validObject(obj) obj @@ -135,11 +137,11 @@ MashPrior <- function(fullFit = NULL, cvFits = NULL) { #' @rdname getFullFit #' @export -setMethod("getFullFit", "MashPrior", function(x, ...) x@fullFit) +setMethod("getFullFit", "MashPrior", function(x) x@fullFit) #' @rdname getCvFits #' @export -setMethod("getCvFits", "MashPrior", function(x, ...) x@cvFits) +setMethod("getCvFits", "MashPrior", function(x) x@cvFits) #' @rdname show-methods #' @export diff --git a/R/MethodOptions.R b/R/MethodOptions.R new file mode 100644 index 000000000..09b6a63a0 --- /dev/null +++ b/R/MethodOptions.R @@ -0,0 +1,650 @@ +# ============================================================================= +# MethodOptions S4 class +# ----------------------------------------------------------------------------- +# One fitting engine's arguments, as built by a constructor. +# +# Every tunable pecotmr forwards to an external engine is built by a +# constructor: pecotmr's own defaults are the constructor's named formals, and +# anything else the engine accepts goes through `...`. The constructor checks +# the extras against the engine's LIVE formals, so the check can never drift +# from the upstream signature the way a transcribed list of names does. +# +# It IS a SimpleList, which is what makes "constructor required" enforceable. +# A plain list carrying an S3 class loses that class on `[`, `c()` and +# `compact()` -- all of which this package performs on these very records +# (.fmNarrowAfterJoint, .fmQssJointPhase, .ctwasInvoke) -- so the marker would +# evaporate on first use. SimpleList's subsetting is endomorphic and its +# metadata() survives, and it still splices with `!!!`, so no existing +# exec(fn, !!!args) call site changes. +# +# Why constructors exist at all: a bare list cannot be checked. +# `summaryStatsQc`'s imputation bundle advertised an `rcond` in its own +# default, but QC always routes RAISS through the SVD solver, which takes +# `svdTol` -- so `rcond` was read by nobody and silently ignored for as long +# as it existed. A constructor turns that into an error at the call site. +# ============================================================================= + +#' @include AllGenerics.R +NULL + +#' @title Arguments For One Fitting Engine +#' @description A validated bundle of arguments destined for one external +#' fitting engine, produced by an engine constructor such as +#' \code{SusieOptions()} or \code{MrmashOptions()} rather than written as a +#' bare list. Names are checked against the engine's own formals at +#' construction, so a misspelled option fails immediately instead of being +#' silently dropped. +#' +#' It \strong{is} a \code{\link[S4Vectors]{SimpleList}}: \code{$}, +#' \code{[[}, \code{names()} and \code{length()} behave as on a list, it +#' splices into a call with \code{!!!}, and subsetting returns a +#' \code{MethodOptions} rather than degrading to a plain list. The engine name +#' and the callee it forwards to travel in \code{metadata()}. +#' @section Whether argument names are checked: +#' A constructor checks the names you give it against the \emph{live} +#' formals of the function it forwards to, so the check can never drift from +#' the version of that package you have installed. Printing a +#' \code{MethodOptions} says which applies to it. +#' +#' Names cannot be checked in two situations, and in both the arguments are +#' forwarded unchecked rather than rejected: +#' \itemize{ +#' \item \strong{The engine takes \code{...}}, so any name is legal as +#' far as it is concerned. As of writing this applies to +#' \code{mvsusieR::mvsusie_rss}, \code{mvsusieR::create_mixture_prior}, +#' \code{ncvreg::ncvreg}, \code{ncvreg::cv.ncvreg}, +#' \code{RcppDPR::fit_model}, \code{mashr::cov_ed}, +#' \code{ctwas::finemap_regions} and +#' \code{ctwas::postprocess_region_merging}. A misspelling here reaches +#' the engine, which may ignore it silently. +#' \item \strong{The engine's package is not installed}, so its formals +#' cannot be read. Building the arguments still works -- it is not +#' running the engine -- and the engine's own requirement check reports +#' the missing package when you actually run it. +#' } +#' +#' Every other engine enumerates its arguments, so a misspelling is an error +#' at the call site naming the accepted set. Constructors for pecotmr's own +#' engines take no \code{...} at all, so R itself rejects an unknown name as +#' an unused argument. +#' @aliases MethodOptions +#' @importClassesFrom S4Vectors SimpleList +#' @export +setClass("MethodOptions", contains = "SimpleList") + +# Resolve "pkg::fn" to the function, or NULL when there is nothing to resolve: +# a package that is not installed, or `callee = NULL` for a bundle pecotmr owns +# outright. A missing Suggests package is not an error here -- building an +# argument list is not running the engine, and the engine's own +# requireNamespace() guard gives a better message where it actually matters. +# @noRd +.engineCallee <- function(callee) { + if (is.null(callee)) { + return(NULL) + } + if (is.function(callee)) { + return(callee) + } + parts <- str_split_1(callee, fixed("::")) + if (length(parts) != 2L) { + abort(glue("engine callee must be 'pkg::fn', got '{callee}'")) + } + if (!requireNamespace(parts[[1L]], quietly = TRUE)) { + return(NULL) + } + tryCatch( + get(parts[[2L]], envir = asNamespace(parts[[1L]])), + error = function(cnd) NULL + ) +} + +# The names an engine will accept, or NULL when that cannot be determined -- +# either the package is absent or the engine takes `...`, in which case it +# accepts anything and there is nothing to check against. +# +# Several callees may be given, for a bundle that reaches more than one +# function. What can be checked then depends on HOW the caller forwards it: +# +# filtered = TRUE -- the caller intersects the bundle with each callee's +# explicit formals before calling it (see .ctwasInvoke). A name outside +# the union of those formals reaches no callee, so it can only be a +# mistake, and `...` on any one callee changes nothing. +# filtered = FALSE -- the caller splices the bundle straight in, so a +# callee's `...` really will accept anything and nothing can be rejected. +# @noRd +.engineAcceptedNames <- function(callee, filtered = FALSE) { + if (length(callee) > 1L) { + if (!filtered && any(map_lgl(callee, .engineTakesDots))) { + return(NULL) + } + return(.engineUnionNames(callee)) + } + fn <- .engineCallee(callee) + if (is.null(fn)) { + return(NULL) + } + fm <- tryCatch(names(formals(fn)), error = function(cnd) NULL) + if (is.null(fm) || is_in("...", fm)) { + return(NULL) + } + fm +} + +# TRUE when a callee takes `...`, so it accepts any name. An unreadable +# callee is treated as not taking dots; .engineUnionNames drops it anyway. +# @noRd +.engineTakesDots <- function(callee) { + fn <- .engineCallee(callee) + if (is.null(fn)) { + return(FALSE) + } + fm <- tryCatch(names(formals(fn)), error = function(cnd) NULL) + !is.null(fm) && is_in("...", fm) +} + +# Union of several callees' explicit formals; NULL when none could be read, +# which keeps a missing package from turning every name into an error. +# @noRd +.engineUnionNames <- function(callees) { + fns <- map(callees, .engineCallee) + known <- compact(fns) + if (length(known) == 0L) { + return(NULL) + } + sort(unique(list_c(map(known, .engineExplicitFormals)))) +} + +# One callee's formals with `...` removed, NULL when they cannot be read. +# @noRd +.engineExplicitFormals <- function(fn) { + setdiff(tryCatch(names(formals(fn)), error = function(cnd) NULL), "...") +} + +# --- which input classes a set of engine arguments belongs to ------------- +# +# A method that runs on both individual-level and summary-statistic data +# reaches a DIFFERENT engine on each path -- often in a different package +# (glmnet vs lassosum, RcppDPR vs SDPR) -- so an Options record is valid for +# one path and meaningless for the other. Recording which lets a pipeline +# reject `SusieRssOptions()` for a QtlDataset by asking the record, instead +# of joining against a registry at the point of use. +# +# Derived from the two dispatch tables, never declared per constructor: a +# hand-written `inputType = "QtlSumStats"` in 24 constructors would be 24 +# more things to keep in step with the tables that actually drive dispatch. +# +# NULL for an engine with no input-path dimension at all -- mash prior +# components, p-value tests, ctwas, coloc -- which is most of them. +# @noRd +.engineInputType <- function(callee, label) { + unique(c( + .fmCalleeInputType(callee), + .twasLabelInputType(label) + )) +} + +# Whether one fine-mapping method token accepts GwasSumStats. +# @noRd +.fmTokenGwasAllowed <- function(tk, caps) { + isTRUE(caps[[tk]]$gwasAllowed) +} + +# Fine-mapping stores the callees themselves, so the lookup is direct. A +# callee may serve several methods (susieR::susie backs susie, susieInf and +# susieAsh), and GwasSumStats is a summary-statistics class that only the +# univariate methods accept -- exactly what `gwasAllowed` already records. +# @noRd +.fmCalleeInputType <- function(callee) { + if (!is.character(callee) || length(callee) == 0L) { + return(character(0)) + } + caps <- .fineMappingMethodCapabilities + ind <- compact(map(caps, "individualImpl")) + sumstat <- compact(map(caps, "sumstatImpl")) + gwas <- keep(names(sumstat), .fmTokenGwasAllowed, caps = caps) + c( + if (any(is_in(callee, unlist(ind)))) "QtlDataset", + if (any(is_in(callee, unlist(sumstat)))) "QtlSumStats", + if (any(is_in(callee, unlist(sumstat[gwas])))) "GwasSumStats" + ) +} + +# The Options-constructor names declared by every TWAS method that fills +# one capability field. +# @noRd +.twasCtorNamesFor <- function(caps, field) { + unlist(compact(map( + compact(map(caps, field)), + .twasImplCtorName + ))) +} + +# TWAS stores pecotmr implementations rather than callees, and each one +# names its own Options constructor through its `methodArgs` default -- so +# the lookup is by constructor name, which is what `label` carries. +# @noRd +.twasLabelInputType <- function(label) { + if (!is.character(label) || length(label) != 1L) { + return(character(0)) + } + caps <- .twasMethodCapabilities + individual <- .twasCtorNamesFor(caps, "individualImpl") + sumstat <- .twasCtorNamesFor(caps, "sumstatImpl") + c( + if (is_in(label, individual)) "QtlDataset", + if (is_in(label, sumstat)) "QtlSumStats" + ) +} + +# The input classes a record is valid for, or NULL when it has no path +# dimension. Reads what the constructor derived; never recomputes. +# @noRd +.optionsInputType <- function(x) { + if (!.isMethodOptions(x)) { + return(NULL) + } + it <- metadata(x)$inputType + if (length(it) == 0L) NULL else it +} + +# Reject extras the engine cannot accept. `accepted = NULL` means the check is +# not possible (absent package, or an engine with `...`), so the extras pass +# through untouched -- deliberately, since such an engine really does take +# arbitrary names. +# @noRd +.engineCheckExtra <- function(extra, accepted, label, calleeName) { + if (length(extra) == 0L || is.null(accepted)) { + return(invisible(NULL)) + } + unknown <- setdiff(names(extra), accepted) + if (length(unknown) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "{label}: unknown argument(s) ", + "{str_flatten(unknown, ', ')}. ", + "`{calleeName}` accepts: {str_flatten(accepted, ', ')}." + )) +} + +# The record's entries: pecotmr's defaults, with an explicit value +# replacing one of the same name. +# +# Two names colliding inside `extra` is the caller saying the same thing +# twice -- including a wrapper's own contribution meeting the caller's +# record under .methodOptionsWith() -- and there is no basis for picking a +# winner. A `defaults` entry is only pecotmr's preference, so an explicit +# value replaces it in place, keeping the default's position; an argument +# pecotmr truly owns is refused outright by the constructor rather than +# left to collide here. +# @noRd +.configMerge <- function(defaults, extra, label) { + dup <- names(extra)[duplicated(names(extra))] + if (length(dup) > 0L) { + abort(glue( + "{label}: argument(s) given twice: {str_flatten(dup, ', ')}" + )) + } + defaults <- discard(defaults, is.null) + overridden <- intersect(names(defaults), names(extra)) + defaults[overridden] <- extra[overridden] + c(defaults, extra[!names(extra) %in% overridden]) +} + +# Build one engine's argument record: pecotmr's defaults, overlaid with the +# caller's extras, validated against the engine where that is possible. +# +# `defaults` is what the constructor's own formals resolved to; `extra` is its +# `...`. A NULL default means "leave it to the engine", so it is dropped rather +# than forwarded as an explicit NULL, which some engines treat differently from +# an absent argument. Only NULL: `compact()` would also drop a zero-length +# value, silently losing `keepSamples = character(0)` and +# `greedy_args = list()` -- both meaningful settings, not absent ones. +# Values are carried as given -- matrices, fits, functions and all -- since +# what an engine accepts is the engine's business; only the argument NAMES +# are checkable. +# +# `callee = NULL` marks a bundle pecotmr owns rather than forwards. Such a +# constructor declares every field as a formal and takes no `...`, so R's own +# argument matching rejects a misspelling before this is ever reached; there +# is no foreign signature to check against. +# @noRd +#' @importFrom rlang is_named +#' @importFrom purrr map2_lgl +#' @importFrom S4Vectors SimpleList metadata metadata<- +.newMethodOptions <- function( + callee, + defaults, + extra, + label, + engine = NULL, + accepted = NULL, + filtered = FALSE, + inputType = NULL +) { + if (length(extra) > 0L && !is_named(extra)) { + abort(glue("{label}: all arguments passed through `...` must be named")) + } + # A callee handed over as a function -- or absent entirely, for a bundle + # pecotmr owns -- has no spellable name, so the label stands in for it. + calleeName <- if (is.character(callee)) { + str_flatten(callee, " / ") + } else { + label + } + # `accepted` given explicitly is for an engine whose options are not its + # formals -- udr takes a `control` list, whose valid names come from + # udr::ud_fit_control_default(). Still a live source, not a transcription. + # + # There is no flag for "do not check": the one case where names cannot + # be checked is an engine that takes `...`, and .engineAcceptedNames() + # reads that off the callee's live formals, returning NULL -- which is + # what .engineCheckExtra() treats as "nothing to check against". A + # missing package and unreadable formals answer NULL the same way. + accepted <- accepted %||% .engineAcceptedNames(callee, filtered) + .engineCheckExtra(extra, accepted, label, calleeName) + res <- new( + "MethodOptions", + SimpleList(.configMerge(defaults, extra, label)) + ) + metadata(res) <- list( + engine = engine %||% label, + callee = if (is.character(callee)) callee else NA_character_, + filtered = filtered, + inputType = inputType %||% .engineInputType(callee, label) + ) + res +} + +# Refuse names the caller cannot usefully set, naming where the setting +# lives instead. Same shape as .ctwasRefusePipelineOwned: a real formal of +# the engine that pecotmr supplies itself, so a value given here would be +# overwritten rather than honoured. `owned` is a named character vector, +# name = the refused argument, value = where the caller sets it instead. +# @noRd +.configRefuseOwned <- function(extra, owned, label) { + clash <- intersect(names(extra), names(owned)) + if (length(clash) == 0L) { + return(invisible(NULL)) + } + where <- str_flatten( + sprintf("`%s` -> %s", clash, unname(owned[clash])), + collapse = "; " + ) + abort(glue( + "{label}: {str_flatten(clash, \', \')} ", + "{if (length(clash) == 1L) \'is\' else \'are\'} supplied by ", + "pecotmr, so a value given here would be overwritten. Use: {where}." + )) +} + +# TRUE for a record a constructor produced. Used by the pipelines to refuse a +# bare list, which is the whole point of requiring constructors. +# @noRd +.isMethodOptions <- function(x) { + is(x, "MethodOptions") +} + +# Demand a constructor-built record, naming the constructor the caller should +# have used so the error is actionable rather than merely correct. +# @noRd +.assertMethodOptions <- function(x, ctor, argName) { + if (.isMethodOptions(x)) { + return(invisible(x)) + } + if (is.list(x) && length(x) == 0L) { + # An empty list carries no settings, so there is nothing to validate + # and nothing a constructor would have added. Accepting it keeps + # `list()` working as "no options". + return(invisible(x)) + } + abort(glue( + "`{argName}` must be built with {ctor}(), not a bare list. ", + "A bare list cannot be checked against the engine, so a misspelled ", + "option would be silently ignored." + )) +} + +# A wrapper that contributes an engine option of its own -- bayesCWeights's +# `pi`, dprVbWeights's `n_k` -- cannot simply c() it onto the caller's record: +# c() appends a MethodOptions as one opaque element rather than splicing it, and +# even flattening first would hand the next hop a bare list its +# .assertMethodOptions() then refuses. Rebuild through the constructor instead, +# so what travels on is still a checked record -- and a caller who also set +# that option through `methodArgs` gets .newMethodOptions()'s "given twice" +# error rather than a silent override. +# @noRd +.methodOptionsWith <- function(x, ctor, ...) { + exec(match.fun(ctor), ..., !!!as.list(x)) +} + +# --- character-or-constructor selection ------------------------------------ +# +# Anywhere pecotmr lets the caller pick an engine, the argument takes either +# the engine's name or that engine's constructor. The constructor already +# carries the identity in metadata(), so `engine = CovUdrOptions(...)` says +# which engine AND how to configure it in one value, and a bare string stays +# the no-options shorthand. + +# The engine a selection denotes, whether it arrived as a name or a record. +# @noRd +.engineOf <- function(x) { + if (.isMethodOptions(x)) { + return(metadata(x)$engine) + } + # A Param carries no metadata() -- its class IS its identity, so the + # engine comes from the class name. DentistParam() and SlalomParam() are + # both engine choices for `ldMismatchQcMethod`, so this arm is load + # bearing, not defensive. + if (.isMethodParam(x)) { + return(.paramEngineOf(x)) + } + if (is.character(x) && length(x) == 1L) { + return(x) + } + NULL +} + +# Resolve a character-or-constructor selection into the chosen engine and its +# arguments. `allowed` is the permitted engine vocabulary; a record built by a +# constructor outside it is rejected by name rather than left to fail further +# down. +# @noRd +.resolveEngineChoice <- function(x, allowed, argName) { + engine <- .engineOf(x) + if (is.null(engine)) { + abort(glue( + "`{argName}` must be one of {str_flatten(allowed, ', ')}, ", + "or the matching constructor." + )) + } + if (!is_in(engine, allowed)) { + abort(glue( + "`{argName}`: unknown engine '{engine}'. ", + "Known: {str_flatten(allowed, ', ')}." + )) + } + list( + engine = engine, + args = if (.isMethodOptions(x) || .isMethodParam(x)) { + x + } else { + .newMethodOptions( + NULL, + defaults = list(), + extra = list(), + label = argName, + engine = engine + ) + } + ) +} + +# --- nested per-engine bundles --------------------------------------------- + +# Every entry must have been built by a constructor its key accepts. +# Checked before building so the message is the user's, not purrr's "In +# index: 1. With name: foo." framing around it. The acceptable engines come +# from the key's own constructor rather than from the key: several keys may +# share one engine (lasso and enet are both glmnet). `engines` overrides +# that for a key whose paths run more than one -- TWAS's lasso fits with +# glmnet on individual data and with pecotmr's lassosum solver on summary +# statistics, and either constructor is a legitimate way to configure it. +# @noRd +.nestedAssertEngines <- function(elements, ctors, engines, label) { + declared <- map_chr(elements, .nestedDeclaredEngine) + allowed <- map( + names(elements), + .nestedAllowedEngines, + ctors = ctors, + engines = engines + ) + mismatch <- which(!map2_lgl(declared, allowed, .nestedEngineMatches)) + if (length(mismatch) == 0L) { + return(invisible(NULL)) + } + i <- mismatch[[1L]] + abort(glue( + "{label}: the `{names(elements)[i]}` entry was built with the ", + "constructor for '{declared[[i]]}', but `{names(elements)[i]}` ", + "uses the ", + "{str_flatten(sprintf(\"'%s'\", allowed[[i]]), ' or ')} ", + "constructor. ", + "{if (length(allowed[[i]]) > 1L) 'Pass one of those' else ", + "'Pass that'}, or a plain list." + )) +} + +# A plain-list entry declares no engine, so nothing to match. +# @noRd +.nestedEngineMatches <- function(declared, allowed) { + is.na(declared) || is_in(declared, allowed) +} + +# The engines a key accepts: the caller's list for that key when given, +# otherwise the single one the key's own constructor produces. +# @noRd +.nestedAllowedEngines <- function(key, ctors, engines) { + engines[[key]] %||% .nestedExpectedEngine(key, ctors) +} + +# The engine a key's own constructor produces, so an entry built by a +# different engine's constructor can be told apart from one built by a +# sibling key that shares the same engine. +# @noRd +.nestedExpectedEngine <- function(key, ctors) { + rec <- tryCatch(ctors[[key]](), error = function(cnd) NULL) + if (is.null(rec)) { + return(key) + } + metadata(rec)$engine %||% key +} + +# The engine a nested entry was built for, or NA when it is a plain list. +# @noRd +.nestedDeclaredEngine <- function(value) { + if (.isMethodOptions(value)) metadata(value)$engine else NA_character_ +} + +# One element of a nested bundle: pass an already-built record through, or +# splice a plain list into the method's constructor. +# @noRd +.nestedElement <- function(value, key, ctors, label) { + if (.isMethodOptions(value)) { + return(value) + } + if (!is.list(value)) { + abort(glue( + "{label}: the `{key}` entry must be a list or a ", + "constructor result." + )) + } + exec(ctors[[key]], !!!value) +} + +# Why a given callee's arguments can or cannot be checked. Three reasons a +# name goes unchecked, and the user is entitled to know which one applies: +# the engine takes `...` so any name is legal, the engine's package is not +# installed so its formals cannot be read, or -- the normal case -- the +# engine enumerates its arguments and the names were checked. +# @noRd +.engineCheckNote <- function(callee, filtered = FALSE) { + if (length(callee) > 1L) { + accepted <- .engineAcceptedNames(callee, filtered) + if (is.null(accepted)) { + return(glue( + "argument names NOT checked: one of these functions takes ", + "`...`, so any name is accepted" + )) + } + return(glue( + "argument names checked against the {length(accepted)} arguments ", + "these {length(callee)} functions accept between them" + )) + } + fn <- .engineCallee(callee) + if (is.null(fn)) { + return(glue( + "argument names NOT checked: package ", + "'{str_split_1(callee, fixed('::'))[[1L]]}' is not installed" + )) + } + fm <- tryCatch(names(formals(fn)), error = function(cnd) NULL) + if (is.null(fm)) { + return("argument names NOT checked: the engine's formals are unknown") + } + if (is_in("...", fm)) { + return(glue( + "argument names NOT checked: {callee}() takes `...`, ", + "so any name is accepted" + )) + } + glue("argument names checked against {callee}()") +} + +#' @rdname MethodOptions-class +#' @param object A \code{MethodOptions} object. +#' @return \code{show} is called for its side effect and returns +#' \code{invisible(NULL)}. +#' @export +setMethod("show", "MethodOptions", function(object) { + md <- metadata(object) + cat(glue(""), "\n", sep = "") + if (!is.null(md$callee) && !anyNA(md$callee)) { + cat( + glue(" forwarded to {str_flatten(md$callee, '(), ')}()"), + "\n", + sep = "" + ) + # Whether names were checkable is a property of the callee, not of + # this record, so say it here rather than leaving the user to guess + # why a typo was or was not caught. + note <- .engineCheckNote(md$callee, md$filtered %||% FALSE) + cat(" ", note, "\n", sep = "") + } + # Which input classes these arguments belong to, when that is a + # meaningful question: a method running on both data paths reaches a + # different engine on each, so a record built for one is not usable on + # the other. + it <- .optionsInputType(object) + if (!is.null(it)) { + cat( + " for input class ", + str_flatten(sort(it), ", "), + "\n", + sep = "" + ) + } + if (length(object) == 0L) { + cat(" (no options set)\n") + return(invisible(NULL)) + } + for (nm in names(object)) { + cat(sprintf( + " %-22s %s\n", + nm, + str_flatten(format(object[[nm]]), ", ") + )) + } + invisible(NULL) +}) diff --git a/R/MethodParam.R b/R/MethodParam.R new file mode 100644 index 000000000..4f49d684d --- /dev/null +++ b/R/MethodParam.R @@ -0,0 +1,1035 @@ +# ============================================================================= +# MethodParam S4 virtual base +# ----------------------------------------------------------------------------- +# The other half of the argument-management split. +# +# A *Options() record is an argument bag bound for an external engine. Nothing +# in pecotmr defines what those arguments mean, so the only honest check is +# that each NAME exists in the engine's live formals; the values travel as +# given. That is MethodOptions. +# +# A *Param() record is the opposite case: a setting pecotmr itself reads. No +# upstream signature defines it, so there is nothing to validate names +# against -- but equally, nothing stops pecotmr from declaring each field's +# type and checking it, which is what Bioconductor's own *Param classes do. +# ScanBamParam, PileupParam and ScanVcfParam are each a plain setClass with +# typed slots and a validity method, inheriting from nothing. +# +# So: Options check names against someone else's signature, Params check +# types against their own. +# +# Why a shared virtual base rather than 26 unrelated classes: these records +# are read list-style throughout the pipelines -- `args$coverage`, +# `names(args)`, `as.list(args)` spliced into an engine. Declaring the slots +# typed and keeping the list view as methods on one base buys the typing +# without rewriting every read site. +# ============================================================================= + +#' @include AllGenerics.R +#' @include MethodOptions.R +#' @importFrom methods slot slotNames new is validObject +#' @importClassesFrom S4Vectors character_OR_NULL +NULL + +# --- nullable slot types --------------------------------------------------- +# +# A typed slot cannot hold NULL, and "unset" is a real state for most of +# these fields -- `medianAbsCorr = NULL` means "do not apply one", not "zero". +# A union per base type is the standard S4 way to say "this type, or unset", +# and it keeps the type declared rather than retreating to "ANY". +# +# `character_OR_NULL` is not defined here: S4Vectors exports it already, +# with the same definition, so it is imported rather than shadowed. + +setClassUnion("numeric_OR_NULL", c("numeric", "NULL")) +setClassUnion("logical_OR_NULL", c("logical", "NULL")) +setClassUnion("list_OR_NULL", c("list", "NULL")) + +# The one cross-family slot: SusieRssParam() carries a SusieRssControlOptions() +# record, which is a MethodOptions rather than a Param -- `control` really is +# someone else's argument list, nested inside a pecotmr setting. +setClassUnion("MethodOptions_OR_NULL", c("MethodOptions", "NULL")) + +#' @title Typed Settings For One Pipeline Stage +#' @description The virtual base of pecotmr's \code{*Param()} records -- +#' \code{\link{CredibleSetParam}}, \code{\link{SusieRssParam}}, +#' \code{\link{PanelFilterParam}} and the rest. Each one holds settings +#' \strong{pecotmr itself reads}, declared as typed slots and checked when +#' the record is built. +#' +#' This is the counterpart to \code{\link{MethodOptions}}, which carries +#' arguments bound for an \emph{external} engine. The distinction is +#' deliberate and visible in the name: a \code{*Param()} is a pecotmr +#' setting whose meaning and type pecotmr defines, so pecotmr validates it; +#' a \code{*Options()} is somebody else's argument list, so pecotmr checks +#' only that each name exists in that engine's live formals and otherwise +#' does not attempt to mirror its semantics. +#' @section List interface: +#' A \code{MethodParam} reads like a list: \code{$} and \code{[[} fetch a +#' field, and \code{names()}, \code{length()} and \code{as.list()} describe +#' it. +#' +#' Those last three report only the fields that are \strong{set}. A slot +#' holding \code{NULL} is absent from all three, while \code{$} and +#' \code{[[} still return \code{NULL} for it. This is not cosmetic: +#' \code{as.list()} on one of these records is spliced into an engine call, +#' and an engine that distinguishes an explicit \code{NULL} argument from an +#' omitted one would otherwise see a different call. +#' +#' Unlike a list, \code{$} on a name that is not a field is an error rather +#' than \code{NULL}. Silently reading a misspelled setting as "unset" is the +#' failure these classes exist to prevent. +#' @aliases MethodParam +#' @name MethodParam-class +#' @docType class +#' @export +setClass("MethodParam", representation("VIRTUAL")) + +# The fields a record actually carries, in declaration order: every slot +# except those holding NULL. The single definition behind names(), length() +# and as.list(), so the three can never disagree about what is set. +# @noRd +.paramSetFields <- function(x) { + nms <- slotNames(x) + keep(nms, .paramFieldIsSet, x = x) +} + +# @noRd +.paramFieldIsSet <- function(nm, x) { + !is.null(slot(x, nm)) +} + +# Reject a field name the class does not declare, naming the ones it does. +# @noRd +.paramAssertField <- function(x, name) { + nms <- slotNames(x) + if (is_in(name, nms)) { + return(invisible(NULL)) + } + abort(glue( + "`{name}` is not a setting of {class(x)[[1L]]}. ", + "It has: {str_flatten(nms, ', ')}." + )) +} + +#' @rdname MethodParam-class +#' @param x A \code{MethodParam} object. +#' @param name The name of a setting. +#' @return \code{$} returns that setting's value, \code{NULL} when it is +#' unset. +#' @export +setMethod("$", "MethodParam", function(x, name) { + .paramAssertField(x, name) + slot(x, name) +}) + +#' @rdname MethodParam-class +#' @param i A setting's name, or its position among the settings that are +#' set. +#' @param j Unused, for consistency with the generic. +#' @param ... Unused, for consistency with the generic. +#' @return \code{[[} returns that setting's value. +#' @export +setMethod("[[", "MethodParam", function(x, i, j, ...) { + if (is.character(i)) { + .paramAssertField(x, i) + return(slot(x, i)) + } + # A positional index counts over the fields that are set, matching what + # names() and as.list() report. + set <- .paramSetFields(x) + if ( + !is.numeric(i) || + length(i) != 1L || + is.na(i) || + i < 1L || + i > length(set) + ) { + abort(glue( + "subscript out of bounds: {class(x)[[1L]]} has ", + "{length(set)} setting(s) set." + )) + } + slot(x, set[[as.integer(i)]]) +}) + +#' @rdname MethodParam-class +#' @return \code{names} returns the settings that are set. +#' @export +setMethod("names", "MethodParam", function(x) { + .paramSetFields(x) +}) + +#' @rdname MethodParam-class +#' @return \code{length} returns how many settings are set. +#' @export +setMethod("length", "MethodParam", function(x) { + length(.paramSetFields(x)) +}) + +#' @rdname MethodParam-class +#' @return \code{as.list} returns the settings that are set, as a named list. +#' @export +setMethod("as.list", "MethodParam", function(x, ...) { + set <- .paramSetFields(x) + set_names(map(set, slot, object = x), set) +}) + +#' @rdname MethodParam-class +#' @param object A \code{MethodParam} object. +#' @return \code{show} is called for its side effect and returns +#' \code{invisible(NULL)}. +#' @export +setMethod("show", "MethodParam", function(object) { + cat(glue("<{class(object)[[1L]]}>"), "\n", sep = "") + set <- .paramSetFields(object) + unset <- setdiff(slotNames(object), set) + if (length(set) == 0L) { + cat(" (nothing set)\n") + } + for (nm in set) { + cat(sprintf(" %-24s %s\n", nm, .paramSlotText(slot(object, nm)))) + } + if (length(unset) > 0L) { + cat(" unset: ", str_flatten(unset, ", "), "\n", sep = "") + } + invisible(NULL) +}) + +# ============================================================================= +# Method-selection Params +# ----------------------------------------------------------------------------- +# Which methods a pipeline runs, and each one's engine arguments. +# +# Three slots rather than one because a method running on both data paths +# reaches a DIFFERENT engine on each -- lasso is glmnet on individual data +# and lassosum on summary statistics -- so one bag of arguments per method +# cannot serve a MultiStudyQtlDataset carrying both. The split is declared +# by the user rather than guessed: +# +# methods entries whose input path need not be stated: a +# single-type run, or a method with nothing +# path-specific to configure (the fit-derived ones +# carry no arguments at all). +# qtlDatasetMethods entries bound for the individual-level path. +# qtlSumStatsMethods entries bound for the summary-statistics path. +# +# A method appears in exactly ONE of the three. That is per-method, not +# per-slot: a dual-type run tuning `lasso` differently per path while +# selecting `susie` with defaults has something to say in all three places, +# and forcing `susie` into both path slots would imply two configurations +# where there is only one fit. +# ============================================================================= + +#' @title Which Methods A Pipeline Runs, And How +#' @description The virtual base of +#' \code{\link{FineMappingMethodsParam}} and +#' \code{\link{TwasWeightsMethodsParam}}: which methods a pipeline runs, +#' and each one's engine arguments. +#' +#' Three slots rather than one because a method running on both data paths +#' reaches a different engine on each --- lasso is glmnet on +#' individual-level data and lassosum on summary statistics --- so one bag +#' of arguments per method cannot serve a \code{MultiStudyQtlDataset} +#' carrying both. \code{methods} holds entries whose input path need not +#' be stated; \code{qtlDatasetMethods} and \code{qtlSumStatsMethods} hold +#' the ones that must state it. Naming a method selects it. +#' @slot methods Named list of per-method options whose input path need not +#' be stated. +#' @slot qtlDatasetMethods Named list of per-method options for the +#' individual-level path. +#' @slot qtlSumStatsMethods Named list of per-method options for the +#' summary-statistics path. +#' @seealso \code{\link{FineMappingMethodsParam}}, +#' \code{\link{TwasWeightsMethodsParam}} +#' @aliases MethodsSelectionParam-class +#' @name MethodsSelectionParam-class +#' @docType class +#' @exportClass MethodsSelectionParam +setClass( + "MethodsSelectionParam", + contains = c("MethodParam", "VIRTUAL"), + slots = c( + methods = "list_OR_NULL", + qtlDatasetMethods = "list_OR_NULL", + qtlSumStatsMethods = "list_OR_NULL" + ) +) + +# The input path a slot is bound for; NULL for `methods`, which is the slot +# that does not state one. +# @noRd +.methodsSlotInput <- function(slotName) { + switch( + slotName, + qtlDatasetMethods = "QtlDataset", + qtlSumStatsMethods = "QtlSumStats", + NULL + ) +} + +# Which methods each family offers on a given path. Keyed on the class so +# the two concrete subclasses differ in nothing but their registry. +# @noRd +.methodsParamAvailable <- function(cls, inputKind) { + if (identical(cls, "FineMappingMethodsParam")) { + return(.fmMethodsFor(inputKind)) + } + .twasMethodsFor(inputKind) +} + +# Every method the family knows, on any path -- the vocabulary `methods` +# itself is checked against, since that slot does not name a path. +# @noRd +.methodsParamAnyMethod <- function(cls) { + unique(unlist(map( + c("QtlDataset", "QtlSumStats", "GwasSumStats"), + .methodsParamAvailable, + cls = cls + ))) +} + +.methodsSlotNames <- c("methods", "qtlDatasetMethods", "qtlSumStatsMethods") + +setValidity("MethodsSelectionParam", function(object) { + cls <- class(object)[[1L]] + problems <- c( + unlist(map( + .methodsSlotNames, + .methodsSlotProblems, + object = object, + cls = cls + )), + .methodsParamOverlapProblem(object), + .methodsParamSharedInputProblem(object) + ) + if (length(problems) == 0L) TRUE else as.character(problems) +}) + +# Every method a Param names, across all three slots. The answer to +# token-level questions that do not care which path a method came from -- +# "is mrmash requested", "are these methods available at all". +# @noRd +.methodsParamTokens <- function(param) { + unique(unlist(map( + .methodsSlotNames, + function(s) names(slot(param, s)) %||% character(0) + ))) +} + +# The same Param with some methods removed from every slot -- the joint +# phase handles mrmash itself, so the per-method loop must not also run it. +# Returns a Param rather than a flat list so the path structure survives +# into the per-component recursion. +# @noRd +.methodsParamDrop <- function(param, drop) { + args <- set_names( + map(.methodsSlotNames, .methodsSlotWithout, param = param, drop = drop), + .methodsSlotNames + ) + exec(match.fun(class(param)[[1L]]), !!!args) +} + +# @noRd +.methodsSlotWithout <- function(slotName, param, drop) { + v <- slot(param, slotName) + if (is.null(v)) { + return(NULL) + } + kept <- v[!is_in(names(v), drop)] + if (length(kept) == 0L) NULL else kept +} + +# The methods to run on one input class, and each one's arguments. +# +# `methods` applies to every input class -- it is the slot that states no +# path -- so it is always included; the path slot for this class is added to +# it. The other path slot is simply not this run's business. +# @noRd +.methodsParamResolve <- function(param, inputKind) { + entries <- c( + slot(param, "methods") %||% list(), + slot(param, .methodsPathSlotFor(inputKind)) %||% list() + ) + list( + tokens = names(entries), + methodArgs = map(entries, as.list) + ) +} + +# Which path slot serves an input class. GwasSumStats is a +# summary-statistics class, so it reads the same slot as QtlSumStats. +# @noRd +.methodsPathSlotFor <- function(inputKind) { + if (identical(inputKind, "QtlDataset")) { + "qtlDatasetMethods" + } else { + "qtlSumStatsMethods" + } +} + +# The same, for a MultiStudyQtlDataset -- which may carry individual-level +# studies AND summary statistics, so one input class does not describe it. +# +# Two extra list shapes, named for the data they target and not mixable: +# +# selection list("susie", qtlDataset = "fsusie", qtlSumStats = "ser") +# bare strings run on whatever the dataset holds; a path key +# takes a character vector of methods for that half only. +# override list(susie = list(L = 20), +# qtlDataset = list(susie = list(...)), +# qtlSumStats = list(susie = list(...))) +# a method named at the top carries arguments SHARED by both +# halves, distributed into both path slots so each is checked +# against the engine that half actually runs; a path key takes +# a list of per-method argument lists for that half only. +# +# Mixing them is refused rather than guessed at: `list("susie", lasso = +# list(...))` could mean either and nothing says which. +# @noRd +.methodsParamForMulti <- function(value, cls, label, hasSumStats) { + param <- if (is(value, cls)) { + value + } else if (is(value, "MethodsSelectionParam")) { + abort(glue( + "{label}: `methods` is a {class(value)[[1L]]}, which configures ", + "a different pipeline. Use {cls}()." + )) + } else if (is.character(value)) { + exec(match.fun(cls), methods = value) + } else if (is.list(value)) { + .methodsMultiFromList(value, cls, label) + } else { + abort(glue( + "{label}: `methods` must be a character vector, a named list of ", + "per-method options, or a {cls}() record; got ", + "{class(value)[[1L]]}" + )) + } + .methodsAssertSumStats(param, hasSumStats, label) + param +} + +# @noRd +.methodsMultiFromList <- function(value, cls, label) { + nms <- names(value) %||% rep("", length(value)) + pathAt <- is_in(nms, c("qtlDataset", "qtlSumStats")) + rest <- value[!pathAt] + restNames <- nms[!pathAt] + .methodsAssertOneShape(rest, restNames, label) + shared <- if (length(rest) > 0L && all(nzchar(restNames))) { + rest + } else { + list() + } + selected <- if (length(rest) > 0L && !all(nzchar(restNames))) { + unlist(rest, use.names = FALSE) + } else { + character(0) + } + exec( + match.fun(cls), + methods = if (length(selected) > 0L) selected else NULL, + qtlDatasetMethods = .methodsMultiSlot( + value[nms == "qtlDataset"], + shared, + label, + "qtlDataset" + ), + qtlSumStatsMethods = .methodsMultiSlot( + value[nms == "qtlSumStats"], + shared, + label, + "qtlSumStats" + ) + ) +} + +# A path key's own entries, with the shared ones merged in beneath them: a +# per-path value wins over the shared value of the same name. +# @noRd +.methodsMultiSlot <- function(entry, shared, label, key) { + own <- if (length(entry) == 0L) { + list() + } else { + .methodsMultiPathEntries(entry[[1L]], label, key) + } + if (length(shared) == 0L && length(own) == 0L) { + return(NULL) + } + merged <- shared + for (nm in names(own)) { + merged[[nm]] <- if (is.list(own[[nm]]) && is.list(shared[[nm]])) { + list_modify(shared[[nm]], !!!own[[nm]]) + } else { + own[[nm]] + } + } + merged +} + +# A path key takes either a character vector of methods or a named list of +# per-method arguments; a character vector becomes empty entries, which is +# what "run it with its defaults" looks like everywhere else. +# @noRd +.methodsMultiPathEntries <- function(v, label, key) { + if (is.character(v)) { + return(set_names(rep(list(list()), length(v)), v)) + } + if (is.list(v)) { + return(v) + } + abort(glue( + "{label}: `{key}` must be a character vector of methods or a named ", + "list of per-method options; got {class(v)[[1L]]}" + )) +} + +# The two list shapes are not mixable. +# @noRd +.methodsAssertOneShape <- function(rest, restNames, label) { + if (length(rest) == 0L) { + return(invisible(NULL)) + } + named <- nzchar(restNames) + if (all(named) || !any(named)) { + return(invisible(NULL)) + } + abort(glue( + "{label}: `methods` mixes two shapes -- bare method names, which ", + "select, and named entries, which configure. Use one: a character ", + "vector to select, or a named list to configure." + )) +} + +# Summary-statistics options are an instruction that cannot be carried out +# on a dataset holding none. +# @noRd +.methodsAssertSumStats <- function(param, hasSumStats, label) { + if (hasSumStats) { + return(invisible(NULL)) + } + entries <- slot(param, "qtlSumStatsMethods") + if (length(entries) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "{label}: `qtlSumStats` names ", + "{str_flatten(names(entries), ', ')}, but this ", + "MultiStudyQtlDataset carries no summary statistics. Remove them, ", + "or supply a dataset whose sumStats slot is set." + )) +} + +# Whatever the caller gave a pipeline as `methods`, as a Param of this +# family. +# +# A pipeline knows its input class by dispatch, which is what makes a plain +# named list routable here but not in the constructor: the overrides go +# straight into the slot for this run's path, so they are checked against +# the engine that will actually receive them. That is why +# `methods = list(susie = list(L = 20))` stays as short at a single-type +# pipeline as it ever was. +# @noRd +.methodsParamFor <- function(value, inputKind, cls, label) { + if (is(value, cls)) { + return(value) + } + if (is(value, "MethodsSelectionParam")) { + abort(glue( + "{label}: `methods` is a {class(value)[[1L]]}, which configures ", + "a different pipeline. Use {cls}()." + )) + } + ctor <- match.fun(cls) + if (is.character(value)) { + return(ctor(methods = value)) + } + args <- list() + args[[.methodsPathSlotFor(inputKind)]] <- value + exec(ctor, !!!args) +} + +# One slot's value as it is stored: a named list of records. +# +# A bare character vector selects methods with their defaults, which is the +# same thing `methods = c("susie", "lasso")` means at a pipeline. A plain +# list entry is spliced into that method's own constructor, so it gets the +# same checking as writing the constructor out -- but only in a path slot, +# where the path is known. Under `methods` the path is not known until the +# pipeline dispatches, so an entry there must either be an already-built +# record (which carries its own input type) or list(); the pipelines route +# plain lists themselves, where the input class is settled. +# @noRd +.methodsNormalizeSlot <- function(value, slotName, cls) { + if (is.null(value) || length(value) == 0L) { + return(NULL) + } + if (is.character(value)) { + return(set_names(rep(list(list()), length(value)), value)) + } + if (!is.list(value)) { + abort(glue( + "{cls}: `{slotName}` must be a named list of per-method ", + "options, or a character vector of method names; got ", + "{class(value)[[1L]]}" + )) + } + if ( + length(value) > 0L && + (is.null(names(value)) || any(!nzchar(names(value)))) + ) { + abort(glue( + "{cls}: every `{slotName}` entry must be named for its method" + )) + } + # Detected with a map but reported OUTSIDE one: aborting from inside any + # purrr call wraps the message in "In index: 1. With name: x." framing, + # which is the caller's mistake dressed as an internal one. Same reason + # .nestedAssertEngines() checks up front. + imap(value, .methodsNormalizeEntry, slotName = slotName, cls = cls) +} + +# An entry is stored as the caller wrote it. A plain list is NOT coerced +# into the engine's Options constructor: a per-method bundle is legitimately +# mixed -- the pecotmr wrapper's own formals (`dataDrivenPriorMatrices`, +# `fitRetention`) alongside the engine's arguments -- and .splitMethodArgs +# separates them at call time. Coercing would reject the wrapper half. +# +# Its NAMES are still checked here when the slot names a path, against the +# whole chain that path runs; see .methodsEntryNameProblem. +# @noRd +.methodsNormalizeEntry <- function(value, key, slotName, cls) { + value +} + +# Every name one method accepts on one input path: the wrapper chain's +# formals plus the engine's arguments. NULL when that cannot be determined, +# which is the existing convention for "do not reject anything here". +# @noRd +.methodsPathAccepted <- function(cls, token, inputKind) { + if (identical(cls, "FineMappingMethodsParam")) { + callee <- .fmMethodCalleeFor(token, inputKind) + if (is.null(callee)) { + return(NULL) + } + accepted <- .engineAcceptedNames(callee) + if (is.null(accepted)) { + return(NULL) + } + return(unique(c(accepted, .fmSeededArgNames()))) + } + .twasChainAccepted(token, inputKind) +} + +# One slot's own problems: shape, vocabulary, element class, and -- for the +# two path slots -- that each record is actually usable on that path. +# @noRd +.methodsSlotProblems <- function(slotName, object, cls) { + entries <- slot(object, slotName) + if (is.null(entries) || length(entries) == 0L) { + return(character(0)) + } + nms <- names(entries) + if (is.null(nms) || any(!nzchar(nms))) { + return(glue("`{slotName}`: every entry must be named for its method")) + } + dup <- unique(nms[duplicated(nms)]) + if (length(dup) > 0L) { + return(glue( + "`{slotName}`: {str_flatten(dup, ', ')} given more than once; ", + "one set of options per method" + )) + } + inputKind <- .methodsSlotInput(slotName) + allowed <- if (is.null(inputKind)) { + .methodsParamAnyMethod(cls) + } else { + .methodsParamAvailable(cls, inputKind) + } + unknown <- setdiff(nms, allowed) + if (length(unknown) > 0L) { + return(glue( + "`{slotName}`: {str_flatten(unknown, ', ')} ", + "{if (length(unknown) == 1L) 'is not a method' else ", + "'are not methods'} this pipeline runs", + "{if (is.null(inputKind)) '' else glue(' on {inputKind}')}. ", + "Available: {str_flatten(allowed, ', ')}." + )) + } + c( + unlist(map( + nms, + .methodsEntryClassProblem, + entries = entries, + slotName = slotName + )), + unlist(map( + nms, + .methodsEntryOptionlessProblem, + entries = entries, + slotName = slotName, + cls = cls + )), + if (!is.null(inputKind)) { + c( + unlist(map( + nms, + .methodsEntryPathProblem, + entries = entries, + slotName = slotName, + inputKind = inputKind + )), + unlist(map( + nms, + .methodsEntryNameProblem, + entries = entries, + slotName = slotName, + inputKind = inputKind, + cls = cls + )), + unlist(map( + nms, + .methodsEntryEngineProblem, + entries = entries, + slotName = slotName, + inputKind = inputKind, + cls = cls + )) + ) + } + ) +} + +# An entry is a constructor-built record or a plain list of that method's +# arguments; list() means "run it with its defaults". A plain list is +# allowed because the bundle is legitimately mixed -- the wrapper's own +# formals and the engine's arguments together -- so only its NAMES can be +# judged, which .methodsEntryNameProblem does wherever the path is known. +# @noRd +.methodsEntryClassProblem <- function(nm, entries, slotName) { + v <- entries[[nm]] + if (.isMethodOptions(v) || is.list(v)) { + return(character(0)) + } + glue( + "`{slotName}${nm}` must be that method's Options record or a list ", + "of its arguments; got {class(v)[[1L]]}" + ) +} + +# A method with nothing to configure, given something to configure. +# +# The fit-derived methods extract weights from a fit a prior +# fineMappingPipeline() run produced, so they have no arguments of their own +# on either path -- which is why naming one with list() SELECTS it and is +# the only thing it can say. A non-empty entry is a misunderstanding worth +# naming, and .twasTokenNoArgsReason already says where the setting lives. +# +# Path-independent, so this applies to `methods` as well: the answer does +# not depend on which input class runs. +# @noRd +.methodsEntryOptionlessProblem <- function(nm, entries, slotName, cls) { + v <- entries[[nm]] + if (.isMethodOptions(v) || !is.list(v) || length(v) == 0L) { + return(character(0)) + } + reason <- .methodsNoOptionsReason(cls, nm) + if (is.null(reason)) { + return(character(0)) + } + glue("`{slotName}${nm}`: {reason}") +} + +# @noRd +.methodsNoOptionsReason <- function(cls, token) { + if (identical(cls, "FineMappingMethodsParam")) { + return(NULL) + } + .twasTokenNoArgsReason(token) +} + +# The engine one method's options must have been built for on one path. +# +# Not the token: `SusieRssOptions()` records engine "susieRss" while the +# token is "susie". Derived by taking that token's OWN constructors and +# picking the one whose callee matches this path's -- which is also what +# tells `susie` from `susieInf`, since both run `susieR::susie` on +# individual data and only the per-token pair distinguishes them. +# @noRd +.methodsExpectedEngine <- function(cls, token, inputKind) { + if (identical(cls, "FineMappingMethodsParam")) { + return(.fmExpectedEngine(token, inputKind)) + } + ctor <- .twasMethodCtorFor(token, inputKind) + if (is.null(ctor)) { + return(NULL) + } + .methodsRecordEngine(ctor) +} + +# @noRd +.fmExpectedEngine <- function(token, inputKind) { + ctors <- .fmTokenCtorsByPath()[[token]] + want <- .fmMethodCalleeFor(token, inputKind) + if (is.null(ctors) || is.null(want)) { + return(NULL) + } + hit <- keep(ctors, .methodsCtorHasCallee, callee = want) + if (length(hit) == 0L) { + return(NULL) + } + .methodsRecordEngine(hit[[1L]]) +} + +# @noRd +.methodsCtorHasCallee <- function(ctor, callee) { + rec <- tryCatch(ctor(), error = function(cnd) NULL) + !is.null(rec) && identical(metadata(rec)$callee, callee) +} + +# @noRd +.methodsRecordEngine <- function(ctor) { + rec <- tryCatch(ctor(), error = function(cnd) NULL) + if (is.null(rec)) { + return(NULL) + } + metadata(rec)$engine +} + +# An Options record keyed under one method must have been built by THAT +# method's constructor. The input-type check cannot see this: `lasso` and +# `bayesA` both run on individual data, so `GlmnetOptions()` and +# `QggOptions()` are indistinguishable by path and only the engine tells +# them apart. +# @noRd +.methodsEntryEngineProblem <- function(nm, entries, slotName, inputKind, cls) { + v <- entries[[nm]] + if (!.isMethodOptions(v)) { + return(character(0)) + } + want <- .methodsExpectedEngine(cls, nm, inputKind) + got <- metadata(v)$engine + if (is.null(want) || is.null(got) || identical(got, want)) { + return(character(0)) + } + glue( + "`{slotName}${nm}` was built with the constructor for '{got}', but ", + "{nm} on {inputKind} uses the '{want}' constructor" + ) +} + +# A plain list's names, against everything that method accepts on this path +# -- the wrapper chain plus the engine. Only in a path slot: `methods` +# names no path, so the pipeline checks it once the input class is settled. +# @noRd +.methodsEntryNameProblem <- function(nm, entries, slotName, inputKind, cls) { + v <- entries[[nm]] + if (.isMethodOptions(v) || !is.list(v) || length(v) == 0L) { + return(character(0)) + } + accepted <- .methodsPathAccepted(cls, nm, inputKind) + if (is.null(accepted)) { + return(character(0)) + } + unknown <- setdiff(names(v), accepted) + if (length(unknown) == 0L) { + return(character(0)) + } + glue( + "`{slotName}${nm}`: unknown argument(s) ", + "{str_flatten(unknown, ', ')} for {nm} on {inputKind}." + ) +} + +# A record carries the input classes it is for (see .engineInputType), so a +# summary-statistics record under `qtlDatasetMethods` is caught here rather +# than failing inside the engine. +# @noRd +.methodsEntryPathProblem <- function(nm, entries, slotName, inputKind) { + it <- .optionsInputType(entries[[nm]]) + if (is.null(it) || is_in(inputKind, it)) { + return(character(0)) + } + glue( + "`{slotName}${nm}`: these options are for ", + "{str_flatten(sort(it), ' / ')}, but `{slotName}` is forwarded to ", + "{inputKind}" + ) +} + +# A method named in `methods` must not also be named in a path slot: the +# first says its path need not be stated, the second states one, and +# nothing decides which wins. +# +# Appearing in BOTH path slots is not a conflict -- it is the whole point of +# having two, and how a dual-type run gives one method different arguments +# per path. +# @noRd +.methodsParamOverlapProblem <- function(object) { + pathless <- names(slot(object, "methods")) %||% character(0) + paths <- unique(c( + names(slot(object, "qtlDatasetMethods")) %||% character(0), + names(slot(object, "qtlSumStatsMethods")) %||% character(0) + )) + clash <- intersect(pathless, paths) + if (length(clash) == 0L) { + return(character(0)) + } + glue( + "{str_flatten(clash, ', ')} ", + "{if (length(clash) == 1L) 'is' else 'are'} named in `methods` and ", + "also under an input path. Put each method in one or the other: ", + "`methods` for options that need no path, the path slots for ones ", + "that do." + ) +} + +# @noRd +.methodsInputTypeLabel <- function(key, types) { + sprintf("%s -> %s", key, str_flatten(sort(types[[key]]), "/")) +} + +# `methods` states no path, so everything in it has to be usable on one +# single input class -- otherwise the slot describes a run that cannot +# happen. +# @noRd +.methodsParamSharedInputProblem <- function(object) { + entries <- slot(object, "methods") + if (is.null(entries) || length(entries) == 0L) { + return(character(0)) + } + types <- compact(map(entries, .optionsInputType)) + if (length(types) == 0L) { + return(character(0)) + } + if (length(reduce(types, intersect)) > 0L) { + return(character(0)) + } + detail <- str_flatten( + map_chr(names(types), .methodsInputTypeLabel, types = types), + collapse = "; " + ) + glue( + "`methods`: these options cannot all be used with one input class ", + "({detail}). Use `qtlDatasetMethods` / `qtlSumStatsMethods` to say ", + "which goes where." + ) +} + +# One slot's value as a line of text. +# +# A slot holding a LIST -- the per-method entries of a method-selection +# Param, each an Options record or a list of arguments -- is shown by naming +# its entries. format() cannot render those: it falls through to +# as.character() on an S4 object and errors, which is how printing a +# populated FineMappingMethodsParam used to fail. +# @noRd +.paramSlotText <- function(value) { + # A slot may hold a RECORD rather than a value: an Options bag bound for + # an engine, or a nested Param. format() prints the S4 class header for + # those -- "" -- which tells a + # reader nothing. Name what it is instead. + if (.isMethodOptions(value)) { + return(.paramOptionsText(value)) + } + if (.isMethodParam(value)) { + return(.paramNestedText(value)) + } + if (is.list(value) && !is.null(names(value))) { + return(str_flatten(names(value), ", ")) + } + if (is.list(value)) { + return(glue( + "{length(value)} entr{if (length(value) == 1L) 'y' else 'ies'}" + )) + } + str_flatten(format(value), ", ") +} + +# A nested Param by what it CONTAINS, not by its slot names. The +# aggregators hold their per-method entries in one list slot, so reporting +# slot names would say "components" where the reader wants "pca". +# @noRd +.paramNestedText <- function(value) { + set <- names(value) + if (length(set) == 0L) { + return(glue("<{class(value)[[1L]]}: nothing set>")) + } + inner <- unlist(map(set, .paramNestedEntryNames, value = value)) + if (length(inner) > 0L) { + return(str_flatten(unique(inner), ", ")) + } + str_flatten(set, ", ") +} + +# @noRd +.paramNestedEntryNames <- function(nm, value) { + v <- slot(value, nm) + if (is.list(v)) names(v) else character(0) +} + +# An Options record by the engine it is for, with its settings when it +# carries any. +# @noRd +.paramOptionsText <- function(value) { + engine <- metadata(value)$engine %||% "options" + if (length(value) == 0L) { + return(glue("<{engine}: defaults>")) + } + glue("<{engine}: {str_flatten(names(value), ', ')}>") +} + +# TRUE for a record one of the *Param() constructors produced. The Param +# counterpart of .isMethodOptions(), and the two are disjoint: a Param is not +# a MethodOptions and never was. +# @noRd +.isMethodParam <- function(x) { + is(x, "MethodParam") +} + +# Demand a record of one specific Param class, naming the constructor that +# builds it. Stricter than the MethodOptions equivalent could be: every +# *Param() has its own class, so handing `ColocPriorParam()` where +# `CredibleSetParam()` was wanted is caught here rather than surfacing as a +# missing field somewhere downstream. +# @noRd +.assertMethodParam <- function(x, ctor, argName, class = NULL) { + class <- class %||% .paramClassOf(ctor) + if (is(x, class)) { + return(invisible(x)) + } + if (is.list(x) && length(x) == 0L) { + # An empty list carries no settings, so there is nothing a + # constructor would have added. Accepting it keeps `list()` working + # as "no settings", as it does for MethodOptions. + return(invisible(x)) + } + got <- if (.isMethodParam(x) || .isMethodOptions(x)) { + glue("a {class(x)[[1L]]}") + } else { + "a bare list" + } + abort(glue( + "`{argName}` must be built with {ctor}(), not {got}. ", + "A setting pecotmr reads is type-checked when the record is built, ", + "which a bare list cannot be." + )) +} + +# The engine a Param denotes: "DentistParam" -> "dentist". The inverse of +# .paramClassOf(), for the choices that take either an engine name or that +# engine's record (see .engineOf). +# @noRd +.paramEngineOf <- function(x) { + base <- str_remove(class(x)[[1L]], "Param$") + str_c(str_to_lower(str_sub(base, 1L, 1L)), str_sub(base, 2L)) +} + +# The class a constructor builds: "CredibleSetParam" -> "CredibleSetParam". +# Derived rather than tabulated so the two can never drift apart; every +# *Param() constructor follows the convention without exception. +# @noRd +.paramClassOf <- function(ctor) { + str_c(str_to_upper(str_sub(ctor, 1L, 1L)), str_sub(ctor, 2L)) +} diff --git a/R/MultiStudyQtlDataset.R b/R/MultiStudyQtlDataset.R index 8e99792cc..342206e8e 100644 --- a/R/MultiStudyQtlDataset.R +++ b/R/MultiStudyQtlDataset.R @@ -43,40 +43,33 @@ setClass( # @noRd .validateMultiStudyQtlDataset <- function(object) { - errors <- c( + # Each stage only makes sense once the previous one holds: the study count + # reads slots the type checks just validated, and trait consistency reads + # across the studies the count check just confirmed. + slotErrors <- c( .msqdCheckDatasets(object@qtlDatasets), .msqdCheckSumStats(object@sumStats) ) - if (length(errors) == 0L) { - errors <- .msqdCheckStudyCount(object) + if (length(slotErrors) > 0L) { + return(slotErrors) } - if (length(errors) == 0L) { - errors <- .msqdCheckTraitConsistency(object) + countErrors <- .msqdCheckStudyCount(object) + if (length(countErrors) > 0L) { + return(countErrors) } - if (length(errors) == 0L) TRUE else errors + traitErrors <- .msqdCheckTraitConsistency(object) + if (length(traitErrors) == 0L) TRUE else traitErrors } # @noRd +#' @importFrom checkmate checkList .msqdCheckDatasets <- function(qtlDatasets) { - if (!is.list(qtlDatasets) || length(qtlDatasets) == 0L) { - return("'qtlDatasets' must be a non-empty named list") + # names = "unique" subsumes the old named/non-empty/non-NA/unique checks. + res <- checkList(qtlDatasets, min.len = 1L, names = "unique") + if (!isTRUE(res)) { + return(str_c("'qtlDatasets' ", res)) } - c( - .msqdCheckDatasetNames(names(qtlDatasets)), - .msqdCheckDatasetTypes(qtlDatasets) - ) -} - -# @noRd -.msqdCheckDatasetNames <- function(nm) { - isEmpty <- any(str_length(nm) == 0L, na.rm = TRUE) - if (is.null(nm) || isEmpty || any(is.na(nm))) { - return("'qtlDatasets' must be a named list with non-empty names") - } - if (n_distinct(nm) < length(nm)) { - return("names of 'qtlDatasets' must be unique") - } - NULL + .msqdCheckDatasetTypes(qtlDatasets) } # @noRd @@ -129,7 +122,7 @@ setClass( traitRanges <- map(object@qtlDatasets, .msqdTraitRanges) pairs <- utils::combn(seq_along(traitRanges), 2L) dsNames <- names(object@qtlDatasets) - unlist(compact(map( + list_c(compact(map( seq_len(ncol(pairs)), .msqdPairErrors, pairs = pairs, @@ -141,19 +134,40 @@ setClass( # Per-dataset trait -> rowRanges map (first occurrence of each trait id). # @noRd .msqdTraitRanges <- function(qd) { - out <- list() - for (ctx in getContexts(qd)) { - se <- getPhenotypes(qd, ctx) - rr <- SummarizedExperiment::rowRanges(se) - ids <- rownames(se) - for (i in seq_along(ids)) { - tid <- ids[[i]] - if (is.null(out[[tid]])) { - out[[tid]] <- rr[i] - } - } + pairs <- .msqdConcat(map(getContexts(qd), .msqdContextTraitRanges, qd = qd)) + if (length(pairs) == 0L) { + return(list()) + } + # First occurrence of each trait id wins, as the "only set it while still + # NULL" assignment did. + tids <- map_chr(pairs, "tid") + keep <- !duplicated(tids) + set_names(map(pairs[keep], "range"), tids[keep]) +} + +# @noRd +.msqdConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) } - out + list_c(pieces) +} + +# @noRd +.msqdTraitRangePair <- function(i, ids, rr) { + list(tid = ids[[i]], range = rr[i]) +} + +# One context's (trait, range) pairs in row order. +# @noRd +.msqdContextTraitRanges <- function(ctx, qd) { + se <- getPhenotypes(qd, ctx) + map( + seq_along(rownames(se)), + .msqdTraitRangePair, + ids = rownames(se), + rr = SummarizedExperiment::rowRanges(se) + ) } # Inconsistency errors for the k-th dataset pair. @@ -231,8 +245,10 @@ setClass( #' study = "s2", genotypes = panel, phenotypes = list(brain = se) #' ) #' MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) +#' @importFrom checkmate assertList #' @export MultiStudyQtlDataset <- function(qtlDatasets, sumStats = NULL) { + assertList(qtlDatasets, min.len = 1L, names = "unique") obj <- new( "MultiStudyQtlDataset", qtlDatasets = qtlDatasets, @@ -248,17 +264,11 @@ setMethod("getQtlDatasets", "MultiStudyQtlDataset", function(x) x@qtlDatasets) #' @rdname getSumStats #' @export -setMethod("getSumStats", "MultiStudyQtlDataset", function(x, ...) { - if (length(list(...)) > 0L) { - msg <- glue( - "getSumStats(MultiStudyQtlDataset) does not accept selection ", - "arguments; it returns the embedded QtlSumStats collection ", - "(use getSumStats() on that result to fetch one entry)." - ) - abort(msg) - } - x@sumStats -}) +# No selectors: this returns the embedded QtlSumStats collection whole, and +# one entry is fetched by calling getSumStats() on that result. Taking no +# extra formals is what refuses a selector -- R reports the unused argument +# by name. +setMethod("getSumStats", "MultiStudyQtlDataset", function(x) x@sumStats) #' @rdname getStudy #' @export diff --git a/R/QtlDataset.R b/R/QtlDataset.R index 7c7bf0606..ab06169b0 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -12,6 +12,7 @@ # ============================================================================= #' @include AllGenerics.R +#' @include MethodParam.R NULL #' @title QTL Dataset (individual-level data for one study) @@ -118,30 +119,39 @@ setClass( # study / scaleResiduals / keepIndel scalars + the four non-negative cutoffs. # @noRd +#' @importFrom checkmate makeAssertCollection assertString assertLogical +#' @importFrom checkmate assertFlag assertNumber +#' @importFrom purrr walk .qtlValidateScalars <- function(object) { - errors <- character() - if (length(object@study) != 1L || str_length(object@study) == 0L) { - errors <- c( - errors, - "'study' must be a single non-empty character string" - ) - } - if (length(object@scaleResiduals) != 1L) { - errors <- c(errors, "'scaleResiduals' must be a single logical value") - } - if (length(object@keepIndel) != 1L || is.na(object@keepIndel)) { - errors <- c(errors, "'keepIndel' must be a single logical value") - } - for (nm in c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff")) { - v <- methods::slot(object, nm) - if (length(v) != 1L || is.na(v) || !is.finite(v) || v < 0) { - errors <- c( - errors, - glue("'{nm}' must be a single finite non-negative numeric") - ) - } - } - errors + coll <- makeAssertCollection() + assertString(object@study, min.chars = 1L, .var.name = "study", add = coll) + assertLogical( + object@scaleResiduals, + len = 1L, + .var.name = "scaleResiduals", + add = coll + ) + assertFlag(object@keepIndel, .var.name = "keepIndel", add = coll) + walk( + c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff"), + .qtlValidateCutoff, + object = object, + coll = coll + ) + coll$getMessages() +} + +# Each cutoff slot must be a single finite non-negative number. +# @noRd +#' @importFrom checkmate assertNumber +.qtlValidateCutoff <- function(nm, object, coll) { + assertNumber( + methods::slot(object, nm), + lower = 0, + finite = TRUE, + .var.name = nm, + add = coll + ) } # Shape checks on the phenotype list handed to the constructor. Run before @@ -149,71 +159,93 @@ setClass( # ExperimentList fail first with a message about experiments rather than # about contexts. Returns an error vector. # @noRd -.qtlCheckPhenotypeList <- function(phenotypes) { - errors <- character() - if (length(phenotypes) == 0L) { - errors <- c(errors, "'phenotypes' must not be empty") - } - contextNames <- names(phenotypes) +# What is wrong with the context names, if anything. The checks are ordered: +# a list with no usable names is not also reported as having duplicates. +# @noRd +.qtlContextNameErrors <- function(contextNames) { if ( is.null(contextNames) || any(str_length(contextNames) == 0L, na.rm = TRUE) || any(is.na(contextNames)) ) { - errors <- c( - errors, - "'phenotypes' must be a named list with non-empty names" - ) - } else if (n_distinct(contextNames) < length(contextNames)) { - errors <- c(errors, "context names in 'phenotypes' must be unique") - } else if (is_in(.QTL_GENO_EXPERIMENT, contextNames)) { - errors <- c( - errors, - glue( - "'{.QTL_GENO_EXPERIMENT}' is reserved for the genotype ", - "experiment and cannot name a context" - ) - ) + return("'phenotypes' must be a named list with non-empty names") } - for (ctx in seq_along(phenotypes)) { - se <- phenotypes[[ctx]] - if (!methods::is(se, "SummarizedExperiment")) { - errors <- c( - errors, - glue( - "phenotypes[[{ctx}]] must be a SummarizedExperiment ", - "(got {class(se)[[1L]]})" - ) - ) - } else if (is.null(colnames(se))) { - errors <- c( - errors, - glue( - "phenotypes[[{ctx}]] has no column names. Which samples ", - "a context observes is recorded in the sampleMap, so ", - "every context must name its samples" - ) - ) - } + if (n_distinct(contextNames) < length(contextNames)) { + return("context names in 'phenotypes' must be unique") + } + if (is_in(.QTL_GENO_EXPERIMENT, contextNames)) { + return(glue( + "'{.QTL_GENO_EXPERIMENT}' is reserved for the genotype ", + "experiment and cannot name a context" + )) } - errors + character(0) +} + +# What is wrong with one context's SummarizedExperiment, if anything. +# @noRd +.qtlPhenotypeEntryErrors <- function(ctx, phenotypes) { + se <- phenotypes[[ctx]] + if (!methods::is(se, "SummarizedExperiment")) { + return(glue( + "phenotypes[[{ctx}]] must be a SummarizedExperiment ", + "(got {class(se)[[1L]]})" + )) + } + if (is.null(colnames(se))) { + return(glue( + "phenotypes[[{ctx}]] has no column names. Which samples ", + "a context observes is recorded in the sampleMap, so ", + "every context must name its samples" + )) + } + character(0) +} + +.qtlCheckPhenotypeList <- function(phenotypes) { + emptyError <- if (length(phenotypes) == 0L) { + "'phenotypes' must not be empty" + } else { + character(0) + } + # Each check answers with its own message or nothing, so the report is a + # concatenation rather than a vector appended to in place. + entryErrors <- map( + seq_along(phenotypes), + .qtlPhenotypeEntryErrors, + phenotypes = phenotypes + ) + as.character(c( + emptyError, + .qtlContextNameErrors(names(phenotypes)), + .qtlConcatChr(entryErrors) + )) +} + +# Concatenate per-item message vectors, empty-safe. +# @noRd +.qtlConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + as.character(list_c(pieces)) } # The MAE must carry the genotype experiment plus at least one context. # @noRd .qtlValidatePhenotypes <- function(object) { exps <- MultiAssayExperiment::experiments(object) - errors <- character() - if (!is_in(.QTL_GENO_EXPERIMENT, names(exps))) { - errors <- c( - errors, - glue("experiment '{.QTL_GENO_EXPERIMENT}' is missing") - ) + missingGeno <- if (is_in(.QTL_GENO_EXPERIMENT, names(exps))) { + character(0) + } else { + glue("experiment '{.QTL_GENO_EXPERIMENT}' is missing") } - if (length(.qtlPhenotypeList(object)) == 0L) { - errors <- c(errors, "'phenotypes' must not be empty") + noContexts <- if (length(.qtlPhenotypeList(object)) == 0L) { + "'phenotypes' must not be empty" + } else { + character(0) } - errors + as.character(c(missingGeno, noContexts)) } # TRUE when two GRanges share canonical chrom + start + end. @@ -236,32 +268,61 @@ setClass( if (!allSe) { return(character()) } - errors <- character() - traitToRange <- list() - for (ctx in seq_along(pheno)) { - se <- pheno[[ctx]] - rr <- SummarizedExperiment::rowRanges(se) - ids <- rownames(se) - if (length(rr) != length(ids)) { - next - } - for (i in seq_along(ids)) { - tid <- ids[[i]] - prev <- traitToRange[[tid]] - if (is.null(prev)) { - traitToRange[[tid]] <- rr[i] - } else if (!.qtlSameRange(prev, rr[i])) { - errors <- c( - errors, - glue( - "trait '{tid}' has inconsistent rowRanges across ", - "contexts" - ) - ) - } - } + # Every (trait, range) observation in context order, so each one can be + # compared against the first sighting of its trait without a running map. + pairs <- .qtlConcat(map( + seq_along(pheno), + .qtlTraitRangePairs, + pheno = pheno + )) + tids <- map_chr(pairs, "tid") + .qtlConcatChr(map( + seq_along(pairs), + .qtlTraitRangeError, + tids = tids, + ranges = map(pairs, "range") + )) +} + +# Concatenate per-item lists, empty-safe. +# @noRd +.qtlConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# @noRd +.qtlTraitRangePair <- function(i, ids, rr) { + list(tid = ids[[i]], range = rr[i]) +} + +# One context's (trait, range) observations, or none when the rowRanges and +# the rownames disagree on length. +# @noRd +.qtlTraitRangePairs <- function(ctx, pheno) { + se <- pheno[[ctx]] + rr <- SummarizedExperiment::rowRanges(se) + ids <- rownames(se) + if (length(rr) != length(ids)) { + return(list()) + } + map(seq_along(ids), .qtlTraitRangePair, ids = ids, rr = rr) +} + +# Observation `i` disagrees with the first sighting of the same trait. Earlier +# sightings are the reference, so the first one never reports. +# @noRd +.qtlTraitRangeError <- function(i, tids, ranges) { + earlier <- which(tids[seq_len(i - 1L)] == tids[[i]]) + if (length(earlier) == 0L) { + return(character(0)) + } + if (.qtlSameRange(ranges[[earlier[[1L]]]], ranges[[i]])) { + return(character(0)) } - errors + glue("trait '{tids[[i]]}' has inconsistent rowRanges across contexts") } # ============================================================================= @@ -329,29 +390,31 @@ setClass( #' (e.g., ancestry PCs); rows are samples. Becomes the \code{colData} of the #' genotype experiment. #' @param scaleResiduals Logical (length 1). Default \code{TRUE}. -#' @param mafCutoff Numeric (length 1). Minor allele frequency threshold; -#' variants with \code{MAF < mafCutoff} are dropped at extraction time inside -#' \code{getGenotypes()} / \code{getResidualizedGenotypes()}. Default 0 (no -#' filter). -#' @param macCutoff Numeric (length 1). Minor allele count threshold; converted -#' to a MAF threshold using \code{max(mafCutoff, macCutoff / (2 * n))} where -#' \code{n} is the post-narrowing sample count of the extracted block. Default -#' 0 (no filter). -#' @param xvarCutoff Numeric (length 1). Per-variant genotype variance -#' threshold; variants with column variance below this are dropped at -#' extraction time. Default 0 (no filter). -#' @param imissCutoff Numeric (length 1). Per-sample genotype-missingness -#' threshold; samples with a missing-genotype rate above this are dropped at -#' extraction time. Default 0 (no filter). -#' @param keepSamples Character vector of sample identifiers to retain. The -#' dataset is subset to them, narrowing \code{colData} and -#' \code{sampleMap} together, so the sample set has one home rather than -#' two. Length 0 means no restriction. -#' @param keepVariants Character vector of variant identifiers to retain prior -#' to per-block QC. Length 0 means no restriction. -#' @param keepIndel Logical (length 1). When \code{FALSE}, variants whose -#' alleles are not single nucleotides (indels) are dropped at extraction. -#' Default \code{TRUE} (keep all variants). +#' @param genotypeFilterArgs Which variants and samples to keep, built with +#' \code{\link{GenotypeFilterParam}}. A bare list is refused, since it +#' cannot be checked. Each field is recorded on the object and applied +#' lazily, at extraction time inside \code{getGenotypes()} / +#' \code{getResidualizedGenotypes()}: +#' \itemize{ +#' \item \code{mafCutoff} --- drop variants with +#' \code{MAF < mafCutoff}. Unset means 0 (no filter). +#' \item \code{macCutoff} --- a minor-allele-count threshold, converted +#' to a MAF threshold as \code{max(mafCutoff, macCutoff / (2 * n))} +#' with \code{n} the post-narrowing sample count of the extracted +#' block. Unset means 0. +#' \item \code{xvarCutoff} --- drop variants whose column variance is +#' below this. Unset means 0. +#' \item \code{imissCutoff} --- drop samples whose missing-genotype rate +#' exceeds this. Unset means 0. +#' \item \code{keepSamples} --- subset the dataset to these samples, +#' narrowing \code{colData} and \code{sampleMap} together so the +#' sample set has one home rather than two. Unset, or +#' \code{character(0)}, means no restriction. +#' \item \code{keepVariants} --- retain only these variants, before +#' per-block QC. Unset, or \code{character(0)}, means no restriction. +#' \item \code{keepIndel} --- when \code{FALSE}, drop variants whose +#' alleles are not single nucleotides. Unset means \code{TRUE}. +#' } #' @return A \code{QtlDataset} object. #' @examples #' panel <- readGenotypes( @@ -376,14 +439,14 @@ QtlDataset <- function( phenotypes, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0), scaleResiduals = TRUE, - mafCutoff = 0, - macCutoff = 0, - xvarCutoff = 0, - imissCutoff = 0, - keepSamples = character(0), - keepVariants = character(0), - keepIndel = TRUE + genotypeFilterArgs = GenotypeFilterParam() ) { + .assertMethodParam( + genotypeFilterArgs, + "GenotypeFilterParam", + "genotypeFilter" + ) + filt <- .qtlResolveFilter(genotypeFilterArgs) handle <- .qtlValidateInputs(phenotypes, genotypes) experiments <- c( set_names( @@ -399,15 +462,15 @@ QtlDataset <- function( ) obj <- methods::new( "QtlDataset", - .qtlRestrictSamples(mae, keepSamples), + .qtlRestrictSamples(mae, filt$keepSamples), study = as.character(study), scaleResiduals = isTRUE(scaleResiduals), - mafCutoff = as.numeric(mafCutoff), - macCutoff = as.numeric(macCutoff), - xvarCutoff = as.numeric(xvarCutoff), - imissCutoff = as.numeric(imissCutoff), - keepVariants = as.character(keepVariants), - keepIndel = isTRUE(keepIndel) + mafCutoff = as.numeric(filt$mafCutoff), + macCutoff = as.numeric(filt$macCutoff), + xvarCutoff = as.numeric(filt$xvarCutoff), + imissCutoff = as.numeric(filt$imissCutoff), + keepVariants = as.character(filt$keepVariants), + keepIndel = isTRUE(filt$keepIndel) ) validObject(obj) obj @@ -516,14 +579,15 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { # Read the dosages into memory so the reshape can see them. # @noRd .qtlRealizeDosages <- function(mae) { - exps <- MultiAssayExperiment::experiments(mae) - se <- exps[[.QTL_GENO_EXPERIMENT]] - SummarizedExperiment::assay(se, "dosage") <- as.matrix( - SummarizedExperiment::assay(se, "dosage") + lazy <- MultiAssayExperiment::experiments(mae) + bare <- lazy[[.QTL_GENO_EXPERIMENT]] + se <- SummarizedExperiment::`assay<-`( + bare, + "dosage", + value = as.matrix(SummarizedExperiment::assay(bare, "dosage")) ) - exps[[.QTL_GENO_EXPERIMENT]] <- se - MultiAssayExperiment::experiments(mae) <- exps - mae + exps <- `[[<-`(lazy, .QTL_GENO_EXPERIMENT, value = se) + MultiAssayExperiment::`experiments<-`(mae, value = exps) } # Resolve an experiment subscript to names, always keeping the genotype @@ -579,10 +643,14 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { .qtlWithGenotypeHandle <- function(x, handle) { exps <- MultiAssayExperiment::experiments(x) gCov <- .qtlColDataMatrix(exps[[.QTL_GENO_EXPERIMENT]]) - exps[[.QTL_GENO_EXPERIMENT]] <- .genotypeExperiment(handle, gCov) - MultiAssayExperiment::experiments(x) <- exps - validObject(x) - x + withHandle <- `[[<-`( + exps, + .QTL_GENO_EXPERIMENT, + value = .genotypeExperiment(handle, gCov) + ) + rebuilt <- MultiAssayExperiment::`experiments<-`(x, value = withHandle) + validObject(rebuilt) + rebuilt } # The primary sample table: every sample any experiment observes, in @@ -655,9 +723,7 @@ setMethod("getGenotypeCovariates", "QtlDataset", function(x) { # @noRd .qtlColDataMatrix <- function(se) { cd <- SummarizedExperiment::colData(se) - out <- as.matrix(as.data.frame(cd)) - rownames(out) <- rownames(cd) - out + `rownames<-`(as.matrix(as.data.frame(cd)), rownames(cd)) } #' @rdname getScaleResiduals @@ -678,27 +744,27 @@ setMethod("getGenotypeHandle", "QtlDataset", function(x) { #' @rdname qtlDatasetFilters #' @export -setMethod("getMafCutoff", "QtlDataset", function(x, ...) x@mafCutoff) +setMethod("getMafCutoff", "QtlDataset", function(x) x@mafCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getMacCutoff", "QtlDataset", function(x, ...) x@macCutoff) +setMethod("getMacCutoff", "QtlDataset", function(x) x@macCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getXvarCutoff", "QtlDataset", function(x, ...) x@xvarCutoff) +setMethod("getXvarCutoff", "QtlDataset", function(x) x@xvarCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getImissCutoff", "QtlDataset", function(x, ...) x@imissCutoff) +setMethod("getImissCutoff", "QtlDataset", function(x) x@imissCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getKeepVariants", "QtlDataset", function(x, ...) x@keepVariants) +setMethod("getKeepVariants", "QtlDataset", function(x) x@keepVariants) #' @rdname qtlDatasetFilters #' @export -setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) +setMethod("getKeepIndel", "QtlDataset", function(x) x@keepIndel) # --- Internal: resolve the variant-selection region for the genotype handle. # Returns a GRanges (one or more ranges). When `traitId` is supplied, expand @@ -729,6 +795,25 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) # The union span (+/- cisWindow) of a trait's rowRanges across all contexts. # Requires cisWindow and a single shared chromosome. # @noRd +# The requested traits' ranges within one context, or NULL when it carries +# none of them. +# @noRd +.qtlTraitRangesInContext <- function(ctx, x, traitId) { + se <- getPhenotypes(x, ctx) + hits <- .qtlPresentIndices(traitId, rownames(se)) + if (length(hits) == 0L) { + return(NULL) + } + SummarizedExperiment::rowRanges(se)[hits] +} + +# Positions of `wanted` in `available`, dropping the ones not present. +# @noRd +.qtlPresentIndices <- function(wanted, available) { + hits <- match(wanted, available) + hits[!is.na(hits)] +} + .qtlTraitRegion <- function(x, traitId, cisWindow) { if (is.null(cisWindow) || length(cisWindow) != 1L || cisWindow < 0) { msg <- glue( @@ -737,16 +822,12 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) ) abort(msg) } - perTraitRanges <- list() - for (ctx in getContexts(x)) { - se <- getPhenotypes(x, ctx) - hits <- match(traitId, rownames(se)) - hits <- hits[!is.na(hits)] - if (length(hits) > 0) { - rr <- SummarizedExperiment::rowRanges(se) - perTraitRanges[[length(perTraitRanges) + 1L]] <- rr[hits] - } - } + perTraitRanges <- compact(map( + getContexts(x), + .qtlTraitRangesInContext, + x = x, + traitId = traitId + )) if (length(perTraitRanges) == 0L) { abort("None of the requested traitId values were found in any context.") } @@ -770,19 +851,17 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) # A literal `region` GRanges, each range optionally extended by cisWindow. # @noRd +#' @importFrom checkmate assertNumber +#' @importFrom checkmate assertClass .qtlLiteralRegion <- function(region, cisWindow) { - if (!methods::is(region, "GRanges")) { - abort("`region` must be a GRanges object.") - } + assertClass(region, "GRanges") if (length(region) == 0L) { abort("`region` must contain at least one range.") } if (is.null(cisWindow)) { return(region) } - if (length(cisWindow) != 1L || cisWindow < 0) { - abort("`cisWindow` must be a single non-negative value.") - } + assertNumber(cisWindow, lower = 0) GenomicRanges::GRanges( seqnames = GenomicRanges::seqnames(region), ranges = IRanges::IRanges( @@ -802,46 +881,64 @@ setMethod("getKeepIndel", "QtlDataset", function(x, ...) x@keepIndel) # 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 (ctx in getContexts(x)) { - se <- getPhenotypes(x, ctx) - 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) - } + spans <- map(traitIds, .qtlTraitSpan, x = x, contexts = getContexts(x)) + starts <- map_int(spans, "start") + # `set_names()` is vector-only, so name the GRanges through `names<-` + # applied as a function -- still a copy, no binding rewritten. + `names<-`( + GenomicRanges::GRanges( + map_chr(spans, "chr"), + IRanges::IRanges( + start = starts, + end = pmax(map_int(spans, "end"), starts) + ) + ), + traitIds + ) +} + +# @noRd +.qtlFirstSeqname <- function(rr) { + as.character(GenomicRanges::seqnames(rr))[[1L]] +} + +# One trait's union span across every context that carries it. The chromosome +# is the last matching context's, which is what the running assignment left +# behind; the span is the widest across all of them. +# @noRd +.qtlTraitSpan <- function(tid, x, contexts) { + ranges <- compact(map( + contexts, + .qtlTraitRangesInContext, + x = x, + traitId = tid + )) + if (length(ranges) == 0L) { + return(list(chr = "chrUn", start = 1L, end = 1L)) } - gr <- GenomicRanges::GRanges( - chrs, - IRanges::IRanges(start = starts, end = pmax(ends, starts)) + chrs <- map_chr(ranges, .qtlFirstSeqname) + list( + chr = chrs[[length(chrs)]], + start = as.integer(min(map_dbl(ranges, .qtlRangeMinStart))), + end = as.integer(max(map_dbl(ranges, .qtlRangeMaxEnd))) ) - names(gr) <- traitIds - gr +} + +# @noRd +.qtlRangeMinStart <- function(rr) { + min(GenomicRanges::start(rr)) +} + +# @noRd +.qtlRangeMaxEnd <- function(rr) { + max(GenomicRanges::end(rr)) } #' @rdname getTraitPosition #' @export -setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { +setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { tids <- if (is.null(traitId)) { - unique(unlist(map(.qtlPhenotypeList(x), rownames))) + unique(list_c(map(.qtlPhenotypeList(x), rownames))) } else { as.character(traitId) } @@ -862,17 +959,66 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { rChr <- canonChrom(GenomicRanges::seqnames(region)) rStart <- GenomicRanges::start(region) rEnd <- GenomicRanges::end(region) - idx <- integer(0) - for (i in seq_along(region)) { - idx <- c(idx, which(siChr == rChr[i] & bp >= rStart[i] & bp <= rEnd[i])) - } - unique(idx) + if (length(region) == 0L) { + return(integer(0)) + } + unique(list_c(map( + seq_along(region), + .qtlRegionHitIndices, + siChr = siChr, + bp = bp, + rChr = rChr, + rStart = rStart, + rEnd = rEnd + ))) +} + +# Rows of the SNP table falling inside region `i`. +# @noRd +.qtlRegionHitIndices <- function(i, siChr, bp, rChr, rStart, rEnd) { + which(siChr == rChr[i] & bp >= rStart[i] & bp <= rEnd[i]) } # Internal: keepIndel slot read, tolerant of QtlDataset objects serialized # before the slot existed (treat a missing slot as TRUE = keep indels). +#' @importFrom purrr possibly .qtlKeepIndel <- function(x) { - isTRUE(tryCatch(getKeepIndel(x), error = function(e) TRUE)) + isTRUE(possibly(getKeepIndel, otherwise = TRUE)(x)) +} + +# A GenotypeFilterParam() bundle with every field resolved. Unset fields +# (absent from the bundle) take this constructor's documented defaults -- +# which is what makes the same bundle usable as a specification here and as an +# override in .qtlApplyFilterOverrides, where unset means "leave the slot". +# @noRd +.qtlResolveFilter <- function(genotypeFilterArgs) { + list( + mafCutoff = genotypeFilterArgs$mafCutoff %||% 0, + macCutoff = genotypeFilterArgs$macCutoff %||% 0, + xvarCutoff = genotypeFilterArgs$xvarCutoff %||% 0, + imissCutoff = genotypeFilterArgs$imissCutoff %||% 0, + keepSamples = genotypeFilterArgs$keepSamples %||% character(0), + keepVariants = genotypeFilterArgs$keepVariants %||% character(0), + keepIndel = genotypeFilterArgs$keepIndel %||% TRUE + ) +} + +# Coerce an override, preserving "unset" as NULL. Hoisted rather than written +# inline three times, and not nested, per the package's no-nested-functions +# rule. +# @noRd +.qtlNumOverride <- function(x) { + if (is.null(x)) NULL else as.numeric(x) +} + +# @noRd +.qtlLglOverride <- function(x) { + if (is.null(x)) NULL else as.logical(x) +} + +# @noRd +.qtlChrOverride <- function(x) { + if (is.null(x)) NULL else as.character(x) } # Internal: return a copy of a QtlDataset with the supplied filter cutoffs / @@ -880,39 +1026,48 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { # untouched). This lets a pipeline accept per-call filter overrides as ordinary # arguments instead of forcing callers to mutate @slots directly (which bypasses # the class's validity checks). Applied against a validated copy. -.qtlApplyFilterOverrides <- function( - data, - mafCutoff = NULL, - macCutoff = NULL, - xvarCutoff = NULL, - imissCutoff = NULL, - keepIndel = NULL, - keepSamples = NULL, - keepVariants = NULL -) { - if (!is.null(mafCutoff)) { - data@mafCutoff <- as.numeric(mafCutoff) - } - if (!is.null(macCutoff)) { - data@macCutoff <- as.numeric(macCutoff) - } - if (!is.null(xvarCutoff)) { - data@xvarCutoff <- as.numeric(xvarCutoff) - } - if (!is.null(imissCutoff)) { - data@imissCutoff <- as.numeric(imissCutoff) - } - if (!is.null(keepIndel)) { - data@keepIndel <- as.logical(keepIndel) - } - if (!is.null(keepSamples)) { - data <- .qtlRestrictSamples(data, keepSamples) +.qtlApplyFilterOverrides <- function(data, genotypeFilterArgs) { + .assertMethodParam( + genotypeFilterArgs, + "GenotypeFilterParam", + "genotypeFilter" + ) + # discard(is.null), not compact(): a keepVariants of character(0) is a + # real instruction ("restrict to nothing was not asked, keep all"), and + # compact() would drop it along with the unset fields. + overridden <- exec( + methods::initialize, + data, + !!!discard( + list( + mafCutoff = .qtlNumOverride(genotypeFilterArgs$mafCutoff), + macCutoff = .qtlNumOverride(genotypeFilterArgs$macCutoff), + xvarCutoff = .qtlNumOverride(genotypeFilterArgs$xvarCutoff), + imissCutoff = .qtlNumOverride(genotypeFilterArgs$imissCutoff), + keepIndel = .qtlLglOverride(genotypeFilterArgs$keepIndel), + keepVariants = .qtlChrOverride(genotypeFilterArgs$keepVariants) + ), + is.null + ) + ) + keepSamples <- genotypeFilterArgs$keepSamples + restricted <- if (is.null(keepSamples)) { + overridden + } else { + .qtlRestrictSamples(overridden, keepSamples) } - if (!is.null(keepVariants)) { - data@keepVariants <- as.character(keepVariants) + methods::validObject(restricted) + restricted +} + +# Drop samples whose missingness across the block exceeds the dataset's +# imissCutoff. A cutoff of 0 (or an empty block) keeps every sample. +# @noRd +.qtlDropMissingSamples <- function(dosage, x) { + if (getImissCutoff(x) <= 0 || nrow(dosage) == 0L || ncol(dosage) == 0L) { + return(dosage) } - methods::validObject(data) - data + dosage[rowMeans(is.na(dosage)) <= getImissCutoff(x), , drop = FALSE] } # Internal: extract the panel dosage block (samples x variants) for the @@ -945,13 +1100,13 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { region = region, cisWindow = cisWindow ) - snpIdx <- .qtlVariantIndices(x, gr) - if (length(snpIdx) == 0L) { + inRegion <- .qtlVariantIndices(x, gr) + if (length(inRegion) == 0L) { return(.qtlEmptyBlockAllSamples(x)) } # Apply keepVariants + indel restrictions before materialization so we do # not extract dosage we would immediately drop. - snpIdx <- .qtlNarrowSnpIdx(x, snpIdx) + snpIdx <- .qtlNarrowSnpIdx(x, inRegion) if (length(snpIdx) == 0L) { return(.qtlEmptyBlock()) } @@ -961,21 +1116,13 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { if (length(keep) == 0L) { return(.qtlEmptyBlockNoSamples(dosage)) } - dosage <- dosage[keep, , drop = FALSE] - # Per-sample missingness filter. - if (getImissCutoff(x) > 0 && nrow(dosage) > 0L && ncol(dosage) > 0L) { - dosage <- dosage[ - rowMeans(is.na(dosage)) <= getImissCutoff(x), - , - drop = FALSE - ] - } - filtered <- .qtlVariantFilters(dosage, x) - dosage <- .qtlMeanImpute(filtered$dosage) + kept <- dosage[keep, , drop = FALSE] + filtered <- .qtlVariantFilters(.qtlDropMissingSamples(kept, x), x) + imputed <- .qtlMeanImpute(filtered$dosage) list( - geno = dosage, - variantIds = colnames(dosage), - sampleIds = rownames(dosage), + geno = imputed, + variantIds = colnames(imputed), + sampleIds = rownames(imputed), maf = filtered$maf, af = filtered$af ) @@ -1033,22 +1180,22 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { # @noRd .qtlNarrowSnpIdx <- function(x, snpIdx) { handle <- getGenotypeHandle(x) - if (length(getKeepVariants(x)) > 0L) { + kept <- if (length(getKeepVariants(x)) == 0L) { + snpIdx + } else { snpAll <- as.character(getSnpInfo(handle)$SNP[snpIdx]) km <- matchVariants(snpAll, as.character(getKeepVariants(x))) - keepMask <- logical(length(snpAll)) - keepMask[km$idxA] <- TRUE - snpIdx <- snpIdx[keepMask] + snpIdx[replace(logical(length(snpAll)), km$idxA, TRUE)] } - if (length(snpIdx) > 0L && !.qtlKeepIndel(x)) { - si <- getSnpInfo(handle) - # which() (not the mask) so an NA mask drops the variant rather than - # injecting an NA index. - snpMask <- str_length(as.character(si$A1[snpIdx])) == 1L & - str_length(as.character(si$A2[snpIdx])) == 1L - snpIdx <- snpIdx[which(snpMask)] + if (length(kept) == 0L || .qtlKeepIndel(x)) { + return(kept) } - snpIdx + si <- getSnpInfo(handle) + # which() (not the mask) so an NA mask drops the variant rather than + # injecting an NA index. + snpMask <- str_length(as.character(si$A1[kept])) == 1L & + str_length(as.character(si$A2[kept])) == 1L + kept[which(snpMask)] } # Resolve the sample set: panel samples intersected with the dataset's @@ -1056,12 +1203,14 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { # per-call `samples` arg. # @noRd .qtlResolveSamples <- function(dosage, x, samples) { - keep <- intersect( + inDataset <- intersect( rownames(dosage), rownames(MultiAssayExperiment::colData(x)) ) - if (!is.null(samples)) { - keep <- intersect(keep, as.character(samples)) + keep <- if (is.null(samples)) { + inDataset + } else { + intersect(inDataset, as.character(samples)) } keep } @@ -1086,13 +1235,20 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { getMafCutoff(x), if (nSamp > 0L) getMacCutoff(x) / (2 * nSamp) else 0 ) - keepVarMask <- !is.na(mafVec) & mafVec >= effectiveMaf - if (getXvarCutoff(x) > 0 && nSamp > 1L) { + byMaf <- !is.na(mafVec) & mafVec >= effectiveMaf + keepVarMask <- if (getXvarCutoff(x) <= 0 || nSamp <= 1L) { + byMaf + } else { mu <- if_else(nObs > 0L, sumD / nObs, 0) - centered <- sweep(dosage, 2L, mu, FUN = "-") - centered[is.na(centered)] <- 0 + # mu is finite everywhere, so the centered NAs are exactly the + # dosage NAs; they contribute nothing to the variance. + centered <- replace( + sweep(dosage, 2L, mu, FUN = "-"), + is.na(dosage), + 0 + ) varVec <- colSums(centered * centered) / (nSamp - 1L) - keepVarMask <- keepVarMask & varVec >= getXvarCutoff(x) + byMaf & varVec >= getXvarCutoff(x) } list( dosage = dosage[, keepVarMask, drop = FALSE], @@ -1108,15 +1264,13 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { if (!anyNA(dosage)) { return(dosage) } - for (j in seq_len(ncol(dosage))) { - col <- dosage[, j] - na <- is.na(col) - if (any(na)) { - col[na] <- mean(col[!na]) - dosage[, j] <- col - } - } - dosage + naMask <- is.na(dosage) + # An all-NA column means NaN either way, matching mean(numeric(0)). + means <- colMeans(dosage, na.rm = TRUE) + # One fill over the whole matrix instead of a copy per column: dosage is + # variants x samples, so rebuilding it column by column is the expensive + # way to say this. + replace(dosage, naMask, means[col(dosage)[naMask]]) } #' @rdname getGenotypes @@ -1129,8 +1283,7 @@ setMethod( traitId = NULL, region = NULL, cisWindow = NULL, - samples = NULL, - ... + samples = NULL ) { .qtlExtractBlock( x, @@ -1147,7 +1300,7 @@ setMethod( setMethod( "getMaf", "QtlDataset", - function(x, region = NULL, cisWindow = NULL, samples = NULL, ...) { + function(x, region = NULL, cisWindow = NULL, samples = NULL) { block <- .qtlExtractBlock( x, traitId = NULL, @@ -1155,9 +1308,7 @@ setMethod( cisWindow = cisWindow, samples = samples ) - out <- block$maf - names(out) <- block$variantIds - out + set_names(block$maf, block$variantIds) } ) @@ -1171,8 +1322,7 @@ setMethod( traitId = NULL, region = NULL, cisWindow = NULL, - samples = NULL, - ... + samples = NULL ) { block <- .qtlExtractBlock( x, @@ -1181,9 +1331,7 @@ setMethod( cisWindow = cisWindow, samples = samples ) - out <- block$af - names(out) <- block$variantIds - out + set_names(block$af, block$variantIds) } ) @@ -1200,21 +1348,22 @@ setMethod( naAction = c("keep", "drop", "impute"), outlierAction = c("keep", "drop"), outlierPvalThreshold = 1e-3, - ... + outlierArgs = CovMcdOptions() ) { naAction <- arg_match(naAction) outlierAction <- arg_match(outlierAction) + .assertMethodOptions(outlierArgs, "CovMcdOptions", "outlierArgs") .qtlValidateContexts(x, contexts) - out <- .qtlPhenotypeList(x)[contexts] - out <- .qtlFilterPhenotypes( - out, - contexts, - traitId, - region, - naAction, - outlierAction, - outlierPvalThreshold - ) + out <- .qtlPhenotypeList(x)[contexts] |> + .qtlFilterPhenotypes( + contexts, + traitId, + region, + naAction, + outlierAction, + outlierPvalThreshold, + outlierArgs + ) if (length(contexts) == 1L) out[[1L]] else out } ) @@ -1264,35 +1413,40 @@ setMethod( region, naAction, outlierAction, - outlierPvalThreshold + outlierPvalThreshold, + outlierArgs = list() ) { - if (!is.null(traitId)) { - out <- .qtlFilterTraits(out, contexts, traitId) + byTrait <- if (is.null(traitId)) { + out + } else { + .qtlFilterTraits(out, contexts, traitId) } - if (!is.null(region)) { - out <- set_names( - map(out, .qtlSeInRegion, region = region), - contexts - ) + inRegion <- if (is.null(region)) { + byTrait + } else { + set_names(map(byTrait, .qtlSeInRegion, region = region), contexts) } - if (naAction != "keep") { - out <- set_names( - map(out, .qtlApplyPhenoNaAction, naAction = naAction), + naHandled <- if (naAction == "keep") { + inRegion + } else { + set_names( + map(inRegion, .qtlApplyPhenoNaAction, naAction = naAction), contexts ) } - if (outlierAction != "keep") { - out <- set_names( - map( - out, - .qtlApplyPhenoOutliers, - action = outlierAction, - pvalThreshold = outlierPvalThreshold - ), - contexts - ) + if (outlierAction == "keep") { + return(naHandled) } - out + set_names( + map( + naHandled, + .qtlApplyPhenoOutliers, + action = outlierAction, + pvalThreshold = outlierPvalThreshold, + outlierArgs = outlierArgs + ), + contexts + ) } # Internal: apply naAction to a SummarizedExperiment slice. SE assay rows @@ -1310,23 +1464,27 @@ setMethod( return(se) } if (naAction == "drop") { - keepSamp <- colSums(is.na(Y)) == 0L - se <- se[, keepSamp, drop = FALSE] - } else if (naAction == "impute") { - if (anyNA(Y)) { - for (j in seq_len(nrow(Y))) { - row <- Y[j, ] - na <- is.na(row) - if (any(na)) { - obs <- row[!na] - row[na] <- if (length(obs) > 0L) mean(obs) else 0 - Y[j, ] <- row - } - } - SummarizedExperiment::assay(se, assayName) <- Y - } + return(se[, colSums(is.na(Y)) == 0L, drop = FALSE]) + } + if (naAction != "impute" || !anyNA(Y)) { + return(se) } - se + SummarizedExperiment::`assay<-`( + se, + assayName, + value = .qtlRowMeanImpute(Y) + ) +} + +# Fill each row's missing values with that row's mean, or 0 when the row has +# nothing observed. One fill over the whole matrix rather than a copy per row. +# @noRd +.qtlRowMeanImpute <- function(Y) { + naMask <- is.na(Y) + # rowMeans of an all-NA row is NaN, which is the `else 0` case. + means <- rowMeans(Y, na.rm = TRUE) + filled <- if_else(is.nan(means), 0, means) + replace(Y, naMask, filled[row(Y)[naMask]]) } # Multivariate-outlier keep mask via Mahalanobis distance against a @@ -1340,6 +1498,74 @@ setMethod( # message; the test then still works but its estimates are pulled by # the very outliers it should be flagging. # +#' @title Options for the Robust Outlier Covariance Estimator +#' @description Build a checked record of extra arguments for +#' \code{robustbase::covMcd()}, the minimum-covariance-determinant +#' estimator behind \code{outlierAction = "drop"} on +#' \code{\link{getPhenotypes}} and +#' \code{\link{getResidualizedPhenotypes}}. +#' @param ... Arguments for \code{robustbase::covMcd()} -- in practice +#' \code{alpha} (the subset fraction the determinant is minimised over, +#' which sets the breakdown point), \code{nsamp}, \code{use.correction} +#' and \code{nmini} / \code{kmini}. \code{x} is the trait matrix pecotmr +#' assembles and is refused, as is \code{seed}: pecotmr owns RNG +#' reproducibility, and \code{covMcd()}'s \code{seed} restores the ambient +#' \code{.Random.seed} on exit, which would silently undo the caller's +#' stream. +#' @return A \code{MethodOptions} record for the \code{outlierArgs} argument. +#' @seealso \code{\link{getPhenotypes}}, +#' \code{\link{getResidualizedPhenotypes}} +#' @examples +#' CovMcdOptions(alpha = 0.75) +#' @export +CovMcdOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + x = "the trait matrix pecotmr assembles", + seed = "pecotmr's own RNG handling" + ), + "CovMcdOptions" + ) + .newMethodOptions( + "robustbase::covMcd", + defaults = list(), + extra = extra, + label = "CovMcdOptions", + engine = "covMcd" + ) +} + +# The centre and covariance the Mahalanobis distance is measured against: +# robustbase's MCD when it is installed and converges, else the non-robust +# colMeans/cov pair. Both fallbacks are announced -- a silently non-robust +# estimate would make the outlier rule mean something different from what +# the caller asked for. +# @noRd +#' @importFrom rlang try_fetch +.qtlOutlierCenterCov <- function(Y, outlierArgs = list()) { + # Engine-call exception: robustbase::covMcd is a covariance estimator, + # interchangeable with the colMeans/stats::cov fallback above -- a numeric + # primitive for outlier detection while a QtlDataset is built. + if (!requireNamespace("robustbase", quietly = TRUE)) { + msg <- glue( + "outlier detection: install 'robustbase' for an MCD-based ", + "estimator; falling back to non-robust colMeans/cov." + ) + inform(msg) + return(list(center = colMeans(Y), cov = stats::cov(Y))) + } + mcd <- try_fetch( + exec(robustbase::covMcd, Y, !!!as.list(outlierArgs)), + error = function(cnd) NULL + ) + if (is.null(mcd)) { + return(list(center = colMeans(Y), cov = stats::cov(Y))) + } + list(center = mcd$center, cov = mcd$cov) +} + # Significance: per-sample chi-squared(p) p-value with Bonferroni # correction over the sample count. A sample is flagged when its # corrected p-value falls below `pvalThreshold`. With single-trait Y @@ -1347,7 +1573,8 @@ setMethod( # # Returns all-TRUE (no-op) when there are too few samples to support # a covariance estimate (n < p + 2). -.qtlOutlierKeepMask <- function(Y, pvalThreshold) { +#' @importFrom rlang try_fetch +.qtlOutlierKeepMask <- function(Y, pvalThreshold, outlierArgs = list()) { Y <- as.matrix(Y) n <- nrow(Y) p <- ncol(Y) @@ -1362,25 +1589,20 @@ setMethod( warn(msg) return(rep(TRUE, n)) } - if (requireNamespace("robustbase", quietly = TRUE)) { - mcd <- tryCatch(robustbase::covMcd(Y), error = function(e) NULL) - if (!is.null(mcd)) { - ctr <- mcd$center - covMat <- mcd$cov - } else { - ctr <- colMeans(Y) - covMat <- stats::cov(Y) + est <- .qtlOutlierCenterCov(Y, outlierArgs) + ctr <- est$center + covMat <- est$cov + invCov <- try_fetch( + solve(covMat), + error = function(cnd) { + msg <- glue( + "outlier detection: the trait covariance is singular; ", + "using a Moore-Penrose pseudo-inverse instead." + ) + inform(msg, parent = cnd) + MASS::ginv(covMat) } - } else { - msg <- glue( - "outlier detection: install 'robustbase' for an MCD-based ", - "estimator; falling back to non-robust colMeans/cov." - ) - inform(msg) - ctr <- colMeans(Y) - covMat <- stats::cov(Y) - } - invCov <- tryCatch(solve(covMat), error = function(e) MASS::ginv(covMat)) + ) Yc <- sweep(Y, 2L, ctr) d2 <- rowSums((Yc %*% invCov) * Yc) raw <- stats::pchisq(d2, df = p, lower.tail = FALSE) @@ -1390,13 +1612,18 @@ setMethod( # Wrapper: apply the keep-mask to a SummarizedExperiment slice. SE # columns are samples; transpose the assay (traits x samples) before # calling .qtlOutlierKeepMask which expects samples x traits. -.qtlApplyPhenoOutliers <- function(se, action, pvalThreshold) { +.qtlApplyPhenoOutliers <- function( + se, + action, + pvalThreshold, + outlierArgs = list() +) { if (action == "keep") { return(se) } assayName <- SummarizedExperiment::assayNames(se)[[1L]] Y <- t(SummarizedExperiment::assay(se, assayName)) - keep <- .qtlOutlierKeepMask(Y, pvalThreshold) + keep <- .qtlOutlierKeepMask(Y, pvalThreshold, outlierArgs) if (all(keep)) { return(se) } @@ -1415,9 +1642,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") abort(msg) } - out <- map(contexts, .qtlContextColData, x = x) - names(out) <- contexts - out + set_names(map(contexts, .qtlContextColData, x = x), contexts) }) # Internal: residualize a numeric matrix Y (n x k) against a covariate @@ -1441,21 +1666,21 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { # `qr.resid` does not support LAPACK pivoted QR, so use `lm.fit`. It # handles rank-deficient designs gracefully via base-R's pivoted QR # internally -- same effect the LAPACK path was meant to deliver. - res <- stats::lm.fit(x = X, y = Y)$residuals - res <- as.matrix(res) - rownames(res) <- rownames(Y) - colnames(res) <- colnames(Y) + res <- `dimnames<-`( + as.matrix(stats::lm.fit(x = X, y = Y)$residuals), + list(rownames(Y), colnames(Y)) + ) if (isTRUE(scaleResiduals)) { - sds <- apply(res, 2L, stats::sd, na.rm = TRUE) # `sds == 0` exact-zero test is unreliable for residuals coming out of # lm.fit on a constant Y: roundoff gives sd ~ 1e-16 instead of 0, and # dividing the (also-tiny) residuals by it amplifies floating-point # noise to unit-scale. Treat anything below sqrt(.Machine$double.eps) # as effectively zero (column is constant) and skip rescaling. - nearZero <- !is.finite(sds) | sds < sqrt(.Machine$double.eps) - sds[nearZero] <- 1 - res[, nearZero] <- 0 - res <- sweep(res, 2L, sds, FUN = "/") + rawSds <- apply(res, 2L, stats::sd, na.rm = TRUE) + nearZero <- !is.finite(rawSds) | rawSds < sqrt(.Machine$double.eps) + # One multiplier per column: 1/sd where it is meaningful, 0 where the + # column is constant, which zeroes that column outright. + return(sweep(res, 2L, if_else(nearZero, 0, 1 / rawSds), FUN = "*")) } res } @@ -1473,7 +1698,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(keep) != length(requested)) { missingNames <- setdiff(requested, avail) msg <- glue( - "phenotypeCovariatesToResidualize: context '{ctx}' has no ", + "residualizationArgs$phenotypeCovariates: context '{ctx}' has no ", "covariate(s) named: {str_flatten(missingNames, ', ')}" ) abort(msg) @@ -1481,7 +1706,8 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { keep } -# Internal: validate and resolve the `*ToResidualize` argument against a +# Internal: validate and resolve a covariate-selection field of +# ResidualizationParam() against a # set of contexts and the covariates actually present in those contexts' # colData. Accepts either NULL (use all), a character vector (apply to all # listed contexts), or a named list keyed by context. Returns a named list @@ -1508,13 +1734,13 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { )) } msg <- glue( - "phenotypeCovariatesToResidualize must be NULL, a character vector, ", + "`phenotypeCovariates` must be NULL, a character vector, ", "or a named list keyed by context." ) abort(msg) } -# List-form phenotypeCovariatesToResidualize: must be named with EXACTLY the +# List-form `phenotypeCovariates`: must be named with EXACTLY the # `contexts` set. Resolves each context's selection. # @noRd .qtlPhenoSelectionList <- function(x, contexts, toResidualize) { @@ -1523,7 +1749,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { is.null(toResNames) || any(str_length(toResNames) == 0L, na.rm = TRUE) ) { msg <- glue( - "phenotypeCovariatesToResidualize: when supplied as a list, it ", + "`phenotypeCovariates`: when supplied as a list, it ", "must be named with context names." ) abort(msg) @@ -1531,7 +1757,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { badKeys <- setdiff(names(toResidualize), contexts) if (length(badKeys) > 0L) { msg <- glue( - "phenotypeCovariatesToResidualize: list key(s) not in ", + "`phenotypeCovariates`: list key(s) not in ", "`contexts`: {str_flatten(badKeys, ', ')}" ) abort(msg) @@ -1539,7 +1765,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { missingKeys <- setdiff(contexts, names(toResidualize)) if (length(missingKeys) > 0L) { msg <- glue( - "phenotypeCovariatesToResidualize: list does not cover all ", + "`phenotypeCovariates`: list does not cover all ", "`contexts`. Per-context lists must have exactly the same context ", "set as `contexts`. Missing keys: ", "{str_flatten(missingKeys, ', ')}" @@ -1555,10 +1781,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { # Internal: validate the genotype-covariate selection vector. Returns # character(0) when nothing selected, the resolved set otherwise. .qtlResolveGenoSelection <- function(x, toResidualize) { - avail <- colnames(getGenotypeCovariates(x)) - if (is.null(avail)) { - avail <- character(0) - } + avail <- colnames(getGenotypeCovariates(x)) %||% character(0) if (is.null(toResidualize)) { return(avail) } @@ -1566,7 +1789,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(keep) != length(toResidualize)) { missingNames <- setdiff(toResidualize, avail) msg <- glue( - "genotypeCovariatesToResidualize: no covariate(s) named: ", + "`genotypeCovariates`: no covariate(s) named: ", "{str_flatten(missingNames, ', ')}" ) abort(msg) @@ -1627,29 +1850,41 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { # rownames(colData(se)). # @noRd .qtlPhenoCovBlocks <- function(x, contexts, phenoSelection) { - perContext <- list() - for (ctx in contexts) { - keep <- phenoSelection[[ctx]] - if (length(keep) == 0L) { - next - } - se <- getPhenotypes(x, ctx) - cd <- as.matrix(as.data.frame(SummarizedExperiment::colData(se))) - cdMat <- cd[, keep, drop = FALSE] - colnames(cdMat) <- str_c(ctx, ".", colnames(cdMat)) - perContext[[ctx]] <- cdMat + compact(set_names( + map( + contexts, + .qtlPhenoCovBlock, + x = x, + phenoSelection = phenoSelection + ), + contexts + )) +} + +# One context's selected covariate columns, context-qualified, or NULL when +# nothing is selected there. +# @noRd +.qtlPhenoCovBlock <- function(ctx, x, phenoSelection) { + keep <- phenoSelection[[ctx]] + if (length(keep) == 0L) { + return(NULL) } - perContext + se <- getPhenotypes(x, ctx) + cd <- as.matrix(as.data.frame(SummarizedExperiment::colData(se))) + block <- cd[, keep, drop = FALSE] + `colnames<-`(block, str_c(ctx, ".", colnames(block))) } # Intersect the covariate blocks to their common samples and column-bind them # into one design matrix; NULL when no samples are shared. # @noRd .qtlAlignCovariates <- function(perContext, gCov) { - sampleSets <- map(perContext, .qtlBlockSamples) - if (!is.null(gCov) && ncol(gCov) > 0L) { - sampleSets <- c(sampleSets, list(.qtlBlockSamples(gCov))) - } + sampleSets <- c( + map(perContext, .qtlBlockSamples), + if (!is.null(gCov) && ncol(gCov) > 0L) { + list(.qtlBlockSamples(gCov)) + } + ) common <- if (length(sampleSets) == 0L) { character(0) } else { @@ -1658,16 +1893,23 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(common) == 0L) { return(NULL) } - blocks <- list() - for (mat in perContext) { - blocks[[length(blocks) + 1L]] <- mat[common, , drop = FALSE] - } - if (!is.null(gCov) && ncol(gCov) > 0L) { - blocks[[length(blocks) + 1L]] <- gCov[common, , drop = FALSE] + genoBlock <- if (!is.null(gCov) && ncol(gCov) > 0L) { + list(gCov[common, , drop = FALSE]) + } else { + list() } + blocks <- c( + map(perContext, .qtlRestrictToSamples, common = common), + genoBlock + ) exec(cbind, !!!blocks) } +# @noRd +.qtlRestrictToSamples <- function(mat, common) { + mat[common, , drop = FALSE] +} + # The samples a covariate block covers, or NULL when it does not say. A block # with no rows covers none of them, which base R reports as NULL rownames # rather than an empty character vector; reading that as "unconstrained" @@ -1702,102 +1944,13 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { keep <- rowSums(is.na(C)) == 0L return(C[keep, , drop = FALSE]) } - for (j in seq_len(ncol(C))) { - col <- C[, j] - na <- is.na(col) - if (any(na)) { - mu <- mean(col[!na]) - col[na] <- if (is.finite(mu)) mu else 0 - C[, j] <- col - } - } - C -} - -# Internal: resolve a (convenience, precise) flag pair to a single boolean. -# `missing*` arguments are passed as the result of `missing()` evaluated in -# the calling method to detect whether the user explicitly set the value. -# Rules: -# - both missing: returns TRUE (the documented default) -# - only convenience set: returns convenience -# - only precise set: returns precise -# - both set: must agree, else error -.qtlResolveResidualizationFlag <- function( - conveniencePassed, - convenienceMissing, - precisePassed, - preciseMissing, - convenienceName, - preciseName -) { - if (preciseMissing && convenienceMissing) { - return(TRUE) - } - if (preciseMissing) { - return(isTRUE(conveniencePassed)) - } - if (convenienceMissing) { - return(isTRUE(precisePassed)) - } - if (isTRUE(conveniencePassed) != isTRUE(precisePassed)) { - msg <- glue( - "Conflicting values: `{convenienceName}` = {conveniencePassed} ", - "and `{preciseName}` = {precisePassed}. ", - "Set only one, or pass consistent values." - ) - abort(msg) - } - isTRUE(precisePassed) + naMask <- is.na(C) + # colMeans of an all-NA column is NaN, which is the non-finite `else 0`. + means <- colMeans(C, na.rm = TRUE) + filled <- if_else(is.finite(means), means, 0) + replace(C, naMask, filled[col(C)[naMask]]) } -#' @rdname getResidualizedGenotypes -#' @export -setMethod( - "getResidualizedGenotypes", - "QtlDataset", - function( - x, - contexts, - traitId = NULL, - region = NULL, - cisWindow = NULL, - samples = NULL, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - residualizePhenotypeCovariatesFromGenotypes = NULL, - residualizeGenotypeCovariatesFromGenotypes = NULL, - covariateNaAction = c("impute", "drop"), - ... - ) { - if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { - msg <- glue( - "`contexts` is required for ", - "getResidualizedGenotypes(QtlDataset). ", - "Use getContexts(x) to list the available contexts. ", - "Pass a single context for per-context mode or multiple ", - "contexts for joint mode (sample intersection)." - ) - abort(msg) - } - covariateNaAction <- arg_match(covariateNaAction) - convPhenoMissing <- missing(residualizePhenotypeCovariates) - convGenoMissing <- missing(residualizeGenotypeCovariates) - precPhenoMissing <- missing( - residualizePhenotypeCovariatesFromGenotypes - ) || - is.null(residualizePhenotypeCovariatesFromGenotypes) - precGenoMissing <- missing( - residualizeGenotypeCovariatesFromGenotypes - ) || - is.null(residualizeGenotypeCovariatesFromGenotypes) - p <- as.list(environment()) - p$dots <- list(...) - .qtlResidualizedGenotypesImpl(p) - } -) - # Intersect a genotype matrix G and covariate design C to their common samples # (no-op when C is NULL); errors if they share none. # @noRd @@ -1817,141 +1970,104 @@ setMethod( list(G = G[common, , drop = FALSE], C = C[common, , drop = FALSE]) } -# getResidualizedGenotypes worker: resolve the covariate inclusion flags + -# selections, extract genotypes, build + NA-handle the covariate design, and -# QR-residualize. `p` holds the setMethod args + the precomputed `missing()` -# booleans. -# @noRd -# The two residualization flags, each reconciled against its convenience and -# precision spellings. Paired here because the reconciliation rule is the same -# for both and only the argument names differ. -# @noRd -.qtlResidualizationFlags <- function(p) { - list( - pheno = .qtlResolveResidualizationFlag( - p$residualizePhenotypeCovariates, - p$convPhenoMissing, - p$residualizePhenotypeCovariatesFromGenotypes, - p$precPhenoMissing, - "residualizePhenotypeCovariates", - "residualizePhenotypeCovariatesFromGenotypes" - ), - geno = .qtlResolveResidualizationFlag( - p$residualizeGenotypeCovariates, - p$convGenoMissing, - p$residualizeGenotypeCovariatesFromGenotypes, - p$precGenoMissing, - "residualizeGenotypeCovariates", - "residualizeGenotypeCovariatesFromGenotypes" +.qtlResidualizedGenotypesImpl <- function( + x, + contexts, + traitId = NULL, + region = NULL, + cisWindow = NULL, + samples = NULL, + residualizationArgs = ResidualizationParam() +) { + if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { + msg <- glue( + "`contexts` is required for ", + "getResidualizedGenotypes(QtlDataset). ", + "Use getContexts(x) to list the available contexts. ", + "Pass a single context for per-context mode or multiple ", + "contexts for joint mode (sample intersection)." ) + abort(msg) + } + .assertMethodParam( + residualizationArgs, + "ResidualizationParam", + "residualizationArgs" ) -} - -.qtlResidualizedGenotypesImpl <- function(p) { - bad <- setdiff(p$contexts, getContexts(p$x)) + bad <- setdiff(contexts, getContexts(x)) if (length(bad) > 0L) { - msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") + msg <- glue("Unknown context(s): {str_flatten(bad, \', \')}") abort(msg) } - include <- .qtlResidualizationFlags(p) - includePheno <- include$pheno - includeGeno <- include$geno - phenoSel <- .qtlResolvePhenoSelection( - p$x, - p$contexts, - p$phenotypeCovariatesToResidualize - ) - genoSel <- .qtlResolveGenoSelection(p$x, p$genotypeCovariatesToResidualize) G <- getGenotypes( - p$x, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - samples = p$samples + x, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples ) if (ncol(G) == 0L) { return(G) } - C <- .qtlBuildResidualizationDesign( - p$x, - contexts = p$contexts, - phenoSelection = phenoSel, - genoSelection = genoSel, - includePheno = includePheno, - includeGeno = includeGeno - ) - C <- .qtlHandleCovariateNa(C, p$covariateNaAction) - aligned <- .qtlAlignGC(G, C, p$contexts) + C <- .qtlResidCovariateMatrix(x, contexts, residualizationArgs) + aligned <- .qtlAlignGC(G, C, contexts) .qtlResidualizeQr( aligned$G, aligned$C, - scaleResiduals = getScaleResiduals(p$x) + scaleResiduals = getScaleResiduals(x) ) } -#' @rdname getResidualizedPhenotypes +#' @rdname getResidualizedGenotypes #' @export setMethod( - "getResidualizedPhenotypes", + "getResidualizedGenotypes", "QtlDataset", - function( - x, - contexts, - traitId = NULL, - region = NULL, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - residualizePhenotypeCovariatesFromPhenotypes = NULL, - residualizeGenotypeCovariatesFromPhenotypes = NULL, - naAction = c("keep", "drop", "impute"), - covariateNaAction = c("impute", "drop"), - outlierAction = c("keep", "drop"), - outlierPvalThreshold = 1e-3, - ... - ) { - if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { - abort("`contexts` is required for getResidualizedPhenotypes().") - } - naAction <- arg_match(naAction) - covariateNaAction <- arg_match(covariateNaAction) - outlierAction <- arg_match(outlierAction) - convPhenoMissing <- missing(residualizePhenotypeCovariates) - convGenoMissing <- missing(residualizeGenotypeCovariates) - precPhenoMissing <- missing( - residualizePhenotypeCovariatesFromPhenotypes - ) || - is.null(residualizePhenotypeCovariatesFromPhenotypes) - precGenoMissing <- missing( - residualizeGenotypeCovariatesFromPhenotypes - ) || - is.null(residualizeGenotypeCovariatesFromPhenotypes) - p <- as.list(environment()) - p$dots <- list(...) - .qtlResidualizedPhenotypesImpl(p) - } + .qtlResidualizedGenotypesImpl ) # NA-handled raw phenotypes per context (re-wrapped to a list so single- and # multi-context callers see the same shape). # @noRd .qtlResidPhenoY <- function(x, contexts, traitId, region, naAction) { - Yraw <- getPhenotypes( + fetched <- getPhenotypes( x, contexts = contexts, traitId = traitId, region = region, naAction = naAction ) - if (length(contexts) == 1L) { - Yraw <- set_names(list(Yraw), contexts) + # A single context returns the bare matrix rather than a named list. + Yraw <- if (length(contexts) == 1L) { + set_names(list(fetched), contexts) + } else { + fetched } Yraw } -# Residualize one context's phenotypes against the covariate design (intersected -# to common samples) and drop residual-scale outliers. +# Phenotype and covariate matrices restricted to the samples they share. +# A NULL covariate matrix leaves the phenotypes whole. +# @noRd +.qtlAlignPhenoCovariates <- function(allY, C, ctx) { + if (is.null(C)) { + return(list(Y = allY, C = NULL)) + } + common <- intersect(rownames(allY), rownames(C)) + if (length(common) == 0L) { + abort(glue( + "context '{ctx}': no samples shared between phenotype data ", + "and the resolved covariate matrix." + )) + } + list( + Y = allY[common, , drop = FALSE], + C = C[common, , drop = FALSE] + ) +} + +# Residualize one context's phenotypes against the covariate design +# (intersected to common samples) and drop residual-scale outliers. # @noRd .qtlResidualizeContextPheno <- function( se, @@ -1959,110 +2075,152 @@ setMethod( ctx, outlierAction, outlierPvalThreshold, - scaleResiduals + scaleResiduals, + outlierArgs = list() ) { - Y <- t(SummarizedExperiment::assay(se)) # samples x traits - Cctx <- NULL - if (!is.null(C)) { - common <- intersect(rownames(Y), rownames(C)) - if (length(common) == 0L) { - msg <- glue( - "context '{ctx}': no samples shared between phenotype data ", - "and the resolved covariate matrix." - ) - abort(msg) - } - Y <- Y[common, , drop = FALSE] - Cctx <- C[common, , drop = FALSE] + allY <- t(SummarizedExperiment::assay(se)) # samples x traits + aligned <- .qtlAlignPhenoCovariates(allY, C, ctx) + allRes <- .qtlResidualizeQr( + aligned$Y, + aligned$C, + scaleResiduals = scaleResiduals + ) + if (outlierAction == "keep") { + return(allRes) } - Yres <- .qtlResidualizeQr(Y, Cctx, scaleResiduals = scaleResiduals) # Outlier detection on the residualized scale. - if (outlierAction != "keep") { - keep <- .qtlOutlierKeepMask(Yres, outlierPvalThreshold) - if (!all(keep)) { - Yres <- Yres[keep, , drop = FALSE] - } + keep <- .qtlOutlierKeepMask(allRes, outlierPvalThreshold, outlierArgs) + if (all(keep)) { + return(allRes) } - Yres -} - -# Resolve the phenotype/genotype covariate inclusion flags (convenience vs -# precise `*FromPhenotypes`) for getResidualizedPhenotypes. -# @noRd -.qtlResidPhenoFlags <- function(p) { - list( - includePheno = .qtlResolveResidualizationFlag( - p$residualizePhenotypeCovariates, - p$convPhenoMissing, - p$residualizePhenotypeCovariatesFromPhenotypes, - p$precPhenoMissing, - "residualizePhenotypeCovariates", - "residualizePhenotypeCovariatesFromPhenotypes" - ), - includeGeno = .qtlResolveResidualizationFlag( - p$residualizeGenotypeCovariates, - p$convGenoMissing, - p$residualizeGenotypeCovariatesFromPhenotypes, - p$precGenoMissing, - "residualizeGenotypeCovariates", - "residualizeGenotypeCovariatesFromPhenotypes" - ) - ) + allRes[keep, , drop = FALSE] } # getResidualizedPhenotypes worker: resolve covariate inclusion + selections, # NA-handle Y, build the covariate design, and per-context residualize + # outlier-filter. `p` holds the setMethod args + precomputed missing() flags. # @noRd -.qtlResidualizedPhenotypesImpl <- function(p) { - bad <- setdiff(p$contexts, getContexts(p$x)) +.qtlResidualizedPhenotypesImpl <- function( + x, + contexts, + traitId = NULL, + region = NULL, + naAction = c("keep", "drop", "impute"), + outlierAction = c("keep", "drop"), + outlierPvalThreshold = 1e-3, + outlierArgs = CovMcdOptions(), + residualizationArgs = ResidualizationParam() +) { + if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { + abort("`contexts` is required for getResidualizedPhenotypes().") + } + naAction <- arg_match(naAction) + outlierAction <- arg_match(outlierAction) + .assertMethodOptions(outlierArgs, "CovMcdOptions", "outlierArgs") + .assertMethodParam( + residualizationArgs, + "ResidualizationParam", + "residualizationArgs" + ) + bad <- setdiff(contexts, getContexts(x)) if (length(bad) > 0L) { - msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") + msg <- glue("Unknown context(s): {str_flatten(bad, \', \')}") abort(msg) } - flags <- .qtlResidPhenoFlags(p) - includePheno <- flags$includePheno - includeGeno <- flags$includeGeno - phenoSel <- .qtlResolvePhenoSelection( - p$x, - p$contexts, - p$phenotypeCovariatesToResidualize - ) - genoSel <- .qtlResolveGenoSelection(p$x, p$genotypeCovariatesToResidualize) + C <- .qtlResidCovariateMatrix(x, contexts, residualizationArgs) Yraw <- .qtlResidPhenoY( - p$x, - p$contexts, - p$traitId, - p$region, - p$naAction + x, + contexts, + traitId, + region, + naAction ) - C <- .qtlBuildResidualizationDesign( - p$x, - contexts = p$contexts, + .qtlResidPerContext( + contexts, + Yraw = Yraw, + C = C, + x = x, + outlierAction = outlierAction, + outlierPvalThreshold = outlierPvalThreshold, + outlierArgs = outlierArgs + ) +} + +#' @rdname getResidualizedPhenotypes +#' @export +setMethod( + "getResidualizedPhenotypes", + "QtlDataset", + .qtlResidualizedPhenotypesImpl +) + +# What the phenotypes are regressed against: resolve the convenience vs +# precise inclusion flags, pick the phenotype- and genotype-covariate sets +# they select, build the design, and apply the NA policy to it. One step, +# because none of the four halves means anything without the others. +# @noRd +.qtlResidCovariateMatrix <- function(x, contexts, residualizationArgs) { + # arg_match() reports on its argument by name, so it must be handed a + # symbol: resolve the bundle field first, then validate it. + covariateNaAction <- residualizationArgs$covariateNaAction %||% "impute" + covariateNaAction <- arg_match(covariateNaAction, c("impute", "drop")) + phenoSel <- .qtlResolvePhenoSelection( + x, + contexts, + residualizationArgs$phenotypeCovariates + ) + design <- .qtlBuildResidualizationDesign( + x, + contexts = contexts, phenoSelection = phenoSel, - genoSelection = genoSel, - includePheno = includePheno, - includeGeno = includeGeno + genoSelection = .qtlResolveGenoSelection( + x, + residualizationArgs$genotypeCovariates + ), + # Unset means "residualize on this side": the accessors' own + # historical default, now expressed as the absence of a value + # rather than as a formal defaulting to TRUE. + includePheno = residualizationArgs$residualizePhenotype %||% TRUE, + includeGeno = residualizationArgs$residualizeGenotype %||% TRUE ) - C <- .qtlHandleCovariateNa(C, p$covariateNaAction) + .qtlHandleCovariateNa(design, covariateNaAction) +} + +# Residualize every requested context, unwrapping a single-context request +# the way the rest of the QtlDataset accessors do. +# @noRd +.qtlResidPerContext <- function( + contexts, + Yraw, + C, + x, + outlierAction, + outlierPvalThreshold, + outlierArgs +) { out <- set_names( - map(p$contexts, .qtlResidualizeContext, Yraw = Yraw, C = C, p = p), - p$contexts + map( + contexts, + .qtlResidualizeContext, + Yraw = Yraw, + C = C, + x = x, + outlierAction = outlierAction, + outlierPvalThreshold = outlierPvalThreshold, + outlierArgs = outlierArgs + ), + contexts ) - if (length(p$contexts) == 1L) out[[1L]] else out + if (length(contexts) == 1L) out[[1L]] else out } - #' @rdname show-methods #' @export setMethod("show", "QtlDataset", function(object) { pheno <- .qtlPhenotypeList(object) nCtx <- length(pheno) ctxNames <- names(pheno) - totalTraits <- length(unique(unlist( - map(pheno, rownames), - use.names = FALSE - ))) + totalTraits <- length(unique(unname(list_c(map(pheno, rownames))))) cat(glue("QtlDataset for study '{object@study}'\n", .trim = FALSE)) cat(glue( " {nCtx} context(s): {str_flatten(ctxNames, ', ')}\n", @@ -2128,13 +2286,210 @@ setMethod("show", "QtlDataset", function(object) { # Residualize + filter one context's raw phenotype matrix against covariates C. # @noRd -.qtlResidualizeContext <- function(ctx, Yraw, C, p) { +.qtlResidualizeContext <- function( + ctx, + Yraw, + C, + x, + outlierAction, + outlierPvalThreshold, + outlierArgs = list() +) { .qtlResidualizeContextPheno( Yraw[[ctx]], C, ctx, - p$outlierAction, - p$outlierPvalThreshold, - getScaleResiduals(p$x) + outlierAction, + outlierPvalThreshold, + getScaleResiduals(x), + outlierArgs + ) +} + +# Which covariates to residualize on: a character vector of names applied to +# every context, a list keyed by context name, or NULL to take each context's +# own. .qtlResolvePhenoSelection() branches on exactly these three. +setClassUnion("CovariateSelection", c("character", "list", "NULL")) + +#' @rdname ResidualizationParam +#' @aliases ResidualizationParam-class +#' @exportClass ResidualizationParam +setClass( + "ResidualizationParam", + contains = "MethodParam", + slots = c( + phenotypeCovariates = "CovariateSelection", + genotypeCovariates = "CovariateSelection", + residualizePhenotype = "logical_OR_NULL", + residualizeGenotype = "logical_OR_NULL", + covariateNaAction = "character_OR_NULL" + ) +) + +#' @title Covariate Residualization Settings +#' @description What is regressed out of the phenotype and genotype before +#' fitting. Shared by \code{\link{fineMappingPipeline}} and +#' \code{\link{twasWeightsPipeline}}, which hold the same four settings. +#' +#' \code{fineMappingPipeline}'s \code{usePCA} / \code{nPCs} are +#' \strong{not} here. They do not residualize anything: they PCA-reduce a +#' multi-trait context's phenotype matrix and fine-map each top principal +#' component \emph{as a trait}. That is an analysis mode, a sibling of the +#' univariate and multivariate dispatch paths, not a covariate setting. +#' @section Summary-statistics inputs: +#' A \code{QtlSumStats} / \code{GwasSumStats} input carries no genotypes +#' or covariates, so nothing here applies and the whole bundle is +#' \strong{ignored} --- not refused. +#' +#' That is the opposite of \code{\link{CrossValidationParam}}, which +#' \emph{is} refused on those inputs +#' (\code{fineMappingPipeline(QtlSumStats, crossValidation = ...)} errors). +#' The difference is the default: CV is off unless asked for +#' (\code{folds = 0}), so a non-default value on a summary-statistics run +#' is an explicit request for something impossible. Residualization is on +#' by default (\code{residualizePhenotype} and \code{residualizeGenotype} +#' are both \code{TRUE}), so refusing a non-default would reject the +#' \emph{default} bundle and force every sumstats caller to unset it. +#' +#' One bundle therefore travels to either input kind unchanged, the same +#' way \code{CrossValidationParam}'s \code{weightMethods} / +#' \code{maxVariants} are carried but ignored by +#' \code{fineMappingPipeline}. +#' @param phenotypeCovariates Covariates to residualize the phenotype on, or +#' \code{NULL} (default) for the dataset's own. +#' @param genotypeCovariates Covariates to residualize the genotype on, or +#' \code{NULL} (default) for the dataset's own. +#' @param residualizePhenotype Logical. Residualize on the phenotype +#' covariates. \code{NULL} (default) means unset, which the accessors +#' read as \code{TRUE}. +#' @param residualizeGenotype Logical. Residualize on the genotype +#' covariates. \code{NULL} (default) means unset, read as \code{TRUE}. +#' @param covariateNaAction How missing covariate values are handled when the +#' design is assembled: \code{"impute"} or \code{"drop"}. \code{NULL} +#' (default) leaves the accessor's own default in place. +#' @return A \code{ResidualizationParam} object, a \code{\link{MethodParam}}. +#' @examples +#' ResidualizationParam(residualizeGenotype = FALSE) +#' @export +ResidualizationParam <- function( + phenotypeCovariates = NULL, + genotypeCovariates = NULL, + residualizePhenotype = NULL, + residualizeGenotype = NULL, + covariateNaAction = NULL +) { + # NULL means "unset", which is why the accessors no longer need a + # `missing()` companion for each flag: FALSE and "not given" are both + # falsy, so a flat formal defaulting to TRUE could not tell them apart, + # and each needed a second formal recording whether it was supplied. + new( + "ResidualizationParam", + phenotypeCovariates = phenotypeCovariates, + genotypeCovariates = genotypeCovariates, + residualizePhenotype = residualizePhenotype, + residualizeGenotype = residualizeGenotype, + covariateNaAction = covariateNaAction ) } + +#' @rdname GenotypeFilterParam +#' @aliases GenotypeFilterParam-class +#' @exportClass GenotypeFilterParam +setClass( + "GenotypeFilterParam", + contains = "MethodParam", + slots = c( + mafCutoff = "numeric_OR_NULL", + macCutoff = "numeric_OR_NULL", + xvarCutoff = "numeric_OR_NULL", + imissCutoff = "numeric_OR_NULL", + keepSamples = "character_OR_NULL", + keepVariants = "character_OR_NULL", + keepIndel = "logical_OR_NULL" + ) +) + +#' @title Genotype Filtering Options +#' @description Which variants and samples survive when a genotype matrix is +#' assembled, as one checked bundle. Used by \code{\link{QtlDataset}}, the +#' manifest loaders, and the pipelines that build a dataset. +#' @section Unset versus set: +#' Every field defaults to \code{NULL}, meaning \strong{not set}, and an +#' unset field is absent from the result rather than carried as \code{NULL}. +#' That is what lets one bundle serve two roles: +#' \itemize{ +#' \item to \code{\link{QtlDataset}} it is a \emph{specification}, and +#' an unset field takes that constructor's own default --- \code{0} for +#' each cutoff, \code{character(0)} for each \code{keep}, \code{TRUE} +#' for \code{keepIndel}. +#' \item to a pipeline it is an \emph{override}, and an unset field +#' leaves the dataset's construct-time value alone. +#' } +#' So \code{GenotypeFilterParam(mafCutoff = 0)} and +#' \code{GenotypeFilterParam()} differ: the first pins the cutoff at zero, +#' the second defers. \code{\link{PanelFilterParam}} needs no such +#' distinction and keeps ordinary defaults. +#' @param mafCutoff Minor-allele-frequency floor. +#' @param macCutoff Minor-allele-count floor; the stricter of this and +#' \code{mafCutoff} applies. +#' @param xvarCutoff Genotype-variance floor. +#' @param imissCutoff Per-variant missingness ceiling. +#' @param keepSamples Sample ids to restrict to; \code{character(0)} keeps +#' all samples. +#' @param keepVariants Variant ids to restrict to; \code{character(0)} keeps +#' all variants. +#' @param keepIndel Logical. Retain insertions and deletions. +#' @return A \code{GenotypeFilterParam} object, a \code{\link{MethodParam}}. +#' @seealso \code{\link{PanelFilterParam}}, \code{\link{SumstatsFilterParam}} +#' @examples +#' GenotypeFilterParam(mafCutoff = 0.01, keepIndel = FALSE) +#' @export +GenotypeFilterParam <- function( + mafCutoff = NULL, + macCutoff = NULL, + xvarCutoff = NULL, + imissCutoff = NULL, + keepSamples = NULL, + keepVariants = NULL, + keepIndel = NULL +) { + new( + "GenotypeFilterParam", + mafCutoff = mafCutoff, + macCutoff = macCutoff, + xvarCutoff = xvarCutoff, + imissCutoff = imissCutoff, + keepSamples = keepSamples, + keepVariants = keepVariants, + keepIndel = keepIndel + ) +} + +# ============================================================================= +# Variant / sample filtering bundles +# ----------------------------------------------------------------------------- +# Which rows and columns of the DATA survive, as opposed to the stage bundles +# above, which describe how a stage behaves. Three filters run in this +# package, on three different objects, and they are deliberately three +# constructors rather than one: +# +# GenotypeFilterParam -- a study's own genotype matrix (QtlDataset and the +# pipelines that build one) +# PanelFilterParam -- an LD reference panel's variants +# SumstatsFilterParam -- rows of a summary-statistics table +# +# Their fields overlap without meaning the same thing, and their defaults +# genuinely differ: `imissCutoff` resolves to 0 on the genotype path and 1 on +# the panel path. One union bundle would have to pick one of those, and would +# accept `removeIndels` where nothing reads it -- the failure mode these +# constructors exist to prevent. +# +# GenotypeFilterParam defaults every field to NULL ("not set") because its +# fields are a SPECIFICATION to QtlDataset and an OVERRIDE to the pipelines; +# absence is what distinguishes "pin this value" from "leave it alone". The +# other two have one meaning each and keep ordinary defaults. +# +# SumstatsCleaningParam sits with them because it runs on the same pass over +# the same table, but it is coercion and normalisation (coerceNumeric, +# normalizeChr, clampSmallP) that also drops rows -- not a filter. +# ============================================================================= diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index 99607609b..8d49d6ab4 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -42,24 +42,23 @@ setClass( # run only once the required columns are present; the ldSketch check always # runs. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames checkNames .validateQtlFineMappingResult <- function(object) { - errors <- .qfmrCheckRequiredCols(object) - if (length(errors) == 0L) { - errors <- .qfmrCheckEntries(object) - } - errors <- c(errors, .qfmrCheckLdSketch(object)) - if (length(errors) == 0L) TRUE else errors -} - -# The study/context/trait/method/entry columns must be present. -# @noRd -.qfmrCheckRequiredCols <- function(object) { - required <- c("study", "context", "trait", "method") - missingCols <- setdiff(required, .tupleColumnNames(object)) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) + coll <- makeAssertCollection() + assertNames( + .tupleColumnNames(object), + must.include = c("study", "context", "trait", "method"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } - NULL + coll$push(.qfmrCheckEntries(object)) + coll$getMessages() } # Entry-column + region/traitPos + joint-column + tuple-uniqueness contract. @@ -81,17 +80,15 @@ setClass( # to check is that the fit payload columns are present and parallel. # @noRd .qfmrCheckEntryLength <- function(object) { - missingCols <- setdiff( - c("susieFit", "cvResult"), - .tupleColumnNames(object) + res <- checkNames( + .tupleColumnNames(object), + must.include = c("susieFit", "cvResult"), + what = "colnames" ) - if (length(missingCols) > 0L) { - return(str_c( - "missing entry payload columns: ", - str_flatten(missingCols, ", ") - )) + if (isTRUE(res)) { + return(NULL) } - NULL + str_c("missing entry payload columns: ", res) } # @noRd @@ -101,7 +98,7 @@ setClass( # Each present joint* column must be character. # @noRd .qfmrCheckJointCols <- function(object, jointCols) { - unlist(compact(map(jointCols, .qfmrJointColError, object = object))) + list_c(compact(map(jointCols, .qfmrJointColError, object = object))) } # @noRd @@ -141,12 +138,6 @@ setClass( } # ldSketch must be a GenotypeHandle or NULL. -# @noRd -.qfmrCheckLdSketch <- function(object) { - # The slot's class union enforces the type; nothing to check. - NULL -} - # The identity-tuple vectors and the payload list are parallel: one entry per # (study, context, trait, method). A length mismatch would otherwise surface as @@ -204,6 +195,8 @@ setClass( #' variantIds = tl$variant_id, susieFit = list(), topLoci = tl) #' QtlFineMappingResult(study = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(fe)) +#' @importFrom checkmate assertCharacter assert checkList +#' @importFrom checkmate checkClass #' @export QtlFineMappingResult <- function( study, @@ -217,44 +210,114 @@ QtlFineMappingResult <- function( traitPos = NULL, ldSketch = NULL ) { + .qfmrAssertArgs( + study, + context, + trait, + method, + entry, + jointStudies, + jointContexts, + jointTraits + ) n <- length(study) .qfmrCheckTupleLengths(study, context, trait, method, entry) - entry <- map(entry, .asFmRowPayload) - .checkRowPayloads(entry, "FineMappingRow", "fine-mapping") - cols <- list( - study = as.character(study), - context = as.character(context), - trait = as.character(trait), - method = as.character(method), - susieFit = S4Vectors::SimpleList(map(entry, getSusieFit)), - cvResult = S4Vectors::SimpleList(map(entry, getCvResult)) - ) - cols <- .qfmrAppendJointCols( - cols, + payloads <- map(entry, .asFmRowPayload) + .checkRowPayloads(payloads, "FineMappingRow", "fine-mapping") + cols <- .qfmrMetadataCols( + study, + context, + trait, + method, + payloads, jointStudies, jointContexts, jointTraits, + traitPos, n ) - cols <- .appendTraitPosCol(cols, traitPos, n) - dfArgs <- c(cols, list(check.names = FALSE)) - # Each entry's variants become one ELEMENT, its topLoci that element's - # inner mcols, and its fit/cv payload outer mcols. A multi-seqname entry - # splits by chromosome with its metadata row replicated. - split <- .rtlSplitBySeqname(map(entry, rowVariants)) - grl <- GenomicRanges::GRangesList(split$entry) - md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] obj <- new( "QtlFineMappingResult", - grl, + .rtlGrlWithMetadata(payloads, cols), ldSketch = .asLdSketch(ldSketch) ) validObject(obj) obj } -# Append any supplied joint* provenance columns (each must match length(study)). +# Every argument's type contract, checked before anything is built. +# @noRd +.qfmrAssertArgs <- function( + study, + context, + trait, + method, + entry, + jointStudies, + jointContexts, + jointTraits +) { + assertCharacter(study, any.missing = FALSE) + assertCharacter(context, any.missing = FALSE) + assertCharacter(trait, any.missing = FALSE) + assertCharacter(method, any.missing = FALSE) + # `entry` is documented as "List / SimpleList"; SimpleList is S4 and + # fails checkList, so this must be an or-combination. + assert( + checkList(entry), + checkClass(entry, "SimpleList"), + .var.name = "entry" + ) + assertCharacter(jointStudies, null.ok = TRUE) + assertCharacter(jointContexts, null.ok = TRUE) + assertCharacter(jointTraits, null.ok = TRUE) +} + +# The collection's outer mcols: the identity tuple, each entry's fit / cv +# payload, and any joint-provenance or trait-position columns. +# @noRd +.qfmrMetadataCols <- function( + study, + context, + trait, + method, + payloads, + jointStudies, + jointContexts, + jointTraits, + traitPos, + n +) { + baseCols <- list( + study = as.character(study), + context = as.character(context), + trait = as.character(trait), + method = as.character(method), + susieFit = S4Vectors::SimpleList(map(payloads, getSusieFit)), + cvResult = S4Vectors::SimpleList(map(payloads, getCvResult)) + ) + withJoint <- .qfmrAppendJointCols( + baseCols, + jointStudies, + jointContexts, + jointTraits, + n + ) + .appendTraitPosCol(withJoint, traitPos, n) +} + +# Each joint-provenance column must be one value per row. +# @noRd +.qfmrCheckJointColLength <- function(nm, val, n) { + if (length(val) == n) { + return(invisible(NULL)) + } + msg <- glue("`{nm}` must have the same length as `study`.") + abort(msg) +} + +# Append any supplied joint* provenance columns (each must match +# length(study)). # @noRd .qfmrAppendJointCols <- function( cols, @@ -263,23 +326,13 @@ QtlFineMappingResult <- function( jointTraits, n ) { - joints <- list( + supplied <- compact(list( jointStudies = jointStudies, jointContexts = jointContexts, jointTraits = jointTraits - ) - for (nm in names(joints)) { - val <- joints[[nm]] - if (is.null(val)) { - next - } - if (length(val) != n) { - msg <- glue("`{nm}` must have the same length as `study`.") - abort(msg) - } - cols[[nm]] <- as.character(val) - } - cols + )) + walk2(names(supplied), supplied, .qfmrCheckJointColLength, n = n) + c(cols, map(supplied, as.character)) } # The single row a (study, context, trait, method) selector pins. @@ -317,8 +370,7 @@ setMethod( context = NULL, trait = NULL, method = NULL, - returnList = FALSE, - ... + returnList = FALSE ) { pip <- .fmrRowPip( .fmrRowParts( @@ -331,9 +383,7 @@ setMethod( "{as.character(x$study)[1L]}|{as.character(x$context)[1L]}|", "{as.character(x$trait)[1L]}|{as.character(x$method)[1L]}" ) - out <- list() - out[[nm]] <- pip - return(out) + return(set_names(list(pip), nm)) } pip } @@ -351,8 +401,19 @@ setMethod( context = NULL, trait = NULL, method = NULL, - ... + region = NULL ) { + # The shared FineMappingResultBase accessors pass the whole selector + # set, and only GwasFineMappingResult is region-indexed. Refusing a + # non-NULL `region` is the point of naming it: it used to vanish into + # `...` and silently return the study/context/trait/method match. + if (!is.null(region)) { + abort(glue( + "QtlFineMappingResult is not region-indexed: select with ", + "study / context / trait / method. `region` applies to ", + "GwasFineMappingResult only." + )) + } .fmrRowParts( x, .qfmrSelectRowIndex(x, study, context, trait, method) @@ -370,8 +431,7 @@ setMethod( study = NULL, context = NULL, trait = NULL, - method = NULL, - ... + method = NULL ) { getCvResult(.fmrRowParts( x, diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index 8024da1b1..a2447fcec 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -147,18 +147,17 @@ methods::setValidity("RangedTupleList", function(object) { return(grl) } if (length(GenomeInfoDb::seqlevels(grl)) == 0L) { - GenomeInfoDb::seqinfo(grl) <- si - return(grl) + return(GenomeInfoDb::`seqinfo<-`(grl, value = si)) } keepLevels <- intersect( GenomeInfoDb::seqlevels(si), GenomeInfoDb::seqlevels(grl) ) - GenomeInfoDb::seqinfo( + GenomeInfoDb::`seqinfo<-`( grl, - new2old = match(keepLevels, GenomeInfoDb::seqlevels(grl)) - ) <- si[keepLevels] - grl + new2old = match(keepLevels, GenomeInfoDb::seqlevels(grl)), + value = si[keepLevels] + ) } .rtlRebuild <- function(x, elements, keep) { @@ -166,16 +165,18 @@ methods::setValidity("RangedTupleList", function(object) { # during initialize(), and a subclass's validity method reads its identity # columns and slots. Building the object bare and filling it in afterwards # trips that check on the way past. - grl <- GenomicRanges::GRangesList(elements) + bare <- GenomicRanges::GRangesList(elements) # seqinfo is collection-level state, exactly like the slots below: it # carries the genome build. A rebuild from bare elements starts with the # seqlevels those elements happen to span -- none at all when everything # was dropped -- so the original seqinfo is merged back in, or subsetting # to nothing would silently discard the build. - grl <- .rtlRestoreSeqinfo(grl, x) + withSeqinfo <- .rtlRestoreSeqinfo(bare, x) md <- mcols(x, use.names = FALSE) - if (!is.null(md)) { - mcols(grl) <- md[keep, , drop = FALSE] + grl <- if (is.null(md)) { + withSeqinfo + } else { + S4Vectors::`mcols<-`(withSeqinfo, value = md[keep, , drop = FALSE]) } ownSlots <- .rtlOwnSlots(x) slotArgs <- set_names(map(ownSlots, .rtlGetSlot, x = x), ownSlots) @@ -259,10 +260,8 @@ setMethod("$", "RangedTupleList", function(x, name) { #' @rdname RangedTupleList-methods #' @export setMethod("$<-", "RangedTupleList", function(x, name, value) { - md <- mcols(x, use.names = FALSE) - md[[name]] <- value - mcols(x) <- md - x + md <- `[[<-`(mcols(x, use.names = FALSE), name, value = value) + S4Vectors::`mcols<-`(x, value = md) }) #' @rdname RangedTupleList-methods @@ -307,8 +306,7 @@ setMethod("[[<-", "RangedTupleList", function(x, i, j, ..., value) { abort(msg) } idx <- .rtlAssignIndex(x, i) - elements <- as.list(x) - elements[[idx]] <- value + elements <- `[[<-`(as.list(x), idx, value = value) # Growing the collection has no defined identity row for the new element, # and mcols would be padded with NA -- which the validity method reads as a # broken tuple. Rejected here so the failure names the real cause. @@ -324,6 +322,7 @@ setMethod("[[<-", "RangedTupleList", function(x, i, j, ..., value) { # Resolve `[[` index forms (positive integer or element name) to a position. # @noRd +#' @importFrom checkmate assertScalar .rtlAssignIndex <- function(x, i) { if (is.character(i)) { pos <- match(i, names(x)) @@ -332,9 +331,7 @@ setMethod("[[<-", "RangedTupleList", function(x, i, j, ..., value) { } return(pos) } - if (length(i) != 1L || is.na(i)) { - abort("`[[<-` takes a single non-NA index.") - } + assertScalar(i, na.ok = FALSE, .var.name = "`[[<-` index") as.integer(i) } @@ -397,7 +394,7 @@ setMethod("endoapply", "RangedTupleList", function(X, FUN, ...) { #' @rdname subsetRegion #' @export -setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { +setMethod("subsetRegion", "RangedTupleList", function(x, region) { win <- .asGRegion(region) elements <- map(as.list(x), .rtlRestrictOne, win = win) keep <- lengths(elements) > 0L @@ -408,6 +405,22 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { # Construction helper: enforce one seqname per element # ----------------------------------------------------------------------------- +# Each entry's variants become one ELEMENT of the GRangesList, with that +# entry's metadata row as the element's outer mcols. A multi-seqname entry +# splits into one element per chromosome, its metadata row replicated +# alongside -- which is why the metadata is indexed by `fromIdx` rather +# than used as-is. Shared by the TwasWeights and *FineMappingResult +# constructors, whose assembly differs only in the columns handed in. +# @noRd +.rtlGrlWithMetadata <- function(payloads, cols) { + split <- .rtlSplitBySeqname(map(payloads, rowVariants)) + md <- exec(S4Vectors::DataFrame, !!!c(cols, list(check.names = FALSE))) + S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md[split$fromIdx, , drop = FALSE] + ) +} + # Split any multi-seqname element into one element per seqname, and report the # index each piece came from so the caller can replicate that element's # metadata row alongside it. @@ -436,7 +449,12 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { } pieces <- map(entry, .rtlSplitOne) list( - entry = unlist(pieces, recursive = FALSE, use.names = TRUE), + # unname(): the flattened names were an artifact of base unlist()'s + # `outer.inner` mangling and were never coherent -- a multi-seqname + # entry got `a.chr1`, a single-seqname one got bare `a`, an unnamed + # input got `chr1` or "". Nothing reads them, and the seqname path + # already had to unname() derived values to keep them out of mcols. + entry = unname(list_flatten(pieces)), fromIdx = rep(seq_along(entry), lengths(pieces)) ) } @@ -499,7 +517,12 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { warn(msg) } list( - entry = unlist(pieces, recursive = FALSE, use.names = TRUE), + # unname(): the flattened names were an artifact of base unlist()'s + # `outer.inner` mangling and were never coherent -- a multi-seqname + # entry got `a.chr1`, a single-seqname one got bare `a`, an unnamed + # input got `chr1` or "". Nothing reads them, and the seqname path + # already had to unname() derived values to keep them out of mcols. + entry = unname(list_flatten(pieces)), fromIdx = rep(seq_along(entry), lengths(pieces)), blockId = unname(list_c(map(pieces, names))) ) @@ -528,8 +551,9 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region, ...) { ) abort(msg) } - names(blocks) <- keys - blocks + # `names<-` not set_names(): `blocks` is a GRanges, and set_names() is + # vector-only -- it rejects an S4 object. + `names<-`(blocks, keys) } # Block keys come from names(), a `blockId` mcol, or the rendered range, in @@ -686,11 +710,26 @@ flattenTupleRanges <- function(x) { return(gr) } tupleCols <- names(md)[map_lgl(as.list(md), is.atomic)] - reps <- rep(seq_len(length(x)), lengths(x)) - for (nm in tupleCols) { - mcols(gr)[[.rtlDotName(nm)]] <- md[[nm]][reps] + if (length(tupleCols) == 0L) { + return(gr) } - gr + reps <- rep(seq_len(length(x)), lengths(x)) + broadcast <- set_names( + map(md[tupleCols], .rtlBroadcastColumn, reps = reps), + map_chr(tupleCols, .rtlDotName) + ) + `mcols<-`( + gr, + value = cbind( + mcols(gr, use.names = FALSE), + DataFrame(broadcast, check.names = FALSE) + ) + ) +} + +# @noRd +.rtlBroadcastColumn <- function(col, reps) { + col[reps] } # The broadcast name for an identity column. Dotted so it cannot collide with @@ -853,15 +892,12 @@ select.RangedTupleList <- function(.data, ...) { #' @exportS3Method dplyr::slice slice.RangedTupleList <- function(.data, ...) { .rtlRequirePlyranges("slice") - elements <- map(as.list(.data), .rtlSliceOne, ...) + # map() forwards `...` to the function, so the user's slice expressions + # reach dplyr::slice directly -- no wrapper needed. + elements <- map(as.list(.data), dplyr::slice, ...) .rtlRebuild(.data, elements, seq_len(length(.data))) } -# @noRd -.rtlSliceOne <- function(g, ...) { - dplyr::slice(g, ...) -} - # Orders WITHIN each element. A global sort of the flattened set followed by # partitioning on the identity tuple leaves each element internally sorted -- # the two are the same thing for the partitioned result -- so no grouping is @@ -898,8 +934,14 @@ group_by.RangedTupleList <- function(.data, ...) { intersect(dotted, colnames(mcols(flat))), colnames(mcols(out)) ) - for (nm in missing) { - mcols(out)[[nm]] <- mcols(flat)[[nm]] - } - out + if (length(missing) == 0L) { + return(out) + } + `mcols<-`( + out, + value = cbind( + mcols(out, use.names = FALSE), + mcols(flat, use.names = FALSE)[, missing, drop = FALSE] + ) + ) } diff --git a/R/SldscData.R b/R/SldscData.R index 65a87abff..5caab186f 100644 --- a/R/SldscData.R +++ b/R/SldscData.R @@ -46,30 +46,34 @@ setValidity("SldscData", function(object) .validateSldscData(object)) } # @noRd +#' @importFrom checkmate checkNames .sldscDataCheckAnnot <- function(annot) { - errs <- character(0) - if (!all(is_in(c("CHR", "SNP"), names(annot)))) { - errs <- c(errs, "`annot` must have columns CHR and SNP.") - } + cols <- checkNames(names(annot), must.include = c("CHR", "SNP")) annotCols <- setdiff(names(annot), c("CHR", "SNP", "BP", "CM")) - if (length(annotCols) == 0L) { - errs <- c( - errs, + c( + if (!isTRUE(cols)) { + str_c("`annot` must have columns CHR and SNP: ", cols) + }, + if (length(annotCols) == 0L) { str_c( "`annot` must have at least one annotation ", "column beyond CHR/SNP/BP/CM." ) - ) - } - errs + } + ) %||% + character(0) } # @noRd .sldscDataCheckFrq <- function(frq) { - if (nrow(frq) > 0L && !all(is_in(c("SNP", "MAF"), names(frq)))) { - return("non-empty `frq` must have columns SNP and MAF.") + if (nrow(frq) == 0L) { + return(NULL) } - NULL + cols <- checkNames(names(frq), must.include = c("SNP", "MAF")) + if (isTRUE(cols)) { + return(NULL) + } + str_c("non-empty `frq` must have columns SNP and MAF: ", cols) } # @noRd @@ -77,11 +81,14 @@ setValidity("SldscData", function(object) .validateSldscData(object)) if (length(tr) == 0L) { return(NULL) } - errs <- character(0) - if (is.null(names(tr)) || any(str_length(names(tr)) == 0L, na.rm = TRUE)) { - errs <- c(errs, "`traits` must be a named list (one entry per trait).") - } - c(errs, unlist(compact(map(names(tr), .sldscDataCheckOneTrait, tr = tr)))) + unnamed <- is.null(names(tr)) || + any(str_length(names(tr)) == 0L, na.rm = TRUE) + c( + if (unnamed) { + "`traits` must be a named list (one entry per trait)." + }, + list_c(compact(map(names(tr), .sldscDataCheckOneTrait, tr = tr))) + ) } # @noRd diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index c15228ca5..dd15af59d 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -1,3 +1,6 @@ +#' @include MethodParam.R +NULL + #' @title Causal Inference Pipeline (TWAS-Z + Mendelian Randomization) #' @description Per-region pipeline that pairs QTL-derived weight vectors #' (\code{\link{TwasWeights}} and/or a QTL \code{\link{QtlFineMappingResult}}) @@ -52,48 +55,23 @@ #' supplied, drives the MR computation and (when \code{twasWeights = NULL}) #' the TWAS-Z weights via the SuSiE-style coefficients on each entry's #' \code{topLoci}. -#' @param rsqCutoff Numeric (length 1). When \code{> 0}, performs CV weight -#' selection (ports the legacy \code{twas_pipeline} \code{pick_best_model} + -#' \code{update_twas_method}): per \code{(study, context, trait, gwasStudy)} -#' keep only the method whose \code{cvResult} \code{rsqOption} metric is -#' highest among methods that clear both \code{rsqCutoff} and the -#' \code{rsqPvalCutoff} gate AND that produced a finite TWAS Z (the NA/Inf -#' re-selection); groups where no method clears the cutoffs are dropped. A -#' group whose methods carry no usable \code{cvResult} (the SS-TWAS path) -#' keeps all methods. Needs the \code{twasWeights} \code{cvResult}, so -#' selection is a no-op on the fineMappingResult-only path. Default \code{0} -#' (no selection; score every method). -#' @param rsqPvalCutoff Numeric (length 1). CV-p-value gate for weight selection -#' (ports legacy \code{rsq_pval_cutoff}): a method is eligible only when its -#' \code{cvResult} \code{rsqPvalOption} metric is \code{< rsqPvalCutoff}. -#' Default \code{Inf} (no p-value gate). A finite value activates selection -#' even when \code{rsqCutoff = 0}. -#' @param rsqOption Character. Which \code{cvResult} metric is the "r-squared" -#' used for the cutoff and ranking (ports legacy \code{rsq_option}); typically -#' \code{"rsq"} or \code{"adj_rsq"}. Default \code{"rsq"}. -#' @param rsqPvalOption Character vector of candidate \code{cvResult} metric -#' names for the p-value gate (ports legacy \code{rsq_pval_option}); the first -#' one present in a tuple's metrics is used. Default \code{c("adj_rsq_pval", -#' "pval")}. -#' @param mrPipCutoff Numeric (length 1). PIP threshold for a \code{topLoci} -#' variant to be used as an instrumental variable. Used only when -#' \code{mrMethod = "ivwPerVariant"}. Default \code{0.5}. -#' @param mrMethod One of \code{"ivwPerVariant"} (default) or \code{"csAware"}. -#' The IVW-per-variant method filters topLoci variants by \code{pip > -#' mrPipCutoff} and IVW-pools Wald ratios across variants. The CS-aware method -#' groups variants by credible set (column \code{cs} in topLoci), computes a -#' PIP-weighted composite Wald ratio per CS using \code{mrCpipCutoff} on the -#' per-CS cumulative PIP, then IVW-pools across CSs and reports Cochran's Q + -#' I-squared in the output columns \code{Q}, \code{I2}. -#' @param mrCpipCutoff Numeric (length 1). Cumulative-PIP cutoff for retaining a -#' credible set. Used only when \code{mrMethod = "csAware"}. Default -#' \code{0.5}. -#' @param mrPvalCutoff Numeric (length 1). TWAS-p-value gate for running MR -#' (ports the legacy \code{twas_pipeline} \code{mr_pval_cutoff}): MR is -#' computed for a \code{(qtl tuple, gwas)} only when its \code{twasPval < -#' mrPvalCutoff}; otherwise the MR output columns are \code{NA}. Default -#' \code{1} (no gate; MR runs wherever a \code{fineMappingResult} entry -#' exists). +#' @param weightSelectionArgs How one TWAS method's weights are picked per +#' \code{(study, context, trait, gwasStudy)} tuple, built with +#' \code{\link{WeightSelectionParam}}: \code{cutoff} (minimum +#' cross-validated r-squared, default \code{0}), \code{pvalCutoff} (the +#' CV-p-value gate, default \code{Inf}), and \code{metric} / +#' \code{pvalMetric} naming which \code{cvResult} metrics those two read. +#' Selection runs when \code{cutoff > 0} or \code{pvalCutoff} is finite; +#' it keeps the highest-\code{metric} method among those clearing both +#' gates that also produced a finite TWAS Z. Otherwise every method is +#' carried through. Ports the legacy \code{twas_pipeline} +#' \code{pick_best_model} / \code{update_twas_method}. +#' @param mrArgs How Mendelian randomization is run, built with +#' \code{\link{MrParam}}: \code{method} (\code{"ivwPerVariant"}, the +#' default, or \code{"csAware"}), the PIP threshold that method reads +#' (\code{pipCutoff} or \code{cpipCutoff}), and \code{pvalCutoff}, the +#' TWAS-p-value gate below which MR runs at all (default \code{1}, no +#' gate; otherwise the MR columns are \code{NA}). #' @param combineMethods Optional character vector forwarded to #' \code{\link{combinePValues}} for cross-method combination per #' \code{(qtlStudy, context, trait, gwasStudy)} group. \code{NULL} (default) @@ -102,7 +80,6 @@ #' to the GWAS by (chrom, pos) with ref/alt swaps recognized and the exposure #' effect / weight sign-flipped accordingly; when FALSE, match on exact #' alleles only, so a ref/alt swap is treated as a distinct variant. -#' @param ... Reserved. #' @return A \code{GRanges} as described above. #' @examples #' data(qtlDatasetExample) @@ -116,57 +93,77 @@ causalInferencePipeline <- function( gwasSumStats, twasWeights = NULL, fineMappingResult = NULL, - rsqCutoff = 0, - rsqPvalCutoff = Inf, - rsqOption = "rsq", - rsqPvalOption = c("adj_rsq_pval", "pval"), - mrPipCutoff = 0.5, - mrMethod = c("ivwPerVariant", "csAware"), - mrCpipCutoff = 0.5, - mrPvalCutoff = 1, + weightSelectionArgs = WeightSelectionParam(), + mrArgs = MrParam(), combineMethods = NULL, - alleleFlip = TRUE, - ... + alleleFlip = TRUE ) { - mrMethod <- arg_match(mrMethod) - p <- as.list(environment()) - p$dots <- list(...) - .cipRun(p) + .assertMethodParam( + weightSelectionArgs, + "WeightSelectionParam", + "weightSelection" + ) + .assertMethodParam(mrArgs, "MrParam", "mr") + .cipRun( + gwasSumStats = gwasSumStats, + twasWeights = twasWeights, + fineMappingResult = fineMappingResult, + combineMethods = combineMethods, + weightSelectionArgs = weightSelectionArgs, + alleleFlip = alleleFlip, + mrArgs = mrArgs + ) } -# Orchestrate the causal-inference pipeline over a parameter bundle `p` (from -# as.list(environment())): validate, resolve the QTL work list, apply optional -# CV selection, score every (qtl, gwas) pair, and finalize. +# Orchestrate the causal-inference pipeline: validate, resolve the QTL work +# list, apply optional CV selection, score every (qtl, gwas) pair, finalize. # @noRd -.cipRun <- function(p) { - .cipValidateInputs(p$gwasSumStats, p$twasWeights, p$fineMappingResult) - p$gwasLd <- .cipCheckLdSketches( - p$gwasSumStats, - p$twasWeights, - p$fineMappingResult +.cipRun <- function( + gwasSumStats, + twasWeights, + fineMappingResult, + combineMethods, + weightSelectionArgs, + alleleFlip, + mrArgs +) { + .cipValidateInputs(gwasSumStats, twasWeights, fineMappingResult) + gwasLd <- .cipCheckLdSketches( + gwasSumStats, + twasWeights, + fineMappingResult + ) + allRows <- .cipResolveWorkList(twasWeights, fineMappingResult) + sel <- .cipCvSelection( + qtlRows = allRows, + twasWeights = twasWeights, + weightSelectionArgs = weightSelectionArgs ) - p$qtlRows <- .cipResolveWorkList(p$twasWeights, p$fineMappingResult) - sel <- .cipCvSelection(p) - p$qtlRows <- sel$qtlRows + qtlRows <- sel$qtlRows outRows <- list_flatten(map( - seq_len(nrow(p$qtlRows)), + seq_len(nrow(qtlRows)), .cipScoreQtlTuple, - p = p + qtlRows = qtlRows, + twasWeights = twasWeights, + fineMappingResult = fineMappingResult, + gwasSumStats = gwasSumStats, + gwasLd = gwasLd, + alleleFlip = alleleFlip, + mrArgs = mrArgs )) if (length(outRows) == 0L) { abort( "causalInferencePipeline: no (qtl, gwas) tuples produced a result." ) } - .cipFinalize(outRows, sel, p$combineMethods) + .cipFinalize(outRows, sel, combineMethods) } # Validate the object classes + QC state of the pipeline inputs. # @noRd +#' @importFrom checkmate assertClass checkClass .cipValidateInputs <- function(gwasSumStats, twasWeights, fineMappingResult) { - if (!methods::is(gwasSumStats, "GwasSumStats")) { - abort("`gwasSumStats` must be a GwasSumStats object.") - } + assertClass(gwasSumStats, "GwasSumStats") if (length(getQcInfo(gwasSumStats)) == 0L) { msg <- glue( "causalInferencePipeline: gwasSumStats has no QC record ", @@ -181,17 +178,18 @@ causalInferencePipeline <- function( ) abort(msg) } - if (!is.null(twasWeights) && !methods::is(twasWeights, "TwasWeights")) { - abort("`twasWeights` must be a TwasWeights object or NULL.") - } - if ( - !is.null(fineMappingResult) && - !methods::is(fineMappingResult, "QtlFineMappingResult") - ) { + assertClass(twasWeights, "TwasWeights", null.ok = TRUE) + # Composed rather than asserted: rejecting the GWAS-side class here is + # deliberate, and checkClass alone cannot say so. + res <- checkClass( + fineMappingResult, + "QtlFineMappingResult", + null.ok = TRUE + ) + if (!isTRUE(res)) { msg <- glue( - "`fineMappingResult` must be a QtlFineMappingResult or NULL ", - "(causalInferencePipeline does not accept GWAS-side fine ", - "mapping for the QTL slot)." + "`fineMappingResult` {res} (causalInferencePipeline does not ", + "accept GWAS-side fine mapping for the QTL slot)." ) abort(msg) } @@ -232,50 +230,67 @@ causalInferencePipeline <- function( ) abort(msg) } - qtlRows$useFmrForWeights <- is.null(twasWeights) - qtlRows + mutate(qtlRows, useFmrForWeights = is.null(twasWeights)) +} + +# CV R-squared keyed by the (study, context, trait, method) tuple. The +# separator is \\r because it cannot occur in any of the four identifiers. +# @noRd +.cipRsqLookup <- function(metricTab) { + set_names( + metricTab$rsq, + str_c( + metricTab$qtlStudy, + metricTab$context, + metricTab$trait, + metricTab$method, + sep = "\r" + ) + ) } # Optional CV weight selection (legacy pick_best_model + update_twas_method): # filter to eligible methods now, deferring the final best-method pick to after # the TWAS Z. Returns list(qtlRows, rsqLookup, selectionActive). # @noRd -.cipCvSelection <- function(p) { - selectionActive <- !is.null(p$twasWeights) && - (p$rsqCutoff > 0 || is.finite(p$rsqPvalCutoff)) +.cipCvSelection <- function( + qtlRows, + twasWeights, + weightSelectionArgs +) { + # The bundle's terminal. .cipMethodMetrics / .cipEligibleRowsIn below + # take plain scalars, so it is unrolled once, here. + rsqCutoff <- weightSelectionArgs$cutoff + rsqPvalCutoff <- weightSelectionArgs$pvalCutoff + rsqOption <- weightSelectionArgs$metric + rsqPvalOption <- weightSelectionArgs$pvalMetric + selectionActive <- !is.null(twasWeights) && + (rsqCutoff > 0 || is.finite(rsqPvalCutoff)) if (!selectionActive) { return(list( - qtlRows = p$qtlRows, + qtlRows = qtlRows, rsqLookup = NULL, selectionActive = FALSE )) } metricTab <- .cipMethodMetrics( - p$qtlRows, - p$twasWeights, - p$rsqOption, - p$rsqPvalOption - ) - rsqLookup <- set_names( - metricTab$rsq, - str_c( - metricTab$qtlStudy, - metricTab$context, - metricTab$trait, - metricTab$method, - sep = "\r" - ) + qtlRows, + twasWeights, + rsqOption, + rsqPvalOption ) + rsqLookup <- .cipRsqLookup(metricTab) qtlRows <- .cipFilterEligibleMethods( - p$qtlRows, + qtlRows, metricTab, - p$rsqCutoff, - p$rsqPvalCutoff + rsqCutoff, + rsqPvalCutoff ) if (nrow(qtlRows) == 0L) { msg <- glue( "causalInferencePipeline: every QTL tuple was filtered out by ", - "rsqCutoff = {p$rsqCutoff} / rsqPvalCutoff = {p$rsqPvalCutoff} ", + "WeightSelectionParam(cutoff = {rsqCutoff}, ", + "pvalCutoff = {rsqPvalCutoff}) ", "(no method cleared the CV cutoffs)." ) abort(msg) @@ -286,43 +301,51 @@ causalInferencePipeline <- function( # Score one QTL tuple against every GWAS study -> a list of result records # (empty when the tuple has no usable weights). # @noRd -.cipScoreQtlTuple <- function(qi, p) { - qStudy <- p$qtlRows$qtlStudy[[qi]] - qContext <- p$qtlRows$context[[qi]] - qTrait <- p$qtlRows$trait[[qi]] - qMethod <- p$qtlRows$method[[qi]] +.cipScoreQtlTuple <- function( + qi, + qtlRows, + twasWeights, + fineMappingResult, + gwasSumStats, + gwasLd, + alleleFlip, + mrArgs +) { + tuple <- list( + qStudy = qtlRows$qtlStudy[[qi]], + qContext = qtlRows$context[[qi]], + qTrait = qtlRows$trait[[qi]], + qMethod = qtlRows$method[[qi]] + ) weightsInfo <- .cipExtractWeights( - twasWeights = p$twasWeights, - fineMappingResult = p$fineMappingResult, - study = qStudy, - context = qContext, - trait = qTrait, - method = qMethod, - useFmr = p$qtlRows$useFmrForWeights[[qi]] + twasWeights = twasWeights, + fineMappingResult = fineMappingResult, + study = tuple$qStudy, + context = tuple$qContext, + trait = tuple$qTrait, + method = tuple$qMethod, + useFmr = qtlRows$useFmrForWeights[[qi]] ) if (is.null(weightsInfo)) { return(list()) } fmrEntry <- .cipResolveFmrEntry( - p$fineMappingResult, - qStudy, - qContext, - qTrait, - qMethod - ) - tuple <- list( - qStudy = qStudy, - qContext = qContext, - qTrait = qTrait, - qMethod = qMethod + fineMappingResult, + tuple$qStudy, + tuple$qContext, + tuple$qTrait, + tuple$qMethod ) compact(map( - seq_len(nrow(p$gwasSumStats)), + seq_len(nrow(gwasSumStats)), .cipScoreGwasPair, tuple = tuple, weightsInfo = weightsInfo, fmrEntry = fmrEntry, - p = p + gwasSumStats = gwasSumStats, + gwasLd = gwasLd, + alleleFlip = alleleFlip, + mrArgs = mrArgs )) } @@ -352,10 +375,19 @@ causalInferencePipeline <- function( # Score one (qtl tuple, gwas study) pair -> a result record, or NULL when the # TWAS Z cannot be computed (too little overlap). # @noRd -.cipScoreGwasPair <- function(gi, tuple, weightsInfo, fmrEntry, p) { - gStudy <- as.character(p$gwasSumStats$study)[[gi]] +.cipScoreGwasPair <- function( + gi, + tuple, + weightsInfo, + fmrEntry, + gwasSumStats, + gwasLd, + alleleFlip, + mrArgs +) { + gStudy <- as.character(gwasSumStats$study)[[gi]] gdf <- getSumStatsDf( - p$gwasSumStats, + gwasSumStats, study = gStudy, require = c("SNP", "Z") ) @@ -363,14 +395,20 @@ causalInferencePipeline <- function( weights = weightsInfo$weights, variantIds = weightsInfo$variantIds, gwasDf = gdf, - gwasLd = p$gwasLd, - alleleFlip = p$alleleFlip, + gwasLd = gwasLd, + alleleFlip = alleleFlip, label = .cipPairLabel(tuple, gStudy) ) if (is.null(twasOut)) { return(NULL) } - mrOut <- .cipRunMr(fmrEntry, gdf, twasOut, p) + mrOut <- .cipRunMr( + fmrEntry, + gdf, + twasOut, + alleleFlip = alleleFlip, + mrArgs = mrArgs + ) .cipResultRow(tuple, gStudy, twasOut, mrOut) } @@ -387,25 +425,36 @@ causalInferencePipeline <- function( # Run MR for a pair, gated on the TWAS p-value (mrPvalCutoff >= 1 disables the # gate) and the presence of a fine-mapping entry. # @noRd -.cipRunMr <- function(fmrEntry, gdf, twasOut, p) { - mrGateOpen <- p$mrPvalCutoff >= 1 || - (!is.na(twasOut$pval) && twasOut$pval < p$mrPvalCutoff) +.cipRunMr <- function( + fmrEntry, + gdf, + twasOut, + alleleFlip, + mrArgs +) { + # The bundle's terminal; the MR engines below take plain scalars. + mrMethod <- mrArgs$method + mrPipCutoff <- mrArgs$pipCutoff + mrCpipCutoff <- mrArgs$cpipCutoff + mrPvalCutoff <- mrArgs$pvalCutoff + mrGateOpen <- mrPvalCutoff >= 1 || + (!is.na(twasOut$pval) && twasOut$pval < mrPvalCutoff) if (is.null(fmrEntry) || !mrGateOpen) { return(.cipEmptyMr()) } - if (p$mrMethod == "csAware") { + if (mrMethod == "csAware") { .cipComputeMrCsAware( fmrEntry = fmrEntry, gwasDf = gdf, - cpipCutoff = p$mrCpipCutoff, - alleleFlip = p$alleleFlip + cpipCutoff = mrCpipCutoff, + alleleFlip = alleleFlip ) } else { .cipComputeMr( fmrEntry = fmrEntry, gwasDf = gdf, - pipCutoff = p$mrPipCutoff, - alleleFlip = p$alleleFlip + pipCutoff = mrPipCutoff, + alleleFlip = alleleFlip ) } } @@ -452,17 +501,21 @@ causalInferencePipeline <- function( # GRanges, and (optionally) combine across methods. # @noRd .cipFinalize <- function(outRows, sel, combineMethods) { - resultDf <- .cipRowsToDf(outRows) + allRows <- .cipRowsToDf(outRows) # Final best-method pick + NA/Inf re-selection (legacy update_twas_method): # per (qtlStudy, context, trait, gwasStudy) keep the highest-rsqOption # eligible method whose TWAS Z is finite, falling back to the top-rsq method # when none is finite. SS-TWAS groups (no usable rsq) keep all methods. - if (sel$selectionActive) { - resultDf <- .cipSelectBestMethod(resultDf, sel$rsqLookup) + resultDf <- if (sel$selectionActive) { + .cipSelectBestMethod(allRows, sel$rsqLookup) + } else { + allRows } - out <- .cipDfToGranges(resultDf) - if (!is.null(combineMethods)) { - out <- .cipCombineAcrossMethods(out, methods = combineMethods) + perMethod <- .cipDfToGranges(resultDf) + out <- if (is.null(combineMethods)) { + perMethod + } else { + .cipCombineAcrossMethods(perMethod, methods = combineMethods) } out } @@ -511,8 +564,9 @@ causalInferencePipeline <- function( # metrics vector / data frame is tolerated too. `which` is a vector of candidate # metric names; the first present is used. Returns NA when no usable metric. # @noRd +#' @importFrom rlang try_fetch .cipCvMetric <- function(twasWeights, study, context, trait, method, which) { - perf <- tryCatch( + perf <- try_fetch( getCvResult( twasWeights, study = study, @@ -520,7 +574,7 @@ causalInferencePipeline <- function( trait = trait, method = method ), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(perf)) { return(NA_real_) @@ -585,24 +639,49 @@ causalInferencePipeline <- function( metricTab$trait, sep = "\r" ) - keep <- logical(nrow(qtlRows)) - pvalGate <- is.finite(rsqPvalCutoff) - for (g in unique(grp)) { - idx <- which(grp == g) - rsq <- metricTab$rsq[idx] - if (all(is.na(rsq))) { - keep[idx] <- TRUE - next - } # SS-TWAS: keep all - elig <- !is.na(rsq) & rsq >= rsqCutoff - if (pvalGate) { - elig <- elig & - !is.na(metricTab$pval[idx]) & - metricTab$pval[idx] < rsqPvalCutoff - } - keep[idx[elig]] <- TRUE + kept <- .cipConcatInt(map( + unique(grp), + .cipEligibleRowsIn, + grp = grp, + metricTab = metricTab, + rsqCutoff = rsqCutoff, + rsqPvalCutoff = rsqPvalCutoff + )) + filter(qtlRows, .cipRowMask(kept, nrow(qtlRows))) +} + +# @noRd +.cipConcatInt <- function(pieces) { + if (length(pieces) == 0L) { + return(integer(0)) } - filter(qtlRows, keep) + list_c(pieces) +} + +# A logical mask of length `n` that is TRUE at `at`. +# @noRd +.cipRowMask <- function(at, n) { + replace(logical(n), at, TRUE) +} + +# The rows of group `g` that clear the R^2 (and optional p-value) gate. A +# group with no usable R^2 at all is SS-TWAS, which keeps every row. +# @noRd +.cipEligibleRowsIn <- function(g, grp, metricTab, rsqCutoff, rsqPvalCutoff) { + idx <- which(grp == g) + rsq <- metricTab$rsq[idx] + if (all(is.na(rsq))) { + return(idx) + } + byRsq <- !is.na(rsq) & rsq >= rsqCutoff + elig <- if (!is.finite(rsqPvalCutoff)) { + byRsq + } else { + byRsq & + !is.na(metricTab$pval[idx]) & + metricTab$pval[idx] < rsqPvalCutoff + } + idx[elig] } # Final best-method pick + NA/Inf re-selection (legacy update_twas_method): per @@ -618,21 +697,30 @@ causalInferencePipeline <- function( key <- str_c(df$qtlStudy, df$context, df$trait, df$method, sep = "\r") rsq <- unname(rsqLookup[key]) grp <- str_c(df$qtlStudy, df$context, df$trait, df$gwasStudy, sep = "\r") - keepRow <- logical(nrow(df)) - for (g in unique(grp)) { - idx <- which(grp == g) - r <- rsq[idx] - if (all(is.na(r))) { - keepRow[idx] <- TRUE - next - } # SS-TWAS: keep all - ord <- idx[order(r, decreasing = TRUE)] # NA sorts last - z <- suppressWarnings(as.numeric(df$twasZ[ord])) - fin <- which(is.finite(z)) - sel <- if (length(fin) > 0L) ord[[fin[[1L]]]] else ord[[1L]] - keepRow[sel] <- TRUE - } - filter(df, keepRow) + kept <- .cipConcatInt(map( + unique(grp), + .cipBestRowsIn, + grp = grp, + df = df, + rsq = rsq + )) + filter(df, .cipRowMask(kept, nrow(df))) +} + +# The row group `g` contributes: the highest-R^2 method whose twasZ is finite, +# else the highest-R^2 one. A group with no usable R^2 is SS-TWAS and keeps +# every row. +# @noRd +.cipBestRowsIn <- function(g, grp, df, rsq) { + idx <- which(grp == g) + r <- rsq[idx] + if (all(is.na(r))) { + return(idx) + } + ord <- idx[order(r, decreasing = TRUE)] # NA sorts last + z <- suppressWarnings(as.numeric(df$twasZ[ord])) + fin <- which(is.finite(z)) + if (length(fin) > 0L) ord[[fin[[1L]]]] else ord[[1L]] } .cipFmrHasTuple <- function(fmr, study, context, trait, method) { @@ -1080,8 +1168,8 @@ causalInferencePipeline <- function( # returns the pooled effect, its SE (1/sqrt(sum w)), two-tailed p-value, # Cochran's Q, and the number pooled (n = 0 when nothing is poolable). .ivwPool <- function(effect, se) { - w <- 1 / se^2 - ok <- is.finite(w) & w > 0 + invVar <- 1 / se^2 + ok <- is.finite(invVar) & invVar > 0 if (!any(ok)) { return(list( effect = NA_real_, @@ -1092,7 +1180,7 @@ causalInferencePipeline <- function( )) } effect <- effect[ok] - w <- w[ok] + w <- invVar[ok] metaEff <- sum(w * effect) / sum(w) metaSe <- 1 / sqrt(sum(w)) list( @@ -1109,10 +1197,15 @@ causalInferencePipeline <- function( # falls back to any column whose name starts with "cs" (e.g. cs_0.95). .cipTlCols <- function(tl) { cn <- colnames(tl) - cs <- intersect("cs", cn) - if (length(cs) == 0L) { - csCand <- cn[str_detect(cn, "^cs")] - if (length(csCand) > 0L) cs <- csCand[[1L]] + exact <- intersect("cs", cn) + # No bare `cs` column: fall back to the first cs_ variant. + csCand <- cn[str_detect(cn, "^cs")] + cs <- if (length(exact) > 0L) { + exact + } else if (length(csCand) > 0L) { + csCand[[1L]] + } else { + exact } list( pip = intersect(c("pip", "PIP"), cn), @@ -1156,8 +1249,7 @@ causalInferencePipeline <- function( "nCs" )) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcols) - gr + S4Vectors::`mcols<-`(gr, value = S4Vectors::DataFrame(mcols)) } # Combine TWAS p-values across method for each (qtlStudy, context, @@ -1165,37 +1257,64 @@ causalInferencePipeline <- function( # combined p-value and methodName = "combined.". Uses # combinePValues() with the cross-method correlation set to the identity # (we have no cross-method covariance available downstream). +# @noRd +.cipConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# One combined row: the group's first row re-stamped with the combined +# p-value for method `m`. The per-method statistics do not carry over, so +# they are blanked rather than inherited. +# @noRd +.cipCombinedRow <- function(m, mc, rows, cp) { + mutate( + slice(mc, rows[[1L]]), + method = str_c("combined.", m), + twasZ = NA_real_, + twasPval = as.numeric(cp$results[[m]]$pval), + waldRatio = NA_real_, + waldRatioSe = NA_real_, + mrPval = NA_real_, + nIV = NA_integer_ + ) +} + +# One group's combined rows, or none when it holds a single method (nothing +# to combine across). +# @noRd +.cipCombinedRowsFor <- function(rows, mc, methods) { + if (length(rows) < 2L) { + return(list()) + } + cp <- combinePValues( + pvals = as.numeric(mc$twasPval[rows]), + zScores = as.numeric(mc$twasZ[rows]), + methods = methods + ) + map(methods, .cipCombinedRow, mc = mc, rows = rows, cp = cp) +} + .cipCombineAcrossMethods <- function(gr, methods) { mc <- as_tibble(as.data.frame(S4Vectors::mcols(gr))) key <- str_c(mc$qtlStudy, mc$context, mc$trait, mc$gwasStudy, sep = "||") groups <- split(seq_len(nrow(mc)), key) - extras <- list() - for (gkey in names(groups)) { - rows <- groups[[gkey]] - if (length(rows) < 2L) { - next - } - pvals <- as.numeric(mc$twasPval[rows]) - zvec <- as.numeric(mc$twasZ[rows]) - cp <- combinePValues(pvals = pvals, zScores = zvec, methods = methods) - for (m in methods) { - newRow <- slice(mc, rows[[1L]]) - newRow$method <- str_c("combined.", m) - newRow$twasZ <- NA_real_ - newRow$twasPval <- as.numeric(cp$results[[m]]$pval) - newRow$waldRatio <- NA_real_ - newRow$waldRatioSe <- NA_real_ - newRow$mrPval <- NA_real_ - newRow$nIV <- NA_integer_ - extras[[length(extras) + 1L]] <- newRow - } - } + extras <- .cipConcat(map( + groups, + .cipCombinedRowsFor, + mc = mc, + methods = methods + )) if (length(extras) == 0L) { return(gr) } newMcs <- bind_rows(extras) - newGr <- gr[rep(1L, nrow(newMcs))] - S4Vectors::mcols(newGr) <- S4Vectors::DataFrame(newMcs) + newGr <- S4Vectors::`mcols<-`( + gr[rep(1L, nrow(newMcs))], + value = S4Vectors::DataFrame(newMcs) + ) c(gr, newGr) } @@ -1235,6 +1354,7 @@ causalInferencePipeline <- function( # Row-align V to the weights (by name when available, else positionally). # @noRd +#' @importFrom checkmate assertMatrix .twasZAlignV <- function(V, rn, nW) { if (!is.null(rownames(V)) && !is.null(rn)) { idx <- match(rn, rownames(V)) @@ -1247,11 +1367,7 @@ causalInferencePipeline <- function( } return(V[idx, , drop = FALSE]) } - if (nrow(V) != nW) { - abort( - "twasZ: positional alignment requires nrow(V) == nrow(weights)." - ) - } + assertMatrix(V, nrows = nW, .var.name = "V (positional alignment)") V } @@ -1270,6 +1386,7 @@ causalInferencePipeline <- function( # Symmetric-align R to the weights (by name when available, else positionally). # @noRd +#' @importFrom checkmate assertMatrix .twasZAlignR <- function(R, rn, nW) { if (!is.null(rownames(R)) && !is.null(rn)) { idx <- match(rn, rownames(R)) @@ -1282,11 +1399,7 @@ causalInferencePipeline <- function( } return(R[idx, idx, drop = FALSE]) } - if (nrow(R) != nW) { - abort( - "twasZ: positional alignment requires nrow(R) == nrow(weights)." - ) - } + assertMatrix(R, nrows = nW, .var.name = "R (positional alignment)") R } @@ -1347,6 +1460,7 @@ causalInferencePipeline <- function( #' w <- setNames(rnorm(20) * 0.1, colnames(X)) #' twasZ(weights = w, z = rnorm(20), R = cor(X)) #' @export +#' @importFrom checkmate assertCharacter assertCount twasZ <- function( weights, z, @@ -1357,6 +1471,8 @@ twasZ <- function( nSketch = NULL, combineMethods = NULL ) { + assertCount(nSketch, positive = TRUE, null.ok = TRUE) + assertCharacter(combineMethods, null.ok = TRUE) weights <- .twasZPrepWeights(weights, z) covY <- .twasZCovY( weights = weights, @@ -1370,8 +1486,10 @@ twasZ <- function( stats <- as.numeric(crossprod(weights, as.numeric(z))) zVec <- stats / ySd pVec <- .zToPvalue(zVec) - zMatrix <- cbind(Z = zVec, pval = pVec) - rownames(zMatrix) <- colnames(weights) + zMatrix <- `rownames<-`( + cbind(Z = zVec, pval = pVec), + colnames(weights) + ) combined <- .twasZCombine( combineMethods, ncol(weights), @@ -1387,6 +1505,7 @@ twasZ <- function( # Coerce a weight vector to a one-column matrix, validate the class / dims, and # default the column names. # @noRd +#' @importFrom checkmate assertMatrix .twasZPrepWeights <- function(weights, z) { if (is.numeric(weights) && is.null(dim(weights))) { nm <- if (!is.null(names(weights))) names(weights) else NULL @@ -1395,13 +1514,13 @@ twasZ <- function( if (!is.matrix(weights)) { abort("`weights` must be a numeric vector or a matrix.") } - if (is.null(colnames(weights))) { - colnames(weights) <- str_c("method", seq_len(ncol(weights))) - } - if (nrow(weights) != length(z)) { - abort("nrow(weights) must equal length(z).") + named <- if (is.null(colnames(weights))) { + `colnames<-`(weights, str_c("method", seq_len(ncol(weights)))) + } else { + weights } - weights + assertMatrix(named, nrows = length(z), .var.name = "weights") + named } # Optional cross-tuple p-value combination via combinePValues (K == 1 uses the @@ -1415,13 +1534,14 @@ twasZ <- function( if (K == 1L) { return(.twasZCombineSingle(combineMethods, pVec, zMatrix)) } - sig <- covY / tcrossprod(ySd, ySd) - rownames(sig) <- colnames(sig) <- rownames(zMatrix) - names(pVec) <- rownames(zMatrix) - names(zVec) <- rownames(zMatrix) + methodNames <- rownames(zMatrix) + sig <- `dimnames<-`( + covY / tcrossprod(ySd, ySd), + list(methodNames, methodNames) + ) combinePValues( - pvals = pVec, - zScores = zVec, + pvals = set_names(pVec, methodNames), + zScores = set_names(zVec, methodNames), methods = combineMethods, R = sig ) @@ -1472,3 +1592,123 @@ twasZ <- function( .cipSingleMethodPval <- function(m, pVec) { list(method = m, pval = as.numeric(pVec[[1L]])) } + +#' @rdname WeightSelectionParam +#' @aliases WeightSelectionParam-class +#' @exportClass WeightSelectionParam +setClass( + "WeightSelectionParam", + contains = "MethodParam", + slots = c( + cutoff = "numeric", + pvalCutoff = "numeric", + metric = "character", + pvalMetric = "character" + ) +) + +#' @title TWAS Weight-Selection Settings +#' @description How \code{\link{causalInferencePipeline}} picks which TWAS +#' method's weights to use for each \code{(study, context, trait, +#' gwasStudy)} tuple, from the cross-validation metrics on the +#' \code{cvResult}. Selection runs when \code{cutoff > 0} or +#' \code{pvalCutoff} is finite; otherwise every method is carried through. +#' @param cutoff Numeric. Minimum cross-validated r-squared a method must +#' reach to be eligible. Default \code{0} (no r-squared gate). +#' @param pvalCutoff Numeric. A method is eligible only when its +#' \code{cvResult} p-value metric is below this. Default \code{Inf} (no +#' gate). A finite value activates selection even when \code{cutoff = 0}. +#' @param metric Character. Which \code{cvResult} metric is the r-squared +#' used for the cutoff and for ranking; typically \code{"rsq"} or +#' \code{"adj_rsq"}. Default \code{"rsq"}. +#' @param pvalMetric Character vector of candidate \code{cvResult} metric +#' names for the p-value gate; the first one present in a tuple's metrics +#' is used. Default \code{c("adj_rsq_pval", "pval")}. +#' @return A \code{WeightSelectionParam} object, a \code{\link{MethodParam}}. +#' @examples +#' WeightSelectionParam(cutoff = 0.01, metric = "adj_rsq") +#' @export +WeightSelectionParam <- function( + cutoff = 0, + pvalCutoff = Inf, + metric = "rsq", + pvalMetric = c("adj_rsq_pval", "pval") +) { + new( + "WeightSelectionParam", + cutoff = cutoff, + pvalCutoff = pvalCutoff, + metric = metric, + pvalMetric = pvalMetric + ) +} + +#' @rdname MrParam +#' @aliases MrParam-class +#' @exportClass MrParam +setClass( + "MrParam", + contains = "MethodParam", + slots = c( + method = "character", + pipCutoff = "numeric", + cpipCutoff = "numeric", + pvalCutoff = "numeric" + ) +) + +#' @title Mendelian-Randomization Settings +#' @description How \code{\link{causalInferencePipeline}} runs MR from a +#' tuple's \code{topLoci} table. +#' @param method \code{"ivwPerVariant"} (default) filters \code{topLoci} +#' variants by \code{pip > pipCutoff} and IVW-pools their Wald ratios. +#' \code{"csAware"} groups variants by credible set and computes a +#' PIP-weighted composite Wald ratio per set, using \code{cpipCutoff}. +#' @param pipCutoff Numeric. PIP threshold for a variant to be used as an +#' instrument. Default \code{0.5}. Used only by \code{"ivwPerVariant"}. +#' @param cpipCutoff Numeric. Cumulative-PIP cutoff for retaining a credible +#' set. Default \code{0.5}. Used only by \code{"csAware"}. +#' @param pvalCutoff Numeric. MR runs for a \code{(qtl tuple, gwas)} pair +#' only when its \code{twasPval} is below this; otherwise the MR columns +#' are \code{NA}. Default \code{1} (no gate). +#' @return A \code{MrParam} object, a \code{\link{MethodParam}}. +#' @examples +#' MrParam(method = "csAware", cpipCutoff = 0.8) +#' @export +MrParam <- function( + method = c("ivwPerVariant", "csAware"), + pipCutoff = 0.5, + cpipCutoff = 0.5, + pvalCutoff = 1 +) { + method <- arg_match(method) + .mrAssertApplicable(method, pipCutoff, cpipCutoff) + new( + "MrParam", + method = method, + pipCutoff = pipCutoff, + cpipCutoff = cpipCutoff, + pvalCutoff = pvalCutoff + ) +} + +# Each method reads exactly one of the two PIP cutoffs. Setting the other to +# something other than its default is a request that would be ignored, so it +# fails here rather than silently doing nothing. +# @noRd +.mrAssertApplicable <- function(method, pipCutoff, cpipCutoff) { + unused <- if (method == "csAware") { + if (!isTRUE(all.equal(pipCutoff, 0.5))) "pipCutoff" else NULL + } else { + if (!isTRUE(all.equal(cpipCutoff, 0.5))) "cpipCutoff" else NULL + } + if (is.null(unused)) { + return(invisible(NULL)) + } + other <- if (method == "csAware") "cpipCutoff" else "pipCutoff" + abort(glue( + "MrParam: `{unused}` is not read by method = \"{method}\"; that ", + "method uses `{other}`. Set the one its method reads, or change ", + "`method`." + )) +} diff --git a/R/colocPipeline.R b/R/colocPipeline.R index 8a21f9ec8..f07d8c6b6 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -1,3 +1,232 @@ +# fastenloc refuses to do both: given explicit p1/p2/p12 it prints +# "Applying user-specified colocalization priors, skipping enrichment +# analysis" and skips the enrichment step. pecotmr errors instead of choosing +# silently -- the silence is what made the two parameterisations easy to +# confuse in the first place. +# @noRd +#' @include MethodParam.R +#' @include ld.R +#' @include fineMappingPipeline.R +NULL + +.colocRefusePriorsWithEnrichment <- function(priors, enrichment, wasDefault) { + if (is.null(enrichment) || wasDefault) { + return(invisible(NULL)) + } + abort(glue( + "colocPipeline: `priors` and `enrichment` cannot both be given. ", + "With an enrichment table the priors are enloc's, derived from the ", + "genome-wide QTL results by qtlEnrichmentPipeline(); supplying them ", + "here as well would mean scoring with one set and enriching with ", + "another. Drop `priors`, or drop `enrichment` to use your own." + )) +} + +# The three argument groups, checked in one place so the pipeline body does +# not open with three near-identical lines. +# @noRd +.colocAssertGroups <- function(priors, lbfFilterArgs, methodArgs) { + .assertMethodParam(priors, "ColocPriorParam", "priors") + .assertMethodParam(lbfFilterArgs, "ColocLbfFilterParam", "lbfFilter") + .assertMethodOptions(methodArgs, "ColocOptions", "methodArgs") +} + +# The coloc.bf_bf option list: the priors pecotmr owns, injected under +# coloc's names, plus whatever else the caller asked for. The priors are also +# read by the enrichment adjustment, so they must agree -- setting one in +# `methodArgs` too is refused rather than silently resolved. +# @noRd +.colocEngineArgs <- function(methodArgs, priors) { + user <- as.list(methodArgs) + clash <- intersect(names(user), c("p1", "p2", "p12")) + if (length(clash) > 0L) { + abort(glue( + "colocPipeline: {str_flatten(clash, ', ')} ", + "{if (length(clash) == 1L) 'is' else 'are'} set through ", + "`priors`, which the enrichment adjustment reads as well, so ", + "{if (length(clash) == 1L) 'it' else 'they'} cannot also be ", + "given in `methodArgs`." + )) + } + user +} + +#' @rdname ColocPriorParam +#' @aliases ColocPriorParam-class +#' @exportClass ColocPriorParam +setClass( + "ColocPriorParam", + contains = "MethodParam", + slots = c( + p1 = "numeric", + p2 = "numeric", + p12 = "numeric" + ) +) + +#' @title Prior Probabilities For Colocalisation +#' @description The per-variant prior probabilities coloc scores with, all +#' three forwarded to \code{coloc::coloc.bf_bf}. +#' +#' These describe the baseline analysis only. When \code{enrichment} is +#' supplied to \code{\link{colocPipeline}} the priors are \emph{derived} +#' from the enrichment estimate instead, the way enloc derives them, and +#' supplying both is an error rather than a silent precedence rule. +#' @param p1 Prior probability a variant is causal for the QTL trait. +#' Default \code{1e-4}. +#' @param p2 Prior probability a variant is causal for the GWAS trait. +#' Default \code{1e-4}. +#' @param p12 Prior probability a variant is causal for both. Default +#' \code{5e-6}. +#' @return A \code{ColocPriorParam} object, a \code{\link{MethodParam}}. +#' @examples +#' ColocPriorParam(p12 = 1e-5) +#' @export +ColocPriorParam <- function( + p1 = 1e-4, + p2 = 1e-4, + p12 = 5e-6 +) { + new( + "ColocPriorParam", + p1 = p1, + p2 = p2, + p12 = p12 + ) +} + +#' @rdname ColocLbfFilterParam +#' @aliases ColocLbfFilterParam-class +#' @exportClass ColocLbfFilterParam +setClass( + "ColocLbfFilterParam", + contains = "MethodParam", + slots = c( + filterLbfCs = "logical", + secondary = "numeric_OR_NULL", + concentration = "numeric", + priorTol = "numeric" + ) +) + +#' @title Credible-Set Filtering For Colocalisation +#' @description Whether and how to restrict each fine-mapping result to its +#' credible sets before scoring, using the log Bayes factors. +#' @param filterLbfCs Logical. Restrict to credible-set variants. Default +#' \code{FALSE}. +#' @param secondary Optional secondary coverage levels used when selecting +#' credible sets. \code{NULL} (default) uses the primary sets only. +#' @param concentration Minimum share of the credible set's posterior mass a +#' variant must carry to be kept. Default \code{0.5}. +#' @param priorTol Prior-variance cutoff for the default filter: effects with +#' \code{V <= priorTol} are dropped. Default \code{1e-9}. This is the +#' default filter's own parameter, which is why it lives here rather than +#' beside it --- \code{filterLbfCs} and \code{secondary} select a +#' different filter, and then it does not apply. +#' @return A \code{ColocLbfFilterParam} object, a \code{\link{MethodParam}}. +#' @examples +#' ColocLbfFilterParam(filterLbfCs = TRUE) +#' @export +ColocLbfFilterParam <- function( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5, + priorTol = 1e-9 +) { + new( + "ColocLbfFilterParam", + filterLbfCs = filterLbfCs, + secondary = secondary, + concentration = concentration, + priorTol = priorTol + ) +} + +# `methods` takes either an engine name or a FineMappingMethodsParam() +# record carrying that engine's own options, exactly as fineMappingPipeline() +# does -- this bundle is forwarded there whole. Now exact: it was +# `MethodOptions` only while the aggregator was one, so any engine's +# argument bag was accepted here. +setClassUnion( + "MethodSelection", + c("character", "FineMappingMethodsParam") +) + +#' @rdname GwasFineMappingParam +#' @aliases GwasFineMappingParam-class +#' @exportClass GwasFineMappingParam +setClass( + "GwasFineMappingParam", + contains = "MethodParam", + slots = c( + methods = "MethodSelection", + credibleSetArgs = "CredibleSetParam", + rssArgs = "SusieRssParam", + panelFilterArgs = "PanelFilterParam", + addSusieInf = "logical", + fitRetention = "character" + ) +) + +#' @title Inline GWAS Fine-Mapping Settings +#' @description How \code{\link{colocPipeline}} fine-maps \code{gwasInput} +#' when it is summary statistics rather than an existing fine-mapping +#' result. Every field is forwarded to +#' \code{\link{fineMappingPipeline}}; the settings that pipeline exposes +#' but that cannot apply here are deliberately absent: +#' \code{fineMappingResult} (the pipeline is being asked to produce one), +#' \code{crossValidation} (refused on summary statistics) and +#' \code{residualization} (nothing to regress out). +#' +#' The whole bundle is inert when \code{gwasInput} is already a +#' fine-mapping result, since no fit is run. +#' @param methods Fine-mapping methods, as a character vector or a +#' \code{\link{FineMappingMethodsParam}} record. Default \code{"susie"}. +#' @param credibleSetArgs How credible sets are built, built with +#' \code{\link{CredibleSetParam}}. \code{coverage} and \code{L} matter +#' most here: they decide the sets whose log Bayes factors coloc scores, so +#' leaving them at the defaults while the QTL side used something else +#' compares two differently-built sets. +#' @param rssArgs The summary-statistics solver, built with +#' \code{\link{SusieRssParam}} --- \code{serFallback}, \code{rMismatch}, +#' \code{rFinite} and the \code{susie_rss} control list. What a GWAS block +#' with an imperfect LD panel needs. +#' @param panelFilterArgs LD-reference-panel filters, built with +#' \code{\link{PanelFilterParam}}. +#' @param addSusieInf Logical. Chain a SuSiE-inf fit, when \code{methods} +#' asks for \code{susieInf} alongside \code{susie}. Default \code{TRUE}. +#' @param fitRetention How much of each fit is kept: \code{"slim"} (default) +#' or \code{"full"}. Only observable when +#' \code{returnGwasFineMapping = TRUE}, which is when the fine-mapping +#' result is handed back for other uses. +#' @return \code{GwasFineMappingParam} returns a +#' \code{GwasFineMappingParam} object, a \code{\link{MethodParam}}. +#' Each \code{get*} returns that setting's value --- for the three +#' nested bundles, the \code{MethodParam} itself --- and each +#' \code{set*} returns a modified copy. +#' @examples +#' GwasFineMappingParam(credibleSet = CredibleSetParam(coverage = 0.9)) +#' @export +GwasFineMappingParam <- function( + methods = "susie", + credibleSetArgs = CredibleSetParam(), + rssArgs = SusieRssParam(), + panelFilterArgs = PanelFilterParam(), + addSusieInf = TRUE, + fitRetention = c("slim", "full") +) { + fitRetention <- arg_match(fitRetention) + new( + "GwasFineMappingParam", + methods = methods, + credibleSetArgs = credibleSetArgs, + rssArgs = rssArgs, + panelFilterArgs = panelFilterArgs, + addSusieInf = addSusieInf, + fitRetention = fitRetention + ) +} + #' @title Colocalization Pipeline (coloc.bf_bf over paired LBF matrices) #' @description Per-region pipeline that pairs two fine-mapping result #' collections and runs \code{coloc::coloc.bf_bf} per (first-side tuple, @@ -28,11 +257,11 @@ #' \item \strong{fSuSiE support}: the LBF matrix lives at a different #' slot for fSuSiE fits (\code{fsusie_result$lBF}) and gets stacked #' into a single matrix. -#' \item \strong{Effect filtering}: \code{filterLbfCs} keeps only -#' effects that produced a credible set; \code{filterLbfCsSecondary} -#' keeps effects at a secondary coverage; otherwise the default -#' filter drops effects whose prior variance is below -#' \code{priorTol}. +#' \item \strong{Effect filtering}: \code{lbfFilter}'s +#' \code{filterLbfCs} keeps only effects that produced a credible +#' set, its \code{secondary} keeps effects at a secondary coverage; +#' otherwise the default filter drops effects whose prior variance is +#' below \code{priorTol}. #' \item \strong{Per-tuple LBF reuse}: each second-side tuple's LBF #' matrix is extracted once and scored against every first-side #' tuple, so the filtering above is applied once per tuple rather @@ -45,7 +274,7 @@ #' \item \code{gwasInput} is a \code{\link{QtlSumStats}} or a #' \code{\link{GwasSumStats}}: it is fine-mapped inline by #' \code{\link{fineMappingPipeline}} with the supplied -#' \code{finemappingMethods} (default \code{"susie"}). +#' \code{GwasFineMappingParam()} (methods default \code{"susie"}). #' \item \code{gwasInput} is a fine-mapping result: used directly; no #' inline fine-mapping. #' } @@ -70,30 +299,30 @@ #' \code{\link{GwasFineMappingResult}}, or the summary statistics to #' fine-map inline (\code{\link{QtlSumStats}} or #' \code{\link{GwasSumStats}}). -#' @param filterLbfCs Logical. When \code{TRUE} (and \code{filterLbfCsSecondary} -#' is \code{NULL}), keep only effects that produced a credible set -#' (\code{trimmedFit$sets$cs_index}). Default \code{FALSE}. -#' @param filterLbfCsSecondary Optional secondary coverage (numeric in \eqn{(0, -#' 1)}). When supplied, run a credible-set concentration filter at this -#' coverage level instead of \code{filterLbfCs}: each L-effect's credible set -#' must span fewer than \code{nVariants * filterLbfCsSecondary * -#' filterLbfCsConcentration} variants to be kept. Effects with diffuse -#' credible sets are dropped before the LBF matrix is passed to -#' \code{coloc::coloc.bf_bf}. Overrides \code{filterLbfCs} when set. -#' @param filterLbfCsConcentration Numeric in \eqn{(0, 1)}; the concentration -#' factor in the cutoff above. With the default \code{0.5} a 50\% credible set -#' is kept only if it spans fewer than 25\% of the locus's variants. Only -#' consulted when \code{filterLbfCsSecondary} is non-NULL. Default \code{0.5}. -#' @param priorTol Prior-variance cutoff for the default filter: effects with -#' \code{V <= priorTol} are dropped. Ignored when either \code{filterLbfCs} or -#' \code{filterLbfCsSecondary} is in use. Default \code{1e-9}. -#' @param p1 Prior probability of QTL signal per variant. Default \code{1e-4}. -#' @param p2 Prior probability of GWAS signal per variant. Default \code{1e-4}. -#' @param p12 Prior probability of shared signal per variant. Default -#' \code{5e-6}. -#' @param finemappingMethods Character vector forwarded to -#' \code{\link{fineMappingPipeline}} when \code{gwasInput} is summary -#' statistics rather than a fine-mapping result. Default \code{"susie"}. +#' @param lbfFilterArgs Credible-set filtering applied before scoring, +#' built with +#' \code{\link{ColocLbfFilterParam}}. \code{filterLbfCs} keeps only effects +#' that produced a credible set; supplying \code{secondary} instead runs a +#' concentration filter at that coverage, where an effect is kept only if +#' its credible set spans fewer than +#' \code{nVariants * secondary * concentration} variants. Diffuse effects +#' are dropped before the LBF matrix reaches +#' \code{coloc::coloc.bf_bf}. \code{priorTol} is the default filter's own +#' cutoff (effects with \code{V <= priorTol} are dropped) and does not +#' apply once \code{filterLbfCs} or \code{secondary} selects another. +#' @param priors Per-variant prior probabilities, built with +#' \code{\link{ColocPriorParam}}: \code{p1} (QTL signal), \code{p2} (GWAS +#' signal) and \code{p12} (shared). Mutually exclusive with +#' \code{enrichment}, which derives the same three. +#' @param gwasFineMappingArgs How \code{gwasInput} is fine-mapped when it is +#' summary statistics rather than a fine-mapping result, built with +#' \code{\link{GwasFineMappingParam}}: \code{methods}, +#' \code{credibleSet}, \code{rss}, \code{panelFilter}, +#' \code{addSusieInf} and \code{fitRetention}. Inert when +#' \code{gwasInput} is already fine-mapped. \code{credibleSet} is the one +#' to check: its \code{coverage} / \code{L} decide the sets whose LBFs are +#' scored, so defaults here against a differently-built QTL side compare +#' two different things. #' @param returnGwasFineMapping Logical. When \code{TRUE}, attach the #' fine-mapping result computed from \code{gwasInput} on the returned object #' as attribute \code{"gwasFineMapping"}. Default \code{FALSE}. @@ -102,14 +331,12 @@ #' \code{enrichment}, and optionally \code{gwasContext} / \code{gwasTrait} #' (which the join uses when present, and which #' \code{\link{qtlEnrichmentPipeline}} emits for a QTL outcome side). Output -#' of \code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL}, each pair's -#' \code{p12} prior is scaled to \code{min(p12 * (1 + enrichment), p12Max)} -#' (the enrichment-informed colocalization variant, "enloc"). Pairs without a -#' matching enrichment row fall back to the baseline \code{p12} with a -#' warning. Default \code{NULL} (baseline coloc). -#' @param p12Max Numeric scalar. Maximum value for the enrichment-adjusted -#' \code{p12} prior. Default \code{1e-3}. Ignored when \code{enrichment = -#' NULL}. +#' of \code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL} the pair is +#' scored by enloc rather than coloc: the priors come from that table's +#' \code{colocP1} / \code{colocP2} / \code{colocP12} columns, and the +#' report gains \code{RCP} and \code{LCP}. Pairs without a matching +#' enrichment row fall back to the baseline priors with a warning. Default +#' \code{NULL} (baseline coloc). #' @param adjustPips Logical, default \code{TRUE}. When TRUE, before any #' per-pair inference the QTL and GWAS fine-mapping result collections are #' reconciled with \code{\link{intersectVariants}}, so both sides are scored @@ -130,7 +357,10 @@ #' between the QTL and GWAS by (chrom, pos) with ref/alt swaps recognized (LBF #' is coding-invariant, so no sign change is needed); when FALSE, match on #' exact alleles only, so a ref/alt swap is treated as a distinct variant. -#' @param ... Additional arguments forwarded to \code{coloc::coloc.bf_bf}. +#' @param methodArgs Additional arguments forwarded to +#' \code{coloc::coloc.bf_bf}, built with \code{\link{ColocOptions}}. The +#' prior probabilities are set through \code{priors} instead, since the +#' enrichment adjustment reads them too. #' @return A \code{\linkS4class{ColocResult}}: one element per tested #' (first-side credible set, second-side credible set, block) pair, holding #' that pair's aligned variants with their \code{SNP.PP.H4}. Pair-level @@ -141,10 +371,14 @@ #' standard coloc fields (\code{idx1}, \code{idx2}, \code{nSnps}, #' \code{hit1}, \code{hit2}, \code{PP.H0.abf} \ldots \code{PP.H4.abf}) and #' the reconciliation diagnostics \code{qtlRetainedMass} / -#' \code{gwasRetainedMass}. When \code{enrichment} is supplied, two -#' additional columns \code{enrichment} and \code{p12Used} report the -#' per-pair factor and the prior actually passed to -#' \code{coloc::coloc.bf_bf}. +#' \code{gwasRetainedMass}. When \code{enrichment} is supplied the pair is +#' scored by enloc instead, and four further columns appear: +#' \code{enrichment} and \code{p12Used} report the per-pair factor and the +#' shared-signal prior enloc derived, while \code{RCP} and \code{LCP} are +#' enloc's regional and locus colocalisation probabilities. Those two are +#' the same numbers as \code{PP.H4.abf} and +#' \code{PP.H3.abf + PP.H4.abf}, reported under enloc's names because that +#' is what readers of enloc output expect to find. #' #' Project it with \code{\link{getColocPairs}} (the flat table this #' pipeline used to return, also available as \code{as.data.frame}), @@ -165,83 +399,152 @@ colocPipeline <- function( qtlFineMappingResult, gwasInput, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9, - p1 = 1e-4, - p2 = 1e-4, - p12 = 5e-6, - finemappingMethods = "susie", + priors = ColocPriorParam(), + lbfFilterArgs = ColocLbfFilterParam(), + gwasFineMappingArgs = GwasFineMappingParam(), returnGwasFineMapping = FALSE, enrichment = NULL, - p12Max = 1e-3, adjustPips = TRUE, alleleFlip = TRUE, - ... + methodArgs = ColocOptions() ) { - p <- as.list(environment()) - p$dots <- list(...) - p$useEnrichment <- !is.null(enrichment) - .colocValidateInputs(p) - p$gwasFmr <- .colocResolveGwasFmr(gwasInput, finemappingMethods) - .colocRequireMatchingLdSketches( - getLdSketch(qtlFineMappingResult), - getLdSketch(p$gwasFmr) + prepared <- .colocPrepare( + qtlFineMappingResult = qtlFineMappingResult, + gwasInput = gwasInput, + priors = priors, + gwasFineMappingArgs = gwasFineMappingArgs, + enrichment = enrichment, + adjustPips = adjustPips, + methodArgs = methodArgs, + lbfFilterArgs = lbfFilterArgs, + priorsMissing = missing(priors) ) - p <- .colocMaybeAdjustPips(p) # Pre-extract per-GWAS-tuple LBF matrices: group the GWAS FMR by study, # stack each study's LBF rows, and store per-(study, method) batched # matrices (reproduces the legacy row-wise combine per xQTL). - p$gwasLbfByPair <- .colocPreextractGwasLbf( - p$gwasFmr, - filterLbfCs, - filterLbfCsSecondary, - filterLbfCsConcentration, - priorTol + gwasLbfByPair <- .colocPreextractGwasLbf(prepared$gwasFmr, lbfFilterArgs) + # Both exits -- no scorable GWAS effect, and the scored result -- shape + # their output from the same five values, so they are named once. + shape <- list( + useEnrichment = prepared$useEnrichment, + qtlFineMappingResult = prepared$qtlFineMappingResult, + gwasFmr = prepared$gwasFmr, + gwasInput = gwasInput, + returnGwasFineMapping = returnGwasFineMapping ) - if (length(p$gwasLbfByPair) == 0L) { - return(.colocEarlyReturn(p)) + if (length(gwasLbfByPair) == 0L) { + return(exec(.colocEarlyReturn, !!!shape)) } - results <- list_flatten(map( - seq_len(nrow(p$qtlFineMappingResult)), + results <- .colocScoreAll( + prepared, + gwasLbfByPair, + lbfFilterArgs = lbfFilterArgs, + enrichment = enrichment, + priors = priors, + alleleFlip = alleleFlip + ) + exec(.colocFinalize, results, !!!shape) +} + +# Score every QTL tuple against the pre-extracted GWAS LBF matrices. +# @noRd +.colocScoreAll <- function( + prepared, + gwasLbfByPair, + lbfFilterArgs, + enrichment, + priors, + alleleFlip +) { + list_flatten(map( + seq_len(nrow(prepared$qtlFineMappingResult)), .colocScoreQtlTuple, - p = p + qtlFineMappingResult = prepared$qtlFineMappingResult, + gwasLbfByPair = gwasLbfByPair, + lbfFilterArgs = lbfFilterArgs, + useEnrichment = prepared$useEnrichment, + enrichment = enrichment, + priors = priors, + alleleFlip = alleleFlip, + ColocOptions = prepared$ColocOptions )) - .colocFinalize(results, p) +} + +# Validate the inputs, resolve the GWAS side to a fine-mapping result, check +# the two sides share an LD sketch, and apply the PIP adjustment. Everything +# that must happen before any tuple is scored, in one step because each part +# depends on the one before it. +# @noRd +.colocPrepare <- function( + qtlFineMappingResult, + gwasInput, + priors, + gwasFineMappingArgs, + enrichment, + adjustPips, + methodArgs, + lbfFilterArgs, + priorsMissing +) { + .colocAssertGroups(priors, lbfFilterArgs, methodArgs) + .colocRefusePriorsWithEnrichment(priors, enrichment, priorsMissing) + useEnrichment <- !is.null(enrichment) + .colocValidateInputs( + gwasInput = gwasInput, + qtlFineMappingResult = qtlFineMappingResult, + enrichment = enrichment, + useEnrichment = useEnrichment + ) + rawGwasFmr <- .colocResolveGwasFmr(gwasInput, gwasFineMappingArgs) + .colocRequireMatchingLdSketches( + getLdSketch(qtlFineMappingResult), + getLdSketch(rawGwasFmr) + ) + adjusted <- .colocMaybeAdjustPips( + adjustPips = adjustPips, + qtlFineMappingResult = qtlFineMappingResult, + gwasFmr = rawGwasFmr + ) + list( + ColocOptions = .colocEngineArgs(methodArgs, priors), + useEnrichment = useEnrichment, + qtlFineMappingResult = adjusted$qtlFineMappingResult, + gwasFmr = adjusted$gwasFmr + ) } # Validate the enrichment table (when supplied), the coloc package, and the # input object classes. # @noRd -.colocValidateInputs <- function(p) { - if (p$useEnrichment) { - .colocValidateEnrichment(p$enrichment) +.colocValidateInputs <- function( + gwasInput, + qtlFineMappingResult, + enrichment, + useEnrichment +) { + if (useEnrichment) { + .colocValidateEnrichment(enrichment) } if (!requireNamespace("coloc", quietly = TRUE)) { - msg <- glue( - "Package 'coloc' is required for colocPipeline. ", - "Install with: install.packages('coloc')." - ) - abort(msg) + abort("Package 'coloc' is required for colocPipeline.") } - if (!methods::is(p$qtlFineMappingResult, "FineMappingResultBase")) { + if (!methods::is(qtlFineMappingResult, "FineMappingResultBase")) { msg <- glue( "`qtlFineMappingResult` must be a QtlFineMappingResult or a ", "GwasFineMappingResult ", - "(got class '{class(p$qtlFineMappingResult)[[1L]]}')." + "(got class '{class(qtlFineMappingResult)[[1L]]}')." ) abort(msg) } if ( - !methods::is(p$gwasInput, "SumStatsBase") && - !methods::is(p$gwasInput, "FineMappingResultBase") + !methods::is(gwasInput, "SumStatsBase") && + !methods::is(gwasInput, "FineMappingResultBase") ) { msg <- glue( "`gwasInput` must be a fine-mapping result ", "(QtlFineMappingResult / GwasFineMappingResult) or summary ", "statistics (QtlSumStats / GwasSumStats) ", - "(got class '{class(p$gwasInput)[[1L]]}')." + "(got class '{class(gwasInput)[[1L]]}')." ) abort(msg) } @@ -251,24 +554,18 @@ colocPipeline <- function( # The enrichment table must be a data.frame carrying the required id + value # columns. # @noRd +#' @importFrom checkmate assertDataFrame assertNames .colocValidateEnrichment <- function(enrichment) { - if (!is.data.frame(enrichment)) { - msg <- glue( - "`enrichment` must be a data.frame with at least gwasStudy, ", - "qtlStudy, qtlContext, enrichment columns (output of ", - "qtlEnrichmentPipeline)." - ) - abort(msg) - } - required <- c("gwasStudy", "qtlStudy", "qtlContext", "enrichment") - missingCols <- setdiff(required, colnames(enrichment)) - if (length(missingCols) > 0L) { - msg <- glue( - "`enrichment` is missing column(s): ", - "{str_flatten(missingCols, ', ')}" - ) - abort(msg) - } + # The producer is named in .var.name so a caller passing the wrong object + # is pointed at what produces the right one. + label <- "enrichment (output of qtlEnrichmentPipeline)" + assertDataFrame(enrichment, .var.name = label) + assertNames( + colnames(enrichment), + must.include = c("gwasStudy", "qtlStudy", "qtlContext", "enrichment"), + what = "colnames", + .var.name = label + ) .colocValidateEnrichmentKeys(enrichment) invisible(NULL) } @@ -296,10 +593,18 @@ colocPipeline <- function( # Resolve the second side to a fine-mapping collection (fine-map QC'd sumstats # when summary statistics are passed, whichever flavour they are). # @noRd -.colocResolveGwasFmr <- function(gwasInput, finemappingMethods) { +.colocResolveGwasFmr <- function(gwasInput, gwasFineMappingArgs) { if (methods::is(gwasInput, "FineMappingResultBase")) { + # Already fine-mapped: nothing in the bundle applies, so a setting + # given here would be dropped rather than honoured. + .colocAssertGwasFmrUnset(gwasFineMappingArgs, class(gwasInput)[[1L]]) return(gwasInput) } + .assertMethodParam( + gwasFineMappingArgs, + "GwasFineMappingParam", + "gwasFineMapping" + ) if (length(getQcInfo(gwasInput)) == 0L) { msg <- glue( "colocPipeline: gwasInput ({class(gwasInput)[[1L]]}) has no QC ", @@ -307,7 +612,51 @@ colocPipeline <- function( ) abort(msg) } - fineMappingPipeline(gwasInput, methods = finemappingMethods) + # The bundle's terminal: fineMappingPipeline takes these as its own + # arguments, so it is unrolled once, here. + fineMappingPipeline( + gwasInput, + methods = gwasFineMappingArgs$methods %||% "susie", + credibleSetArgs = gwasFineMappingArgs$credibleSetArgs %||% + CredibleSetParam(), + rssArgs = gwasFineMappingArgs$rssArgs %||% SusieRssParam(), + panelFilterArgs = gwasFineMappingArgs$panelFilterArgs %||% + PanelFilterParam(), + addSusieInf = gwasFineMappingArgs$addSusieInf %||% TRUE, + fitRetention = gwasFineMappingArgs$fitRetention %||% "slim" + ) +} + +# `gwasFineMapping` configures the fine-mapping run colocPipeline does on a +# raw GWAS input. A caller who has already fine-mapped the GWAS has no such +# run, so a non-default bundle is an instruction that cannot be carried out. +# @noRd +.colocAssertGwasFmrUnset <- function(gwasFineMappingArgs, inputClass) { + if (!.isMethodParam(gwasFineMappingArgs)) { + return(invisible(NULL)) + } + defaults <- GwasFineMappingParam() + set <- keep( + names(defaults), + .colocGwasFmrFieldSet, + given = gwasFineMappingArgs, + defaults = defaults + ) + if (length(set) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "colocPipeline: `gwasFineMapping` ", + "({str_flatten(str_c(set, ' ='), ', ')}) configures the GWAS ", + "fine-mapping run, but `gwasInput` is already a ", + "{inputClass} -- there is no run to configure. ", + "Drop `gwasFineMapping`, or pass the raw GwasSumStats instead." + )) +} + +# @noRd +.colocGwasFmrFieldSet <- function(field, given, defaults) { + !isTRUE(all.equal(given[[field]], defaults[[field]])) } # Optional PIP renormalization, via the symmetric reconciliation verb. @@ -318,17 +667,23 @@ colocPipeline <- function( # adjusted each side to the UNION of the other's variants -- a union is not an # intersection, so the two sides could still end up on different sets. # @noRd -.colocMaybeAdjustPips <- function(p) { - if (!isTRUE(p$adjustPips)) { - return(p) +.colocMaybeAdjustPips <- function( + adjustPips, + qtlFineMappingResult, + gwasFmr +) { + unchanged <- list( + qtlFineMappingResult = qtlFineMappingResult, + gwasFmr = gwasFmr + ) + if (!isTRUE(adjustPips)) { + return(unchanged) } - if (nrow(p$qtlFineMappingResult) == 0L || nrow(p$gwasFmr) == 0L) { - return(p) + if (nrow(qtlFineMappingResult) == 0L || nrow(gwasFmr) == 0L) { + return(unchanged) } - both <- intersectVariants(p$qtlFineMappingResult, p$gwasFmr) - p$qtlFineMappingResult <- both$x - p$gwasFmr <- both$y - p + both <- intersectVariants(qtlFineMappingResult, gwasFmr) + list(qtlFineMappingResult = both$x, gwasFmr = both$y) } # The LD reference the result carries forward, so getColocCredibleSets() can @@ -338,53 +693,70 @@ colocPipeline <- function( # first side fit on individual-level data carries none, and then the second # side's panel is the only one there is. # @noRd -.colocLdSketch <- function(p) { - getLdSketch(p$qtlFineMappingResult) %||% getLdSketch(p$gwasFmr) +.colocLdSketch <- function(qtlFineMappingResult, gwasFmr) { + getLdSketch(qtlFineMappingResult) %||% getLdSketch(gwasFmr) } # Empty-result early return (attaching the GWAS fine-mapping when requested). # @noRd -.colocEarlyReturn <- function(p) { +.colocEarlyReturn <- function( + useEnrichment, + qtlFineMappingResult, + gwasFmr, + gwasInput, + returnGwasFineMapping +) { out <- .colocEmptyResult( - enriched = p$useEnrichment, - ldSketch = .colocLdSketch(p) + enriched = useEnrichment, + ldSketch = .colocLdSketch(qtlFineMappingResult, gwasFmr) ) - if (p$returnGwasFineMapping && methods::is(p$gwasInput, "SumStatsBase")) { - attr(out, "gwasFineMapping") <- p$gwasFmr - } - out + .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) } # Score one QTL tuple against every pre-extracted GWAS pair -> summary rows. # @noRd -.colocScoreQtlTuple <- function(qi, p) { - q <- .colocQtlTupleInfo(qi, p) +.colocScoreQtlTuple <- function( + qi, + qtlFineMappingResult, + gwasLbfByPair, + lbfFilterArgs, + useEnrichment, + enrichment, + priors, + alleleFlip, + ColocOptions +) { + q <- .colocQtlTupleInfo(qi, qtlFineMappingResult) qLbfInfo <- .colocExtractLbfFromEntry( q$parts, - p$filterLbfCs, - p$filterLbfCsSecondary, - p$filterLbfCsConcentration, - p$priorTol, + lbfFilterArgs, label = q$label ) if (is.null(qLbfInfo)) { return(list()) } - q$retainedMass <- qLbfInfo$retainedMass - q$effect <- qLbfInfo$effect + scored <- list_assign( + q, + retainedMass = qLbfInfo$retainedMass, + effect = qLbfInfo$effect + ) compact(map( - p$gwasLbfByPair, + gwasLbfByPair, .colocScorePairAt, qLbfInfo = qLbfInfo, - p = p, - q = q + q = scored, + useEnrichment = useEnrichment, + enrichment = enrichment, + priors = priors, + alleleFlip = alleleFlip, + ColocOptions = ColocOptions )) } # Identity + row payload + log label for one first-side tuple. # @noRd -.colocQtlTupleInfo <- function(qi, p) { - fmr <- p$qtlFineMappingResult +.colocQtlTupleInfo <- function(qi, qtlFineMappingResult) { + fmr <- qtlFineMappingResult ident <- .colocTupleIdentity(fmr, qi) c( ident, @@ -407,22 +779,70 @@ colocPipeline <- function( ) } +# With an enrichment table this is an enloc run: the prior depends on +# whether the GWAS hit is itself the causal eQTL, which coloc.bf_bf cannot +# express, so the scoring is ours. Without one it is plain coloc. +# @noRd +.colocRunPairEither <- function( + aligned, + p12Info, + q, + gInfo, + useEnrichment, + ColocOptions +) { + if (useEnrichment) { + return(.colocRunPairEnloc(aligned, p12Info)) + } + .colocRunPair( + aligned, + p12Info$p12Used, + q, + gInfo, + p1 = p12Info$p1, + p2 = p12Info$p2, + ColocOptions = ColocOptions + ) +} + # Score one (QTL, GWAS) pair via coloc.bf_bf -> a summary row, or NULL when the # variants don't align or coloc fails / returns no summary. # @noRd -.colocScorePair <- function(qLbf, gInfo, q, p) { +.colocScorePair <- function( + qLbf, + gInfo, + q, + useEnrichment, + enrichment, + priors, + alleleFlip, + ColocOptions +) { # Align variants between the QTL and GWAS LBF matrices by (chrom, pos, # allele) tuple via matchVariants (see .colocAlignLbf). - aligned <- .colocAlignLbf(qLbf, gInfo$lbf, alleleFlip = p$alleleFlip) + aligned <- .colocAlignLbf(qLbf, gInfo$lbf, alleleFlip = alleleFlip) if (is.null(aligned)) { return(NULL) } - p12Info <- .colocResolveP12(p, gInfo, q) - pairRes <- .colocRunPair(aligned, p, p12Info$p12Used, q, gInfo) + p12Info <- .colocResolvePriors( + gInfo, + q, + useEnrichment = useEnrichment, + enrichment = enrichment, + priors = priors + ) + pairRes <- .colocRunPairEither( + aligned, + p12Info, + q, + gInfo, + useEnrichment = useEnrichment, + ColocOptions = ColocOptions + ) if (is.null(pairRes) || is.null(pairRes$summary)) { return(NULL) } - rows <- .colocSummaryRow(pairRes, q, gInfo, p, p12Info) + rows <- .colocSummaryRow(pairRes, q, gInfo, useEnrichment, p12Info) # $results is the per-variant layer that process_coloc_results() used to # consume and that this pipeline silently dropped. It is pivoted here, the # only place that knows which results column belongs to which summary row. @@ -432,111 +852,211 @@ colocPipeline <- function( ) } -# Enrichment-informed p12 (per-(gwasStudy, qtlStudy, qtlContext) scaling capped -# at p12Max; baseline p12 with no enrichment table / no matching row). +# The priors for one pair. Without an enrichment table these are the caller's +# own; with one they are enloc's, taken from the table rather than derived +# from a default -- which is the whole point of running in enrichment mode. # @noRd -.colocResolveP12 <- function(p, gInfo, q) { - if (!p$useEnrichment) { - return(list(enRow = NA_real_, p12Used = p$p12)) +.colocResolvePriors <- function(gInfo, q, useEnrichment, enrichment, priors) { + if (!useEnrichment) { + return(list( + enRow = NA_real_, + p1 = priors$p1, + p2 = priors$p2, + p12Used = priors$p12 + )) } - enRow <- .colocLookupEnrichment(p$enrichment, gInfo, q) - if (is.na(enRow)) { + idx <- .colocLookupEnrichment(enrichment, gInfo, q) + if (is.na(idx)) { msg <- glue( "colocPipeline: no enrichment entry for ", "(gwasStudy='{gInfo$study}', qtlStudy='{q$study}', ", - "qtlContext='{q$context}'); using baseline p12." + "qtlContext='{q$context}'); this pair is scored with no ", + "enrichment, i.e. the unconditional priors." ) warn(msg) - enRow <- 0 + return(list( + enRow = NA_real_, + p1 = priors$p1, + p2 = priors$p2, + p12Used = priors$p12 + )) } - list(enRow = enRow, p12Used = min(p$p12 * (1 + enRow), p$p12Max)) + en <- .colocEnrichmentPriors(enrichment, idx) + list( + enRow = en$enrichment, + p1 = en$p1, + p2 = en$p2, + p12Used = en$p12 + ) } -# Run coloc.bf_bf for an aligned pair, warning + NULL on failure. +# Score every (QTL effect, GWAS effect) pair with the enloc configuration +# probabilities, in the shape coloc.bf_bf returns so the two modes' rows line +# up. RCP and LCP are reported alongside the hypothesis probabilities they +# are: RCP is PP.H4 and LCP is PP.H3 + PP.H4. # @noRd -.colocRunPair <- function(aligned, p, p12Used, q, gInfo) { - colocArgs <- c( - list( - aligned$qtl, - aligned$gwas, - p1 = p$p1, - p2 = p$p2, - p12 = p12Used - ), - p$dots +.colocRunPairEnloc <- function(aligned, p12Info) { + priors <- list( + p1 = p12Info$p1, + p2 = p12Info$p2, + p12 = p12Info$p12Used ) - tryCatch( - exec(coloc::coloc.bf_bf, !!!colocArgs), - error = function(e) { - msg <- glue( - "colocPipeline: coloc.bf_bf failed for ", - "{q$label} x {gInfo$label}: ", - "{conditionMessage(e)}" - ) - warn(msg) - NULL - } + qtlRows <- seq_len(nrow(aligned$qtl)) + gwasRows <- seq_len(nrow(aligned$gwas)) + grid <- expand.grid(idx1 = qtlRows, idx2 = gwasRows) + scored <- map2( + grid$idx1, + grid$idx2, + .colocEnlocOneEffectPair, + aligned = aligned, + priors = priors ) + summary <- data.frame( + idx1 = grid$idx1, + idx2 = grid$idx2, + nSnps = ncol(aligned$qtl), + PP.H0.abf = map_dbl(scored, "ppH0"), + PP.H1.abf = map_dbl(scored, "ppH1"), + PP.H2.abf = map_dbl(scored, "ppH2"), + PP.H3.abf = map_dbl(scored, "ppH3"), + PP.H4.abf = map_dbl(scored, "ppH4"), + RCP = map_dbl(scored, "rcp"), + LCP = map_dbl(scored, "lcp"), + stringsAsFactors = FALSE + ) + list(summary = summary, results = .colocEnlocResults(scored, aligned)) } -# Build a coloc summary row carrying the QTL / GWAS identity + enrichment. +# One (QTL effect, GWAS effect) pair, which is enloc's signal cluster. # @noRd -.colocSummaryRow <- function(pairRes, q, gInfo, p, p12Info) { - sm <- as.data.frame(pairRes$summary, stringsAsFactors = FALSE) - sm <- .colocRenameNsnps(sm) - sm$study <- q$study - sm$context <- q$context - sm$trait <- q$trait - sm$method <- q$method - sm$gwasStudy <- gInfo$study - sm$gwasContext <- gInfo$context - sm$gwasTrait <- gInfo$trait - sm$gwasMethod <- gInfo$method - # idx1 / idx2 index the LBF rows handed to coloc.bf_bf, which is exactly - # what retainedMass runs parallel to -- so the mass reported here is the - # mass of the two effects this row actually scores, not a per-entry - # average. - sm$qtlRetainedMass <- .colocPickAt( - q$retainedMass, - sm[["idx1"]], - nrow(sm) +.colocEnlocOneEffectPair <- function(i, j, aligned, priors) { + .enlocScoreEffectPair( + qtlLog10Bf = aligned$qtl[i, ], + gwasLog10Bf = aligned$gwas[j, ], + priors = priors ) - sm$gwasRetainedMass <- .colocPickAt( - gInfo$retainedMass, - sm[["idx2"]], - nrow(sm) +} + +# The per-variant layer, matching what coloc.bf_bf's `results` carries: one +# column per scored pair, holding that pair's SNP-level colocalisation +# probabilities (enloc's SCP, which sums to RCP). +# @noRd +.colocEnlocResults <- function(scored, aligned) { + scp <- map(scored, "scp") + # A data.frame rather than a tibble: this stands in for what + # coloc.bf_bf's `results` carries, and .crPivotColocResults consumes both + # paths' output through the same code. + out <- as.data.frame( + exec(cbind, !!!scp), + stringsAsFactors = FALSE ) - # coloc's idx1 / idx2 number the rows of THIS call, so they are not - # comparable across blocks. The fit's own effect indices are, and they are - # what the credible-set and gene views group on. - sm$qtlCs <- .colocPickAt( - q$effect, - sm[["idx1"]], - nrow(sm), - fill = NA_integer_ + colnames(out) <- sprintf("SNP.PP.H4.row%d", seq_along(scp)) + mutate(out, snp = colnames(aligned$qtl)) +} + +# The enrichment columns, present only when the pipeline used an enrichment +# table. A NULL `p12Info` carries the zero-row schema an empty result needs. +# @noRd +.colocEnrichmentCols <- function(useEnrichment, p12Info) { + if (!useEnrichment) { + return(list()) + } + if (is.null(p12Info)) { + return(list(enrichment = numeric(0), p12Used = numeric(0))) + } + list(enrichment = p12Info$enRow, p12Used = p12Info$p12Used) +} + +# Which QTL tuple and which GWAS tuple a summary row belongs to. +# @noRd +.colocRowIdentity <- function(q, gInfo) { + list( + study = q$study, + context = q$context, + trait = q$trait, + method = q$method, + gwasStudy = gInfo$study, + gwasContext = gInfo$context, + gwasTrait = gInfo$trait, + gwasMethod = gInfo$method + ) +} + +# Build a coloc summary row carrying the QTL / GWAS identity + enrichment. +# @noRd +.colocSummaryRow <- function( + pairRes, + q, + gInfo, + useEnrichment, + p12Info +) { + sm <- .colocRenameNsnps( + as.data.frame(pairRes$summary, stringsAsFactors = FALSE) ) - sm$gwasCs <- .colocPickAt( - gInfo$effect, - sm[["idx2"]], - nrow(sm), - fill = NA_integer_ + mutate( + sm, + !!!.colocRowIdentity(q, gInfo), + # idx1 / idx2 index the LBF rows handed to coloc.bf_bf, which is + # exactly what retainedMass runs parallel to -- so the mass reported + # here is the mass of the two effects this row actually scores, not a + # per-entry average. + qtlRetainedMass = .colocPickAt( + q$retainedMass, + sm[["idx1"]], + nrow(sm) + ), + gwasRetainedMass = .colocPickAt( + gInfo$retainedMass, + sm[["idx2"]], + nrow(sm) + ), + # coloc's idx1 / idx2 number the rows of THIS call, so they are not + # comparable across blocks. The fit's own effect indices are, and they + # are what the credible-set and gene views group on. + qtlCs = .colocPickAt( + q$effect, + sm[["idx1"]], + nrow(sm), + fill = NA_integer_ + ), + gwasCs = .colocPickAt( + gInfo$effect, + sm[["idx2"]], + nrow(sm), + fill = NA_integer_ + ), + blockId = gInfo$blockId %||% NA_character_, + !!!.colocEnrichmentCols(useEnrichment, p12Info) ) - sm$blockId <- gInfo$blockId %||% NA_character_ - if (p$useEnrichment) { - sm$enrichment <- p12Info$enRow - sm$p12Used <- p12Info$p12Used - } - sm } # Assemble the result table + attach the GWAS fine-mapping when requested. # @noRd -.colocFinalize <- function(results, p) { - out <- .colocAssemble(results, p$useEnrichment, .colocLdSketch(p)) - if (p$returnGwasFineMapping && methods::is(p$gwasInput, "SumStatsBase")) { - attr(out, "gwasFineMapping") <- p$gwasFmr +.colocFinalize <- function( + results, + useEnrichment, + qtlFineMappingResult, + gwasFmr, + gwasInput, + returnGwasFineMapping +) { + out <- .colocAssemble( + results, + useEnrichment, + .colocLdSketch(qtlFineMappingResult, gwasFmr) + ) + .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) +} + +# The GWAS fine-mapping the pipeline produced, carried back on the result when +# the caller asked for it and the GWAS side was fine-mapped here. +# @noRd +.colocAttachGwasFm <- function(out, returnGwasFineMapping, gwasInput, gwasFmr) { + if (!returnGwasFineMapping || !methods::is(gwasInput, "SumStatsBase")) { + return(out) } - out + `attr<-`(out, "gwasFineMapping", gwasFmr) } # Row-bind + column-order the per-pair summary rows (empty result when none). @@ -546,7 +1066,7 @@ colocPipeline <- function( return(.colocEmptyResult(enriched = useEnrichment, ldSketch = ldSketch)) } rows <- bind_rows(map(map(results, "rows"), .colocStandardiseRow)) - variants <- unlist(map(results, "variants"), recursive = FALSE) + variants <- list_c(map(results, "variants")) ColocResult(.colocOrderColumns(rows, useEnrichment), variants, ldSketch) } @@ -564,11 +1084,9 @@ colocPipeline <- function( "gwasMethod", "blockId", "qtlCs", - "gwasCs" + "gwasCs", + if (useEnrichment) c("enrichment", "p12Used") ) - if (useEnrichment) { - idCols <- c(idCols, "enrichment", "p12Used") - } select(out, all_of(idCols), everything()) } @@ -601,8 +1119,9 @@ colocPipeline <- function( coverage = 0.5, concentration = 0.5 ) { - fit$V <- NULL # disable V-based filtering inside susie_get_cs - csList <- susie_get_cs(fit, coverage = coverage, dedup = FALSE) + # V zapped to disable V-based filtering inside susie_get_cs + unfiltered <- list_modify(fit, V = zap()) + csList <- susie_get_cs(unfiltered, coverage = coverage, dedup = FALSE) totalVariants <- ncol(fit$alpha) maxSize <- totalVariants * coverage * concentration keep <- map_lgl(csList$cs, .colocCsUnderMax, maxSize = maxSize) @@ -610,9 +1129,10 @@ colocPipeline <- function( } # Extract an LBF matrix (effects x variants) from a FineMappingRow, -# applying the same filtering knobs as the legacy .extractLbfMatrix: +# applying the same filtering knobs as the legacy .extractLbfMatrix, now +# carried as one `lbfFilter` bundle rather than three loose arguments: # - filterLbfCs (CS-only) -# - filterLbfCsSecondary (secondary coverage CS, with concentration cutoff) +# - secondary (secondary coverage CS, with a concentration cutoff) # - priorTol drop on V (default) # Handles the fSuSiE shape (where the LBF lives at a different slot). # Returns list(lbf = , variantIds = ) or NULL when @@ -620,10 +1140,7 @@ colocPipeline <- function( # @noRd .colocExtractLbfFromEntry <- function( parts, - filterLbfCs, - filterLbfCsSecondary, - filterLbfCsConcentration, - priorTol, + lbfFilterArgs, label = "entry" ) { fit <- getSusieFit(parts) @@ -632,25 +1149,18 @@ colocPipeline <- function( warn(msg) return(NULL) } - lbfMatrix <- .colocLbfMatrix(fit, label) - if (is.null(lbfMatrix)) { + allRows <- .colocLbfMatrix(fit, label) + if (is.null(allRows)) { return(NULL) } - mass <- .colocEffectRetainedMass(fit, nrow(lbfMatrix)) - keep <- .colocSelectLbfRows( - lbfMatrix, - fit, - filterLbfCs, - filterLbfCsSecondary, - filterLbfCsConcentration, - priorTol - ) - lbfMatrix <- lbfMatrix[keep, , drop = FALSE] - mass <- mass[keep] - if (nrow(lbfMatrix) == 0L) { + allMass <- .colocEffectRetainedMass(fit, nrow(allRows)) + keep <- .colocSelectLbfRows(allRows, fit, lbfFilterArgs) + kept <- allRows[keep, , drop = FALSE] + mass <- allMass[keep] + if (nrow(kept) == 0L) { return(NULL) } - lbfMatrix <- .colocAssignLbfColnames(lbfMatrix, parts) + lbfMatrix <- .colocAssignLbfColnames(kept, parts) if (ncol(lbfMatrix) == 0L) { return(NULL) } @@ -714,28 +1224,27 @@ colocPipeline <- function( # matching when the exact name is absent, so a fit carrying `sets_secondary` # but no `sets` would silently filter on the wrong element. # @noRd -.colocSelectLbfRows <- function( - lbfMatrix, - fit, - filterLbfCs, - filterLbfCsSecondary, - filterLbfCsConcentration, - priorTol -) { +.colocSelectLbfRows <- function(lbfMatrix, fit, lbfFilterArgs) { + # Read off the bundle like the other three filter fields, rather than + # taken as a second copy of a value the caller already has in hand. + priorTol <- lbfFilterArgs$priorTol %||% 1e-9 + # The only place the filter's fields are read. Every function between + # here and colocPipeline carries the bundle whole, so the names cannot + # drift apart on the way down. allRows <- seq_len(nrow(lbfMatrix)) - if (isTRUE(filterLbfCs) && is.null(filterLbfCsSecondary)) { + if (isTRUE(lbfFilterArgs$filterLbfCs) && is.null(lbfFilterArgs$secondary)) { csIdx <- fit[["sets"]][["cs_index"]] if (!is.null(csIdx) && length(csIdx) > 0L) { return(csIdx) } - } else if (!is.null(filterLbfCsSecondary)) { - secIdx <- tryCatch( + } else if (!is.null(lbfFilterArgs$secondary)) { + secIdx <- try_fetch( .colocFilterCsByConcentration( fit, - coverage = filterLbfCsSecondary, - concentration = filterLbfCsConcentration + coverage = lbfFilterArgs$secondary, + concentration = lbfFilterArgs$concentration ), - error = function(e) NULL + error = function(cnd) NULL ) if (!is.null(secIdx) && length(secIdx) > 0L) { return(secIdx) @@ -761,17 +1270,25 @@ colocPipeline <- function( as.numeric(mass) } +# The entry's variant ids, when the matrix does not already name its columns. +# @noRd +.colocLbfNamesFrom <- function(lbfMatrix, parts) { + if (!is.null(colnames(lbfMatrix)) && !any(is.na(colnames(lbfMatrix)))) { + return(lbfMatrix) + } + vids <- .fmrPartsVariantIds(parts) + if (length(vids) != ncol(lbfMatrix)) { + return(lbfMatrix) + } + `colnames<-`(lbfMatrix, vids) +} + # Assign variant-id column names (fit-provided, else the row's rendered # variant ids) and drop columns with an NA id. # @noRd .colocAssignLbfColnames <- function(lbfMatrix, parts) { - if (is.null(colnames(lbfMatrix)) || any(is.na(colnames(lbfMatrix)))) { - vids <- .fmrPartsVariantIds(parts) - if (length(vids) == ncol(lbfMatrix)) { - colnames(lbfMatrix) <- vids - } - } - lbfMatrix[, !is.na(colnames(lbfMatrix)), drop = FALSE] + named <- .colocLbfNamesFrom(lbfMatrix, parts) + named[, !is.na(colnames(named)), drop = FALSE] } # The second side's LBF matrices, one record per row of the collection, each @@ -783,13 +1300,7 @@ colocPipeline <- function( # another's. Nothing downstream indexes this list by name, so positional # records make the collision impossible instead of merely unlikely. # @noRd -.colocPreextractGwasLbf <- function( - gwasFmr, - filterLbfCs, - filterLbfCsSecondary, - filterLbfCsConcentration, - priorTol -) { +.colocPreextractGwasLbf <- function(gwasFmr, lbfFilterArgs) { if (nrow(gwasFmr) == 0L) { return(list()) } @@ -799,10 +1310,7 @@ colocPipeline <- function( gwasFmr = gwasFmr, blockIds = .colocGwasBlockIds(gwasFmr), side = .fmrSideName(gwasFmr), - filterLbfCs = filterLbfCs, - filterLbfCsSecondary = filterLbfCsSecondary, - filterLbfCsConcentration = filterLbfCsConcentration, - priorTol = priorTol + lbfFilterArgs = lbfFilterArgs )) } @@ -814,20 +1322,14 @@ colocPipeline <- function( gwasFmr, blockIds, side, - filterLbfCs, - filterLbfCsSecondary, - filterLbfCsConcentration, - priorTol + lbfFilterArgs ) { ident <- .colocTupleIdentity(gwasFmr, ri) blockId <- blockIds[[ri]] label <- .fmrTupleLabel(side, ident, block = blockId) info <- .colocExtractLbfFromEntry( .fmrRowParts(gwasFmr, ri), - filterLbfCs, - filterLbfCsSecondary, - filterLbfCsConcentration, - priorTol, + lbfFilterArgs, label = label ) if (is.null(info)) { @@ -877,10 +1379,8 @@ colocPipeline <- function( # Relabel both matrices to one shared id so coloc.bf_bf sees identical # names. sharedIds <- gids[m$idxB] - qSub <- qtlLbf[, m$idxA, drop = FALSE] - gSub <- gwasLbf[, m$idxB, drop = FALSE] - colnames(qSub) <- sharedIds - colnames(gSub) <- sharedIds + qSub <- `colnames<-`(qtlLbf[, m$idxA, drop = FALSE], sharedIds) + gSub <- `colnames<-`(gwasLbf[, m$idxB, drop = FALSE], sharedIds) list(qtl = qSub, gwas = gSub) } @@ -912,11 +1412,11 @@ colocPipeline <- function( qtlRetainedMass = numeric(0), gwasRetainedMass = numeric(0) ) - if (enriched) { - base$enrichment <- numeric(0) - base$p12Used <- numeric(0) - } - ColocResult(base, list(), ldSketch = ldSketch) + ColocResult( + mutate(base, !!!.colocEnrichmentCols(enriched, NULL)), + list(), + ldSketch = ldSketch + ) } # Look up this pair's enrichment factor in the user-supplied enrichment table. @@ -938,9 +1438,34 @@ colocPipeline <- function( ) idx <- which(reduce(hits, `&`)) if (length(idx) == 0L) { - return(NA_real_) + return(NA_integer_) } - as.numeric(enrichment$enrichment[[idx[[1L]]]]) + idx[[1L]] +} + +# The enloc priors for one pair, read from the enrichment table rather than +# derived here. qtlEnrichmentPipeline already computes them the way fastenloc +# does -- p1 = (1 - P_eqtl) * expit(a0), p2 = P_eqtl / (1 + exp(a0 + a1)), +# p12 = P_eqtl * expit(a0 + a1) -- from the genome-wide QTL results, so using +# them is what makes this an enloc run rather than an approximation of one. +# @noRd +.colocEnrichmentPriors <- function(enrichment, idx) { + needed <- c("colocP1", "colocP2", "colocP12") + missing <- setdiff(needed, colnames(enrichment)) + if (length(missing) > 0L) { + abort(glue( + "colocPipeline: `enrichment` is missing ", + "{str_flatten(missing, ', ')}. The enloc priors come from these ", + "columns, which qtlEnrichmentPipeline() emits; a table carrying ", + "only an `enrichment` factor is not enough to form them." + )) + } + list( + p1 = as.numeric(enrichment$colocP1[[idx]]), + p2 = as.numeric(enrichment$colocP2[[idx]]), + p12 = as.numeric(enrichment$colocP12[[idx]]), + enrichment = as.numeric(enrichment$enrichment[[idx]]) + ) } # The identity a pair is looked up by, narrowed to the columns the table has. @@ -972,19 +1497,25 @@ colocPipeline <- function( # shape. # @noRd .colocStandardiseRow <- function(sm) { - for (col in c( - "idx1", - "idx2", - "nSnps", - "PP.H0.abf", - "PP.H1.abf", - "PP.H2.abf", - "PP.H3.abf", - "PP.H4.abf" - )) { - if (!is_in(col, colnames(sm))) sm[[col]] <- NA - } - sm + missing <- setdiff( + c( + "idx1", + "idx2", + "nSnps", + "PP.H0.abf", + "PP.H1.abf", + "PP.H2.abf", + "PP.H3.abf", + "PP.H4.abf" + ), + colnames(sm) + ) + mutate(sm, !!!set_names(map(missing, .colocMissingColumn), missing)) +} + +# @noRd +.colocMissingColumn <- function(col) { + NA } # coloc.bf_bf names the aligned-variant count `nsnps`; this package publishes @@ -1007,9 +1538,7 @@ colocPipeline <- function( } idx <- as.integer(idx) ok <- !is.na(idx) & idx >= 1L & idx <= length(values) - out <- rep(fill, length(idx)) - out[ok] <- values[idx[ok]] - out + replace(rep(fill, length(idx)), ok, values[idx[ok]]) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- @@ -1020,8 +1549,26 @@ colocPipeline <- function( # Score the first side's LBF against one second-side record -> a summary row # (or NULL). # @noRd -.colocScorePairAt <- function(gInfo, qLbfInfo, p, q) { - .colocScorePair(qLbfInfo$lbf, gInfo, q, p) +.colocScorePairAt <- function( + gInfo, + qLbfInfo, + q, + useEnrichment, + enrichment, + priors, + alleleFlip, + ColocOptions +) { + .colocScorePair( + qLbfInfo$lbf, + gInfo, + q, + useEnrichment = useEnrichment, + enrichment = enrichment, + priors = priors, + alleleFlip = alleleFlip, + ColocOptions = ColocOptions + ) } # TRUE when a credible set has fewer than `maxSize` variants. @@ -1029,3 +1576,128 @@ colocPipeline <- function( .colocCsUnderMax <- function(x, maxSize) { length(x) < maxSize } + +# --- GwasFineMappingParam accessors ---------------------------------------- +# The nested getters return the Param itself, so a caller edits it with its +# own setters and hands it back: setCredibleSetArgs(g, setCoverage(cs, 0.9)). + +#' @rdname GwasFineMappingParam +setMethod("getFineMappingMethods", "GwasFineMappingParam", function(x) { + x@methods +}) + +#' @rdname GwasFineMappingParam +setMethod("setFineMappingMethods", "GwasFineMappingParam", function(x, value) { + x@methods <- value + validObject(x) + x +}) + +#' @rdname GwasFineMappingParam +setMethod("getCredibleSetArgs", "GwasFineMappingParam", function(x) { + x@credibleSetArgs +}) + +#' @rdname GwasFineMappingParam +setMethod("setCredibleSetArgs", "GwasFineMappingParam", function(x, value) { + x@credibleSetArgs <- value + validObject(x) + x +}) + +#' @rdname GwasFineMappingParam +setMethod("getRssArgs", "GwasFineMappingParam", function(x) x@rssArgs) + +#' @rdname GwasFineMappingParam +setMethod("setRssArgs", "GwasFineMappingParam", function(x, value) { + x@rssArgs <- value + validObject(x) + x +}) + +#' @rdname GwasFineMappingParam +setMethod("getPanelFilterArgs", "GwasFineMappingParam", function(x) { + x@panelFilterArgs +}) + +#' @rdname GwasFineMappingParam +setMethod("setPanelFilterArgs", "GwasFineMappingParam", function(x, value) { + x@panelFilterArgs <- value + validObject(x) + x +}) + +#' @rdname GwasFineMappingParam +setMethod("getAddSusieInf", "GwasFineMappingParam", function(x) x@addSusieInf) + +#' @rdname GwasFineMappingParam +setMethod("setAddSusieInf", "GwasFineMappingParam", function(x, value) { + x@addSusieInf <- value + validObject(x) + x +}) + +#' @rdname GwasFineMappingParam +setMethod("getFitRetention", "GwasFineMappingParam", function(x) x@fitRetention) + +#' @rdname GwasFineMappingParam +setMethod("setFitRetention", "GwasFineMappingParam", function(x, value) { + x@fitRetention <- value + validObject(x) + x +}) + +#' @title Arguments For coloc's Bayes-Factor Scorer +#' @description Options forwarded to \code{coloc::coloc.bf_bf}. The prior +#' probabilities are \emph{not} settable here --- pecotmr derives them from +#' \code{\link{ColocPriorParam}}, which its enrichment adjustment also +#' reads --- and the two Bayes-factor matrices are supplied by the pipeline. +#' @param overlap.min Minimum overlap between the two variant sets. +#' @param trim_by_posterior Logical; trim by posterior before scoring. +#' @param ... Any other \code{coloc::coloc.bf_bf} argument. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' ColocOptions(trim_by_posterior = FALSE) +#' @export +ColocOptions <- function(overlap.min = NULL, trim_by_posterior = NULL, ...) { + .newMethodOptions( + "coloc::coloc.bf_bf", + defaults = list( + overlap.min = overlap.min, + trim_by_posterior = trim_by_posterior + ), + extra = list(...), + label = "ColocOptions", + engine = "coloc" + ) +} + +# Run coloc.bf_bf for an aligned pair, warning + NULL on failure. +# @noRd +#' @importFrom rlang try_fetch +.colocRunPair <- function(aligned, p12Used, q, gInfo, p1, p2, ColocOptions) { + # Engine-call exception: coloc's whole interface is two blocks -- this and + # ColocOptions -- so a colocWrapper.R would hold ~50 lines against this + # file's 1600. The engine boundary is stated here instead of split out. + callArgs <- c( + list( + aligned$qtl, + aligned$gwas, + p1 = p1, + p2 = p2, + p12 = p12Used + ), + ColocOptions + ) + try_fetch( + exec(coloc::coloc.bf_bf, !!!callArgs), + error = function(cnd) { + msg <- glue( + "colocPipeline: coloc.bf_bf failed for ", + "{q$label} x {gInfo$label}" + ) + warn(msg, parent = cnd) + NULL + } + ) +} diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index af01227f8..7ceaa986a 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -32,15 +32,14 @@ #' \code{getGenotypes()} / \code{getResidualizedGenotypes()}. #' The pipeline does \emph{not} run a separate #' individual-level QC pass. -#' \item \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} act -#' at ANALYSIS time on the sumstat sides, measured against the -#' \strong{LD reference panel}: a variant whose panel genotypes fall -#' below the cutoffs is dropped before the LD matrix is built. They -#' apply to a \code{QtlSumStats} QTL side and to a -#' \code{GwasSumStats} GWAS side (so they still bite when the QTL -#' side is individual-level). Defaults (\code{0}, \code{0}, -#' \code{1}) filter nothing. Unlike -#' \code{summaryStatsQc(imputeOpts = ...)}, which only bounds what +#' \item \code{panelFilter} acts at ANALYSIS time on the sumstat +#' sides, measured against the \strong{LD reference panel}: a +#' variant whose panel genotypes fall below its cutoffs is dropped +#' before the LD matrix is built. It applies to a +#' \code{QtlSumStats} QTL side and to a \code{GwasSumStats} GWAS +#' side (so it still bites when the QTL side is +#' individual-level). Its defaults filter nothing. Unlike +#' \code{summaryStatsQc(imputeArgs = ...)}, which only bounds what #' RAISS will impute, these discard \emph{observed} variants. #' \item All summary-statistic QC (variant filters, harmonization #' against the \code{ldSketch}, LD-mismatch detection, RAISS @@ -81,9 +80,13 @@ #' variant-window selection). #' @param region Optional single-range \code{GRanges} describing the analysis #' window. Mutually exclusive with \code{traitId} (see the \code{QtlDataset} -#' accessors). +#' accessors). Individual-level input only: summary statistics carry no +#' genotypes to window, so the \code{QtlSumStats} method does not take it +#' --- matching \code{\link{fineMappingPipeline}} and +#' \code{\link{twasWeightsPipeline}}. #' @param cisWindow Optional cis window in basepairs; required with -#' \code{traitId}, optional with \code{region}. +#' \code{traitId}, optional with \code{region}. Individual-level input +#' only, as for \code{region}. #' @param samples Optional character vector of sample IDs to restrict the #' analysis to; \code{NULL} (default) uses all samples. #' @param focalTrait Optional trait name; when supplied and present in the @@ -93,36 +96,44 @@ #' GWAS study focal. #' @param xqtlColoc,jointGwas,separateGwas Logical flags selecting which #' colocboost variants to run. -#' @param pipCutoffToSkip Individual-level pre-filter (ports the legacy -#' \code{pip_cutoff_to_skip_ind}). Scalar (applied to every context) or a -#' context-named numeric vector. For each context, every outcome is fit with a -#' single-effect SuSiE (\code{L = 1}) and dropped unless some variant's PIP -#' exceeds the cutoff; a context with no surviving outcome is skipped. -#' \code{0} (default) disables it; a negative value uses \code{3 / -#' n_variants}. (Summary-statistic skipping is handled upstream by -#' \code{\link{summaryStatsQc}}'s own \code{pipCutoffToSkip}.) -#' @param absZCutoffToSkip,bfCutoffToSkip,logBfCutoffToSkip Alternative -#' individual-level pre-filter metrics used in place of -#' \code{pipCutoffToSkip}: drop an outcome unless its maximum marginal -#' \code{|z|} (\code{absZCutoffToSkip}), or its maximum per-variant -#' single-effect Bayes factor (\code{bfCutoffToSkip}) / log Bayes factor -#' (\code{logBfCutoffToSkip}) from the \code{L = 1} fit, exceeds the cutoff. -#' Scalars, each defaulting to 0 (off). Exactly one screening metric may be -#' enabled: setting any of these requires \code{pipCutoffToSkip = 0}. -#' @param mafCutoff,macCutoff,imissCutoff Analysis-time filters applied to the -#' summary-statistic sides against the LD reference panel: a variant whose -#' panel genotypes fall below the cutoffs is dropped before the LD matrix is -#' built. Defaults (\code{0}, \code{0}, \code{1}) filter nothing. See the -#' Details section for how these relate to the individual-level cutoffs -#' recorded on a \code{QtlDataset}. +#' @param signalScreenArgs Individual-level pre-filter (ports the legacy +#' \code{pip_cutoff_to_skip_ind}), built with +#' \code{\link{SignalScreenParam}}. For each context every outcome is fit +#' with a single-effect SuSiE (\code{L = 1}) and dropped unless the chosen +#' metric exceeds its cutoff; a context with no surviving outcome is +#' skipped: +#' \itemize{ +#' \item \code{pip} --- the maximum PIP. A negative cutoff uses +#' \code{3 / n_variants}. Uniquely here it may also be a +#' \strong{context-named} numeric vector rather than a scalar, +#' applying a different cutoff per context. +#' \item \code{absZ} --- the maximum marginal \code{|z|}. +#' \item \code{bf} / \code{logBf} --- the maximum per-variant Bayes +#' factor or log Bayes factor from the \code{L = 1} fit. +#' } +#' Only one metric may be enabled, which +#' \code{\link{SignalScreenParam}} enforces when you build it. Unset (the +#' default) screens nothing. Summary-statistic skipping is handled upstream +#' by \code{\link{summaryStatsQc}}. +#' @param panelFilterArgs Analysis-time filters applied to the summary-statistic +#' sides against the LD reference panel, built with +#' \code{\link{PanelFilterParam}}: a variant whose panel genotypes fall +#' below its cutoffs is dropped before the LD matrix is built. The defaults +#' filter nothing. See the Details section for how these relate to the +#' individual-level cutoffs recorded on a \code{QtlDataset}. #' @param alleleFlip Logical, default \code{TRUE}. When TRUE, harmonize variants #' across the individual X, sumstats, and LD by (chrom, pos) with ref/alt #' swaps recognized (flipping z / residualized dosage / LD to a shared #' coding); when FALSE, match on exact alleles only (names-only), so a ref/alt #' swap is treated as a distinct variant. -#' @param ... Additional arguments forwarded to -#' \code{\link[colocboost]{colocboost}} (e.g., \code{M}, \code{L}, -#' \code{output_level}). +#' @param methodArgs Additional arguments forwarded to +#' \code{colocboost::colocboost}, built with +#' \code{\link{ColocboostOptions}}. Names are checked against that +#' function's formals, so a misspelled option errors instead of being +#' dropped inside the run. The data slots the pipeline assembles itself +#' (\code{X}, \code{Y}, \code{sumstat}, \code{LD}, \code{X_ref}, +#' \code{focal_outcome_idx}) are refused. +#' @param ... Required by the generic; the methods take no further arguments. #' @return A \code{\linkS4class{ColocBoostResult}}: one element per #' confidence set (CoS) across every analysis that ran, holding that set's #' member variants with their \code{vcp}. The \code{analysis} column marks @@ -154,32 +165,74 @@ NULL #' colocboostPipeline(qtlDatasetExample, xqtlColoc = TRUE) #' @export setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { + .cbAssertInputClass(qtlData) standardGeneric("colocboostPipeline") }) -# ============================================================================= -# Helpers (private) -# ============================================================================= +# At least one analysis has to be selected. The three flags are independent +# -- any combination is a valid request -- so they stay separate arguments; +# all-FALSE is the one combination that is not a request at all, and it used +# to run silently and return nothing. +# @noRd +.cbAssertAnyRun <- function(xqtlColoc, jointGwas, separateGwas) { + if (any(c(isTRUE(xqtlColoc), isTRUE(jointGwas), isTRUE(separateGwas)))) { + return(invisible(NULL)) + } + abort(glue( + "colocboostPipeline: no analysis selected. Set at least one of ", + "`xqtlColoc` (xQTL-only), `jointGwas` (all GWAS jointly) or ", + "`separateGwas` (one run per GWAS study) to TRUE." + )) +} -# Run colocboost() with tryCatch + timing. -.cbRun <- function(label, args) { - if (!requireNamespace("colocboost", quietly = TRUE)) { - abort("The colocboost package is required for colocboostPipeline().") +# @noRd +.cbAssertInputClass <- function(qtlData) { + ok <- c("QtlDataset", "QtlSumStats", "MultiStudyQtlDataset") + if (any(map_lgl(ok, is, object = qtlData))) { + return(invisible(NULL)) } - t1 <- Sys.time() - args <- compact(args) - res <- tryCatch( - exec(colocboost::colocboost, !!!args), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("{label} failed: {eMsg}") - inform(msg) - NULL - } + abort(glue( + "colocboostPipeline does not accept inputs of class ", + "'{class(qtlData)[[1L]]}'. Pass a QtlDataset, QtlSumStats, or ", + "MultiStudyQtlDataset for QTL data." + )) +} + +# The data slots the pipeline builds from its inputs. They are real +# colocboost formals, so the union check would accept them -- but the +# pipeline supplies them, so a value given here would be overwritten. +# @noRd +.cbPipelineOwnedArgs <- function() { + c( + "X", + "Y", + "sumstat", + "LD", + "X_ref", + "focal_outcome_idx", + "dict_YX", + "dict_sumstatLD" ) - list(result = res, time = Sys.time() - t1) } +# @noRd +.cbRefusePipelineOwned <- function(extra) { + clash <- intersect(names(extra), .cbPipelineOwnedArgs()) + if (length(clash) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "ColocboostOptions: {str_flatten(clash, ', ')} ", + "{if (length(clash) == 1L) 'is' else 'are'} assembled by ", + "colocboostPipeline() from its inputs, so a value set here would be ", + "overwritten. Use the pipeline's own arguments instead." + )) +} + +# ============================================================================= +# Helpers (private) +# ============================================================================= + # Build the LD / X_ref slot of the colocboost call from a list of LD # matrices. When any matrix is non-square it is treated as a samples x # variants genotype reference and routed to X_ref; otherwise routed to LD. @@ -230,61 +283,6 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { pipCutoffToSkip[[1L]] } -# Combine the four colocboost screen cutoffs into a single spec to thread -# through the pipCutoffToSkip channel: a resolved screen object when a new -# metric (absZ / bf / logBf) is set, otherwise the (possibly context-named) -# legacy pipCutoffToSkip. Enforces one screening metric at a time. -.cbScreenSpec <- function( - pipCutoffToSkip, - absZCutoffToSkip, - bfCutoffToSkip, - logBfCutoffToSkip -) { - newScreen <- .resolveScreenMetric( - 0, - absZCutoffToSkip, - bfCutoffToSkip, - logBfCutoffToSkip - ) - pipOn <- !is.null(pipCutoffToSkip) && - length(pipCutoffToSkip) > 0L && - any(as.numeric(pipCutoffToSkip) != 0, na.rm = TRUE) - if (!is.null(newScreen) && pipOn) { - msg <- glue( - "colocboostPipeline: only one signal screen may be enabled ", - "at a time; unset pipCutoffToSkip to use absZCutoffToSkip / ", - "bfCutoffToSkip / logBfCutoffToSkip." - ) - abort(msg) - } - if (!is.null(newScreen)) newScreen else pipCutoffToSkip -} - -# Per-outcome single-trait skip (ports the legacy qc_individual_data -# pip_cutoff_to_skip): for each outcome column of Y, fit a single-effect -# SuSiE (L = 1, max_iter = 100) on (X, Y[, j]) and keep the outcome only if -# any variant's PIP exceeds the cutoff. A cutoff < 0 means 3 / n_variants. -# Returns the retained Y (NULL when no outcome clears the threshold). -.cbPipSkipOutcomes <- function(X, Y, spec) { - if (is.null(.asScreen(spec))) { - return(Y) - } - # Single-effect screen per outcome, sharing the L = 1 SuSiE pre-screen - # (.fmSerScreen) with the fine-mapping pipeline. fallback = FALSE: an - # outcome that cannot be screened (too few samples / fit failure) is - # dropped. - keep <- map_lgl( - seq_len(ncol(Y)), - .cbScreenOutcome, - X = X, - Y = Y, - spec = spec - ) - if (!any(keep)) { - return(NULL) - } - Y[, keep, drop = FALSE] -} # Materialise an individual-level QtlDataset into the colocboost # (X, Y, dict_YX, outcome_names) bundle. Each context becomes one X / @@ -318,9 +316,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { YperCtx <- set_names(map(built, "Y"), map_chr(built, "ctx")) dedup <- .cbDedupX(XperCtx) split <- .cbSplitY(YperCtx, dedup$xMatch) - outcomeInfo <- split$outcomeInfo - outcomeInfo$study <- getStudy(qd) - outcomeInfo$dataForm <- "individual" + outcomeInfo <- mutate( + split$outcomeInfo, + study = getStudy(qd), + dataForm = "individual" + ) list( X = dedup$uniqueX, Y = split$YSplit, @@ -356,11 +356,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # NULL when the context should be skipped. # @noRd .cbBuildContextXY <- function(ctx, p) { - Y <- .cbResidualizedY(p$qd, ctx, p$traitId, p$region) - if (is.null(Y) || ncol(Y) == 0L) { + rawY <- .cbResidualizedY(p$qd, ctx, p$traitId, p$region) + if (is.null(rawY) || ncol(rawY) == 0L) { return(NULL) } - X <- .cbResidualizedX( + rawX <- .cbResidualizedX( p$qd, ctx, p$traitId, @@ -368,16 +368,16 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { p$cisWindow, p$samples ) - if (is.null(X) || ncol(X) == 0L) { + if (is.null(rawX) || ncol(rawX) == 0L) { return(NULL) } # Canonicalize variant colnames (chr-prefix + separator, allele order # preserved; rsIDs passed through) so colocboost's name-based matching - # aligns - # them with the sumstat / LD ids and across studies. A genuine ref/alt swap - # stays a distinct id -- names are aligned here, allele *coding* is not. - colnames(X) <- normalizeVariantId(colnames(X)) - common <- intersect(rownames(X), rownames(Y)) + # aligns them with the sumstat / LD ids and across studies. A genuine + # ref/alt swap stays a distinct id -- names are aligned here, allele + # *coding* is not. + named <- `colnames<-`(rawX, normalizeVariantId(colnames(rawX))) + common <- intersect(rownames(named), rownames(rawY)) if (length(common) == 0L) { msg <- glue( "colocboostPipeline: skipping context '{ctx}' ", @@ -386,9 +386,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { inform(msg) return(NULL) } - X <- X[common, , drop = FALSE] - Y <- Y[common, , drop = FALSE] - Y <- .cbApplyScreen(X, Y, ctx, p$pipCutoffToSkip) + X <- named[common, , drop = FALSE] + Y <- .cbApplyScreen( + X, + rawY[common, , drop = FALSE], + ctx, + p$pipCutoffToSkip + ) if (is.null(Y)) { return(NULL) } @@ -398,20 +402,19 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Residualized phenotypes for one context (message + NULL on failure). # @noRd .cbResidualizedY <- function(qd, ctx, traitId, region) { - tryCatch( + try_fetch( getResidualizedPhenotypes( qd, contexts = ctx, traitId = traitId, region = region ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( "colocboostPipeline: skipping context '{ctx}' ", - "(residualized phenotypes unavailable: {eMsg})." + "(residualized phenotypes unavailable)." ) - inform(msg) + inform(msg, parent = cnd) NULL } ) @@ -420,7 +423,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Residualized genotypes for one context (message + NULL on failure). # @noRd .cbResidualizedX <- function(qd, ctx, traitId, region, cisWindow, samples) { - tryCatch( + try_fetch( getResidualizedGenotypes( qd, contexts = ctx, @@ -429,13 +432,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { cisWindow = cisWindow, samples = samples ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( "colocboostPipeline: skipping context '{ctx}' ", - "(residualized genotypes unavailable: {eMsg})." + "(residualized genotypes unavailable)." ) - inform(msg) + inform(msg, parent = cnd) NULL } ) @@ -461,26 +463,27 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { Y } +# The index of the first element of `xs` identical to `xs[[i]]`. +# @noRd +.cbFirstIdentical <- function(i, xs) { + which(map_lgl(xs, identical, xs[[i]]))[[1L]] +} + # Deduplicate X matrices identical across contexts so dict_YX can fan out to a # smaller X set. Returns list(uniqueX, xMatch) where xMatch[i] is the uniqueX -# index for the i-th context. (Sequential back-reference dedup -- kept as a -# loop.) +# index for the i-th context. +# +# Each context resolves to the first context it matches, so nothing has to be +# carried between iterations: the ones that resolve to themselves are the +# unique set, and every context's slot is its representative's position in it. # @noRd .cbDedupX <- function(XperCtx) { - uniqueX <- list() - xMatch <- integer(length(XperCtx)) - for (i in seq_along(XperCtx)) { - matched <- names(uniqueX)[ - map_lgl(uniqueX, identical, XperCtx[[i]]) - ] - if (length(matched) > 0L) { - xMatch[[i]] <- match(matched[[1L]], names(uniqueX)) - } else { - uniqueX[[names(XperCtx)[i]]] <- XperCtx[[i]] - xMatch[[i]] <- length(uniqueX) - } - } - list(uniqueX = uniqueX, xMatch = xMatch) + firstIdx <- map_int(seq_along(XperCtx), .cbFirstIdentical, xs = XperCtx) + keepIdx <- which(firstIdx == seq_along(XperCtx)) + list( + uniqueX = XperCtx[keepIdx], + xMatch = match(firstIdx, keepIdx) + ) } # Split each context's Y into single-trait columns (context-qualifying duplicate @@ -488,59 +491,97 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # list(YSplit, dict). (Sequential make.unique naming -- kept as a loop.) # @noRd .cbSplitY <- function(YperCtx, xMatch) { - allTraitNames <- unlist(map(YperCtx, colnames), use.names = FALSE) + allTraitNames <- unname(list_c(map(YperCtx, colnames))) dupTraits <- unique(allTraitNames[ duplicated(allTraitNames) | duplicated(allTraitNames, fromLast = TRUE) ]) - YSplit <- list() - dict <- matrix(integer(0), ncol = 2L) + # Every (context, column) pair, flattened once so the rest is positional. + pairs <- .cbConcat(map( + seq_along(YperCtx), + .cbYPairsForContext, + YperCtx = YperCtx, + xMatch = xMatch + )) # The outcome NAME is a display label: context-qualified only when a trait - # is ambiguous, then made unique. That makes it lossy -- a bare name could - # be a trait seen in one context or a trait literally called that -- so the - # (context, trait) it was minted from is recorded alongside it here, the - # only point where both are still in hand. - info <- list() - for (i in seq_along(YperCtx)) { - Y <- YperCtx[[i]] - ctx <- names(YperCtx)[i] - for (j in seq_len(ncol(Y))) { - tname <- .cbTraitName( - colnames(Y)[j], - ctx, - dupTraits, - names(YSplit) - ) - YSplit[[tname]] <- Y[, j, drop = FALSE] - dict <- rbind(dict, c(length(YSplit), xMatch[[i]])) - info[[length(info) + 1L]] <- tibble( - name = tname, - context = ctx, - trait = as.character(colnames(Y)[j] %||% NA_character_) - ) - } + # is ambiguous, then made unique. Making it unique depends on the names + # already minted, so this one step is a fold -- the only sequential part. + outcomeNames <- reduce( + pairs, + .cbAccumOutcomeName, + dupTraits = dupTraits, + .init = character(0) + ) + # The name is lossy -- a bare name could be a trait seen in one context or + # a trait literally called that -- so the (context, trait) it was minted + # from is recorded alongside it, the only point where both are in hand. + list( + YSplit = set_names(map(pairs, "col"), outcomeNames), + dict = cbind(Y = seq_along(pairs), X = map_int(pairs, "xIdx")), + outcomeInfo = bind_rows(map2(outcomeNames, pairs, .cbOutcomeInfoRow)) + ) +} + +# Concatenate a list of lists into one, empty-safe. +# @noRd +.cbConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) } - colnames(dict) <- c("Y", "X") + list_c(pieces) +} + +# One (context, column) pair: the column itself plus what it was minted from. +# @noRd +.cbYPair <- function(j, Y, ctx, xIdx) { list( - YSplit = YSplit, - dict = dict, - outcomeInfo = bind_rows(info) + col = Y[, j, drop = FALSE], + ctx = ctx, + raw = colnames(Y)[j], + trait = as.character(colnames(Y)[j] %||% NA_character_), + xIdx = xIdx + ) +} + +# @noRd +.cbYPairsForContext <- function(i, YperCtx, xMatch) { + Y <- YperCtx[[i]] + map( + seq_len(ncol(Y)), + .cbYPair, + Y = Y, + ctx = names(YperCtx)[i], + xIdx = xMatch[[i]] ) } +# @noRd +.cbAccumOutcomeName <- function(existing, pair, dupTraits) { + c(existing, .cbTraitName(pair$raw, pair$ctx, dupTraits, existing)) +} + +# @noRd +.cbOutcomeInfoRow <- function(name, pair) { + tibble(name = name, context = pair$ctx, trait = pair$trait) +} + # Resolve a unique outcome name for a single trait column: default unnamed # columns, context-qualify duplicates, and make.unique against existing names. # @noRd .cbTraitName <- function(tname, ctx, dupTraits, existing) { - if (is.null(tname) || is.na(tname) || tname == "") { - tname <- str_c("outcome", length(existing) + 1L) + named <- if (is.null(tname) || is.na(tname) || tname == "") { + str_c("outcome", length(existing) + 1L) + } else { + tname } - if (is_in(tname, dupTraits)) { - tname <- str_c(ctx, "_", tname) + qualified <- if (is_in(named, dupTraits)) { + str_c(ctx, "_", named) + } else { + named } - if (is_in(tname, existing)) { - tname <- make.unique(c(existing, tname))[length(existing) + 1L] + if (!is_in(qualified, existing)) { + return(qualified) } - tname + make.unique(c(existing, qualified))[length(existing) + 1L] } # Build a single (sumstat data.frame, LD correlation matrix) pair from a @@ -557,7 +598,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { if (is.null(df) || nrow(df) == 0L) { return(NULL) } - df$variant_id <- .cbSumstatVariantIds(df) + df <- mutate(df, variant_id = .cbSumstatVariantIds(df)) # Canonicalize ids (chr-prefix + separator, allele order preserved; rsIDs # passed through) so the sumstat `variant` column and the LD dimnames align # by name with the individual X colnames and across studies/sumstats. @@ -588,10 +629,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { return(NULL) } keptIds <- attr(R, "keptVariantIds") - attr(R, "keptVariantIds") <- NULL - df <- filter(df, is_in(variantIds, keptIds)) - ss <- .cbSumstatFrame(df, keptIds, nCase, nControl, varY) - list(sumstat = ss, LD = R, variantIds = keptIds) + kept <- filter(df, is_in(variantIds, keptIds)) + ss <- .cbSumstatFrame(kept, keptIds, nCase, nControl, varY) + list( + sumstat = ss, + LD = `attr<-`(R, "keptVariantIds", NULL), + variantIds = keptIds + ) } # The colocboost sumstat frame for one entry, over the variants the LD panel @@ -605,10 +649,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { variant = keptIds, stringsAsFactors = FALSE ) - if (!is.null(varY) && !is.na(varY)) { - ss$var_y <- varY - } - ss + mutate( + ss, + !!!compact(list( + var_y = if (!is.null(varY) && !is.na(varY)) varY + )) + ) } # Resolve a sumstat entry's variant ids, falling back to the canonical @@ -654,43 +700,70 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { return(list()) } ldSketch <- getLdSketch(ss) - keepRow <- rep(TRUE, nrow(ss)) - if (!is.null(contexts) && length(contexts) > 0L) { - keepRow <- keepRow & is_in(as.character(ss$context), contexts) + byContext <- if (!is.null(contexts) && length(contexts) > 0L) { + is_in(as.character(ss$context), contexts) + } else { + rep(TRUE, nrow(ss)) } - if (!is.null(traitId) && length(traitId) > 0L) { - keepRow <- keepRow & is_in(as.character(ss$trait), traitId) + byTrait <- if (!is.null(traitId) && length(traitId) > 0L) { + is_in(as.character(ss$trait), traitId) + } else { + TRUE } + keepRow <- byContext & byTrait if (!any(keepRow)) { return(list()) } rows <- which(keepRow) - bundle <- list() - for (i in rows) { - st <- as.character(ss$study)[[i]] - ctx <- as.character(ss$context)[[i]] - tr <- as.character(ss$trait)[[i]] - label <- str_c(st, ctx, tr, sep = ":") - pair <- .cbSumstatPair( - df = getSumStatsDf( - ss, - study = st, - context = ctx, - trait = tr, - require = "Z" - ), + compact(set_names( + map( + rows, + .cbQtlEntryPair, + ss = ss, ldSketch = ldSketch, - varY = if (is_in("varY", .tupleColumnNames(ss))) { - ss$varY[[i]] - } else { - NA_real_ - }, cutoffs = cutoffs - ) - if (!is.null(pair)) bundle[[label]] <- pair + ), + map_chr(rows, .cbQtlEntryLabel, ss = ss) + )) +} + +# @noRd +.cbQtlEntryLabel <- function(i, ss) { + str_c( + as.character(ss$study)[[i]], + as.character(ss$context)[[i]], + as.character(ss$trait)[[i]], + sep = ":" + ) +} + +# One QTL entry's (sumstat, LD) pair, or NULL when it has no panel overlap. +# @noRd +.cbQtlEntryPair <- function(i, ss, ldSketch, cutoffs) { + .cbSumstatPair( + df = getSumStatsDf( + ss, + study = as.character(ss$study)[[i]], + context = as.character(ss$context)[[i]], + trait = as.character(ss$trait)[[i]], + require = "Z" + ), + ldSketch = ldSketch, + varY = .cbTupleValue(ss, "varY", i), + cutoffs = cutoffs + ) +} + +# A tuple column's value for row `i`, or NA when the collection lacks it. +# `[[` on one of these collections extracts an ELEMENT, not a column, so this +# goes through mcols() the way the `$` method does. +# @noRd +.cbTupleValue <- function(collection, column, i) { + if (!is_in(column, .tupleColumnNames(collection))) { + return(NA_real_) } - bundle + S4Vectors::mcols(collection, use.names = FALSE)[[column]][[i]] } # Same as .cbQtlSumStatsBundle for a GwasSumStats collection, keyed by @@ -700,32 +773,33 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { return(list()) } ldSketch <- getLdSketch(gws) - bundle <- list() - for (i in seq_len(nrow(gws))) { - st <- as.character(gws$study)[[i]] - pair <- .cbSumstatPair( - df = getSumStatsDf(gws, study = st, require = "Z"), + compact(set_names( + map( + seq_len(nrow(gws)), + .cbGwasEntryPair, + gws = gws, ldSketch = ldSketch, - varY = if (is_in("varY", .tupleColumnNames(gws))) { - gws$varY[[i]] - } else { - NA_real_ - }, - nCase = if (is_in("nCase", .tupleColumnNames(gws))) { - gws$nCase[[i]] - } else { - NA_real_ - }, - nControl = if (is_in("nControl", .tupleColumnNames(gws))) { - gws$nControl[[i]] - } else { - NA_real_ - }, cutoffs = cutoffs - ) - if (!is.null(pair)) bundle[[st]] <- pair - } - bundle + ), + as.character(gws$study) + )) +} + +# One GWAS entry's (sumstat, LD) pair, or NULL when it has no panel overlap. +# @noRd +.cbGwasEntryPair <- function(i, gws, ldSketch, cutoffs) { + .cbSumstatPair( + df = getSumStatsDf( + gws, + study = as.character(gws$study)[[i]], + require = "Z" + ), + ldSketch = ldSketch, + varY = .cbTupleValue(gws, "varY", i), + nCase = .cbTupleValue(gws, "nCase", i), + nControl = .cbTupleValue(gws, "nControl", i), + cutoffs = cutoffs + ) } # Check two LD sketches for the reference-panel compatibility contract. Thin @@ -753,24 +827,20 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { dict_sumstatLD = matrix(integer(0), ncol = 2L) )) } - ldUnique <- list() - ldMatch <- integer(length(bundles)) - for (i in seq_along(bundles)) { - ld <- bundles[[i]]$LD - matched <- which(map_lgl(ldUnique, identical, ld)) - if (length(matched) > 0L) { - ldMatch[[i]] <- matched[[1L]] - } else { - ldUnique[[length(ldUnique) + 1L]] <- ld - ldMatch[[i]] <- length(ldUnique) - } - } - names(ldUnique) <- str_c("LD", seq_along(ldUnique)) - sumstat <- map(bundles, "sumstat") - names(sumstat) <- names(bundles) - dict <- cbind(seq_along(bundles), ldMatch) - colnames(dict) <- c("sumstat", "LD") - list(sumstat = sumstat, LD = ldUnique, dict_sumstatLD = dict) + # Same shape as .cbDedupX: every bundle resolves to the first bundle + # carrying an identical LD matrix, so the unique set and the back-mapping + # both fall out without carrying state. + lds <- map(bundles, "LD") + firstIdx <- map_int(seq_along(lds), .cbFirstIdentical, xs = lds) + keepIdx <- which(firstIdx == seq_along(lds)) + list( + sumstat = map(bundles, "sumstat"), + LD = set_names(lds[keepIdx], str_c("LD", seq_along(keepIdx))), + dict_sumstatLD = cbind( + sumstat = seq_along(bundles), + LD = match(firstIdx, keepIdx) + ) + ) } # Build an empty result skeleton consistent with what the per-method @@ -794,6 +864,21 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # no-op: the caller gets an empty ColocBoostResult whose getComputingTime() # entries are all NULL, with no indication of why. Say so. # @noRd +# TRUE when an analysis was requested and has the data to run. When it was +# requested but cannot run, warn and answer FALSE, so the caller's compact() +# drops it instead of skipping it silently. +# @noRd +.cbCanRun <- function(requested, hasData, flag, needed) { + if (!isTRUE(requested)) { + return(FALSE) + } + if (isTRUE(hasData)) { + return(TRUE) + } + .cbWarnNoData(flag, needed) + FALSE +} + .cbWarnNoData <- function(flag, needed) { msg <- glue( "colocboostPipeline: {flag} = TRUE was requested, but there is no ", @@ -809,6 +894,101 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # colocboost variants the user requested. `qtlSumstatBundle` is the QTL-side # subset of `sumstatBundle` (see .cbDriver); only the xQTL-only run uses it, # so that a GWAS study never becomes an xQTL-only outcome. +# The analyses that were requested AND have data to run on, keyed by the +# result slot each fills. .cbCanRun warns in the "requested but cannot" case +# so the skip is never silent, and compact() drops what did not run. +# @noRd +.cbDispatchRuns <- function( + individualBundle, + sumstatBundle, + qtlSumstatBundle, + xqtlColoc, + jointGwas, + separateGwas, + hasInd, + hasSs, + hasQtlSs, + focalTrait, + methodArgs +) { + # Resolved first, in the order the runs are listed: .cbCanRun() warns + # when a requested analysis has no data for it, and hoisting keeps those + # warnings in the same order they were emitted inline. + ssNeeded <- "summary-statistic data" + runXqtl <- .cbCanRun( + xqtlColoc, + hasInd || hasQtlSs, + "xqtlColoc", + "QTL data" + ) + runJoint <- .cbCanRun(jointGwas, hasSs, "jointGwas", ssNeeded) + runSeparate <- .cbCanRun(separateGwas, hasSs, "separateGwas", ssNeeded) + compact(list( + xqtl_coloc = if (runXqtl) { + .cbRunXqtlOnly( + individualBundle, + qtlSumstatBundle, + hasInd, + focalTrait, + methodArgs + ) + }, + joint_gwas = if (runJoint) { + .cbRunJointGwas(individualBundle, sumstatBundle, hasInd, methodArgs) + }, + separate_gwas = if (runSeparate) { + .cbRunSeparateGwas( + individualBundle, + sumstatBundle, + hasInd, + methodArgs + ) + } + )) +} + +# Each run's result and timing folded into the empty result skeleton, so a +# slot no analysis filled keeps the skeleton's own (empty) value. +# @noRd +.cbMergeRuns <- function(empty, runs) { + list_assign( + list_assign(empty, !!!map(runs, "result")), + computing_time = list_assign( + empty$computing_time, + Analysis = list_assign( + empty$computing_time$Analysis, + !!!map(runs, "time") + ) + ) + ) +} +# Per-outcome single-trait skip (ports the legacy qc_individual_data +# pip_cutoff_to_skip): for each outcome column of Y, fit a single-effect +# SuSiE (L = 1, max_iter = 100) on (X, Y[, j]) and keep the outcome only if +# any variant's PIP exceeds the cutoff. A cutoff < 0 means 3 / n_variants. +# Returns the retained Y (NULL when no outcome clears the threshold). +.cbPipSkipOutcomes <- function(X, Y, spec) { + if (is.null(.asScreen(spec))) { + return(Y) + } + # Single-effect screen per outcome, sharing the L = 1 SuSiE pre-screen + # (.fmSerScreen) with the fine-mapping pipeline. fallback = FALSE: an + # outcome that cannot be screened (too few samples / fit failure) is + # dropped. + keep <- map_lgl( + seq_len(ncol(Y)), + .cbScreenOutcome, + X = X, + Y = Y, + spec = spec + ) + if (!any(keep)) { + return(NULL) + } + Y[, keep, drop = FALSE] +} + + .cbRunVariants <- function( individualBundle, sumstatBundle, @@ -816,11 +996,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { jointGwas, separateGwas, focalTrait, - dotArgs, + methodArgs, qtlLdSketch = NULL, qtlSumstatBundle = NULL ) { - results <- .cbEmptyResult() + empty <- .cbEmptyResult() hasInd <- !is.null(individualBundle) hasSs <- length(sumstatBundle$sumstat) > 0L qtlSumstatBundle <- qtlSumstatBundle %||% .cbMergeSumstatBundles(list()) @@ -833,49 +1013,20 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { inform(msg) return(.cbEmptyResultObject()) } - if (isTRUE(xqtlColoc)) { - if (hasInd || hasQtlSs) { - run <- .cbRunXqtlOnly( - individualBundle, - qtlSumstatBundle, - hasInd, - focalTrait, - dotArgs - ) - results$xqtl_coloc <- run$result - results$computing_time$Analysis$xqtl_coloc <- run$time - } else { - .cbWarnNoData("xqtlColoc", "QTL data") - } - } - if (isTRUE(jointGwas)) { - if (hasSs) { - run <- .cbRunJointGwas( - individualBundle, - sumstatBundle, - hasInd, - dotArgs - ) - results$joint_gwas <- run$result - results$computing_time$Analysis$joint_gwas <- run$time - } else { - .cbWarnNoData("jointGwas", "summary-statistic data") - } - } - if (isTRUE(separateGwas)) { - if (hasSs) { - run <- .cbRunSeparateGwas( - individualBundle, - sumstatBundle, - hasInd, - dotArgs - ) - results$separate_gwas <- run$result - results$computing_time$Analysis$separate_gwas <- run$time - } else { - .cbWarnNoData("separateGwas", "summary-statistic data") - } - } + runs <- .cbDispatchRuns( + individualBundle, + sumstatBundle, + qtlSumstatBundle, + xqtlColoc, + jointGwas, + separateGwas, + hasInd, + hasSs, + hasQtlSs, + focalTrait, + methodArgs + ) + results <- .cbMergeRuns(empty, runs) .cbToResultObject( results, .cbOutcomeInfo(individualBundle, sumstatBundle, hasInd), @@ -904,39 +1055,80 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # key: without it the separate-GWAS sets would be indistinguishable from each # other once flattened. # @noRd -.cbToResultObject <- function(results, outcomeInfo, ldSketch = NULL) { - runs <- list() - analysis <- character(0) - gwasStudy <- character(0) - for (nm in c("xqtl_coloc", "joint_gwas")) { - if (!is.null(results[[nm]])) { - runs[[length(runs) + 1L]] <- results[[nm]] - analysis <- c(analysis, nm) - gwasStudy <- c(gwasStudy, NA_character_) - } +# @noRd +.cbJointRun <- function(nm, results) { + if (is.null(results[[nm]])) { + return(NULL) + } + list(run = results[[nm]], analysis = nm, gwasStudy = NA_character_) +} + +# @noRd +.cbSeparateRun <- function(i, sep, keys) { + if (is.null(sep[[i]])) { + return(NULL) + } + list(run = sep[[i]], analysis = "separate_gwas", gwasStudy = keys[[i]]) +} + +# One character field across run records, empty-safe. +# @noRd +.cbEntryField <- function(entries, field) { + if (length(entries) == 0L) { + return(character(0)) } + map_chr(entries, field) +} + +.cbToResultObject <- function(results, outcomeInfo, ldSketch = NULL) { sep <- results$separate_gwas - if (!is.null(sep) && length(sep) > 0L) { - keys <- names(sep) %||% as.character(seq_along(sep)) - for (i in seq_along(sep)) { - if (is.null(sep[[i]])) { - next - } - runs[[length(runs) + 1L]] <- sep[[i]] - analysis <- c(analysis, "separate_gwas") - gwasStudy <- c(gwasStudy, keys[[i]]) - } + sepRuns <- if (is.null(sep) || length(sep) == 0L) { + list() + } else { + compact(map( + seq_along(sep), + .cbSeparateRun, + sep = sep, + keys = names(sep) %||% as.character(seq_along(sep)) + )) } + # One record per run, so the three parallel vectors are read off a single + # list instead of being grown in step with each other. + entries <- c( + compact(map( + c("xqtl_coloc", "joint_gwas"), + .cbJointRun, + results = results + )), + sepRuns + ) ColocBoostResult( - results = runs, - analysis = analysis, - gwasStudy = gwasStudy, + results = map(entries, "run"), + analysis = .cbEntryField(entries, "analysis"), + gwasStudy = .cbEntryField(entries, "gwasStudy"), outcomeInfo = outcomeInfo, ldSketch = ldSketch, computingTime = results$computing_time %||% list() ) } +# The xQTL-only run's progress line, which names the summary-statistic +# studies only when there are any. +# @noRd +.cbAnnounceXqtl <- function(nCtx, nSs) { + msg <- if (nSs > 0L) { + glue( + "====== Performing xQTL-only ColocBoost on {nCtx} contexts ", + "and {nSs} summary-statistic studies. =====" + ) + } else { + glue( + "====== Performing xQTL-only ColocBoost on {nCtx} contexts. =====" + ) + } + inform(msg) +} + # xQTL-only ColocBoost run -> list(result, time). # # Either side may be absent: `individualBundle` is NULL for a summary-level @@ -950,7 +1142,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { sumstatBundle, hasInd, focalTrait, - dotArgs + methodArgs ) { traits <- c( if (hasInd) individualBundle$outcomeNames else character(), @@ -963,17 +1155,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } nCtx <- if (hasInd) length(individualBundle$Y) else 0L nSs <- length(sumstatBundle$sumstat) - msg <- if (nSs > 0L) { - glue( - "====== Performing xQTL-only ColocBoost on {nCtx} contexts ", - "and {nSs} summary-statistic studies. =====" - ) - } else { - glue( - "====== Performing xQTL-only ColocBoost on {nCtx} contexts. =====" - ) - } - inform(msg) + .cbAnnounceXqtl(nCtx, nSs) ldArgs <- if (nSs > 0L) .cbBuildLdArgs(sumstatBundle$LD) else list() args <- c( list( @@ -991,7 +1173,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { output_level = 2 ), ldArgs, - dotArgs + # as.list(): c() would append the MethodOptions record as one opaque + # element instead of splicing its entries, and exec() would then hand + # that object to colocboost as a positional argument. + as.list(methodArgs) ) run <- .cbRun("xQTL-only ColocBoost", args) list(result = run$result, time = run$time) @@ -1006,20 +1191,19 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # invented. # @noRd .cbOutcomeInfo <- function(individualBundle, sumstatBundle, hasInd) { - parts <- list() - if (isTRUE(hasInd) && !is.null(individualBundle$outcomeInfo)) { - parts[[length(parts) + 1L]] <- individualBundle$outcomeInfo - } ssNames <- names(sumstatBundle$sumstat) - if (length(ssNames) > 0L) { - parts[[length(parts) + 1L]] <- tibble( - name = ssNames, - context = NA_character_, - trait = NA_character_, - study = ssNames, - dataForm = "sumstats" - ) - } + parts <- compact(list( + if (isTRUE(hasInd)) individualBundle$outcomeInfo, + if (length(ssNames) > 0L) { + tibble( + name = ssNames, + context = NA_character_, + trait = NA_character_, + study = ssNames, + dataForm = "sumstats" + ) + } + )) if (length(parts) == 0L) { return(.cbEmptyOutcomeInfo()) } @@ -1039,7 +1223,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Joint (non-focal) QTL + GWAS run -> list(result, time). # @noRd -.cbRunJointGwas <- function(individualBundle, sumstatBundle, hasInd, dotArgs) { +.cbRunJointGwas <- function( + individualBundle, + sumstatBundle, + hasInd, + methodArgs +) { traits <- c( if (hasInd) individualBundle$outcomeNames else character(), names(sumstatBundle$sumstat) @@ -1064,7 +1253,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { output_level = 2 ), ldArgs, - dotArgs + # as.list(): c() would append the MethodOptions record as one opaque + # element instead of splicing its entries, and exec() would then hand + # that object to colocboost as a positional argument. + as.list(methodArgs) ) run <- .cbRun("Joint GWAS ColocBoost", args) list(result = run$result, time = run$time) @@ -1076,7 +1268,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle, sumstatBundle, hasInd, - dotArgs + methodArgs ) { ssNames <- names(sumstatBundle$sumstat) t1 <- Sys.time() @@ -1088,7 +1280,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle = individualBundle, sumstatBundle = sumstatBundle, hasInd = hasInd, - dotArgs = dotArgs + methodArgs = methodArgs ), ssNames ) @@ -1115,7 +1307,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle, sumstatBundle, hasInd, - dotArgs + methodArgs ) { ldIdx <- sumstatBundle$dict_sumstatLD[i, 2L] ldArgs <- .cbBuildLdArgs(sumstatBundle$LD[ldIdx]) @@ -1140,7 +1332,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { output_level = 2 ), ldArgs, - dotArgs + # as.list(): c() would append the MethodOptions record as one opaque + # element instead of splicing its entries, and exec() would then hand + # that object to colocboost as a positional argument. + as.list(methodArgs) ) .cbRun(str_c("Separate GWAS ColocBoost for ", study), args)$result } @@ -1164,13 +1359,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ia <- mm$idxA[o] ib <- mm$idxB[o] sgn <- mm$sign[o] - out <- m[, ia, drop = FALSE] - flip <- which(sgn == -1) - if (length(flip) > 0L) { - out[, flip] <- -out[, flip] - } - colnames(out) <- canonical[ib] - out + # sgn is +1 / -1 per matched column, so one sweep applies every flip. + out <- sweep(m[, ia, drop = FALSE], 2L, sgn, FUN = "*") + `colnames<-`(out, canonical[ib]) } # Relabel a (sumstat, LD) pair to the canonical coding: flip the z-score and the @@ -1188,11 +1379,15 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ia <- mm$idxA[o] ib <- mm$idxB[o] sgn <- mm$sign[o] - ss <- p$sumstat[ia, , drop = FALSE] - ss$z <- ss$z * sgn - ss$variant <- canonical[ib] - ld <- p$LD[ia, ia, drop = FALSE] * outer(sgn, sgn) - dimnames(ld) <- list(canonical[ib], canonical[ib]) + ss <- mutate( + p$sumstat[ia, , drop = FALSE], + z = .data$z * sgn, + variant = canonical[ib] + ) + ld <- `dimnames<-`( + p$LD[ia, ia, drop = FALSE] * outer(sgn, sgn), + list(canonical[ib], canonical[ib]) + ) list(sumstat = ss, LD = ld, variantIds = canonical[ib]) } @@ -1205,18 +1400,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # locus. Only invoked when alleleFlip = TRUE. # @noRd .cbHarmonizeAlleles <- function(individualBundle, pairs) { - ids <- character(0) - if (!is.null(individualBundle)) { - ids <- c( - ids, - unlist(map(individualBundle$X, colnames), use.names = FALSE) - ) - } - ids <- c( - ids, - unlist(map(pairs, list("sumstat", "variant")), use.names = FALSE) + allIds <- c( + if (!is.null(individualBundle)) { + unname(list_c(map(individualBundle$X, colnames))) + }, + unname(list_c(map(pairs, list("sumstat", "variant")))) ) - ids <- unique(ids[!is.na(ids)]) + ids <- unique(allIds[!is.na(allIds)]) if (length(ids) == 0L) { return(list(individualBundle = individualBundle, pairs = pairs)) } @@ -1224,16 +1414,37 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) locus <- if_else(ok, str_c(parsed$chrom, parsed$pos, sep = ":"), ids) canonical <- ids[!duplicated(locus)] - if (!is.null(individualBundle)) { - individualBundle$X <- map( - individualBundle$X, - .cbFlipMatrixToCanonical, - canonical = canonical + flipped <- if (is.null(individualBundle)) { + NULL + } else { + list_assign( + individualBundle, + X = map( + individualBundle$X, + .cbFlipMatrixToCanonical, + canonical = canonical + ) ) } - pairs <- map(pairs, .cbFlipPairToCanonical, canonical = canonical) - pairs <- pairs[!map_lgl(pairs, is.null)] - list(individualBundle = individualBundle, pairs = pairs) + list( + individualBundle = flipped, + pairs = compact( + map(pairs, .cbFlipPairToCanonical, canonical = canonical) + ) + ) +} + +# Harmonize allele coding across all sources to a shared per-locus +# canonical so swapped variants are combined with a consistent sign +# (alleleFlip = TRUE); alleleFlip = FALSE leaves the names-only +# canonicalization done at the source builders, which keeps swapped +# variants distinct. +# @noRd +.cbMaybeHarmonize <- function(individualBundle, combinedPairs, alleleFlip) { + if (!isTRUE(alleleFlip)) { + return(list(individualBundle = individualBundle, pairs = combinedPairs)) + } + .cbHarmonizeAlleles(individualBundle, combinedPairs) } # Top-level driver shared by all input methods. qtlPairs and gwasPairs @@ -1248,7 +1459,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { jointGwas, separateGwas, focalTrait, - dotArgs, + methodArgs, qtlLdSketch = NULL, alleleFlip = TRUE, cutoffs = NULL @@ -1263,30 +1474,26 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { qtlLdSketch, cutoffs = cutoffs ) - # Harmonize allele coding across all sources to a shared per-locus canonical - # so swapped variants are combined with a consistent sign (alleleFlip = - # TRUE); alleleFlip = FALSE leaves the names-only canonicalization done at - # the source builders, which keeps swapped variants distinct. - if (isTRUE(alleleFlip)) { - harmonized <- .cbHarmonizeAlleles(individualBundle, combinedPairs) - individualBundle <- harmonized$individualBundle - combinedPairs <- harmonized$pairs - } - sumstatBundle <- .cbMergeSumstatBundles(combinedPairs) + harmonized <- .cbMaybeHarmonize( + individualBundle, + combinedPairs, + alleleFlip + ) + sumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs) # The xQTL-only run gets its own bundle over just the QTL-side pairs, so # a GWAS study is never treated as an xQTL outcome. Rebuilding it through # .cbMergeSumstatBundles (rather than subsetting the merged one) keeps the # deduplicated LD list and dict_sumstatLD consistent for the subset. - qtlKeys <- intersect(names(combinedPairs), names(qtlPairs)) - qtlSumstatBundle <- .cbMergeSumstatBundles(combinedPairs[qtlKeys]) + qtlKeys <- intersect(names(harmonized$pairs), names(qtlPairs)) + qtlSumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs[qtlKeys]) .cbRunVariants( - individualBundle, + harmonized$individualBundle, sumstatBundle, xqtlColoc, jointGwas, separateGwas, focalTrait, - dotArgs, + methodArgs, qtlLdSketch = qtlLdSketch, qtlSumstatBundle = qtlSumstatBundle ) @@ -1310,17 +1517,17 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { .cbRequireMatchingLdSketches(qtlLdSketch, getLdSketch(gwasSumStats)) } gwasPairs <- .cbGwasSumStatsBundle(gwasSumStats, cutoffs = cutoffs) - combinedPairs <- qtlPairs - for (label in names(gwasPairs)) { - key <- label - if (is_in(key, names(combinedPairs))) { - key <- make.unique( - c(names(combinedPairs), key) - )[length(combinedPairs) + 1L] - } - combinedPairs[[key]] <- gwasPairs[[label]] + if (length(gwasPairs) == 0L) { + return(qtlPairs) } - combinedPairs + # Disambiguating one label at a time against the names so far gives the + # same answer as one make.unique() over the whole sequence, since it too + # renames left to right and leaves the first occurrence alone. + keys <- make.unique(c(names(qtlPairs), names(gwasPairs))) + c( + qtlPairs, + set_names(gwasPairs, keys[length(qtlPairs) + seq_along(gwasPairs)]) + ) } # ============================================================================= @@ -1328,45 +1535,50 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # ============================================================================= # The QtlDataset colocboost run: screen spec, individual-level bundle, shared -# driver. Split out so the method is only its signature -- twenty formals plus -# a body is past the length a reviewer (or BiocCheck) will accept, and the -# signature is the part that cannot be shortened. -# `p` is the method's named arguments; `dots` is its `...`, which -# as.list(environment()) does not capture. +# driver. Split out so the method body stays short; the arguments are passed +# explicitly rather than bundled, so a rename is a compile-time error and the +# dependency of each helper is visible. # @noRd -.cbQtlDatasetDrive <- function(p, dots) { - screenSpec <- .cbScreenSpec( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip - ) +.cbQtlDatasetDrive <- function( + qtlData, + gwasSumStats, + contexts, + traitId, + region, + cisWindow, + focalTrait, + xqtlColoc, + jointGwas, + separateGwas, + samples, + panelFilterArgs, + signalScreenArgs, + alleleFlip, + methodArgs +) { + screenSpec <- .screenResolve(signalScreenArgs) indBundle <- .cbIndividualBundle( - p$qtlData, - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - samples = p$samples, + qtlData, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, pipCutoffToSkip = screenSpec ) .cbDriver( indBundle, qtlPairs = list(), - p$gwasSumStats, - p$xqtlColoc, - p$jointGwas, - p$separateGwas, - p$focalTrait, - dots, - alleleFlip = p$alleleFlip, + gwasSumStats, + xqtlColoc, + jointGwas, + separateGwas, + focalTrait, + methodArgs, + alleleFlip = alleleFlip, # The QTL side is individual-level here, but the GWAS side may still # be sumstats, so the panel cutoffs still apply to it. - cutoffs = .panelCutoffs(list( - mafCutoff = p$mafCutoff, - macCutoff = p$macCutoff, - imissCutoff = p$imissCutoff - )) + cutoffs = .panelCutoffs(panelFilterArgs) ) } @@ -1388,17 +1600,34 @@ setMethod( jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, + panelFilterArgs = PanelFilterParam(), + signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, - ... + # `list()`, not ColocboostOptions(): the formal shadows the + # constructor, so a constructor-call default is a recursive + # reference. An empty list is the "no options" spelling + # .assertMethodOptions already accepts; anything else must be built. + methodArgs = ColocboostOptions() ) { - .cbQtlDatasetDrive(as.list(environment()), list(...)) + .assertMethodOptions(methodArgs, "ColocboostOptions", "methodArgs") + .cbAssertAnyRun(xqtlColoc, jointGwas, separateGwas) + .cbQtlDatasetDrive( + qtlData = qtlData, + gwasSumStats = gwasSumStats, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + focalTrait = focalTrait, + xqtlColoc = xqtlColoc, + jointGwas = jointGwas, + separateGwas = separateGwas, + samples = samples, + panelFilterArgs = panelFilterArgs, + signalScreenArgs = signalScreenArgs, + alleleFlip = alleleFlip, + methodArgs = methodArgs + ) } ) @@ -1412,25 +1641,18 @@ setMethod( gwasSumStats = NULL, contexts = NULL, traitId = NULL, - region = NULL, - cisWindow = NULL, focalTrait = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, alleleFlip = TRUE, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + panelFilterArgs = PanelFilterParam(), + methodArgs = ColocboostOptions() ) { + .assertMethodOptions(methodArgs, "ColocboostOptions", "methodArgs") + .cbAssertAnyRun(xqtlColoc, jointGwas, separateGwas) .cbRequireSumStatsQc(qtlData, "qtlData") - dotArgs <- list(...) - cutoffs <- .panelCutoffs(list( - mafCutoff = mafCutoff, - macCutoff = macCutoff, - imissCutoff = imissCutoff - )) + cutoffs <- .panelCutoffs(panelFilterArgs) qtlPairs <- .cbQtlSumStatsBundle( qtlData, contexts = contexts, @@ -1445,7 +1667,7 @@ setMethod( jointGwas = jointGwas, separateGwas = separateGwas, focalTrait = focalTrait, - dotArgs = dotArgs, + methodArgs = methodArgs, qtlLdSketch = getLdSketch(qtlData), alleleFlip = alleleFlip, cutoffs = cutoffs @@ -1470,51 +1692,85 @@ setMethod( jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, + panelFilterArgs = PanelFilterParam(), + signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, - ... + # `list()`, not ColocboostOptions(): the formal shadows the + # constructor, so a constructor-call default is a recursive + # reference. An empty list is the "no options" spelling + # .assertMethodOptions already accepts; anything else must be built. + methodArgs = ColocboostOptions() ) { - p <- as.list(environment()) - p$dotArgs <- list(...) - .cbPipelineMultiStudy(p) + .assertMethodOptions(methodArgs, "ColocboostOptions", "methodArgs") + .cbAssertAnyRun(xqtlColoc, jointGwas, separateGwas) + .cbPipelineMultiStudy( + qtlData = qtlData, + gwasSumStats = gwasSumStats, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + focalTrait = focalTrait, + xqtlColoc = xqtlColoc, + jointGwas = jointGwas, + separateGwas = separateGwas, + samples = samples, + panelFilterArgs = panelFilterArgs, + signalScreenArgs = signalScreenArgs, + alleleFlip = alleleFlip, + methodArgs = methodArgs + ) } ) # MultiStudyQtlDataset colocboost worker: aggregate the per-study individual # bundles + embedded sumstats, then dispatch to the shared driver. # @noRd -.cbPipelineMultiStudy <- function(p) { - screenSpec <- .cbScreenSpec( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip - ) - indBundle <- .cbMultiStudyIndBundle(p, screenSpec) - cutoffs <- .panelCutoffs(p) +.cbPipelineMultiStudy <- function( + qtlData, + gwasSumStats, + contexts, + traitId, + region, + cisWindow, + focalTrait, + xqtlColoc, + jointGwas, + separateGwas, + samples, + panelFilterArgs, + signalScreenArgs, + alleleFlip, + methodArgs +) { + screenSpec <- .screenResolve(signalScreenArgs) + indBundle <- .cbMultiStudyIndBundle( + qtlData = qtlData, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + screenSpec = screenSpec + ) + cutoffs <- .panelCutoffs(panelFilterArgs) ss <- .cbMultiStudySumstats( - p$qtlData, - p$contexts, - p$traitId, + qtlData, + contexts, + traitId, cutoffs = cutoffs ) .cbDriver( indBundle, ss$qtlPairs, - p$gwasSumStats, - p$xqtlColoc, - p$jointGwas, - p$separateGwas, - p$focalTrait, - p$dotArgs, + gwasSumStats, + xqtlColoc, + jointGwas, + separateGwas, + focalTrait, + methodArgs, qtlLdSketch = ss$qtlLdSketch, - alleleFlip = p$alleleFlip, + alleleFlip = alleleFlip, cutoffs = cutoffs ) } @@ -1524,48 +1780,100 @@ setMethod( # outcomes when two studies share a trait. Returns the combined bundle or NULL. # (Sequential offset-shifted merge -- kept as a loop.) # @noRd -.cbMultiStudyIndBundle <- function(p, screenSpec) { - qtlDatasets <- getQtlDatasets(p$qtlData) - combinedX <- list() - combinedY <- list() - combinedDict <- matrix(integer(0), ncol = 2L) - colnames(combinedDict) <- c("Y", "X") - combinedOutcomes <- character() - combinedInfo <- list() - for (study in names(qtlDatasets)) { - sub <- .cbIndividualBundle( - qtlDatasets[[study]], - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - samples = p$samples, - pipCutoffToSkip = screenSpec - ) - if (is.null(sub)) { - next - } - sub <- .cbPrefixStudyNames(sub, study) - xOffset <- length(combinedX) - yOffset <- length(combinedY) - combinedX <- c(combinedX, sub$X) - combinedY <- c(combinedY, sub$Y) - shifted <- sub$dict_YX - shifted[, "Y"] <- shifted[, "Y"] + yOffset - shifted[, "X"] <- shifted[, "X"] + xOffset - combinedDict <- rbind(combinedDict, shifted) - combinedOutcomes <- c(combinedOutcomes, sub$outcomeNames) - combinedInfo[[length(combinedInfo) + 1L]] <- sub$outcomeInfo +# One study's bundle with its names study-prefixed, or NULL when it has +# nothing to contribute. +# @noRd +.cbStudyBundle <- function( + study, + qtlDatasets, + contexts, + traitId, + region, + cisWindow, + samples, + screenSpec +) { + sub <- .cbIndividualBundle( + qtlDatasets[[study]], + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + pipCutoffToSkip = screenSpec + ) + if (is.null(sub)) { + return(NULL) } + .cbPrefixStudyNames(sub, study) +} + +# @noRd +.cbFieldLength <- function(sub, field) { + length(sub[[field]]) +} + +# How many entries precede each element, given per-element counts. +# @noRd +.cbOffsets <- function(counts) { + cumsum(c(0L, counts))[seq_along(counts)] +} + +# Study `i`'s dict, renumbered into the combined X / Y ordering. +# @noRd +.cbShiftStudyDict <- function(i, subs, xOffsets, yOffsets) { + d <- subs[[i]]$dict_YX + cbind(Y = d[, "Y"] + yOffsets[[i]], X = d[, "X"] + xOffsets[[i]]) +} + +.cbMultiStudyIndBundle <- function( + qtlData, + contexts, + traitId, + region, + cisWindow, + samples, + screenSpec +) { + qtlDatasets <- getQtlDatasets(qtlData) + subs <- compact(map( + names(qtlDatasets), + .cbStudyBundle, + qtlDatasets = qtlDatasets, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + screenSpec = screenSpec + )) + if (length(subs) == 0L) { + return(NULL) + } + # Each study's dict indexes its own X and Y, so it shifts by however many + # entries the studies before it contributed -- a cumulative count, known + # once all the bundles are in hand rather than tracked while looping. + xOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "X")) + yOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "Y")) + combinedX <- .cbConcat(map(subs, "X")) if (length(combinedX) == 0L) { return(NULL) } list( X = combinedX, - Y = combinedY, - dict_YX = combinedDict, - outcomeNames = combinedOutcomes, - outcomeInfo = bind_rows(combinedInfo) + Y = .cbConcat(map(subs, "Y")), + dict_YX = exec( + rbind, + !!!map( + seq_along(subs), + .cbShiftStudyDict, + subs = subs, + xOffsets = xOffsets, + yOffsets = yOffsets + ) + ), + outcomeNames = .cbConcat(map(subs, "outcomeNames")), + outcomeInfo = bind_rows(map(subs, "outcomeInfo")) ) } @@ -1573,17 +1881,29 @@ setMethod( # outcome names). # @noRd .cbPrefixStudyNames <- function(sub, study) { - names(sub$X) <- str_c(study, names(sub$X), sep = ":") - sub$outcomeNames <- str_c(study, sub$outcomeNames, sep = ":") - names(sub$Y) <- sub$outcomeNames + outcomeNames <- str_c(study, sub$outcomeNames, sep = ":") + renamed <- list_assign( + sub, + X = set_names(sub$X, str_c(study, names(sub$X), sep = ":")), + Y = set_names(sub$Y, outcomeNames), + outcomeNames = outcomeNames + ) # The lookup table is keyed on the outcome NAME, so it has to be renamed in # the same pass -- a stale key silently drops every outcome of this study # from the identity join. - if (!is.null(sub$outcomeInfo) && nrow(sub$outcomeInfo) > 0L) { - sub$outcomeInfo$name <- str_c(study, sub$outcomeInfo$name, sep = ":") - sub$outcomeInfo$study <- study - } - sub + if (is.null(sub$outcomeInfo) || nrow(sub$outcomeInfo) == 0L) { + return(renamed) + } + # `studyLabel` so the data mask cannot shadow it with the `study` column. + studyLabel <- study + list_assign( + renamed, + outcomeInfo = mutate( + sub$outcomeInfo, + name = str_c(studyLabel, .data$name, sep = ":"), + study = studyLabel + ) + ) } # Sumstat side of a MultiStudyQtlDataset: bundle any embedded QtlSumStats. @@ -1611,22 +1931,6 @@ setMethod( ) } -#' @rdname colocboostPipeline -#' @export -setMethod( - "colocboostPipeline", - "ANY", - function(qtlData, gwasSumStats = NULL, ...) { - cls <- class(qtlData)[[1L]] - msg <- glue( - "colocboostPipeline does not accept inputs of class ", - "'{cls}'. Pass a QtlDataset, QtlSumStats, or ", - "MultiStudyQtlDataset for QTL data." - ) - abort(msg) - } -) - # ---- map/apply helpers (lambda-free callbacks) --------------------------- # TRUE when a matrix is non-square (a samples x variants genotype reference). @@ -1649,7 +1953,7 @@ setMethod( individualBundle, sumstatBundle, hasInd, - dotArgs + methodArgs ) { .cbRunOneSeparateGwas( i, @@ -1657,6 +1961,56 @@ setMethod( individualBundle, sumstatBundle, hasInd, - dotArgs + methodArgs + ) +} + +#' @title colocboost Engine Settings +#' @description Additional arguments forwarded to +#' \code{colocboost::colocboost}. Names are checked against that +#' function's own formals, so a misspelled option is an error here rather +#' than a setting silently dropped inside the run. +#' +#' The data arguments \code{colocboostPipeline} assembles itself --- +#' \code{X}, \code{Y}, \code{sumstat}, \code{LD}, \code{X_ref}, +#' \code{focal_outcome_idx} --- are not settable here. +#' @param ... Named \code{colocboost::colocboost} arguments. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' ColocboostOptions(M = 5) +#' @export +ColocboostOptions <- function(...) { + extra <- list(...) + .cbRefusePipelineOwned(extra) + .newMethodOptions( + "colocboost::colocboost", + defaults = list(), + extra = extra, + label = "ColocboostOptions", + engine = "colocboost" ) } + +# Run colocboost() with tryCatch + timing. +#' @importFrom rlang try_fetch +.cbRun <- function(label, args) { + # Engine-call exception: colocboost's whole interface is two blocks -- + # this and ColocboostOptions -- so a colocboostWrapper.R would hold ~50 + # lines against this file's 1900. Kept inline deliberately. + if (!requireNamespace("colocboost", quietly = TRUE)) { + abort("The colocboost package is required for colocboostPipeline().") + } + t1 <- Sys.time() + # Callers splice the flattened bundle in with the assembled data slots; + # drop the slots that resolved to NULL before handing them over. + args <- compact(args) + res <- try_fetch( + exec(colocboost::colocboost, !!!args), + error = function(cnd) { + msg <- glue("{label} failed") + inform(msg, parent = cnd) + NULL + } + ) + list(result = res, time = Sys.time() - t1) +} diff --git a/R/cpp11.R b/R/cpp11.R index 82638e610..725ad5d98 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -1,7 +1,7 @@ # Generated by cpp11: do not edit by hand -dentistIterativeImpute <- function(ldMatR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, ncpus, correctChenEtAlBug, verbose, seed) { - .Call(`_pecotmr_dentistIterativeImpute`, ldMatR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, ncpus, correctChenEtAlBug, verbose, seed) +dentistIterativeImpute <- function(ldMatR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed) { + .Call(`_pecotmr_dentistIterativeImpute`, ldMatR, nSample, zScoreR, pValueThreshold, propSVD, gcControl, nIter, gPvalueThreshold, numThreads, correctChenEtAlBug, verbose, seed) } lassosumRssRcpp <- function(zR, LD, lambdaR, thr, maxiter) { @@ -20,6 +20,6 @@ qtlEnrichmentRcpp <- function(rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrin .Call(`_pecotmr_qtlEnrichmentRcpp`, rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) } -sdprRcpp <- function(bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, nThreads, optLlk, verbose, seed) { - .Call(`_pecotmr_sdprRcpp`, bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, nThreads, optLlk, verbose, seed) +sdprRcpp <- function(bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) { + .Call(`_pecotmr_sdprRcpp`, bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) } diff --git a/R/crossValidation.R b/R/crossValidation.R index 2e85d295f..90b0384a6 100644 --- a/R/crossValidation.R +++ b/R/crossValidation.R @@ -1,3 +1,6 @@ +#' @include MethodParam.R +NULL + # ============================================================================= # Cross-validation engine (shared by twasWeightsCv + fine-mapping CV) # ----------------------------------------------------------------------------- @@ -49,18 +52,35 @@ } lmFit <- stats::lm(actual ~ pred) s <- summary(lmFit) - out["corr"] <- stats::cor(actual, pred) - out["rsq"] <- s$r.squared - out["adj_rsq"] <- s$adj.r.squared - out["pval"] <- if (nrow(s$coefficients) >= 2L) { - s$coefficients[2L, 4L] - } else { - NA_real_ - } res <- actual - pred - out["RMSE"] <- sqrt(mean(res^2)) - out["MAE"] <- mean(abs(res)) - out + c( + corr = stats::cor(actual, pred), + rsq = s$r.squared, + adj_rsq = s$adj.r.squared, + pval = if (nrow(s$coefficients) >= 2L) { + s$coefficients[2L, 4L] + } else { + NA_real_ + }, + RMSE = sqrt(mean(res^2)), + MAE = mean(abs(res)) + ) +} + +# A canonical fingerprint of a Sample/Fold partition, used to prove that +# per-fold fits handed to twasWeightsCv were trained on the same folds it is +# scoring. Sample order is normalised first, so two partitions that assign the +# same samples to the same folds agree regardless of row order. +# @noRd +.cvPartitionKey <- function(samplePartition) { + if (is.null(samplePartition)) { + return(NULL) + } + tbl <- samplePartition |> + arrange(.data$Sample, .data$Fold) |> + mutate(.key = str_c(.data$Sample, "=", .data$Fold)) |> + pull(".key") + rlang::hash(tbl) } # One CV fold: split train/test by fold `j`, drop zero-variance training @@ -74,7 +94,7 @@ foldIds <- cv$foldIds fitFold <- cv$fitFold fitFoldCtx <- cv$fitFoldCtx - retainFits <- cv$retainFits + fitRetention <- cv$fitRetention verbose <- cv$verbose if (verbose >= 1) { msg <- glue(" CV fold {j}/{length(foldIds)} ...") @@ -85,14 +105,17 @@ if (all(isTest) || !any(isTest)) { return(list(preds = list(), fits = list())) } - Xtr <- X[!isTest, , drop = FALSE] + trainAll <- X[!isTest, , drop = FALSE] Xte <- X[isTest, , drop = FALSE] Ytr <- Y[!isTest, , drop = FALSE] - keep <- .nonzeroVarColumns(Xtr) - Xtr <- Xtr[, keep, drop = FALSE] + keep <- .nonzeroVarColumns(trainAll) + Xtr <- trainAll[, keep, drop = FALSE] ff <- fitFold(Xtr, Ytr, j, fitFoldCtx) preds <- map(ff$weights, .cvFoldPrediction, Xte = Xte) - list(preds = preds, fits = if (isTRUE(retainFits)) ff$fits else list()) + list( + preds = preds, + fits = if (identical(fitRetention, "none")) list() else ff$fits + ) } # No-op fold fitter: used when the caller only wants the fold partition. @@ -114,7 +137,7 @@ # and keys the output via .cvOutputKey(). `maxNumVariants` (optional) randomly # subsamples variants up front to bound compute; `numThreads` parallelises the # fold loop (-1 = all cores, 0/1 = serial). -#' @importFrom BiocParallel bplapply bpworkers MulticoreParam +#' @importFrom BiocParallel bplapply multicoreWorkers MulticoreParam #' @importFrom stats sd lm cor #' @importFrom dplyr n_distinct #' @noRd @@ -128,10 +151,11 @@ numThreads = 1, maxNumVariants = NULL, variantsToKeep = NULL, - retainFits = FALSE, + fitRetention = c("none", "slim", "full"), verbose = 1, seed = NULL ) { + fitRetention <- arg_match(fitRetention) .applySeed(seed) prep <- .cvPrepareData(X, Y, fold, verbose) X <- .cvSubsampleVariants(prep$X, maxNumVariants, variantsToKeep, verbose) @@ -152,7 +176,7 @@ foldIds = foldIds, fitFold = fitFold, fitFoldCtx = fitFoldCtx, - retainFits = retainFits, + fitRetention = fitRetention, verbose = verbose, rngSeed = seed ) @@ -170,13 +194,12 @@ # Validate inputs, coerce a vector Y to a one-column matrix, and set stable # row/column dimnames on X and Y. Returns list(X, Y). # @noRd +#' @importFrom checkmate assert assertCount assertMatrix +#' @importFrom checkmate checkAtomicVector checkMatrix .cvPrepareData <- function(X, Y, fold, verbose) { - if (!is.null(fold) && (!is.numeric(fold) || fold <= 0)) { - abort("Invalid value for 'fold'. It must be a positive integer.") - } - if (!is.matrix(X) || (!is.matrix(Y) && !is.vector(Y))) { - abort("X must be a matrix and Y must be a matrix or a vector.") - } + assertCount(fold, positive = TRUE, null.ok = TRUE) + assertMatrix(X) + assert(checkMatrix(Y), checkAtomicVector(Y), .var.name = "Y") if (is.vector(Y)) { Y <- matrix(Y, ncol = 1) if (verbose >= 1) { @@ -187,9 +210,7 @@ inform(msg) } } - if (nrow(X) != nrow(Y)) { - abort("The number of rows in X and Y must be the same.") - } + assertMatrix(Y, nrows = nrow(X)) .cvSetDimnames(X, Y) } @@ -202,19 +223,22 @@ } else { str_c("sample_", seq_len(nrow(X))) } - if (is.null(rownames(X))) { - rownames(X) <- sampleNames - } - if (is.null(rownames(Y))) { - rownames(Y) <- sampleNames - } - if (is.null(colnames(X))) { - colnames(X) <- str_c("variable_", seq_len(ncol(X))) - } - if (is.null(colnames(Y))) { - colnames(Y) <- str_c("context_", seq_len(ncol(Y))) - } - list(X = X, Y = Y) + list( + X = `dimnames<-`( + X, + list( + rownames(X) %||% sampleNames, + colnames(X) %||% str_c("variable_", seq_len(ncol(X))) + ) + ), + Y = `dimnames<-`( + Y, + list( + rownames(Y) %||% sampleNames, + colnames(Y) %||% str_c("context_", seq_len(ncol(Y))) + ) + ) + ) } # Optional variant subsample (compute saver; e.g. TWAS weight CV). @@ -324,13 +348,12 @@ } # @noRd +# multicoreWorkers() rather than bpworkers(MulticoreParam()): the two answer +# the same number, but constructing a MulticoreParam costs ~0.6s (almost all +# of it garbage collection) and this runs on every fit. .cvNumCores <- function(numThreads) { - numCores <- if (numThreads == -1) { - bpworkers(MulticoreParam()) - } else { - numThreads - } - min(numCores, bpworkers(MulticoreParam())) + avail <- multicoreWorkers() + min(if (numThreads == -1) avail else numThreads, avail) } # Run each fold (parallel via BiocParallel when >= 2 cores). @@ -377,21 +400,30 @@ # @noRd .cvAggregate <- function(foldResults, Y, verbose) { metricNames <- c("corr", "rsq", "adj_rsq", "pval", "RMSE", "MAE") - methodKeys <- unique(unlist(map(foldResults, .cvPredNames))) - prediction <- list() - performance <- list() - for (mk in methodKeys) { - predMat <- .cvPredMatrix(foldResults, mk, Y) - prediction[[.cvOutputKey(mk, "predicted")]] <- predMat - performance[[.cvOutputKey(mk, "performance")]] <- .cvPerformance( - predMat, - Y, - mk, - verbose, - metricNames + methodKeys <- unique(list_c(map(foldResults, .cvPredNames))) + predMats <- map(methodKeys, .cvPredMatrix, foldResults = foldResults, Y = Y) + list( + prediction = set_names( + predMats, + map_chr(methodKeys, .cvOutputKey, suffix = "predicted") + ), + performance = set_names( + map2( + predMats, + methodKeys, + .cvPerformanceFor, + Y = Y, + verbose = verbose, + metricNames = metricNames + ), + map_chr(methodKeys, .cvOutputKey, suffix = "performance") ) - } - list(prediction = prediction, performance = performance) + ) +} + +# @noRd +.cvPerformanceFor <- function(predMat, mk, Y, verbose, metricNames) { + .cvPerformance(predMat, Y, mk, verbose, metricNames) } # @noRd @@ -402,17 +434,21 @@ # Assemble the (samples x conditions) prediction matrix for a method, scattering # each fold's held-out predictions by row name. # @noRd -.cvPredMatrix <- function(foldResults, mk, Y) { +.cvPredMatrix <- function(mk, foldResults, Y) { + # Deliberate scatter: the folds partition the samples, so each writes its + # own held-out rows once and samples in no fold stay NA. predMat <- matrix(NA_real_, nrow(Y), ncol(Y), dimnames = dimnames(Y)) - for (fr in foldResults) { - yh <- fr$preds[[mk]] - if (!is.null(yh)) { - predMat[rownames(yh), ] <- yh - } + for (yh in compact(map(foldResults, .cvFoldPreds, mk = mk))) { + predMat[rownames(yh), ] <- yh } predMat } +# @noRd +.cvFoldPreds <- function(fr, mk) { + fr$preds[[mk]] +} + # Per-condition performance metrics (conditions x metrics). # @noRd .cvPerformance <- function(predMat, Y, mk, verbose, metricNames) { @@ -424,10 +460,10 @@ mk = mk, verbose = verbose ) - perf <- exec(rbind, !!!metricRows) - colnames(perf) <- metricNames - rownames(perf) <- colnames(Y) - perf + `dimnames<-`( + exec(rbind, !!!metricRows), + list(colnames(Y), metricNames) + ) } # @noRd @@ -470,12 +506,170 @@ if (is.null(W)) { return(NULL) } - W[is.na(W)] <- 0 + W <- replace(W, is.na(W), 0) common <- intersect(colnames(Xte), rownames(W)) if (length(common) == 0L) { return(NULL) } - yhat <- Xte[, common, drop = FALSE] %*% W[common, , drop = FALSE] - rownames(yhat) <- rownames(Xte) - yhat + `rownames<-`( + Xte[, common, drop = FALSE] %*% W[common, , drop = FALSE], + rownames(Xte) + ) +} + +#' @rdname CrossValidationParam +#' @aliases CrossValidationParam-class +#' @exportClass CrossValidationParam +setClass( + "CrossValidationParam", + contains = "MethodParam", + slots = c( + folds = "numeric", + numThreads = "numeric", + samplePartition = "list_OR_NULL", + maxVariants = "numeric_OR_NULL", + weightMethods = "list_OR_NULL" + ) +) + +#' @title Cross-Validation Settings +#' @description How cross-validation runs, shared by +#' \code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}. +#' +#' \code{folds}, \code{numThreads} and \code{samplePartition} mean the same +#' thing in both. \code{maxVariants} and \code{weightMethods} are honoured +#' by \code{\link{twasWeightsPipeline}} only and are \strong{ignored} by +#' \code{\link{fineMappingPipeline}}, so one bundle can be handed to +#' either pipeline unchanged. +#' @param folds Integer. Number of folds; \code{0} (the default) or +#' \code{1} skips cross-validation. The same value in both pipelines --- +#' \code{twasWeightsPipeline} used to default to \code{5}, which made an +#' unspecified setting mean two different things. +#' @param numThreads Integer. Parallel workers for the per-fold refits. +#' \code{1} (default) is serial; \code{-1} uses all cores. Only consulted +#' when \code{folds > 1}. +#' @param samplePartition Optional pre-defined partition \code{data.frame} +#' with columns \code{Sample} and \code{Fold}. When supplied, every method +#' reuses this exact partition instead of generating a fresh one. +#' @param maxVariants Integer. Cap on the number of variants used for CV; +#' unset means no limit. \strong{\code{twasWeightsPipeline} only} --- +#' \code{fineMappingPipeline} ignores it, because it does not use the +#' \code{twasWeightsCv} engine this configures. +#' @param weightMethods Optional override of which methods are +#' cross-validated, as a character vector of tokens or a named method list. +#' Unset cross-validates every method that produced non-zero weights. +#' \strong{\code{twasWeightsPipeline} only} --- +#' \code{fineMappingPipeline} ignores it, because its \code{methods=} are +#' fine-mapping methods and its CV refits all of them. +#' @return A \code{CrossValidationParam} object, a \code{\link{MethodParam}}. +#' @examples +#' CrossValidationParam(folds = 10, numThreads = 4) +#' @export +CrossValidationParam <- function( + folds = 0, + numThreads = 1, + samplePartition = NULL, + maxVariants = NULL, + weightMethods = NULL +) { + new( + "CrossValidationParam", + folds = folds, + numThreads = numThreads, + samplePartition = samplePartition, + maxVariants = maxVariants, + weightMethods = weightMethods + ) +} + +# The fields a pipeline reads, as a plain list so call sites index it without +# caring that the caller passed a constructor result. +# @noRd +.cvResolve <- function(crossValidationArgs) { + list( + folds = crossValidationArgs$folds %||% 0, + numThreads = crossValidationArgs$numThreads %||% 1, + samplePartition = crossValidationArgs$samplePartition, + # -1 is twasWeightsCv()'s "no cap" sentinel. fineMappingPipeline + # resolves these two as well but never reads them. + maxVariants = crossValidationArgs$maxVariants %||% -1, + weightMethods = crossValidationArgs$weightMethods + ) +} + +# TRUE when cross-validation will actually run. Both 0 and 1 mean "no CV", +# and anything that needs out-of-fold predictions has to ask this rather than +# testing `folds` itself. +# @noRd +.cvEnabled <- function(crossValidationArgs) { + folds <- crossValidationArgs$folds %||% 0 + !is.null(folds) && length(folds) == 1L && !is.na(folds) && folds >= 2L +} + +# Refuse a cross-validation request on an input that has no samples to hold +# out. Summary statistics carry no individual-level data, so CV there is not +# unimplemented but meaningless -- saying so beats running to completion and +# returning results that were never cross-validated. +# @noRd +.cvRefuseOnSumstats <- function(crossValidationArgs, pipeline, cls) { + set <- names(crossValidationArgs)[ + map_lgl(as.list(crossValidationArgs), .cvFieldIsSet) + ] + if (length(set) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "{pipeline}: cross-validation is not possible on {cls} input -- ", + "it holds out samples, and summary statistics carry none. ", + "Remove CrossValidationParam({str_flatten(set, ', ')})." + )) +} + +# A field counts as "set" when it differs from the constructor's own default, +# so passing CrossValidationParam() unchanged is not mistaken for a request. +# @noRd +.cvFieldIsSet <- function(x) { + if (is.null(x)) { + return(FALSE) + } + # numThreads = 1 and folds = 0 are the no-op defaults. + !(length(x) == 1L && !is.na(x) && is.numeric(x) && (x == 0 || x == 1)) } + +# ============================================================================= +# Cross-validation settings +# ----------------------------------------------------------------------------- +# One bundle for both fineMappingPipeline() and twasWeightsPipeline(). The two +# had drifted on a setting that means the same thing in each: `cvFolds` +# defaulted to 0 in fine-mapping and 5 in TWAS. Folding them into one +# constructor is the rule the joint specification already follows. +# +# `folds` is 0 everywhere. twasWeightsPipeline used to default to 5, so the +# two pipelines disagreed on what an unspecified `cvFolds` meant; converging +# on "off unless asked" makes one bundle mean one thing. The knock-on is that +# the SR-TWAS ensemble, which needs out-of-fold predictions, no longer runs by +# default -- so `ensemble` defaults to FALSE too, and asking for an ensemble +# without folds is an error rather than a silently missing row. +# +# Two of the five fields are honoured by twasWeightsPipeline() only, and are +# IGNORED rather than rejected by fineMappingPipeline() -- one bundle the +# caller can hand to either pipeline without rewriting it: +# +# weightMethods -- selects among TWAS *weight* methods, matching tokens like +# `lasso` / `mrmash` and their `_weights` spellings. Fine mapping's +# `methods=` are fine-mapping methods and its CV refits all of them, so +# there is no weight-method set to select from. It is also the knob that +# decides whether .jointTwasCvBlocked() reaches back for a fold's +# fine-mapping fit -- a TWAS-to-fine-mapping handoff with no counterpart +# in the other direction. +# maxVariants -- caps the CV design matrix for twasWeightsCv(). Fine mapping +# does not use that engine; .fmWeightsCv() has its own loop and only +# mirrors twasWeightsCv()'s output shape. +# +# Both are documented as TWAS-only so the silence is stated, not discovered. +# +# `seed` is not here either. It seeds the whole call in both pipelines +# (fine-mapping wraps the call in withr::local_seed; TWAS also seeds the +# BiocParallel RNG for method fitting), so it is a call-level knob that CV +# happens to benefit from, not a CV setting. +# ============================================================================= diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index b0d2e3c19..163835b6e 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -1,3 +1,219 @@ +#' @include MethodParam.R +NULL + +#' @rdname CtwasPriorParam +#' @aliases CtwasPriorParam-class +#' @exportClass CtwasPriorParam +setClass( + "CtwasPriorParam", + contains = "MethodParam", + slots = c( + thin = "numeric", + niterPrefit = "numeric", + niter = "numeric", + varStructure = "character", + fallbackToPrefit = "logical" + ) +) + +#' @title cTWAS Prior-Estimation Settings +#' @description The EM stage that estimates cTWAS's group priors +#' (\code{group_prior} / \code{group_prior_var}). These are exactly the +#' settings \code{\link{estCtwasGroupPriors}} takes, so the bundle travels +#' from \code{\link{ctwasPipeline}} to that function whole. +#' @param thin Numeric. Proportion of SNPs retained when assembling region +#' data for the EM. Default \code{0.1}. This is stochastic thinning for +#' speed, unrelated to \code{\link{VariantPruningParam}}, which decides +#' which variants enter a gene's weight matrix. +#' @param niterPrefit Integer. Iterations for the prefit EM. Default +#' \code{3}. +#' @param niter Integer. Iterations for the accurate EM. Default \code{30}. +#' @param varStructure How the prior variance is shared across groups; one of +#' \code{"shared_type"} (default), \code{"shared_context"}, +#' \code{"shared_nonSNP"}, \code{"shared_all"} or \code{"independent"}. +#' @param fallbackToPrefit Logical. When the accurate EM returns NaN on +#' underpowered data, fall back to the prefit estimates rather than failing. +#' Default \code{FALSE}. A pecotmr recovery step, not a cTWAS argument. +#' @return A \code{CtwasPriorParam} object, a \code{\link{MethodParam}}. +#' @examples +#' CtwasPriorParam(thin = 1, niter = 10, fallbackToPrefit = TRUE) +#' @export +CtwasPriorParam <- function( + thin = 0.1, + niterPrefit = 3L, + niter = 30L, + varStructure = c( + "shared_type", + "shared_context", + "shared_nonSNP", + "shared_all", + "independent" + ), + fallbackToPrefit = FALSE +) { + varStructure <- arg_match(varStructure) + new( + "CtwasPriorParam", + thin = thin, + niterPrefit = niterPrefit, + niter = niter, + varStructure = varStructure, + fallbackToPrefit = fallbackToPrefit + ) +} + +#' @rdname VariantPruningParam +#' @aliases VariantPruningParam-class +#' @exportClass VariantPruningParam +setClass( + "VariantPruningParam", + contains = "MethodParam", + slots = c( + weightCutoff = "numeric", + csMinCor = "numeric", + pipRescue = "numeric", + maxVariants = "numeric" + ) +) + +#' @title Per-Gene Variant-Pruning Settings +#' @description Which variants survive into each gene's weight matrix before +#' cTWAS sees it. \code{maxVariants} caps the count; \code{csMinCor} and +#' \code{pipRescue} mark variants as must-keep so they survive the cap. +#' @param weightCutoff Numeric. Drop variants with +#' \code{|weight| < weightCutoff}. Default \code{0} (no filter). +#' @param csMinCor Numeric. Variants in a 95\% credible set whose purity +#' (\code{min_abs_corr}) is at least this are must-keep. Default +#' \code{0.8}. Requires a \code{fineMappingResult}; ignored without one. +#' @param pipRescue Numeric. Variants with PIP above this are must-keep. +#' Default \code{0} (no PIP rescue). Requires a \code{fineMappingResult}. +#' @param maxVariants Numeric. Cap on the per-gene variant count. Above it, +#' all must-keep variants are retained and the remaining slots filled by +#' descending PIP (when available) or descending \code{|weight|}. Default +#' \code{Inf} (no cap). +#' @return A \code{VariantPruningParam} object, a \code{\link{MethodParam}}. +#' @examples +#' VariantPruningParam(weightCutoff = 1e-4, maxVariants = 5000) +#' @export +VariantPruningParam <- function( + weightCutoff = 0, + csMinCor = 0.8, + pipRescue = 0, + maxVariants = Inf +) { + new( + "VariantPruningParam", + weightCutoff = weightCutoff, + csMinCor = csMinCor, + pipRescue = pipRescue, + maxVariants = maxVariants + ) +} + +#' @rdname BoundaryMergeParam +#' @aliases BoundaryMergeParam-class +#' @exportClass BoundaryMergeParam +setClass( + "BoundaryMergeParam", + contains = "MethodParam", + slots = c( + enabled = "logical", + pipThreshold = "numeric", + filterCs = "logical", + maxSnp = "numeric" + ) +) + +#' @title Boundary-Region Merge Settings +#' @description Whether a high-PIP gene whose cis window straddles an +#' LD-block boundary has its adjacent regions merged and re-fine-mapped +#' after each run (\code{\link{mergeCtwasBoundaryRegions}}). +#' @param enabled Logical. Run the merge step. Default \code{FALSE}; the +#' other three fields are read only when this is \code{TRUE}. +#' @param pipThreshold Numeric. PIP threshold for selecting which boundary +#' genes to merge. Default \code{0.5}. +#' @param filterCs Logical. Require the boundary gene to be in a credible set +#' to be selected. Default \code{FALSE}. +#' @param maxSnp Numeric. Per-merged-region SNP cap. Default \code{Inf}. +#' @return A \code{BoundaryMergeParam} object, a \code{\link{MethodParam}}. +#' @examples +#' BoundaryMergeParam(enabled = TRUE, pipThreshold = 0.8) +#' @export +BoundaryMergeParam <- function( + enabled = FALSE, + pipThreshold = 0.5, + filterCs = FALSE, + maxSnp = Inf +) { + new( + "BoundaryMergeParam", + enabled = enabled, + pipThreshold = pipThreshold, + filterCs = filterCs, + maxSnp = maxSnp + ) +} + +# cTWAS arguments the pipeline owns as named settings of its own. They are +# real ctwas formals, so the union check would accept them here -- but +# .ctwasInvoke drops any name the pipeline already supplies, so a value set +# through CtwasOptions() was silently discarded. Refuse it and say where the +# setting lives instead. +# @noRd +.ctwasPipelineOwnedArgs <- function() { + c( + thin = "CtwasPriorParam(thin =)", + niter = "CtwasPriorParam(niter =)", + niter_prefit = "CtwasPriorParam(niterPrefit =)", + group_prior_var_structure = "CtwasPriorParam(varStructure =)", + L = "the pipeline's own `L`", + ncore = "the pipeline's own `numThreads`", + maxSNP = "BoundaryMergeParam(maxSnp =)" + ) +} + +# @noRd +.ctwasRefusePipelineOwned <- function(extra) { + owned <- .ctwasPipelineOwnedArgs() + clash <- intersect(names(extra), names(owned)) + if (length(clash) == 0L) { + return(invisible(NULL)) + } + where <- str_flatten( + sprintf("`%s` -> %s", clash, unname(owned[clash])), + collapse = "; " + ) + abort(glue( + "CtwasOptions: {str_flatten(clash, ', ')} ", + "{if (length(clash) == 1L) 'is' else 'are'} set by the pipeline, ", + "not through methodArgs -- a value given here is dropped. Use: ", + "{where}." + )) +} + +# Every bundle ctwasPipeline() takes, checked together. The argument names +# in the messages are the pipeline's own, which drop the `Args` suffix. +# @noRd +.ctwasAssertBundles <- function( + ctwasPriorArgs, + variantPruningArgs, + boundaryMergeArgs, + methodArgs +) { + .assertMethodParam(ctwasPriorArgs, "CtwasPriorParam", "ctwasPrior") + .assertMethodParam( + variantPruningArgs, + "VariantPruningParam", + "variantPruning" + ) + .assertMethodParam( + boundaryMergeArgs, + "BoundaryMergeParam", + "boundaryMerge" + ) + .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") +} + #' @title Causal TWAS Pipeline (cTWAS, multi LD block) #' @description Pipeline that hands a per-block set of #' \code{\link{GwasSumStats}} of GWAS Z-scores together with the matching @@ -59,30 +275,24 @@ #' present; otherwise run \strong{every} method as an independent cTWAS run #' (one \code{CtwasResult} row-set per method). Passing the name explicitly #' (e.g. \code{"mrash"}) restricts the run to that single method. -#' @param thin,niterPrefit,niter,L Pass-throughs to -#' \code{ctwas::ctwas_sumstats}. -#' @param groupPriorVarStructure Pass-through (defaults \code{"shared_type"}). -#' @param ncore Number of cores. Default \code{1}. -#' @param twasWeightCutoff Numeric (length 1). Drop variants with \code{|weight| -#' < twasWeightCutoff} from each gene's weight matrix before ctwas sees it. -#' Default \code{0} (no filter). -#' @param csMinCor Numeric (length 1). When \code{fineMappingResult} is -#' provided, variants belonging to any 95\% credible set with purity -#' (\code{min_abs_corr}) \code{>= csMinCor} are marked as must-keep and -#' survive the per-gene cap. Default \code{0.8}. Ignored without a -#' \code{fineMappingResult}. -#' @param minPipCutoff Numeric (length 1). When \code{fineMappingResult} is -#' provided, variants with PIP greater than \code{minPipCutoff} are marked as -#' must-keep and survive the per-gene cap. Default \code{0} (no PIP rescue). -#' Ignored without a \code{fineMappingResult}. -#' @param maxNumVariants Numeric (length 1). Cap on per-gene variant count. When -#' the gene has more variants than this, keep all must-keep variants and fill -#' remaining slots by descending PIP (when available) or descending -#' \code{|weight|}. Default \code{Inf} (no cap). -#' @param fallbackToPrefit Logical (length 1). Forwarded to -#' \code{\link{estCtwasParam}}. When \code{TRUE}, ctwas's accurate-EM NaN -#' failure is recovered by falling back to the prefit estimates (mirrors the -#' legacy ctwas_2 workaround on underpowered data). Default \code{FALSE}. +#' @param L Integer. Max number of single effects in cTWAS fine-mapping. +#' Default \code{5}. Pass-through to \code{ctwas::ctwas_sumstats}. +#' @param numThreads Number of cores. Default \code{1}. +#' @param ctwasPriorArgs The EM stage that estimates cTWAS's group priors, built +#' with \code{\link{CtwasPriorParam}}: \code{thin}, \code{niterPrefit}, +#' \code{niter}, \code{varStructure} and \code{fallbackToPrefit}. Handed +#' whole to \code{\link{estCtwasGroupPriors}}. +#' @param variantPruningArgs Which variants survive into each gene's weight +#' matrix, built with \code{\link{VariantPruningParam}}: +#' \code{weightCutoff}, \code{csMinCor}, \code{pipRescue} and +#' \code{maxVariants}. Handed whole to +#' \code{\link{assembleCtwasInputs}}. The \code{csMinCor} / +#' \code{pipRescue} rescues need a \code{fineMappingResult}. +#' @param boundaryMergeArgs Whether a high-PIP gene straddling an LD-block +#' boundary has its regions merged and re-fine-mapped, built with +#' \code{\link{BoundaryMergeParam}}: \code{enabled} (default +#' \code{FALSE}), \code{pipThreshold}, \code{filterCs} and +#' \code{maxSnp}. #' @param keepSnps Logical (length 1). When \code{TRUE}, retain the #' context-agnostic SNP background of each run as one extra \code{CtwasResult} #' row (\code{study = context = "SNP"}, mirroring cTWAS's own \code{"SNP"} @@ -90,21 +300,9 @@ #' \code{\link{getFinemap}} / \code{getSusieAlpha}. Default \code{FALSE} -- #' the SNP rows are the null background and are dropped from the structured #' gene-level result. -#' @param mergeBoundary Logical (length 1). When \code{TRUE}, run -#' \code{\link{mergeCtwasBoundaryRegions}} after fine-mapping each run: a -#' high-PIP gene whose cis window straddles an LD-block boundary has its -#' adjacent regions merged and re-fine-mapped (the legacy default-off -#' \code{ctwas_3} post-processing). Default \code{FALSE}. -#' @param mergePipThresh Numeric (length 1). PIP threshold for selecting which -#' boundary genes to merge (\code{\link{mergeCtwasBoundaryRegions}} -#' \code{pipThresh}). Default \code{0.5}. Ignored unless \code{mergeBoundary = -#' TRUE}. -#' @param mergeFilterCs Logical (length 1). Require the boundary gene to be in a -#' credible set to be selected. Default \code{FALSE}. Ignored unless -#' \code{mergeBoundary = TRUE}. -#' @param mergeMaxSNP Numeric (length 1). Per-merged-region SNP cap. Default -#' \code{Inf}. Ignored unless \code{mergeBoundary = TRUE}. -#' @param ... Additional arguments forwarded to \code{ctwas::ctwas_sumstats}. +#' @param methodArgs Additional arguments forwarded to ctwas, built +#' with \code{\link{CtwasOptions}}. Names are checked against what +#' the ctwas steps accept between them. #' @return A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, #' study, context, method)}. A single-context run is one row per method; a #' multi-context (joint) run emits per-context rows sharing the same @@ -113,8 +311,9 @@ #' fine-mapping posteriors (\code{finemap}), the run's \code{param}, and its #' \code{regionInfo}. For the raw \code{ctwas::finemap_regions} list (e.g. to #' feed \code{\link{mergeCtwasBoundaryRegions}}), call the granular -#' \code{\link{assembleCtwasInputs}} \eqn{\to} \code{\link{estCtwasParam}} -#' \eqn{\to} \code{\link{screenCtwasRegions}} \eqn{\to} +#' \code{\link{assembleCtwasInputs}} \eqn{\to} +#' \code{\link{estCtwasGroupPriors}} \eqn{\to} +#' \code{\link{screenCtwasRegions}} \eqn{\to} #' \code{\link{finemapCtwasRegions}} path instead. #' @examples #' data(ctwasWeightsExample) @@ -129,11 +328,13 @@ #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", #' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) -#' gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) +#' gwasByRegion <- summaryStatsQc(gss, +#' panelFilter = PanelFilterParam(mafCutoff = 0.0025)) #' ctwasPipeline(gwasSumStats = gwasByRegion, -#' twasWeights = list(ctwasWeightsExample), thin = 1, niterPrefit = 3, -#' niter = 10, min_group_size = 1, min_p_single_effect = 0, -#' fallbackToPrefit = TRUE) +#' twasWeights = list(ctwasWeightsExample), +#' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, +#' fallbackToPrefit = TRUE), +#' methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) #' @export ctwasPipeline <- function( gwasSumStats, @@ -141,37 +342,39 @@ ctwasPipeline <- function( twasZ = NULL, fineMappingResult = NULL, method = NULL, - thin = 0.1, - niterPrefit = 3L, - niter = 30L, L = 5L, - groupPriorVarStructure = c( - "shared_type", - "shared_context", - "shared_nonSNP", - "shared_all", - "independent" - ), - ncore = 1L, - twasWeightCutoff = 0, - csMinCor = 0.8, - minPipCutoff = 0, - maxNumVariants = Inf, - fallbackToPrefit = FALSE, + numThreads = 1L, + ctwasPriorArgs = CtwasPriorParam(), + variantPruningArgs = VariantPruningParam(), + boundaryMergeArgs = BoundaryMergeParam(), keepSnps = FALSE, - mergeBoundary = FALSE, - mergePipThresh = 0.5, - mergeFilterCs = FALSE, - mergeMaxSNP = Inf, - ... + methodArgs = CtwasOptions() ) { - groupPriorVarStructure <- arg_match(groupPriorVarStructure) + .ctwasAssertBundles( + ctwasPriorArgs, + variantPruningArgs, + boundaryMergeArgs, + methodArgs + ) .ctwasRequireNamedLists(gwasSumStats, twasWeights) methods <- .ctwasResolveMethods(twasWeights, method) gwasStudy <- .ctwasGwasStudy(gwasSumStats) - cfg <- as.list(environment()) - cfg$dots <- list(...) - rows <- list_flatten(map(methods, .ctwasRunMethod, cfg = cfg)) + rows <- list_flatten(map( + methods, + .ctwasRunMethod, + gwasSumStats = gwasSumStats, + twasWeights = twasWeights, + twasZ = twasZ, + fineMappingResult = fineMappingResult, + variantPruningArgs = variantPruningArgs, + ctwasPriorArgs = ctwasPriorArgs, + numThreads = numThreads, + L = L, + boundaryMergeArgs = boundaryMergeArgs, + gwasStudy = gwasStudy, + keepSnps = keepSnps, + methodArgs = methodArgs + )) if (length(rows) == 0L) { msg <- glue( "ctwasPipeline: no genes were modeled (the weight sources ", @@ -183,66 +386,117 @@ ctwasPipeline <- function( .ctwasRowsToResult(rows) } +# The cTWAS run proper: estimate the group priors, screen regions against +# them, fine-map what survived, and optionally re-fine-map the merged +# boundary regions. Each stage takes the ctwas option list as one named +# argument, so it is passed rather than spliced in as loose top-level args. +# @noRd +.ctwasRunStages <- function( + inputs, + ctwasPriorArgs, + boundaryMergeArgs, + L, + numThreads, + methodArgs +) { + est <- estCtwasGroupPriors( + inputs, + ctwasPriorArgs = ctwasPriorArgs, + numThreads = numThreads, + methodArgs = methodArgs + ) + screened <- screenCtwasRegions( + est, + numThreads = numThreads, + methodArgs = methodArgs + ) + finemap <- finemapCtwasRegions( + screened, + L = L, + numThreads = numThreads, + methodArgs = methodArgs + ) + if (!isTRUE(boundaryMergeArgs$enabled)) { + return(finemap) + } + .ctwasMaybeMerge( + finemap, + boundaryMergeArgs = boundaryMergeArgs, + L = L, + numThreads = numThreads, + methodArgs = methodArgs + ) +} + # One cTWAS run for method `m`: assemble inputs -> estimate params -> screen -> # fine-map (optionally boundary-merge) -> per-context row-specs. `cfg` bundles -# the ctwasPipeline arguments (incl. `dots` = the forwarded `...`). +# the ctwasPipeline arguments (incl. the `CtwasOptions` option list). # @noRd -.ctwasRunMethod <- function(m, cfg) { +.ctwasRunMethod <- function( + m, + gwasSumStats, + twasWeights, + twasZ, + fineMappingResult, + variantPruningArgs, + ctwasPriorArgs, + numThreads, + L, + boundaryMergeArgs, + gwasStudy, + keepSnps, + methodArgs +) { inputs <- assembleCtwasInputs( - gwasSumStats = cfg$gwasSumStats, - twasWeights = cfg$twasWeights, - twasZ = cfg$twasZ, - fineMappingResult = cfg$fineMappingResult, + gwasSumStats = gwasSumStats, + twasWeights = twasWeights, + twasZ = twasZ, + fineMappingResult = fineMappingResult, method = m, - twasWeightCutoff = cfg$twasWeightCutoff, - csMinCor = cfg$csMinCor, - minPipCutoff = cfg$minPipCutoff, - maxNumVariants = cfg$maxNumVariants + variantPruningArgs = variantPruningArgs ) - estArgs <- c( - list( - inputs, - thin = cfg$thin, - niterPrefit = cfg$niterPrefit, - niter = cfg$niter, - groupPriorVarStructure = cfg$groupPriorVarStructure, - ncore = cfg$ncore, - fallbackToPrefit = cfg$fallbackToPrefit - ), - cfg$dots + merged <- .ctwasRunStages( + inputs, + ctwasPriorArgs = ctwasPriorArgs, + boundaryMergeArgs = boundaryMergeArgs, + L = L, + numThreads = numThreads, + methodArgs = methodArgs ) - est <- exec(estCtwasParam, !!!estArgs) - screenArgs <- c(list(est, L = cfg$L, ncore = cfg$ncore), cfg$dots) - screened <- exec(screenCtwasRegions, !!!screenArgs) - finemapArgs <- c(list(screened, L = cfg$L, ncore = cfg$ncore), cfg$dots) - finemap <- exec(finemapCtwasRegions, !!!finemapArgs) - if (cfg$mergeBoundary) { - finemap <- .ctwasMaybeMerge(finemap, cfg) - } .ctwasRunToRows( - finemap, - gwasStudy = cfg$gwasStudy, + merged, + gwasStudy = gwasStudy, method = m, - keepSnps = cfg$keepSnps + keepSnps = keepSnps ) } # Boundary-gene region merging: split a high-PIP straddling gene's adjacent # regions and re-fine-map. Merge-transparent downstream (keyed by gene id). # @noRd -.ctwasMaybeMerge <- function(finemap, cfg) { - mergeArgs <- c( - list( - finemap, - pipThresh = cfg$mergePipThresh, - filterCs = cfg$mergeFilterCs, - maxSNP = cfg$mergeMaxSNP, - L = cfg$L, - ncore = cfg$ncore - ), - cfg$dots +.ctwasMaybeMerge <- function( + finemap, + boundaryMergeArgs, + L, + numThreads, + methodArgs +) { + # The bundle's terminal; mergeCtwasBoundaryRegions() takes scalars. + mergePipThresh <- boundaryMergeArgs$pipThreshold + mergeFilterCs <- boundaryMergeArgs$filterCs + mergeMaxSNP <- boundaryMergeArgs$maxSnp + # methodArgs stays a record all the way down: mergeCtwasBoundaryRegions + # takes one, and c()-ing it into an argument list would append the S4 + # object as a single element rather than splice its entries. + mergeCtwasBoundaryRegions( + finemap, + pipThresh = mergePipThresh, + filterCs = mergeFilterCs, + maxSNP = mergeMaxSNP, + L = L, + numThreads = numThreads, + methodArgs = methodArgs ) - exec(mergeCtwasBoundaryRegions, !!!mergeArgs) } #' Assemble cTWAS inputs from S4 GwasSumStats / TwasWeights @@ -254,7 +508,7 @@ ctwasPipeline <- function( #' \code{\link{ctwasPipeline}} split. #' #' @details The returned list is the SHARED STATE threaded through -#' \code{\link{estCtwasParam}} -> \code{\link{screenCtwasRegions}} -> +#' \code{\link{estCtwasGroupPriors}} -> \code{\link{screenCtwasRegions}} -> #' \code{\link{finemapCtwasRegions}}. Callers can short-circuit at any step #' (e.g. override the estimated priors before fine-mapping) or call #' \code{ctwasPipeline()} for the one-shot path. @@ -277,7 +531,8 @@ ctwasPipeline <- function( #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", #' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) -#' gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) +#' gwasByRegion <- summaryStatsQc(gss, +#' panelFilter = PanelFilterParam(mafCutoff = 0.0025)) #' assembleCtwasInputs(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample)) #' @export @@ -287,11 +542,18 @@ assembleCtwasInputs <- function( twasZ = NULL, fineMappingResult = NULL, method = NULL, - twasWeightCutoff = 0, - csMinCor = 0.8, - minPipCutoff = 0, - maxNumVariants = Inf + variantPruningArgs = VariantPruningParam() ) { + .assertMethodParam( + variantPruningArgs, + "VariantPruningParam", + "variantPruning" + ) + # The bundle's terminal: .ctwasBuildWeights and below take scalars. + twasWeightCutoff <- variantPruningArgs$weightCutoff + csMinCor <- variantPruningArgs$csMinCor + minPipCutoff <- variantPruningArgs$pipRescue + maxNumVariants <- variantPruningArgs$maxVariants .ctwasValidateGwasList(gwasSumStats) # One single-block GwasSumStats per element, keyed by blockId: the region # grid the rest of the assembly walks. @@ -329,11 +591,7 @@ assembleCtwasInputs <- function( # @noRd .ctwasValidateGwasList <- function(gwasSumStats) { if (!requireNamespace("ctwas", quietly = TRUE)) { - msg <- glue( - "Package 'ctwas' is required for the cTWAS pipeline. ", - "Install from https://github.com/xinhe-lab/ctwas ." - ) - abort(msg) + abort("Package 'ctwas' is required for the cTWAS pipeline.") } if (missing(gwasSumStats) || !methods::is(gwasSumStats, "GwasSumStats")) { msg <- glue( @@ -483,42 +741,76 @@ assembleCtwasInputs <- function( # Returns list(ldPanelsByRegion, zSnpPieces, regionInfoPieces, snpMap, # ldFileByRegion). # @noRd -.ctwasFirstPass <- function(regionIds, gwasSumStats, twasWeights) { - ldPanelsByRegion <- list() - zSnpPieces <- list() - regionInfoPieces <- list() - snpMap <- list() - ldFileByRegion <- set_names(character(length(regionIds)), regionIds) - for (rid in regionIds) { - gss <- gwasSumStats[[rid]] - tw <- twasWeights[[rid]] - gwasLd <- getLdSketch(gss) - if (is.null(gwasLd)) { - msg <- glue( - "ctwasPipeline: GwasSumStats for region '{rid}' carries no ", - "ldSketch (ldSketch = NULL); cTWAS requires an LD reference." - ) - abort(msg) - } - if (!is.null(tw)) { - .ctwasRequireMatchingLdSketches(getLdSketch(tw), gwasLd) - } - ldKey <- .ctwasLdPanelKey(gwasLd) - if (is.null(ldPanelsByRegion[[ldKey]])) { - ldPanelsByRegion[[ldKey]] <- .ctwasComputeFullPanelLd(gwasLd) - } - ldPanel <- ldPanelsByRegion[[ldKey]] - ldFileByRegion[[rid]] <- ldKey - zSnpPieces[[rid]] <- .ctwasBuildZSnp(gss, ldPanel$snpInfo$id) - regionInfoPieces[[rid]] <- .ctwasBuildSingleRegionInfo(rid, gss) - snpMap[[rid]] <- .ctwasSnpInfoForGwasBlock(gss, ldPanel$snpInfo) +# One region's GWAS LD sketch, checked against the region's weights. +# @noRd +.ctwasRegionGwasLd <- function(rid, gwasSumStats, twasWeights) { + gwasLd <- getLdSketch(gwasSumStats[[rid]]) + if (is.null(gwasLd)) { + msg <- glue( + "ctwasPipeline: GwasSumStats for region '{rid}' carries no ", + "ldSketch (ldSketch = NULL); cTWAS requires an LD reference." + ) + abort(msg) + } + tw <- twasWeights[[rid]] + if (!is.null(tw)) { + .ctwasRequireMatchingLdSketches(getLdSketch(tw), gwasLd) } + gwasLd +} + +# @noRd +.ctwasZSnpAt <- function(rid, ldPanel, gwasSumStats) { + .ctwasBuildZSnp(gwasSumStats[[rid]], ldPanel$snpInfo$id) +} + +# @noRd +.ctwasSnpMapAt <- function(rid, ldPanel, gwasSumStats) { + .ctwasSnpInfoForGwasBlock(gwasSumStats[[rid]], ldPanel$snpInfo) +} + +# @noRd +.ctwasRegionInfoAt <- function(rid, gwasSumStats) { + .ctwasBuildSingleRegionInfo(rid, gwasSumStats[[rid]]) +} + +.ctwasFirstPass <- function(regionIds, gwasSumStats, twasWeights) { + sketches <- map( + regionIds, + .ctwasRegionGwasLd, + gwasSumStats = gwasSumStats, + twasWeights = twasWeights + ) + ldKeys <- map_chr(sketches, .ctwasLdPanelKey) + # The panel cache is "compute once per distinct key": the first region + # carrying each key is the one whose sketch gets expanded, and every + # region then reads its panel back out by key. + firstOfKey <- !duplicated(ldKeys) + ldPanelsByRegion <- set_names( + map(sketches[firstOfKey], .ctwasComputeFullPanelLd), + ldKeys[firstOfKey] + ) + panels <- unname(ldPanelsByRegion[ldKeys]) list( ldPanelsByRegion = ldPanelsByRegion, - zSnpPieces = zSnpPieces, - regionInfoPieces = regionInfoPieces, - snpMap = snpMap, - ldFileByRegion = ldFileByRegion + zSnpPieces = set_names( + map2(regionIds, panels, .ctwasZSnpAt, gwasSumStats = gwasSumStats), + regionIds + ), + regionInfoPieces = set_names( + map(regionIds, .ctwasRegionInfoAt, gwasSumStats = gwasSumStats), + regionIds + ), + snpMap = set_names( + map2( + regionIds, + panels, + .ctwasSnpMapAt, + gwasSumStats = gwasSumStats + ), + regionIds + ), + ldFileByRegion = set_names(ldKeys, regionIds) ) } @@ -537,34 +829,63 @@ assembleCtwasInputs <- function( cutoffs, globalGwasSnpIds ) { - weightsList <- list() - for (rid in regionIds) { - tw <- twasWeights[[rid]] - if (is.null(tw)) { - next - } - twMethod <- .ctwasFilterMethod(tw, resolvedMethod) - if (is.null(twMethod)) { - next - } - ldPanel <- fp$ldPanelsByRegion[[fp$ldFileByRegion[[rid]]]] - blockWeights <- .ctwasBuildWeights( - twMethod, - ldPanel, - fineMappingResult = fineMappingResult, - twasWeightCutoff = cutoffs$twasWeightCutoff, - csMinCor = cutoffs$csMinCor, - minPipCutoff = cutoffs$minPipCutoff, - maxNumVariants = cutoffs$maxNumVariants, - gwasSnpIds = globalGwasSnpIds, - regionSnpIds = fp$snpMap[[rid]]$id - ) - if (length(blockWeights) > 0L) { - names(blockWeights) <- str_c(rid, "|", names(blockWeights)) - weightsList <- c(weightsList, blockWeights) - } + perRegion <- map( + regionIds, + .ctwasRegionBlockWeights, + twasWeights = twasWeights, + fp = fp, + resolvedMethod = resolvedMethod, + fineMappingResult = fineMappingResult, + cutoffs = cutoffs, + globalGwasSnpIds = globalGwasSnpIds + ) + .ctwasConcat(compact(perRegion)) +} + +# Concatenate per-region lists, empty-safe. +# @noRd +.ctwasConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) } - weightsList + list_c(pieces) +} + +# One region's block weights, region-qualified, or NULL when the region has no +# weights for the resolved method. +# @noRd +.ctwasRegionBlockWeights <- function( + rid, + twasWeights, + fp, + resolvedMethod, + fineMappingResult, + cutoffs, + globalGwasSnpIds +) { + tw <- twasWeights[[rid]] + if (is.null(tw)) { + return(NULL) + } + twMethod <- .ctwasFilterMethod(tw, resolvedMethod) + if (is.null(twMethod)) { + return(NULL) + } + blockWeights <- .ctwasBuildWeights( + twMethod, + fp$ldPanelsByRegion[[fp$ldFileByRegion[[rid]]]], + fineMappingResult = fineMappingResult, + twasWeightCutoff = cutoffs$twasWeightCutoff, + csMinCor = cutoffs$csMinCor, + minPipCutoff = cutoffs$minPipCutoff, + maxNumVariants = cutoffs$maxNumVariants, + gwasSnpIds = globalGwasSnpIds, + regionSnpIds = fp$snpMap[[rid]]$id + ) + if (length(blockWeights) == 0L) { + return(NULL) + } + set_names(blockWeights, str_c(rid, "|", names(blockWeights))) } # Concatenate the per-region pieces into the ctwas-shape input list. @@ -612,72 +933,69 @@ assembleCtwasInputs <- function( #' \code{boundary_genes}, \code{z_gene}, and \code{param}. #' #' @param inputs A list returned by \code{\link{assembleCtwasInputs}}. -#' @param thin,niterPrefit,niter Pass-throughs to -#' \code{ctwas::assemble_region_data} / \code{ctwas::est_param}. -#' @param groupPriorVarStructure Pass-through. -#' @param ncore Number of cores. -#' @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 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 -#' deliberately broad; a genuinely broken input still surfaces because the -#' prefit re-run will itself error. Mirrors the legacy ctwas_2 workaround on -#' toy data where the accurate EM cannot be estimated. -#' @param ... Additional arguments forwarded to \code{ctwas::est_param} (e.g. -#' \code{min_p_single_effect}, \code{min_group_size}). +#' @param ctwasPriorArgs The EM settings, built with +#' \code{\link{CtwasPriorParam}}: \code{thin} (SNP thinning when +#' assembling region data), \code{niterPrefit} and \code{niter} (prefit / +#' accurate EM iterations), \code{varStructure}, and +#' \code{fallbackToPrefit} -- when \code{TRUE}, an accurate EM that fails +#' on a degenerate input is recovered by re-running only the prefit step +#' and returning those (typically finite) priors. +#' @param numThreads Number of cores. +#' @param methodArgs Additional arguments forwarded to ctwas, built +#' with \code{\link{CtwasOptions}}. Names are checked against what +#' the ctwas steps accept between them. #' @return The \code{inputs} list augmented with \code{region_data}, #' \code{boundary_genes}, \code{z_gene}, and \code{param}. #' @examples #' data(ctwasInputsExample) -#' estCtwasParam(ctwasInputsExample, thin = 1, niterPrefit = 3, -#' niter = 10, min_group_size = 1, min_p_single_effect = 0, -#' fallbackToPrefit = TRUE) +#' estCtwasGroupPriors(ctwasInputsExample, +#' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, +#' fallbackToPrefit = TRUE), +#' methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) #' @export -estCtwasParam <- function( +estCtwasGroupPriors <- function( inputs, - thin = 0.1, - niterPrefit = 3L, - niter = 30L, - groupPriorVarStructure = c( - "shared_type", - "shared_context", - "shared_nonSNP", - "shared_all", - "independent" - ), - ncore = 1L, - fallbackToPrefit = FALSE, - ... + ctwasPriorArgs = CtwasPriorParam(), + numThreads = 1L, + methodArgs = CtwasOptions() ) { + .assertMethodParam(ctwasPriorArgs, "CtwasPriorParam", "ctwasPrior") + # The bundle's terminal: the EM helpers below take plain scalars. + thin <- ctwasPriorArgs$thin + niterPrefit <- ctwasPriorArgs$niterPrefit + niter <- ctwasPriorArgs$niter + groupPriorVarStructure <- ctwasPriorArgs$varStructure + fallbackToPrefit <- ctwasPriorArgs$fallbackToPrefit + .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") if (!requireNamespace("ctwas", quietly = TRUE)) { - abort("Package 'ctwas' is required for estCtwasParam.") + abort("Package 'ctwas' is required for estCtwasGroupPriors.") } - groupPriorVarStructure <- arg_match(groupPriorVarStructure) - ncore <- as.integer(ncore) + numThreads <- as.integer(numThreads) inputs <- .ctwasResolveLdPaths(inputs) - extra <- list(...) - zGene <- .ctwasEnsureZGene(inputs, ncore) - regionData <- .ctwasAssembleRegionData(inputs, zGene, thin, ncore, extra) - boundaryGenes <- .ctwasBoundaryGenes(inputs, ncore, extra) + zGene <- .ctwasEnsureZGene(inputs, numThreads, methodArgs) + regionData <- .ctwasAssembleRegionData( + inputs, + zGene, + thin, + numThreads, + methodArgs + ) + boundaryGenes <- .ctwasBoundaryGenes(inputs, numThreads, methodArgs) paramRes <- .ctwasEstParamOrFallback( regionData, niterPrefit, niter, groupPriorVarStructure, - ncore, + numThreads, thin, fallbackToPrefit, - extra + methodArgs ) # assemble_region_data does not echo z_gene back, so propagate the # precomputed z_gene we passed in (inputs$z_gene is NULL when twasZ was not # supplied) so $z_gene resolves to the right entry. - inputs$z_gene <- zGene c( - inputs, + list_assign(inputs, z_gene = zGene), list( region_data = regionData, boundary_genes = boundaryGenes, @@ -686,92 +1004,19 @@ estCtwasParam <- function( ) } -# z_gene for assemble_region_data (which requires it non-NULL): use the caller's -# inputs$z_gene, else compute via ctwas::compute_gene_z (mirrors -# ctwas_sumstats). -# @noRd -.ctwasEnsureZGene <- function(inputs, ncore) { - if (!is.null(inputs$z_gene)) { - return(inputs$z_gene) - } - ctwas::compute_gene_z(inputs$z_snp, inputs$weights, ncore = ncore) -} - -# assemble_region_data -> the per-region list (keyed by region_id). It does NOT -# echo z_gene or return boundary genes; both are recovered separately. -# @noRd -.ctwasAssembleRegionData <- function(inputs, zGene, thin, ncore, extra) { - .ctwasInvoke( - ctwas::assemble_region_data, - list( - region_info = inputs$region_info, - z_snp = inputs$z_snp, - z_gene = zGene, - weights = inputs$weights, - snp_map = inputs$snp_map, - thin = thin, - ncore = ncore - ), - extra = extra - ) -} - -# Boundary genes (computed internally by assemble_region_data for adjustment but -# never returned) recovered via ctwas::get_boundary_genes; NULL for one region. -# @noRd -.ctwasBoundaryGenes <- function(inputs, ncore, extra) { - if (nrow(inputs$region_info) <= 1L) { - return(NULL) - } - .ctwasInvoke( - ctwas::get_boundary_genes, - list( - region_info = inputs$region_info, - weights = inputs$weights, - ncore = ncore - ), - extra = extra - ) -} - -# The accurate EM (ctwas::est_param) invocation, split out so -# .ctwasEstParamOrFallback can run it directly (no fallback) or inside a -# tryCatch -# (with fallback) without duplicating the argument assembly. -# @noRd -.ctwasEstParamAccurate <- function( - regionData, - niterPrefit, - niter, - groupPriorVarStructure, - ncore, - extra -) { - .ctwasInvoke( - ctwas::est_param, - list( - region_data = regionData, - niter_prefit = as.integer(niterPrefit), - niter = as.integer(niter), - group_prior_var_structure = groupPriorVarStructure, - ncore = ncore - ), - extra = extra - ) -} - # est_param (accurate EM), falling back to a converged prefit EM on ANY accurate # error when fallbackToPrefit is set. The accurate EM fails on degenerate inputs # in several version-dependent ways (NAs / "No regions selected!" / NaN # log-likelihood), so catch all rather than match brittle version messages. The # prefit re-run runs to full `niter` (this is now the final prior). # @noRd +#' @importFrom rlang try_fetch .ctwasEstParamOrFallback <- function( regionData, niterPrefit, niter, groupPriorVarStructure, - ncore, + numThreads, thin, fallbackToPrefit, extra @@ -784,104 +1029,37 @@ estCtwasParam <- function( niterPrefit, niter, groupPriorVarStructure, - ncore, + numThreads, extra )) } - tryCatch( + try_fetch( .ctwasEstParamAccurate( regionData, niterPrefit, niter, groupPriorVarStructure, - ncore, + numThreads, extra ), - error = function(e) { + error = function(cnd) { msg <- glue( - "estCtwasParam: accurate EM unusable ", - "({conditionMessage(e)}); falling back to prefit estimates." + "estCtwasGroupPriors: accurate EM unusable; falling back to ", + "prefit estimates." ) - inform(msg) + inform(msg, parent = cnd) .ctwasFitPrefitEm( regionData, niter = as.integer(niter), groupPriorVarStructure = groupPriorVarStructure, thin = thin, - ncore = ncore, + numThreads = numThreads, extra = extra ) } ) } -#' Screen cTWAS regions -#' -#' @description Step 3 of the three-step \code{\link{ctwasPipeline}}: runs -#' \code{ctwas::screen_regions} on the \code{\link{estCtwasParam}} result and -#' returns the screened-region set. Use this entry point to substitute -#' hand-tuned priors for the ones estimated in step 2 (e.g. when the accurate -#' EM diverges to NaN and you want to recover the prefit values). -#' -#' @param estResult A list returned by \code{\link{estCtwasParam}}. -#' @param L Unused. Retained for call-site compatibility with -#' \code{\link{ctwasPipeline}}; ctwas's screening always uses the -#' single-effect (SER) model and ignores L. \code{L} is applied by -#' \code{\link{finemapCtwasRegions}} downstream. -#' @param ncore Number of cores. -#' @param ... Additional arguments forwarded to \code{ctwas::screen_regions} -#' (e.g. \code{min_nonSNP_PIP}, \code{min_snp_pval}, \code{min_var}, -#' \code{min_gene}). -#' @return The \code{estResult} list augmented with \code{screen_res} (the full -#' ctwas output) and \code{screened_region_data}. -#' @importFrom purrr map compact -#' @examples -#' data(ctwasEstExample) -#' screenCtwasRegions(ctwasEstExample, L = 5L) -#' @export -screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { - if (!requireNamespace("ctwas", quietly = TRUE)) { - abort("Package 'ctwas' is required for screenCtwasRegions.") - } - estResult <- .ctwasResolveLdPaths(estResult) - # ctwas::screen_regions requires thin = 1 region_data; expand the - # thinned set first when assemble_region_data was called with thin < 1 - # (matches ctwas_sumstats's own expand-before-screen step). - thinVals <- compact(map(estResult$region_data, "thin")) - needsExpand <- length(thinVals) > 0L && min(unlist(thinVals)) < 1 - regionDataForScreen <- if (needsExpand) { - .ctwasInvoke( - ctwas::expand_region_data, - list( - region_data = estResult$region_data, - snp_map = estResult$snp_map, - z_snp = estResult$z_snp, - ncore = as.integer(ncore) - ), - extra = list(...) - ) - } else { - estResult$region_data - } - screenRes <- .ctwasInvoke( - ctwas::screen_regions, - list( - region_data = regionDataForScreen, - group_prior = estResult$param$group_prior, - group_prior_var = estResult$param$group_prior_var, - ncore = as.integer(ncore) - ), - extra = list(...) - ) - c( - estResult, - list( - screen_res = screenRes, - screened_region_data = screenRes$screened_region_data - ) - ) -} - #' Fine-map cTWAS regions #' #' @description Step 4 (final) of the three-step \code{\link{ctwasPipeline}}: @@ -893,8 +1071,10 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { #' #' @param screenResult A list returned by \code{\link{screenCtwasRegions}}. #' @param L Pass-through. -#' @param ncore Number of cores. -#' @param ... Additional arguments forwarded to \code{ctwas::finemap_regions}. +#' @param numThreads Number of cores. +#' @param methodArgs Additional arguments forwarded to ctwas, built +#' with \code{\link{CtwasOptions}}. Names are checked against what +#' the ctwas steps accept between them. #' @return A list mirroring \code{ctwas::ctwas_sumstats}'s output: #' \code{z_gene}, \code{param}, \code{finemap_res}, \code{susie_alpha_res}, #' \code{region_data}, \code{boundary_genes}, \code{screen_res}. @@ -911,49 +1091,36 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", #' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) -#' gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) +#' gwasByRegion <- summaryStatsQc(gss, +#' panelFilter = PanelFilterParam(mafCutoff = 0.0025)) #' inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample)) -#' est <- estCtwasParam(inp, thin = 1, niterPrefit = 3, niter = 10, -#' min_group_size = 1, min_p_single_effect = 0, fallbackToPrefit = TRUE) -#' screened <- screenCtwasRegions(est, L = 5L) +#' est <- estCtwasGroupPriors(inp, +#' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, +#' fallbackToPrefit = TRUE), +#' methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) +#' screened <- screenCtwasRegions(est) #' finemapCtwasRegions(screened, L = 5L) #' @export -finemapCtwasRegions <- function(screenResult, L = 5L, ncore = 1L, ...) { +finemapCtwasRegions <- function( + screenResult, + L = 5L, + numThreads = 1L, + methodArgs = CtwasOptions() +) { + .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for finemapCtwasRegions.") } screenResult <- .ctwasResolveLdPaths(screenResult) - rd <- screenResult$screened_region_data - fmRes <- if (length(rd) == 0L) { - list(finemap_res = NULL, susie_alpha_res = NULL) - } else { - .ctwasInvoke( - ctwas::finemap_regions, - list( - region_data = rd, - LD_map = screenResult$LD_map, - weights = screenResult$weights, - group_prior = screenResult$param$group_prior, - group_prior_var = screenResult$param$group_prior_var, - L = as.integer(L), - LD_format = "custom", - LD_loader_fun = screenResult$LD_loader_fun, - snpinfo_loader_fun = screenResult$snpinfo_loader_fun, - ncore = as.integer(ncore) - ), - extra = list(...) - ) - } + fmRes <- .ctwasFinemapOrEmpty(screenResult, L, numThreads, methodArgs) # 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, - finemap_res = fmRes$finemap_res, - susie_alpha_res = fmRes$susie_alpha_res, + finemap_res = .ctwasFixMolecularId(fmRes$finemap_res), + susie_alpha_res = .ctwasFixMolecularId(fmRes$susie_alpha_res), region_data = screenResult$region_data, boundary_genes = screenResult$boundary_genes, screen_res = screenResult$screen_res, @@ -998,8 +1165,10 @@ finemapCtwasRegions <- function(screenResult, L = 5L, ncore = 1L, ...) { #' \code{Inf}. #' @param L Integer. Max number of single effects for the merged-region #' re-fine-mapping (LD path only). Default \code{5}. -#' @param ncore Number of cores. Default \code{1}. -#' @param ... Forwarded to the underlying ctwas postprocess function. +#' @param numThreads Number of cores. Default \code{1}. +#' @param methodArgs Additional arguments forwarded to ctwas, built +#' with \code{\link{CtwasOptions}}. Names are checked against what +#' the ctwas steps accept between them. #' @return The \code{finemapResult} list with \code{finemap_res}, #' \code{susie_alpha_res}, \code{region_data}, \code{region_info}, #' \code{LD_map}, and \code{snp_map} replaced by the post-merge ("updated") @@ -1016,9 +1185,10 @@ mergeCtwasBoundaryRegions <- function( filterCs = FALSE, maxSNP = Inf, L = 5L, - ncore = 1L, - ... + numThreads = 1L, + methodArgs = CtwasOptions() ) { + .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for mergeCtwasBoundaryRegions.") } @@ -1037,12 +1207,15 @@ mergeCtwasBoundaryRegions <- function( pipThresh, filterCs, maxSNP, - ncore + numThreads ) fa <- .ctwasMergeDispatch(finemapResult, common, L) - userExtra <- list(...) - userExtra <- userExtra[setdiff(names(userExtra), names(fa$args))] - callArgs <- c(fa$args, userExtra) + # Flatten the record before merging: c() on a list and a MethodOptions (a + # SimpleList) appends the S4 object as ONE unnamed element rather than + # splicing its entries, and exec() would then hand that object to ctwas + # as a positional argument. + user <- as.list(methodArgs) + callArgs <- c(fa$args, user[setdiff(names(user), names(fa$args))]) res <- exec(fa$fn, !!!callArgs) .ctwasApplyMergeResult(finemapResult, res) } @@ -1054,7 +1227,7 @@ mergeCtwasBoundaryRegions <- function( pipThresh, filterCs, maxSNP, - ncore + numThreads ) { list( region_info = finemapResult$region_info, @@ -1070,54 +1243,26 @@ mergeCtwasBoundaryRegions <- function( pip_thresh = pipThresh, filter_cs = filterCs, maxSNP = maxSNP, - ncore = as.integer(ncore) + ncore = as.integer(numThreads) ) } -# Pick the LD vs no-LD region-merging fn + args. ctwas's postprocess_*() -# forward `...` into finemap_regions, so the LD loader closures must ride in the -# explicit arg list (not filtered through .ctwasInvoke). -# @noRd -.ctwasMergeDispatch <- function(finemapResult, common, L) { - if (is.null(finemapResult$LD_loader_fun)) { - return(list( - fn = ctwas::postprocess_region_merging_noLD, - args = common - )) - } - args <- c( - common, - list( - LD_map = finemapResult$LD_map, - L = as.integer(L), - LD_format = "custom", - LD_loader_fun = finemapResult$LD_loader_fun, - snpinfo_loader_fun = finemapResult$snpinfo_loader_fun - ) - ) - list(fn = ctwas::postprocess_region_merging, args = args) -} - # Write region-merging outputs back onto the finemap result (only components # ctwas actually returned). # @noRd .ctwasApplyMergeResult <- function(finemapResult, res) { - finemapResult$finemap_res <- res$updated_finemap_res - finemapResult$susie_alpha_res <- res$updated_susie_alpha_res - if (!is.null(res$updated_region_data)) { - finemapResult$region_data <- res$updated_region_data - } - if (!is.null(res$updated_region_info)) { - finemapResult$region_info <- res$updated_region_info - } - if (!is.null(res$updated_LD_map)) { - finemapResult$LD_map <- res$updated_LD_map - } - if (!is.null(res$updated_snp_map)) { - finemapResult$snp_map <- res$updated_snp_map - } - finemapResult$merge_res <- res - finemapResult + list_assign( + finemapResult, + finemap_res = res$updated_finemap_res, + susie_alpha_res = res$updated_susie_alpha_res, + merge_res = res, + !!!compact(list( + region_data = res$updated_region_data, + region_info = res$updated_region_info, + LD_map = res$updated_LD_map, + snp_map = res$updated_snp_map + )) + ) } # Invoke a ctwas function with a fixed `args` list plus optional `extra` @@ -1126,20 +1271,24 @@ mergeCtwasBoundaryRegions <- function( # arguments always win over caller-supplied `...`. # @noRd .ctwasInvoke <- function(fn, args, extra = list()) { + # The bundle arrives as a MethodOptions record; everything below is ordinary + # list work, so flatten it once at the boundary. + extra <- as.list(extra) if (length(extra) > 0L) { - extra <- extra[setdiff(names(extra), names(args))] + deduped <- extra[setdiff(names(extra), names(args))] # `...` is forwarded uniformly to four different ctwas functions # (assemble_region_data / est_param / screen_regions / # finemap_regions). Restrict to fn's explicit formals so an arg # meant for a sibling step doesn't crash this one -- and so args # that fn would otherwise forward via its own `...` (e.g. into # susie_rss) don't bleed into incompatible downstream functions. - formalsFn <- tryCatch(names(formals(fn)), error = function(e) NULL) - if (!is.null(formalsFn)) { - explicitFormals <- setdiff(formalsFn, "...") - extra <- extra[intersect(names(extra), explicitFormals)] + formalsFn <- try_fetch(names(formals(fn)), error = function(cnd) NULL) + usable <- if (is.null(formalsFn)) { + deduped + } else { + deduped[intersect(names(deduped), setdiff(formalsFn, "..."))] } - args <- c(args, extra) + args <- c(args, usable) } exec(fn, !!!args) } @@ -1162,7 +1311,7 @@ mergeCtwasBoundaryRegions <- function( niter, groupPriorVarStructure, thin, - ncore, + numThreads, extra = list() ) { fitEm <- utils::getFromNamespace("fit_EM", "ctwas") @@ -1171,13 +1320,14 @@ mergeCtwasBoundaryRegions <- function( region_data = fitRegionData, niter = as.integer(niter), group_prior_var_structure = groupPriorVarStructure, - ncore = as.integer(ncore) + ncore = as.integer(numThreads) ) prefit <- .ctwasInvoke(fitEm, fitArgs, extra) adj <- .ctwasApplyThin(prefit$group_prior, prefit$group_size, thin) - groupSize <- adj$groupSize - if (length(adj$groupPrior) > 0L) { - groupSize <- groupSize[names(adj$groupPrior)] + groupSize <- if (length(adj$groupPrior) > 0L) { + adj$groupSize[names(adj$groupPrior)] + } else { + adj$groupSize } list( group_prior = adj$groupPrior, @@ -1205,13 +1355,12 @@ mergeCtwasBoundaryRegions <- function( minGene <- if (!is.null(extra$min_gene)) as.integer(extra$min_gene) else 1L nGid <- lengths(map(region_data, "gid")) nSid <- lengths(map(region_data, "sid")) - keep <- rep(TRUE, length(region_data)) - if (minVar > 0L) { - keep <- keep & (nSid + nGid) >= minVar - } - if (minGene > 0L) { - keep <- keep & nGid >= minGene + byVar <- if (minVar > 0L) { + (nSid + nGid) >= minVar + } else { + rep(TRUE, length(region_data)) } + keep <- if (minGene > 0L) byVar & nGid >= minGene else byVar fitRegionData <- region_data[keep] if (length(fitRegionData) == 0L) { abort("No regions selected!") @@ -1222,15 +1371,23 @@ mergeCtwasBoundaryRegions <- function( # Rescale the SNP group prior / size by `thin` (the SNP subsampling factor). # @noRd .ctwasApplyThin <- function(groupPrior, groupSize, thin) { - if (thin != 1) { - if (is_in("SNP", names(groupPrior))) { - groupPrior["SNP"] <- groupPrior["SNP"] * thin - } - if (is_in("SNP", names(groupSize))) { - groupSize["SNP"] <- groupSize["SNP"] / thin - } + if (thin == 1) { + return(list(groupPrior = groupPrior, groupSize = groupSize)) } - list(groupPrior = groupPrior, groupSize = groupSize) + list( + groupPrior = .ctwasScaleSnpGroup(groupPrior, thin), + groupSize = .ctwasScaleSnpGroup(groupSize, 1 / thin) + ) +} + +# Scale the "SNP" entry of a per-group vector, leaving the molecular groups +# alone. A vector without a SNP group passes through unchanged. +# @noRd +.ctwasScaleSnpGroup <- function(groups, factor) { + if (!is_in("SNP", names(groups))) { + return(groups) + } + replace(groups, "SNP", groups[["SNP"]] * factor) } # ============================================================================= @@ -1253,7 +1410,7 @@ mergeCtwasBoundaryRegions <- function( # - Otherwise: error. # @noRd .ctwasResolveMethod <- function(twasWeightsList, method = NULL) { - available <- unique(unlist(map(twasWeightsList, .ctwasMethodChr))) + available <- unique(list_c(map(twasWeightsList, .ctwasMethodChr))) if (length(available) == 0L) { abort("ctwasPipeline: TwasWeights collections have no method entries.") } @@ -1323,7 +1480,7 @@ mergeCtwasBoundaryRegions <- function( # flat collection or an UNNAMED list is instead treated as a flat weight source # to place internally by region. # @noRd -.ctwasIsPreBucketed <- function(tw, gwasSumStats) { +.ctwasIsPreBucketed <- function(tw) { is.list(tw) && !methods::is(tw, "DFrame") && length(tw) > 0L && @@ -1376,31 +1533,37 @@ mergeCtwasBoundaryRegions <- function( # becomes a 0-width chrUn sentinel, which matches no anchor and so yields the # documented "NA when the anchor falls in no block". # @noRd +# One block id parsed into chrom/start/end, or the unplaced sentinel when it +# does not parse as a range. +# @noRd +.ctwasBlockCoords <- function(id) { + g <- try_fetch( + asGranges(str_replace( + as.character(id), + "_([0-9]+)_([0-9]+)$", + ":\\1-\\2" + )), + error = function(cnd) NULL + ) + if (is.null(g) || length(g) < 1L) { + return(list(chrom = "chrUn", start = 1L, end = 0L)) + } + list( + chrom = as.character(GenomicRanges::seqnames(g))[[1L]], + start = GenomicRanges::start(g)[[1L]], + end = GenomicRanges::end(g)[[1L]] + ) +} + .ctwasBlockGrFromIds <- function(ids) { - n <- length(ids) - chrom <- character(n) - start <- integer(n) - end <- integer(n) - for (i in seq_len(n)) { - g <- tryCatch( - asGranges(str_replace( - as.character(ids[[i]]), - "_([0-9]+)_([0-9]+)$", - ":\\1-\\2" - )), - error = function(e) NULL + coords <- map(ids, .ctwasBlockCoords) + GenomicRanges::GRanges( + map_chr(coords, "chrom"), + IRanges::IRanges( + start = map_int(coords, "start"), + end = map_int(coords, "end") ) - if (!is.null(g) && length(g) >= 1L) { - chrom[[i]] <- as.character(GenomicRanges::seqnames(g))[[1L]] - start[[i]] <- GenomicRanges::start(g)[[1L]] - end[[i]] <- GenomicRanges::end(g)[[1L]] - } else { - chrom[[i]] <- "chrUn" - start[[i]] <- 1L - end[[i]] <- 0L - } - } - GenomicRanges::GRanges(chrom, IRanges::IRanges(start = start, end = end)) + ) } # Place each gene (row) of a flat weight source into its home LD block. The @@ -1455,6 +1618,8 @@ mergeCtwasBoundaryRegions <- function( # @noRd .ctwasBlockSpan <- function(gss) { + # S4 dispatch, not list flattening: `gss` is a GwasSumStats collection and + # unlist() returns the GRanges that range() below needs. variants <- unlist(gss, use.names = FALSE) if (length(variants) == 0L) { return(GenomicRanges::GRanges()) @@ -1474,6 +1639,23 @@ mergeCtwasBoundaryRegions <- function( # that block's GWAS LD sketch (the panel its weights are harmonized against, and # what the downstream match-check expects). # @noRd +# The genes homed into region `rid`, carrying that region's LD sketch, or +# NULL when nothing landed there. `slot<-` applied as a function returns a +# copy rather than writing into the subset in place. +# @noRd +#' @importFrom methods slot<- +.ctwasBucketForRegion <- function(rid, combined, home, gwasSumStats) { + idx <- which(home == rid) + if (length(idx) == 0L) { + return(NULL) + } + `slot<-`( + combined[idx, ], + "ldSketch", + value = getLdSketch(gwasSumStats[[rid]]) + ) +} + .ctwasBucketWeights <- function(weights, gwasSumStats) { combined <- .ctwasCombineWeightSources(weights) # Placement anchors on the GENE's own position, not on a stored analysis @@ -1503,16 +1685,16 @@ mergeCtwasBoundaryRegions <- function( ) warn(msg) } - out <- list() - for (rid in names(gwasSumStats)) { - idx <- which(home == rid) - if (length(idx) == 0L) { - next - } - sub <- combined[idx, ] - sub@ldSketch <- getLdSketch(gwasSumStats[[rid]]) - out[[rid]] <- sub - } + out <- compact(set_names( + map( + names(gwasSumStats), + .ctwasBucketForRegion, + combined = combined, + home = home, + gwasSumStats = gwasSumStats + ), + names(gwasSumStats) + )) if (length(out) == 0L) { msg <- glue( "assembleCtwasInputs: no gene placed into any LD block. ", @@ -1528,7 +1710,7 @@ mergeCtwasBoundaryRegions <- function( # through, otherwise place a flat weight source by region. # @noRd .ctwasResolveWeightBuckets <- function(twasWeights, gwasSumStats) { - if (.ctwasIsPreBucketed(twasWeights, gwasSumStats)) { + if (.ctwasIsPreBucketed(twasWeights)) { return(twasWeights) } .ctwasBucketWeights(twasWeights, gwasSumStats) @@ -1558,7 +1740,7 @@ mergeCtwasBoundaryRegions <- function( # a flat weight source .ctwasMethodsOf(twasWeightsList) } else { - unlist(map(twasWeightsList, .ctwasMethodsOf)) + list_c(compact(map(twasWeightsList, .ctwasMethodsOf))) } ) # a list of them if (length(available) == 0L) { @@ -1588,8 +1770,10 @@ mergeCtwasBoundaryRegions <- function( # Read the collection's own `study` column. map() over a GwasSumStats # iterates its ELEMENTS (per-block GRanges), which carry no study, so it # would silently yield NA for every block. - studies <- unique(.ctwasStudyChr(gwasSumStats)) - studies <- studies[!is.na(studies) & str_length(studies) > 0L] + allStudies <- unique(.ctwasStudyChr(gwasSumStats)) + studies <- allStudies[ + !is.na(allStudies) & str_length(allStudies) > 0L + ] if (length(studies) == 0L) { return(NA_character_) } @@ -1653,8 +1837,14 @@ mergeCtwasBoundaryRegions <- function( } isGene <- lengths(str_split(as.character(df$id), "\\|")) >= 5L if (any(isGene)) { - df$molecular_id[isGene] <- - .ctwasParseGeneIds(as.character(df$id)[isGene])$trait + return(mutate( + df, + molecular_id = replace( + .data$molecular_id, + isGene, + .ctwasParseGeneIds(as.character(df$id)[isGene])$trait + ) + )) } df } @@ -1774,24 +1964,24 @@ mergeCtwasBoundaryRegions <- function( return(df) } gr <- GenomicRanges::GRanges( - map_chr(coord, .ctwasCoordField, field = "chrom", placed = placed), + map_chr(coord, .ctwasCoordField, field = "chrom"), IRanges::IRanges( start = map_int( coord, .ctwasCoordField2, - field = "start", - placed = placed + field = "start" ), end = map_int( coord, .ctwasCoordField2, - field = "end", - placed = placed + field = "end" ) ) ) - mcols(gr) <- S4Vectors::DataFrame(df, check.names = FALSE) - gr[placed] + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(df, check.names = FALSE) + )[placed] } # @noRd @@ -1800,7 +1990,7 @@ mergeCtwasBoundaryRegions <- function( if (!is.null(gc) && is_in(id, names(gc))) { return(gc[[id]]) } - parsed <- tryCatch(parseVariantId(id), error = function(e) NULL) + parsed <- try_fetch(parseVariantId(id), error = function(cnd) NULL) if (is.null(parsed) || is.na(parsed$chrom[[1L]])) { return(NULL) } @@ -1812,12 +2002,12 @@ mergeCtwasBoundaryRegions <- function( } # @noRd -.ctwasCoordField <- function(co, field, placed) { +.ctwasCoordField <- function(co, field) { if (is.null(co)) "chrUnplaced" else as.character(co[[field]]) } # @noRd -.ctwasCoordField2 <- function(co, field, placed) { +.ctwasCoordField2 <- function(co, field) { if (is.null(co)) 1L else as.integer(co[[field]]) } @@ -1829,7 +2019,7 @@ mergeCtwasBoundaryRegions <- function( CtwasResultEntry( finemap = .ctwasRangePayload(fm, geneCoords), susieAlpha = .ctwasRangePayload(sa, geneCoords), - param = runResult$param, + groupPriors = runResult$param, regionInfo = .ctwasRangeRegionInfo(runResult$region_info) ) } @@ -1853,8 +2043,10 @@ mergeCtwasBoundaryRegions <- function( end = as.integer(ri$stop) ) ) - mcols(gr) <- S4Vectors::DataFrame(ri, check.names = FALSE) - gr + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(ri, check.names = FALSE) + ) } # Decompose one cTWAS run (a `finemapCtwasRegions` output) into per-context @@ -1885,7 +2077,7 @@ mergeCtwasBoundaryRegions <- function( } fmDf <- .ctwasAsDf(runResult$finemap_res) saDf <- .ctwasAsDf(runResult$susie_alpha_res) - rows <- map( + contextRows <- map( contexts, .ctwasContextRow, parsed = parsed, @@ -1896,19 +2088,12 @@ mergeCtwasBoundaryRegions <- function( saDf = saDf, runResult = runResult ) - if (keepSnps) { - snpRow <- .ctwasSnpRow( - gwasStudy, - method, - jointStr, - fmDf, - saDf, - runResult - ) - if (!is.null(snpRow)) { - rows <- c(rows, list(snpRow)) - } + snpRow <- if (!keepSnps) { + NULL + } else { + .ctwasSnpRow(gwasStudy, method, jointStr, fmDf, saDf, runResult) } + rows <- c(contextRows, compact(list(snpRow))) rows } @@ -2004,8 +2189,8 @@ mergeCtwasBoundaryRegions <- function( if (is.null(zSnp) || is.null(zSnp$study)) { return(NA_character_) } - s <- unique(as.character(zSnp$study)) - s <- s[!is.na(s) & str_length(s) > 0L] + allStudies <- unique(as.character(zSnp$study)) + s <- allStudies[!is.na(allStudies) & str_length(allStudies) > 0L] if (length(s) == 0L) { return(NA_character_) } @@ -2041,13 +2226,14 @@ mergeCtwasBoundaryRegions <- function( m } +#' @importFrom checkmate assertFlag #' @title Structure a granular cTWAS finemap result as a CtwasResult #' @description Decompose the raw list returned by #' \code{\link{finemapCtwasRegions}} (optionally after #' \code{\link{mergeCtwasBoundaryRegions}}) into the structured, per-(study, #' context) \code{\link{CtwasResult}} -- the same decomposition #' \code{\link{ctwasPipeline}} applies to its one-shot output, exposed for the -#' granular \code{assembleCtwasInputs} \eqn{\to} \code{estCtwasParam} +#' granular \code{assembleCtwasInputs} \eqn{\to} \code{estCtwasGroupPriors} #' \eqn{\to} \code{screenCtwasRegions} \eqn{\to} \code{finemapCtwasRegions} #' path. The GWAS study is read from \code{z_snp$study} and the (single) #' weight method from the gene ids. @@ -2063,6 +2249,7 @@ mergeCtwasBoundaryRegions <- function( #' asCtwasResult(ctwasFinemapExample) #' @export asCtwasResult <- function(finemapResult, keepSnps = FALSE) { + assertFlag(keepSnps) gwasStudy <- .ctwasGwasStudyFromZSnp(finemapResult$z_snp) method <- .ctwasMethodFromWeights(finemapResult$weights) rows <- .ctwasRunToRows( @@ -2087,9 +2274,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } # Row subset carries every column forward (joint* / region / ...); the old # hand-listed rebuild silently dropped them. - out <- tw[keep, ] - out@ldSketch <- getLdSketch(tw) - out + methods::initialize(tw[keep, ], ldSketch = getLdSketch(tw)) } # Build the per-variant Z data.frame ctwas expects from a GwasSumStats. @@ -2131,31 +2316,45 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (length(m$idxA) == 0L) { return(zSnp) } - zSnp$id[m$idxA] <- as.character(panelIds)[m$idxB] + relabelled <- mutate( + zSnp, + id = replace(.data$id, m$idxA, as.character(panelIds)[m$idxB]) + ) flip <- m$idxA[m$sign < 0] - if (length(flip) > 0L) { - zSnp$z[flip] <- -zSnp$z[flip] - swapped <- zSnp$A1[flip] - zSnp$A1[flip] <- zSnp$A2[flip] - zSnp$A2[flip] <- swapped - } - zSnp + if (length(flip) == 0L) { + return(relabelled) + } + # A swapped variant counts the other allele: negate z and exchange the + # allele columns. Both replacements read the ORIGINAL frame, so the pair + # swaps rather than each taking the other's already-swapped value. + mutate( + relabelled, + z = replace(.data$z, flip, -relabelled$z[flip]), + A1 = replace(.data$A1, flip, relabelled$A2[flip]), + A2 = replace(.data$A2, flip, relabelled$A1[flip]) + ) +} + +# @noRd +.ctwasZSnpPiece <- function(i, gwasSumStats) { + df <- .entryToSumstatDf(gwasSumStats[[i]], keepChrPrefix = FALSE) + tibble( + id = df$variant_id, + chrom = as.integer(df$chrom), + pos = df$pos, + A1 = df$A1, + A2 = df$A2, + z = df$z, + study = as.character(gwasSumStats$study)[[i]] + ) } .ctwasBuildZSnp <- function(gwasSumStats, panelIds) { - pieces <- list() - for (i in seq_len(nrow(gwasSumStats))) { - df <- .entryToSumstatDf(gwasSumStats[[i]], keepChrPrefix = FALSE) - pieces[[i]] <- tibble( - id = df$variant_id, - chrom = as.integer(df$chrom), - pos = df$pos, - A1 = df$A1, - A2 = df$A2, - z = df$z, - study = as.character(gwasSumStats$study)[[i]] - ) - } + pieces <- map( + seq_len(nrow(gwasSumStats)), + .ctwasZSnpPiece, + gwasSumStats = gwasSumStats + ) .ctwasHarmonizeZToPanel(bind_rows(pieces), panelIds) } @@ -2163,6 +2362,31 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # (min/max BP per chromosome). The sketch is assumed to cover exactly # one block. # @noRd +# @noRd +.ctwasEntryPositions <- function(i, gss) { + gr <- gss[[i]] + list( + pos = as.integer(GenomicRanges::start(gr)), + chrs = as.character(GenomicRanges::seqnames(gr)) + ) +} + +# @noRd +.ctwasConcatInt <- function(pieces) { + if (length(pieces) == 0L) { + return(integer(0)) + } + list_c(pieces) +} + +# @noRd +.ctwasConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + list_c(pieces) +} + .ctwasBuildSingleRegionInfo <- function(regionId, gss) { # Derive the block's [start, stop] from the GWAS variants actually in this # block (the GwasSumStats entry GRanges) -- NOT the LD sketch. When many @@ -2171,13 +2395,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # would collapse to the same whole-chromosome [start, stop] and every SNP # would be assigned to every region (inflating SNP group_size N-fold and # diluting the gene prior to ~0). - pos <- integer(0) - chrs <- character(0) - for (i in seq_len(nrow(gss))) { - gr <- gss[[i]] - pos <- c(pos, as.integer(GenomicRanges::start(gr))) - chrs <- c(chrs, as.character(GenomicRanges::seqnames(gr))) - } + entries <- map(seq_len(nrow(gss)), .ctwasEntryPositions, gss = gss) + pos <- .ctwasConcatInt(map(entries, "pos")) + chrs <- .ctwasConcatChr(map(entries, "chrs")) # Emptiness is checked FIRST: `pos` and `chrs` are filled from the same # GRanges in the same loop, so an empty block has zero chromosomes too, # and the chromosome check below would report it as "spans multiple @@ -2262,9 +2482,11 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { seq_len(nrow(snpInfoCtwas)), meanImpute = TRUE ) - R <- computeLd(geno, method = "sample") snpIds <- snpInfoCtwas$id - dimnames(R) <- list(snpIds, snpIds) + R <- `dimnames<-`( + computeLd(geno, method = "sample"), + list(snpIds, snpIds) + ) variance <- set_names(apply(geno, 2, stats::var, na.rm = TRUE), snpIds) list(R = R, snpInfo = snpInfoCtwas, variance = variance) } @@ -2281,7 +2503,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Returns NULL when the entry has no variants in common with the panel. # @noRd .ctwasHarmonizeWeights <- function(origVids, origW, refVariants) { - parsed <- tryCatch(parseVariantId(origVids), error = function(e) NULL) + parsed <- try_fetch(parseVariantId(origVids), error = function(cnd) NULL) if (is.null(parsed) || nrow(parsed) == 0L) { return(NULL) } @@ -2293,7 +2515,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { w = as.numeric(origW), origIdx = seq_along(origVids) ) - res <- tryCatch( + res <- try_fetch( harmonizeAlleles( targetData = targetDf, refVariants = refVariants, @@ -2302,7 +2524,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { removeUnmatched = TRUE, removeStrandAmbiguous = TRUE ), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(res)) { return(NULL) @@ -2343,10 +2565,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) { # Fields are READ with `[[`: `$` on a list falls back to prefix matching, # so `fits$mu` would silently return `mu2` on a fit that has no `mu`. - alpha <- fits[["alpha"]] + rawAlpha <- fits[["alpha"]] mu <- fits[["mu"]] xCol <- fits[["X_column_scale_factors"]] - if (is.null(alpha) || is.null(mu) || is.null(xCol)) { + if (is.null(rawAlpha) || is.null(mu) || is.null(xCol)) { return(NULL) } # susieInf / susieAsh carry an infinitesimal term: coef.susie is @@ -2357,7 +2579,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (!is.null(fits[["theta"]]) || !is.null(fits[["omega_weights"]])) { return(NULL) } - alpha <- as.matrix(alpha) + alpha <- as.matrix(rawAlpha) if ( ncol(alpha) != length(origVids) || ncol(mu) != length(origVids) || @@ -2369,16 +2591,16 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } # Per-variant sign flip applied by allele harmonization. NaN signs # (origW == 0) default to +1. - signFlip <- sign(harmonizedW / origW[keptIdx]) - signFlip[!is.finite(signFlip)] <- 1 + rawSign <- sign(harmonizedW / origW[keptIdx]) + signFlip <- replace(rawSign, !is.finite(rawSign), 1) newAlpha <- .ctwasRenormAlpha(alpha, keptIdx) if (is.null(newAlpha)) { return(NULL) } muSub <- sweep(mu[, keptIdx, drop = FALSE], 2L, signFlip, `*`) - xColSub <- xCol[keptIdx] + rawScale <- xCol[keptIdx] # Guard against zero scale factors (shouldn't happen in practice). - xColSub[xColSub == 0] <- 1 + xColSub <- replace(rawScale, rawScale == 0, 1) as.numeric(colSums(newAlpha * muSub) / xColSub) } @@ -2465,11 +2687,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { twasWeights = twasWeights, ctx = ctx )) - out <- list() - for (g in genes) { - out[[g$key]] <- g$entry - } - out + # Later genes overwrite an earlier one sharing a key, which is what the + # `out[[g$key]] <- ...` loop did. + keyed <- set_names(map(genes, "entry"), map_chr(genes, "key")) + keyed[!duplicated(names(keyed), fromLast = TRUE)] } # Panel variant info in the (chrom/pos/A2/A1/variant_id) frame harmonizeAlleles @@ -2538,33 +2759,32 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # genotype variance from the LD panel)). Returns the adjusted weight vector. # @noRd .ctwasAdjustGeneWeights <- function(parts, aligned, ldPanel) { - w <- aligned$w fits <- .rowFits(parts) shrank <- length(aligned$keptIdx) < length(aligned$origVids) - if (.ctwasIsSusieFit(fits) && shrank) { - renorm <- .ctwasRenormalizeSusieWeights( + # A NULL renormalization means the fit could not be re-keyed onto the + # kept variants, so the harmonized weights stand as they are. + renorm <- if (.ctwasIsSusieFit(fits) && shrank) { + .ctwasRenormalizeSusieWeights( fits, origVids = aligned$origVids, origW = aligned$origW, keptIdx = aligned$keptIdx, - harmonizedW = w + harmonizedW = aligned$w ) - if (!is.null(renorm)) { - w <- renorm - } } - if (!.rowStandardized(parts)) { - varLookup <- ldPanel$variance[aligned$vids] - if (anyNA(varLookup)) { - msg <- glue( - ".ctwasBuildWeights: missing genotype variance for ", - "{sum(is.na(varLookup))} variant(s) in the LD panel." - ) - abort(msg) - } - w <- w * sqrt(varLookup) + renormalized <- renorm %||% aligned$w + if (.rowStandardized(parts)) { + return(renormalized) + } + varLookup <- ldPanel$variance[aligned$vids] + if (anyNA(varLookup)) { + msg <- glue( + ".ctwasBuildWeights: missing genotype variance for ", + "{sum(is.na(varLookup))} variant(s) in the LD panel." + ) + abort(msg) } - w + renormalized * sqrt(varLookup) } # The ctwas per-gene weight entry (weight matrix, LD submatrix, chrom/BP span, @@ -2698,17 +2918,18 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (is.null(fineMappingResult)) { return(NULL) } - selectors <- list(study = study, method = method) - if (is_in("context", .tupleColumnNames(fineMappingResult))) { - selectors$context <- context - } - if (is_in("trait", .tupleColumnNames(fineMappingResult))) { - selectors$trait <- trait - } + cols <- .tupleColumnNames(fineMappingResult) + selectors <- c( + list(study = study, method = method), + compact(list( + context = if (is_in("context", cols)) context, + trait = if (is_in("trait", cols)) trait + )) + ) selArgs <- c(list(fineMappingResult), selectors) - entry <- tryCatch( + entry <- try_fetch( exec(getFineMappingResult, !!!selArgs), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(entry)) { return(NULL) @@ -2729,25 +2950,39 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # `_` where idx == 0 means "not in any CS"; cs_95_purity (when # present) broadcasts one purity value across a CS's rows. # @noRd +# One credible set's member variants and its purity. +# @noRd +.ctwasCsEntry <- function(k, tl, csIdx, keepIdx) { + inCs <- csIdx == k & keepIdx + purity <- if (is_in("cs_95_purity", names(tl))) { + as.numeric(tl$cs_95_purity[which(inCs)[1L]]) + } else { + NA_real_ + } + list(members = as.character(tl$variant_id)[inCs], purity = purity) +} + .ctwasCsMembership <- function(tl) { - csMembers <- list() - csPurity <- numeric(0) if (!is_in("cs_95", names(tl))) { - return(list(csMembers = csMembers, csPurity = csPurity)) + return(list(csMembers = list(), csPurity = numeric(0))) } csIdx <- suppressWarnings(as.integer(str_remove(tl$cs_95, "^.*_"))) keepIdx <- !is.na(csIdx) & csIdx > 0L - for (k in sort(unique(csIdx[keepIdx]))) { - inCs <- csIdx == k & keepIdx - csMembers[[length(csMembers) + 1L]] <- as.character(tl$variant_id)[inCs] - p <- if (is_in("cs_95_purity", names(tl))) { - as.numeric(tl$cs_95_purity[which(inCs)[1L]]) + entries <- map( + sort(unique(csIdx[keepIdx])), + .ctwasCsEntry, + tl = tl, + csIdx = csIdx, + keepIdx = keepIdx + ) + list( + csMembers = map(entries, "members"), + csPurity = if (length(entries) == 0L) { + numeric(0) } else { - NA_real_ + map_dbl(entries, "purity") } - csPurity <- c(csPurity, p) - } - list(csMembers = csMembers, csPurity = csPurity) + ) } # Apply the four trimCtwasVariants filters to one gene's (vids, w) @@ -2777,30 +3012,34 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Step 1: magnitude. if (twasWeightCutoff > 0) { magKeep <- !is.na(w) & abs(w) >= twasWeightCutoff - vids <- vids[magKeep] - w <- w[magKeep] - if (length(vids) == 0L) { + keptVids <- vids[magKeep] + keptW <- w[magKeep] + if (length(keptVids) == 0L) { return(NULL) } + } else { + keptVids <- vids + keptW <- w } # Steps 2-3: PIP / CS rescue (only when fineMappingResult was passed). # Relabel first: the auxiliaries are keyed in the fine-mapping result's # frame, the vids in the panel's, and every join from here on is exact. - finemapAux <- .ctwasRelabelFinemapAux(finemapAux, vids) - mustKeep <- .ctwasMustKeep(vids, finemapAux, csMinCor, minPipCutoff) + finemapAux <- .ctwasRelabelFinemapAux(finemapAux, keptVids) + mustKeep <- .ctwasMustKeep(keptVids, finemapAux, csMinCor, minPipCutoff) # Step 4: cap, keeping must-keep variants first. - if (length(vids) > maxNumVariants && is.finite(maxNumVariants)) { - capped <- .ctwasCapVariants( - vids, - w, + capping <- length(keptVids) > maxNumVariants && is.finite(maxNumVariants) + capped <- if (!capping) { + list(vids = keptVids, w = keptW) + } else { + .ctwasCapVariants( + keptVids, + keptW, mustKeep, finemapAux, maxNumVariants ) - vids <- capped$vids - w <- capped$w } - list(vids = vids, w = w) + list(vids = capped$vids, w = capped$w) } # Move a set of variant ids into the frame `vids` uses, leaving ids with no @@ -2811,10 +3050,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(ids) } m <- .ctwasMatchToPanel(ids, vids) - if (length(m$idxA) > 0L) { - ids[m$idxA] <- vids[m$idxB] + if (length(m$idxA) == 0L) { + return(ids) } - ids + replace(ids, m$idxA, vids[m$idxB]) } # Relabel a gene's fine-mapping auxiliaries into the weight/panel frame. @@ -2834,63 +3073,78 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (is.null(finemapAux)) { return(NULL) } - if (!is.null(finemapAux$pip)) { - names(finemapAux$pip) <- .ctwasRelabelIds( - names(finemapAux$pip), - vids + relabelled <- if (is.null(finemapAux$pip)) { + finemapAux + } else { + list_assign( + finemapAux, + pip = set_names( + finemapAux$pip, + .ctwasRelabelIds(names(finemapAux$pip), vids) + ) ) } - if (length(finemapAux$csMembers) > 0L) { - finemapAux$csMembers <- map( - finemapAux$csMembers, - .ctwasRelabelIds, - vids = vids - ) + if (length(finemapAux$csMembers) == 0L) { + return(relabelled) } - finemapAux + list_assign( + relabelled, + csMembers = map(finemapAux$csMembers, .ctwasRelabelIds, vids = vids) + ) } # Variants that must survive the cap: members of any high-purity (>= csMinCor) # credible set, plus any with PIP > minPipCutoff. Empty when no finemapAux. # @noRd +# Variants rescued by credible set `k`, when that set is pure enough. +# @noRd +.ctwasCsRescued <- function(k, finemapAux, vids, csMinCor) { + if (is.na(finemapAux$csPurity[k]) || finemapAux$csPurity[k] < csMinCor) { + return(character(0)) + } + intersect(finemapAux$csMembers[[k]], vids) +} + .ctwasMustKeep <- function(vids, finemapAux, csMinCor, minPipCutoff) { - mustKeep <- character(0) if (is.null(finemapAux)) { - return(mustKeep) - } - if (length(finemapAux$csMembers) > 0L && csMinCor > 0) { - for (k in seq_along(finemapAux$csMembers)) { - if ( - !is.na(finemapAux$csPurity[k]) && - finemapAux$csPurity[k] >= csMinCor - ) { - mustKeep <- union( - mustKeep, - intersect(finemapAux$csMembers[[k]], vids) - ) - } - } + return(character(0)) + } + fromCs <- if (length(finemapAux$csMembers) > 0L && csMinCor > 0) { + map( + seq_along(finemapAux$csMembers), + .ctwasCsRescued, + finemapAux = finemapAux, + vids = vids, + csMinCor = csMinCor + ) + } else { + list() } - if (!is.null(finemapAux$pip) && minPipCutoff > 0) { + fromPip <- if (!is.null(finemapAux$pip) && minPipCutoff > 0) { hits <- names(finemapAux$pip)[finemapAux$pip > minPipCutoff] - mustKeep <- union(mustKeep, intersect(hits, vids)) + intersect(hits, vids) + } else { + character(0) } - mustKeep + # union() folded over the pieces, so each variant appears once and in + # first-rescued order -- the same thing the repeated unions produced. + reduce(c(fromCs, list(fromPip)), union, .init = character(0)) } # Cap to maxNumVariants: must-keep variants first, then fill by descending PIP # (falling back to |w| for variants the PIP table doesn't cover). # @noRd .ctwasCapVariants <- function(vids, w, mustKeep, finemapAux, maxNumVariants) { - priorities <- if (!is.null(finemapAux) && !is.null(finemapAux$pip)) { + fromPip <- if (!is.null(finemapAux) && !is.null(finemapAux$pip)) { unname(finemapAux$pip[vids]) } else { NULL } - if (is.null(priorities) || all(is.na(priorities))) { - priorities <- abs(w) + # No usable PIPs at all -> rank on |weight|; otherwise fill only the gaps. + priorities <- if (is.null(fromPip) || all(is.na(fromPip))) { + abs(w) } else { - priorities[is.na(priorities)] <- abs(w)[is.na(priorities)] + replace(fromPip, is.na(fromPip), abs(w)[is.na(fromPip)]) } isMust <- is_in(vids, mustKeep) ord <- order(!isMust, -priorities) @@ -2945,9 +3199,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(payload) } keyMap <- set_names(resolved, stored) - payload$LD_map$LD_file <- unname(resolved) - payload$LD_map$SNP_file <- unname(resolved) - .ctwasRekeyLdLoaders(payload, keyMap) + rekeyed <- list_assign( + payload, + LD_map = list_assign( + payload$LD_map, + LD_file = unname(resolved), + SNP_file = unname(resolved) + ) + ) + .ctwasRekeyLdLoaders(rekeyed, keyMap) } # Only "pecotmr://" tokens move; an ordinary path is the caller's own and is @@ -2969,10 +3229,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(payload) } hit <- is_in(names(panels), names(keyMap)) - names(panels)[hit] <- unname(keyMap[names(panels)[hit]]) - payload$LD_loader_fun <- .ctwasMultiBlockLdLoader(panels) - payload$snpinfo_loader_fun <- .ctwasMultiBlockSnpInfoLoader(panels) - payload + rekeyed <- `names<-`( + panels, + replace(names(panels), hit, unname(keyMap[names(panels)[hit]])) + ) + list_assign( + payload, + LD_loader_fun = .ctwasMultiBlockLdLoader(rekeyed), + snpinfo_loader_fun = .ctwasMultiBlockSnpInfoLoader(rekeyed) + ) } # The panel cache the loader closures were built over, or NULL when the @@ -2983,11 +3248,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (!is.function(loader)) { return(NULL) } - env <- environment(loader) - if (is.null(env) || !exists("ldPanelsByRegion", envir = env)) { - return(NULL) - } - get("ldPanelsByRegion", envir = env) + attr(loader, "ldPanelsByRegion") } # Multi-block LD loader for ctwas. ctwas invokes @@ -2996,7 +3257,8 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # `LD_map$LD_file`) into the cached per-sketch ldPanel. # @noRd .ctwasMultiBlockLdLoader <- function(ldPanelsByRegion) { - function(LD_file, ...) { + force(ldPanelsByRegion) + fn <- function(LD_file) { panel <- ldPanelsByRegion[[LD_file]] if (is.null(panel)) { msg <- glue( @@ -3007,12 +3269,17 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } panel$R } + # Published explicitly so .ctwasCachedPanels can recover the cache from a + # loader we built, instead of looking the name up inside the closure's + # environment. + `attr<-`(fn, "ldPanelsByRegion", ldPanelsByRegion) } # Multi-block SNP-info loader for ctwas. Mirrors the LD loader. # @noRd .ctwasMultiBlockSnpInfoLoader <- function(ldPanelsByRegion) { - function(LD_file, ...) { + force(ldPanelsByRegion) + function(LD_file) { panel <- ldPanelsByRegion[[LD_file]] if (is.null(panel)) { msg <- glue( @@ -3061,15 +3328,22 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # the block's GWAS variants (intersected against the cached panel) so # snp_map[[region_id]] is sized to the block, not the whole panel. # @noRd -.ctwasSnpInfoForGwasBlock <- function(gwasSumStats, panelSnpInfo) { - blockIds <- character(0) - for (i in seq_len(nrow(gwasSumStats))) { - mc <- S4Vectors::mcols(gwasSumStats[[i]]) - if (is_in("SNP", colnames(mc))) { - blockIds <- c(blockIds, as.character(mc$SNP)) - } +# One entry's variant ids, or none when it does not carry a SNP column. +# @noRd +.ctwasEntrySnpIds <- function(i, gwasSumStats) { + mc <- S4Vectors::mcols(gwasSumStats[[i]]) + if (!is_in("SNP", colnames(mc))) { + return(character(0)) } - blockIds <- unique(blockIds) + as.character(mc$SNP) +} + +.ctwasSnpInfoForGwasBlock <- function(gwasSumStats, panelSnpInfo) { + blockIds <- unique(.ctwasConcatChr(map( + seq_len(nrow(gwasSumStats)), + .ctwasEntrySnpIds, + gwasSumStats = gwasSumStats + ))) if (length(blockIds) == 0L) { return(panelSnpInfo[FALSE, , drop = FALSE]) } diff --git a/R/ctwasWrapper.R b/R/ctwasWrapper.R new file mode 100644 index 000000000..32ba3e4b1 --- /dev/null +++ b/R/ctwasWrapper.R @@ -0,0 +1,263 @@ +# ============================================================================= +# cTWAS engine interface +# ----------------------------------------------------------------------------- +# Every call into the `ctwas` package lives here; ctwasPipeline.R orchestrates +# the three steps and holds the Param bundles. The split is mechanical: a +# function belongs here if it calls `ctwas::`, or is the Options bag that +# forwards arguments to one of those calls. +# ============================================================================= + +# Every ctwas function the pipeline fans `CtwasOptions` out to. The bundle is +# validated against the union of their explicit formals, which is sound +# because .ctwasInvoke filters it per callee (see there). +# @noRd +.ctwasCallees <- function() { + c( + "ctwas::compute_gene_z", + "ctwas::est_param", + "ctwas::screen_regions", + "ctwas::finemap_regions", + "ctwas::expand_region_data", + "ctwas::postprocess_region_merging", + "ctwas::postprocess_region_merging_noLD", + "ctwas::get_boundary_genes" + ) +} + +# z_gene for assemble_region_data (which requires it non-NULL): use the caller's +# inputs$z_gene, else compute via ctwas::compute_gene_z (mirrors +# ctwas_sumstats). Routed through .ctwasInvoke so `methodArgs` reaches it -- +# this was the one ctwas step CtwasOptions() could not configure. +# @noRd +.ctwasEnsureZGene <- function(inputs, numThreads, extra = list()) { + if (!is.null(inputs$z_gene)) { + return(inputs$z_gene) + } + .ctwasInvoke( + ctwas::compute_gene_z, + list( + z_snp = inputs$z_snp, + weights = inputs$weights, + ncore = numThreads + ), + extra = extra + ) +} + +# assemble_region_data -> the per-region list (keyed by region_id). It does NOT +# echo z_gene or return boundary genes; both are recovered separately. +# @noRd +.ctwasAssembleRegionData <- function(inputs, zGene, thin, numThreads, extra) { + .ctwasInvoke( + ctwas::assemble_region_data, + list( + region_info = inputs$region_info, + z_snp = inputs$z_snp, + z_gene = zGene, + weights = inputs$weights, + snp_map = inputs$snp_map, + thin = thin, + ncore = numThreads + ), + extra = extra + ) +} + +# Boundary genes (computed internally by assemble_region_data for adjustment but +# never returned) recovered via ctwas::get_boundary_genes; NULL for one region. +# @noRd +.ctwasBoundaryGenes <- function(inputs, numThreads, extra) { + if (nrow(inputs$region_info) <= 1L) { + return(NULL) + } + .ctwasInvoke( + ctwas::get_boundary_genes, + list( + region_info = inputs$region_info, + weights = inputs$weights, + ncore = numThreads + ), + extra = extra + ) +} + +# The accurate EM (ctwas::est_param) invocation, split out so +# .ctwasEstParamOrFallback can run it directly (no fallback) or inside a +# tryCatch +# (with fallback) without duplicating the argument assembly. +# @noRd +.ctwasEstParamAccurate <- function( + regionData, + niterPrefit, + niter, + groupPriorVarStructure, + numThreads, + extra +) { + .ctwasInvoke( + ctwas::est_param, + list( + region_data = regionData, + niter_prefit = as.integer(niterPrefit), + niter = as.integer(niter), + group_prior_var_structure = groupPriorVarStructure, + ncore = numThreads + ), + extra = extra + ) +} + +#' Screen cTWAS regions +#' +#' @description Step 3 of the three-step \code{\link{ctwasPipeline}}: runs +#' \code{ctwas::screen_regions} on the \code{\link{estCtwasGroupPriors}} +#' result and returns the screened-region set. Use this entry point to +#' substitute hand-tuned priors for the ones estimated in step 2 (e.g. when +#' the accurate EM diverges to NaN and you want to recover the prefit +#' values). +#' +#' @param estResult A list returned by \code{\link{estCtwasGroupPriors}}. +#' @param numThreads Number of cores. +#' @param methodArgs Additional arguments forwarded to ctwas, built +#' with \code{\link{CtwasOptions}}. Names are checked against what +#' the ctwas steps accept between them. +#' @return The \code{estResult} list augmented with \code{screen_res} (the full +#' ctwas output) and \code{screened_region_data}. +#' @importFrom purrr map compact +#' @examples +#' data(ctwasEstExample) +#' screenCtwasRegions(ctwasEstExample) +#' @export +screenCtwasRegions <- function( + estResult, + numThreads = 1L, + methodArgs = CtwasOptions() +) { + .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") + if (!requireNamespace("ctwas", quietly = TRUE)) { + abort("Package 'ctwas' is required for screenCtwasRegions.") + } + estResult <- .ctwasResolveLdPaths(estResult) + # ctwas::screen_regions requires thin = 1 region_data; expand the + # thinned set first when assemble_region_data was called with thin < 1 + # (matches ctwas_sumstats's own expand-before-screen step). + thinVals <- compact(map(estResult$region_data, "thin")) + needsExpand <- length(thinVals) > 0L && min(list_c(thinVals)) < 1 + regionDataForScreen <- if (needsExpand) { + .ctwasInvoke( + ctwas::expand_region_data, + list( + region_data = estResult$region_data, + snp_map = estResult$snp_map, + z_snp = estResult$z_snp, + ncore = as.integer(numThreads) + ), + extra = methodArgs + ) + } else { + estResult$region_data + } + screenRes <- .ctwasInvoke( + ctwas::screen_regions, + list( + region_data = regionDataForScreen, + group_prior = estResult$param$group_prior, + group_prior_var = estResult$param$group_prior_var, + ncore = as.integer(numThreads) + ), + extra = methodArgs + ) + c( + estResult, + list( + screen_res = screenRes, + screened_region_data = screenRes$screened_region_data + ) + ) +} + +# Fine-map the screened regions, or hand back the empty shape when the +# screen kept none -- ctwas::finemap_regions() has no meaningful answer for +# an empty region set, and the caller's result still needs both slots. +# @noRd +.ctwasFinemapOrEmpty <- function(screenResult, L, numThreads, methodArgs) { + rd <- screenResult$screened_region_data + if (length(rd) == 0L) { + return(list(finemap_res = NULL, susie_alpha_res = NULL)) + } + .ctwasInvoke( + ctwas::finemap_regions, + list( + region_data = rd, + LD_map = screenResult$LD_map, + weights = screenResult$weights, + group_prior = screenResult$param$group_prior, + group_prior_var = screenResult$param$group_prior_var, + L = as.integer(L), + LD_format = "custom", + LD_loader_fun = screenResult$LD_loader_fun, + snpinfo_loader_fun = screenResult$snpinfo_loader_fun, + ncore = as.integer(numThreads) + ), + extra = methodArgs + ) +} + +# Pick the LD vs no-LD region-merging fn + args. ctwas's postprocess_*() +# forward `...` into finemap_regions, so the LD loader closures must ride in the +# explicit arg list (not filtered through .ctwasInvoke). +# @noRd +.ctwasMergeDispatch <- function(finemapResult, common, L) { + if (is.null(finemapResult$LD_loader_fun)) { + return(list( + fn = ctwas::postprocess_region_merging_noLD, + args = common + )) + } + args <- c( + common, + list( + LD_map = finemapResult$LD_map, + L = as.integer(L), + LD_format = "custom", + LD_loader_fun = finemapResult$LD_loader_fun, + snpinfo_loader_fun = finemapResult$snpinfo_loader_fun + ) + ) + list(fn = ctwas::postprocess_region_merging, args = args) +} + +#' @title Arguments For The ctwas Fitting Steps +#' @description Options forwarded to ctwas. \code{ctwasPipeline} runs seven +#' ctwas functions in sequence and hands this one bundle to each, forwarding +#' only the arguments that step actually accepts -- so a setting meant for +#' the screening step does not disturb the fitting step. Names are therefore +#' checked against what those seven functions accept \emph{between them}. +#' +#' The interface is deliberately flat, matching ctwas's own +#' \code{ctwas_sumstats}, which takes forty arguments in one signature and +#' distributes them to its internal steps itself. +#' @param ... Any argument accepted by one of the ctwas steps, under ctwas's +#' own names (\code{niter}, \code{min_gene}, \code{min_nonSNP_PIP}, +#' \code{numThreads}, ...). Note that settings pecotmr exposes as its own +#' parameters --- \code{thin}, \code{L}, \code{numThreads} on the pipeline --- +#' are passed there, not here. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasOptions(min_group_size = 1, min_gene = 1) +#' @export +CtwasOptions <- function(...) { + extra <- list(...) + .ctwasRefusePipelineOwned(extra) + .newMethodOptions( + .ctwasCallees(), + defaults = list(), + extra = extra, + label = "CtwasOptions", + engine = "ctwas", + # .ctwasInvoke intersects the bundle with each step's explicit + # formals, so the union check is sound even though three of the seven + # take `...`. + filtered = TRUE + ) +} diff --git a/R/enloc.R b/R/enloc.R new file mode 100644 index 000000000..35c6605cf --- /dev/null +++ b/R/enloc.R @@ -0,0 +1,191 @@ +# ============================================================================= +# enloc scoring +# ----------------------------------------------------------------------------- +# The colocalisation probabilities fastenloc computes, for one eQTL signal +# cluster, under the DAP-1 approximation. +# +# fastenloc enumerates a p x p grid over (GWAS hit m, causal eQTL n) and sums +# it (controller.cc, "case 4"). That is quadratic in the cluster size, but the +# per-cell prior takes only two values -- one on the diagonal, one off it -- +# so the off-diagonal total factorises and the whole grid collapses to a +# handful of vector operations: +# +# diagSum = priD * sum(bf * pip) +# offSum = priO * (sum(bf) * sum(pip) - sum(bf * pip)) +# +# The two agree exactly; this file computes the second. +# +# The four configurations fastenloc enumerates are coloc's hypotheses, so both +# parameterisations come out of one pass: RCP is PP.H4 (both traits causal at +# the same variant) and LCP is PP.H3 + PP.H4 (both causal, same variant or +# not). What makes this enloc rather than coloc is the prior, which depends on +# whether the GWAS hit IS the eQTL -- pi1_e = expit(a0 + a1) on the diagonal +# against pi1_ne = expit(a0) off it. coloc applies one p12 to every shared +# configuration and so cannot express that dependence. +# ============================================================================= + +#' @include AllGenerics.R +NULL + +# The GWAS Bayes factors fastenloc recovers from fine-mapped PIPs, contrasting +# against "every variant in the cluster has no effect" (controller.cc): +# log10bf = log10(pip) - log10(P_gwas) + log10(1 - P_gwas) - log10(1 - cpip) +# A zero PIP is floored, as upstream does, so the log is finite. +# @noRd +.enlocGwasLog10Bf <- function(gwasPip, pGwas, clusterPip) { + floored <- replace(gwasPip, gwasPip == 0, 1e-10) + log10(floored) - log10(pGwas) + (log10(1 - pGwas) - log10(1 - clusterPip)) +} + +# The two priors a configuration can carry. `pi1e` applies when the GWAS hit +# is itself the causal eQTL, `pi1ne` when it is not; the enrichment is +# precisely the gap between them. +# @noRd +.enlocConfigPriors <- function(pi1e, pi1ne, p) { + list( + diagonal = pi1e * (1 - pi1ne)^(p - 1), + offDiagonal = pi1ne * (1 - pi1e) * (1 - pi1ne)^(p - 2) + ) +} + +#' @title enloc Colocalisation Probabilities For One Signal Cluster +#' @description The quantities fastenloc reports for a single eQTL signal +#' cluster, given the GWAS Bayes factors and the eQTL PIPs over the same +#' variants. +#' +#' Both parameterisations are returned because they come from one +#' computation: \code{rcp} is \code{ppH4} and \code{lcp} is +#' \code{ppH3 + ppH4}. +#' @param gwasLog10Bf Numeric vector of per-variant GWAS log10 Bayes factors. +#' @param qtlPip Numeric vector of per-variant eQTL PIPs, same length and +#' order. +#' @param pi1e Prior probability of GWAS causality for a variant that is a +#' causal eQTL, \code{expit(a0 + a1)}. +#' @param pi1ne The same for a variant that is not, \code{expit(a0)}. +#' @param p12 Prior probability of colocalisation, used only for the +#' small-probability floor fastenloc applies to each SNP-level term. +#' @param applyFloor Logical. Apply that floor. fastenloc skips it on the +#' summary-statistics path, where not all variants are present. +#' @return A list with \code{ppH0} to \code{ppH4}, \code{rcp}, \code{lcp} and +#' \code{scp} (the per-variant colocalisation probabilities whose sum is +#' \code{rcp}). +#' @examples +#' enlocClusterProbabilities( +#' gwasLog10Bf = c(2, 0.1, 0.1), +#' qtlPip = c(0.7, 0.2, 0.05), +#' pi1e = 0.02, +#' pi1ne = 0.001 +#' ) +#' @export +enlocClusterProbabilities <- function( + gwasLog10Bf, + qtlPip, + pi1e, + pi1ne, + p12 = 0, + applyFloor = FALSE +) { + p <- length(gwasLog10Bf) + if (p != length(qtlPip)) { + abort(glue( + "enlocClusterProbabilities: `gwasLog10Bf` and `qtlPip` must ", + "describe the same variants ({p} vs {length(qtlPip)})." + )) + } + bf <- 10^gwasLog10Bf + # The cluster's total eQTL posterior, capped as upstream does so that + # log(1 - clusterPip) stays finite. + clusterPip <- min(sum(qtlPip), 1 - 1e-8) + pri <- .enlocConfigPriors(pi1e, pi1ne, p) + # case 4, split by whether the GWAS hit is the causal eQTL + perVariant <- pri$diagonal * bf * qtlPip + if (applyFloor) { + perVariant <- pmax(perVariant, p12) + } + diagSum <- sum(perVariant) + offSum <- pri$offDiagonal * + (sum(bf) * sum(qtlPip) - sum(bf * qtlPip)) + # cases 1-3: neither, GWAS only, eQTL only + nullBoth <- (1 - pi1ne)^p * (1 - clusterPip) + gwasOnly <- pi1ne * (1 - pi1ne)^(p - 1) * sum(bf) * (1 - clusterPip) + qtlOnly <- (1 - pi1e) * (1 - pi1ne)^(p - 1) * sum(qtlPip) + nc <- nullBoth + gwasOnly + qtlOnly + diagSum + offSum + list( + ppH0 = nullBoth / nc, + ppH1 = gwasOnly / nc, + ppH2 = qtlOnly / nc, + ppH3 = offSum / nc, + ppH4 = diagSum / nc, + rcp = diagSum / nc, + lcp = (offSum + diagSum) / nc, + scp = perVariant / nc + ) +} + +# enloc's priors from the enrichment parameters, as +# fastenloc's set_enrich_params(a0, a1) computes them. `a1` is capped first, +# matching the --cap_a1 option upstream. +# @noRd +.enlocPriorsFromEnrichment <- function(a0, a1, pQtl, capA1 = Inf) { + a1 <- min(a1, capA1) + pi1e <- stats::plogis(a0 + a1) + pi1ne <- stats::plogis(a0) + list( + pi1e = pi1e, + pi1ne = pi1ne, + p1 = (1 - pQtl) * pi1ne, + p2 = pQtl * (1 - pi1e), + p12 = pQtl * pi1e + ) +} + +# The inverse: the enrichment parameters implied by a p1/p2/p12 triple, as +# fastenloc's set_enrich_params(p1, p2, p12) computes them. Used to accept an +# enrichment table that carries the priors rather than a0/a1. +# @noRd +.enlocEnrichmentFromPriors <- function(p1, p2, p12) { + rest <- 1 - p1 - p2 - p12 + list( + a0 = log(p1 / rest), + a1 = log(p12 * rest / (p1 * p2)) + ) +} + +# Per-variant posteriors within one signal cluster. A SuSiE effect's log Bayes +# factors become posterior inclusion probabilities by softmax under the +# uniform prior over variants -- which is what SuSiE's own `alpha` is -- so a +# single effect row is exactly enloc's notion of a signal cluster. +# @noRd +.enlocClusterPip <- function(log10Bf) { + shifted <- log10Bf - max(log10Bf) + w <- 10^shifted + w / sum(w) +} + +# Score one (QTL effect, GWAS effect) pair the way fastenloc scores a signal +# cluster. Everything the scorer needs is implied by the priors: the two +# marginals are P_gwas = p1 + p12 and P_eqtl = p2 + p12, and (a0, a1) invert +# out of the triple, so an enrichment table carrying p1/p2/p12 is sufficient. +# @noRd +.enlocScoreEffectPair <- function(qtlLog10Bf, gwasLog10Bf, priors) { + pGwas <- priors$p1 + priors$p12 + pQtl <- priors$p2 + priors$p12 + en <- .enlocEnrichmentFromPriors(priors$p1, priors$p2, priors$p12) + pr <- .enlocPriorsFromEnrichment(en$a0, en$a1, pQtl) + qtlPip <- .enlocClusterPip(qtlLog10Bf) + gwasPip <- .enlocClusterPip(gwasLog10Bf) + # A SuSiE effect's alpha is conditional on that effect being present, so + # it sums to exactly 1 -- the cluster is certain to hold a causal variant. + # fastenloc's own cap on locus_epip is what keeps log(1 - cpip) finite + # there, and it has to be applied before the Bayes factors are recovered, + # not only inside the scorer. + clusterPip <- min(sum(qtlPip), 1 - 1e-8) + enlocClusterProbabilities( + gwasLog10Bf = .enlocGwasLog10Bf(gwasPip, pGwas, clusterPip), + qtlPip = qtlPip, + pi1e = pr$pi1e, + pi1ne = pr$pi1ne, + p12 = priors$p12, + applyFloor = FALSE + ) +} diff --git a/R/exampleData.R b/R/exampleData.R index 19ef9b032..845ca3fe8 100644 --- a/R/exampleData.R +++ b/R/exampleData.R @@ -598,9 +598,10 @@ NULL #' #' @description The assembled cTWAS input list produced by #' \code{\link{assembleCtwasInputs}} over a two-LD-block chr22 grid with one -#' gene, ready for \code{\link{estCtwasParam}}. Self-contained (no external LD -#' files needed for parameter estimation). Derived from the de-identified -#' \code{protocol_example} toy data; all identifiers are synthetic. +#' gene, ready for \code{\link{estCtwasGroupPriors}}. Self-contained (no +#' external LD files needed for parameter estimation). Derived from the +#' de-identified \code{protocol_example} toy data; all identifiers are +#' synthetic. #' #' @format A list with the cTWAS input components \code{z_snp}, \code{z_gene}, #' \code{weights}, \code{region_info}, \code{snp_map}, \code{LD_map}, and the @@ -622,7 +623,7 @@ NULL #' @docType data #' #' @description The augmented cTWAS state returned by -#' \code{\link{estCtwasParam}} (the assembled inputs plus estimated +#' \code{\link{estCtwasGroupPriors}} (the assembled inputs plus estimated #' group priors and per-region data), ready for #' \code{\link{screenCtwasRegions}}. Derived from the de-identified #' \code{protocol_example} toy data; all identifiers are synthetic. diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index bbdd5a694..d0afdc344 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -1,4 +1,4 @@ -#' @include qtlSumStats.R gwasSumStats.R +#' @include qtlSumStats.R gwasSumStats.R MethodParam.R #' @title Fine-Mapping Pipeline #' @description S4-dispatched per-region fine-mapping entry point that #' replaces the deprecated \code{univariateAnalysisPipeline}, @@ -52,8 +52,9 @@ #' } #' #' @section Chained initialisation: When \code{susieInf} is requested alongside -#' \code{susie} and/or \code{susieAsh} and \code{addSusieInf = TRUE} -#' (default), the SuSiE-inf fit is computed first and used as initialisation +#' \code{susie} and/or \code{susieAsh} and +#' \code{addSusieInf = TRUE} (the default), the SuSiE-inf fit is computed +#' first and used as initialisation #' for the SuSiE / SuSiE-ash fits, mirroring the legacy #' \code{univariateAnalysisPipeline} / \code{susieRssPipeline} chained init #' behaviour. SuSiE-inf is dropped from the final result when the caller did @@ -80,8 +81,8 @@ #' \itemize{ #' \item TWAS weights computation (\code{twasWeights = TRUE} path): #' lives in \code{\link{twasWeightsPipeline}} now. -#' \item Filtering knobs (\code{mafCutoff}, \code{imissCutoff}, -#' \code{xvarCutoff}, \code{ldReferenceMetaFile}): individual- +#' \item Filtering knobs (now \code{genotypeFilter} / +#' \code{panelFilter}, \code{ldReferenceMetaFile}): individual- #' level QC lives on the \code{QtlDataset} constructor; sumstat #' QC lives in \code{summaryStatsQc()}. No filtering happens #' inside this pipeline. @@ -90,7 +91,7 @@ #' reanalysis on the RSS path): these are not exposed as #' dedicated method tokens. Callers who want a single-effect #' fit can request it via per-method kwargs, e.g. -#' \code{methods = list(susie = list(L = 1))} (see the +#' \code{methods = FineMappingMethodsParam(susie = list(L = 1))} #' \code{methods} parameter). #' \item \code{loadRssData} and explicit #' \code{ldReferenceMetaFile} arguments: the new @@ -117,11 +118,12 @@ #' \code{c("susie", "susieInf", "mvsusie")} (any subset of #' \code{c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie")}, #' subject to per-class compatibility). -#' \item A named list keyed by method token, where each value is a -#' list of per-method kwargs to splice into the underlying -#' fitter, e.g. -#' \code{list(susie = list(L = 1, refine = FALSE), -#' mvsusie = list(max_iter = 500))}. Mirrors the +#' \item A \code{\link{FineMappingMethodsParam}} record keyed by method +#' token, where each value is a list of per-method kwargs to +#' splice into the underlying fitter, e.g. +#' \code{FineMappingMethodsParam(susie = list(L = 1, refine = +#' FALSE), mvsusie = list(max_iter = 500))}. Each +#' entry is checked against the engine that receives it. Mirrors the #' convention of \code{\link{twasWeightsPipeline}}'s #' \code{methods} argument. User-supplied kwargs override the #' capability-table defaults and any base / chained args set @@ -147,59 +149,65 @@ #' genotypes into one joint fit. Ignored for a single-range / cis #' (\code{traitId} + \code{cisWindow}) request. #' @param addSusieInf Logical. When \code{susieInf} is in \code{methods} -#' alongside \code{susie} and/or \code{susieAsh}, controls whether the -#' SuSiE-inf fit initialises the chained downstream method(s). Default -#' \code{TRUE}. -#' @param coverage Primary credible-set coverage (numeric, length 1). Default -#' \code{0.95}. -#' @param secondaryCoverage Secondary coverages forwarded to -#' \code{postprocessFinemappingFits}. Default \code{c(0.7, 0.5)}. -#' @param signalCutoff PIP cutoff for top-loci selection. Default \code{0.025}. -#' @param minAbsCorr Minimum absolute correlation for credible-set purity. -#' Default \code{0.8}. -#' @param medianAbsCorr Optional median absolute correlation for credible-set -#' purity, routed to \code{susieR::susie_get_cs}. A set is kept if it passes -#' either \code{minAbsCorr} or \code{medianAbsCorr} (OR-logic). Default -#' \code{NULL} (off). +#' alongside \code{susie} and/or \code{susieAsh}, whether the SuSiE-inf +#' fit initialises the chained downstream method(s). Default \code{TRUE}. +#' A choice between methods rather than a property of the credible sets, +#' which is why it stands alone. +#' @param credibleSetArgs How credible sets are built and reported, built with +#' \code{\link{CredibleSetParam}}: \code{coverage} (default \code{0.95}), +#' \code{secondaryCoverage} (\code{c(0.7, 0.5)}), \code{signalCutoff} +#' (the PIP cutoff for top-loci selection, \code{0.025}), +#' \code{minAbsCorr} (\code{0.8}) and \code{medianAbsCorr} +#' (\code{NULL}) for purity --- a set is kept if it passes either, OR-logic +#' --- and \code{includeAllCs}. \code{perCsColumns} adds the per-set +#' variant-level columns to \code{topLoci}. \code{L} bounds how many +#' credible sets can exist (default \code{10}) and \code{Lgreedy} the +#' greedy-L loop of the SuSiE-inf refinement. +#' +#' Most fields are read by \code{\link{postprocessFinemappingFits}}, so a +#' stored fit can be re-summarized under different settings without +#' refitting. \code{L} / \code{Lgreedy} are the exception: they are seeded +#' onto each SuSiE-family token's own arguments, so changing them needs a +#' refit. #' @param fineMappingResult Optional existing \code{FineMappingResult} to use as #' a resume cache; tuples already present are not refit. -#' @param cvFolds Integer. Number of cross-validation folds. Default \code{0} -#' (no CV). When \code{> 1}, each method is refit on the training samples of -#' every fold and used to predict the held-out samples; the fold partition -#' plus per-fold out-of-fold predictions and metrics are stored on each -#' \code{FineMappingRow}'s \code{cvResult} slot (see -#' \code{\link{getCvResult}}). \code{twasWeightsPipeline} reuses this -#' partition and feeds these predictions into the SR-TWAS ensemble. -#' Individual-level (\code{QtlDataset} / \code{MultiStudyQtlDataset}) input -#' only; ignored for sumstat inputs. -#' @param cvThreads Integer. Number of parallel workers for the cross-validation -#' fold refits (passed to the shared CV engine's \code{numThreads}). Default -#' \code{1} (serial); \code{-1} uses all cores. Only consulted when -#' \code{cvFolds > 1}. -#' @param samplePartition Optional pre-defined CV partition \code{data.frame} -#' with columns \code{Sample} and \code{Fold}. When supplied (and -#' \code{cvFolds > 1}), every method reuses this exact partition; otherwise a -#' fresh partition is generated per \code{(study, context, trait)}. +#' @param crossValidationArgs Cross-validation settings, built with +#' \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no +#' CV), \code{numThreads} for the per-fold refits, and \code{samplePartition} +#' to reuse a fixed partition across methods. When \code{folds > 1} each +#' method is refit on every fold's training samples and used to predict the +#' held-out ones; the partition, the out-of-fold predictions and the metrics +#' are stored on each \code{FineMappingRow}'s \code{cvResult} slot. +#' +#' Cross-validation holds out \strong{samples}, so it is not possible on +#' \code{QtlSumStats} / \code{GwasSumStats} input. Those methods accept +#' the argument and \strong{error} if it is set, rather than accepting it +#' and quietly returning results that were never cross-validated. +#' +#' \code{maxVariants} and \code{weightMethods} are honoured by +#' \code{\link{twasWeightsPipeline}} only and are ignored here. #' @param seed Optional integer. When non-NULL, #' \code{withr::local_seed(seed)} is called at the start of the call for #' reproducible fits; the global RNG state is restored on return. Default #' \code{NULL} #' (no seeding). -#' @param pipCutoffToSkip Numeric (length 1). Individual-level single-effect -#' (SER) pre-screen applied to each residualized \code{(X, y)} block before a -#' full fit: a susie model with \code{L = 1} is fit and the block is skipped -#' when no PIP exceeds the cutoff (no potentially significant variant). The -#' summary-statistics analog lives in \code{summaryStatsQc()}. \code{0} -#' (default) disables the screen; a negative value uses the adaptive \code{3 / -#' nVariants} threshold. -#' @param absZCutoffToSkip,bfCutoffToSkip,logBfCutoffToSkip Numeric (length 1). -#' Alternative individual-level pre-screen metrics, in place of -#' \code{pipCutoffToSkip}: skip a block unless its maximum marginal \code{|z|} -#' (\code{absZCutoffToSkip}), or its maximum per-variant single-effect Bayes -#' factor (\code{bfCutoffToSkip}) / log Bayes factor -#' (\code{logBfCutoffToSkip}) from the \code{L = 1} fit, exceeds the cutoff. -#' Each defaults to 0 (off). Exactly one of the four \code{*CutoffToSkip} -#' arguments may be non-zero (one screening metric at a time). +#' @param signalScreenArgs Individual-level single-effect (SER) pre-screen +#' applied to each residualized \code{(X, y)} block before a full fit, +#' built with \code{\link{SignalScreenParam}}. A susie model with +#' \code{L = 1} is fit and the block is skipped unless the chosen metric +#' exceeds its cutoff: +#' \itemize{ +#' \item \code{pip} --- the maximum PIP. A negative cutoff uses the +#' adaptive \code{3 / nVariants} threshold. +#' \item \code{absZ} --- the maximum marginal \code{|z|}, which needs +#' no fit. +#' \item \code{bf} / \code{logBf} --- the maximum per-variant Bayes +#' factor or log Bayes factor from the \code{L = 1} fit. +#' } +#' Only one metric may be enabled, which +#' \code{\link{SignalScreenParam}} enforces when you build it. Unset (the +#' default) screens nothing. The summary-statistics analog lives in +#' \code{\link{summaryStatsQc}}. #' @param usePCA Logical (length 1). \code{QtlDataset} only. When \code{TRUE} #' (default \code{FALSE}), each multi-trait context's PCA-reduced phenotype is #' fine-mapped with univariate SuSiE on its top principal components (ports @@ -221,127 +229,94 @@ #' for the accepted grammar. #' @section Panel filters on the RSS path: On \code{QtlSumStats} / #' \code{GwasSumStats} input there is no genotype matrix to filter, so -#' \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured -#' against the \strong{LD reference panel} instead: a variant whose panel -#' genotypes fall below the cutoffs is dropped before the z-scores and LD -#' matrix are built. The thresholds mean the same thing as on the -#' \code{QtlDataset} path (MAC is converted to a MAF equivalent and the -#' stricter of the two applies), so one number carries across input types. -#' Defaults (\code{0}, \code{0}, \code{1}) filter nothing. +#' \code{panelFilter}'s \code{mafCutoff} / \code{macCutoff} / +#' \code{imissCutoff} are measured against the \strong{LD reference panel} +#' instead: a variant whose panel genotypes fall below the cutoffs is +#' dropped before the z-scores and LD matrix are built. The thresholds mean +#' the same thing as \code{genotypeFilter}'s on the \code{QtlDataset} path +#' (MAC is converted to a MAF equivalent and the stricter of the two +#' applies), so one number carries across input types. The defaults filter +#' nothing. #' #' This discards \emph{observed} variants, unlike -#' \code{summaryStatsQc(imputeOpts = ...)}, which only bounds which variants +#' \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants #' RAISS will impute. Use it when the panel cannot support the LD estimate a #' rare variant would need. #' -#' @param mafCutoff Numeric or \code{NULL}. Per-call override of the -#' \code{QtlDataset} minor-allele-frequency filter; \code{NULL} uses the -#' dataset's stored value. -#' @param macCutoff Numeric or \code{NULL}. Per-call override of the -#' \code{QtlDataset} minor-allele-count filter; \code{NULL} uses the dataset's -#' stored value. -#' @param xvarCutoff Numeric or \code{NULL}. Per-call override of the -#' \code{QtlDataset} per-variant variance filter; \code{NULL} uses the -#' dataset's stored value. -#' @param imissCutoff Numeric or \code{NULL}. Per-call override of the -#' \code{QtlDataset} per-sample missingness filter; \code{NULL} uses the -#' dataset's stored value. -#' @param keepIndel Logical or \code{NULL}. Per-call override of the -#' \code{QtlDataset} indel-retention flag; \code{NULL} uses the dataset's -#' stored value. -#' @param keepSamples Character vector or \code{NULL}. Per-call override of the -#' \code{QtlDataset} sample allow-list; \code{NULL} uses the dataset's stored -#' value. -#' @param keepVariants Character vector or \code{NULL}. Per-call override of the -#' \code{QtlDataset} variant allow-list; \code{NULL} uses the dataset's stored -#' value. -#' @param L Integer. Maximum number of SuSiE single effects. Default \code{10}. -#' @param Lgreedy Integer or \code{NULL}. Number of greedily-added effects in -#' the SuSiE-inf refinement (the greedy-L loop). \code{NULL} (default) -#' disables the greedy loop and fits \code{L} directly. -#' @param twasWeights Optional \code{\link{TwasWeights}} resume cache to reuse -#' previously fitted weights; \code{NULL} fits fresh. +#' @param genotypeFilterArgs Per-call overrides of the \code{QtlDataset}'s own +#' filters, built with \code{\link{GenotypeFilterParam}}. A field left unset +#' keeps the dataset's construct-time value, so +#' \code{GenotypeFilterParam(mafCutoff = 0)} pins the cutoff at zero while +#' \code{GenotypeFilterParam()} changes nothing. Applies to the +#' \code{QtlDataset} method only. +#' @param panelFilterArgs LD-reference-panel filters for the summary-statistics +#' and GWAS methods, built with \code{\link{PanelFilterParam}}. See +#' \emph{Panel filters on the RSS path} above. +#' @param mrmashPrior Optional \code{\link{TwasWeights}} from a previous +#' mr.mash \code{\link{twasWeightsPipeline}} run, mined for the mvSuSiE +#' data-driven prior: the retained \code{mrmash} fits supply the prior +#' mixture, and their cross-validation payload supplies honest per-fold +#' priors. \code{NULL} uses the canonical prior instead. #' @param dataDrivenPriorWeightsCutoff Numeric or \code{NULL}. Cutoff below #' which data-driven prior weights are zeroed; \code{NULL} disables the #' cutoff. #' @param naAction Character. How to handle missing values in the extracted #' phenotype/genotype data. #' @param verbose Verbosity (0 silent, 1 default). Default \code{1}. -#' @param phenotypeCovariatesToResidualize Character vector (or \code{NULL}) of -#' phenotype-covariate names to residualize against. \code{NULL} (default) -#' uses every available phenotype covariate. Only meaningful when the input is -#' a \code{QtlDataset} / \code{MultiStudyQtlDataset} (ignored for sumstat -#' inputs). -#' @param genotypeCovariatesToResidualize Character vector (or \code{NULL}) of -#' genotype-covariate column names to residualize against. \code{NULL} uses -#' every available genotype covariate. -#' @param residualizePhenotypeCovariates Logical (length 1). When \code{TRUE} -#' (default) residualize against the phenotype-side covariates listed in -#' \code{phenotypeCovariatesToResidualize}. Set \code{FALSE} to disable -#' phenotype-covariate residualization entirely. The marginal univariate -#' effects stored on each \code{FineMappingRow} obey the same -#' residualization choice as the SuSiE fit itself -- they are computed against -#' the same residualized \code{X} / \code{Y}. -#' @param residualizeGenotypeCovariates Logical (length 1). When \code{TRUE} -#' (default) residualize against the genotype-side covariates listed in -#' \code{genotypeCovariatesToResidualize}. Set \code{FALSE} to disable. -#' @param trim Logical (length 1). When \code{TRUE} (default) the -#' \code{susieFit} slot on each output \code{FineMappingRow} carries a -#' trimmed view of the SuSiE fit (the minimal subset needed by downstream -#' pipelines). When \code{FALSE} the full untrimmed \code{susie()} return is -#' retained so accessors like \code{getSusieFit()} and non-default-coverage -#' queries through \code{getCs()} can read the full posterior matrices -#' (\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 serFallback Logical (length 1, default \code{FALSE}). -#' \code{QtlSumStats} / \code{GwasSumStats} (summary-statistics SuSiE-RSS -#' paths) only. When \code{TRUE}, after each standard multi-effect SuSiE-RSS -#' fit (\code{susie} / \code{susieAsh}) the pipeline reads susieR's -#' finite-sample R diagnostics and, if -#' \code{fit$R_finite_diagnostics$R_reliability_flag} is \code{TRUE}, reports -#' the single-effect (\code{ser_model}) result for that region instead of the -#' multi-effect fit. Defaults \code{FALSE} so existing callers are unchanged. -#' See \code{keepFullFit} for retaining the multi-effect fit. -#' @param rFinite \code{QtlSumStats} / \code{GwasSumStats} only. Finite-sample -#' size for susieR's \code{R_finite} correction, forwarded to -#' \code{susieR::susie_rss()}. \code{NULL} (default) uses susieR's default, -#' except when a finite/EB mode is active (\code{serFallback=TRUE} or -#' \code{rMismatch != "none"}) and \code{rFinite} is \code{NULL}, in which -#' case it defaults to the LD-panel sample size \code{getNSamples(ldSketch)}. -#' @param rMismatch \code{QtlSumStats} / \code{GwasSumStats} only. LD-mismatch -#' correction mode forwarded to \code{susieR::susie_rss()} as -#' \code{R_mismatch}: \code{"none"} (default), \code{"eb"} (empirical Bayes), -#' or \code{"eb_mix"} (residual-mixture EB). -#' @param rssControl \code{QtlSumStats} / \code{GwasSumStats} only. Optional -#' named list of \code{susieR::susie_rss_control()} settings (e.g. -#' \code{check_prior}, \code{mismatch_estimator}), forwarded as -#' \code{susie_rss()}'s \code{control} argument. Default \code{NULL} leaves -#' the \code{susie_rss_control()} defaults in place. -#' @param keepFullFit \code{QtlSumStats} / \code{GwasSumStats} only. Controls -#' retention of the pre-fallback multi-effect SuSiE-RSS fit when -#' \code{serFallback=TRUE}: \code{"fallback"} (default) keeps it only for -#' regions that fell back to SER; \code{"all"} keeps it for every region; -#' \code{"none"} keeps none. The retained fit and the decision are stored on -#' the entry's SuSiE fit and read via \code{getSusieFit(res)$multiEffectFit}, -#' \code{getSusieFit(res)$R_reliability_flag}, and -#' \code{getSusieFit(res)$serFallbackUsed}. +#' @param residualizationArgs Covariate residualization settings, built with +#' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and +#' \code{genotypeCovariates} name which covariates to regress out +#' (\code{NULL}, the default, uses every available one), and +#' \code{residualizePhenotype} / \code{residualizeGenotype} turn each side +#' off. +#' +#' Only meaningful for \code{QtlDataset} / \code{MultiStudyQtlDataset} +#' input. A \code{QtlSumStats} / \code{GwasSumStats} run has no covariates +#' to regress out, so the bundle is \strong{ignored} there rather than +#' refused --- unlike \code{crossValidation}, which errors. Residualization +#' is on by default, so refusing a non-default value would reject the +#' default bundle; CV is off by default, so a non-default value there is an +#' explicit request for something the input cannot do. +#' +#' The marginal univariate effects stored on each \code{FineMappingRow} +#' obey the same choice as the SuSiE fit itself --- they are computed +#' against the same residualized \code{X} / \code{Y}. +#' @param fitRetention How much of each fit the \code{susieFit} slot keeps: +#' \code{"slim"} (default) a trimmed view, or \code{"full"} the whole +#' \code{susie()} return, so \code{getSusieFit()} and +#' non-default-coverage \code{getCs()} queries can read the full posterior +#' matrices. The per-variant \code{topLoci} table is fully populated +#' either way --- its per-credible-set columns are governed by +#' \code{credibleSet}'s \code{perCsColumns}, not by this. +#' @param rssArgs Summary-statistics solver settings for \code{QtlSumStats} / +#' \code{GwasSumStats} input, built with \code{\link{SusieRssParam}}: +#' \itemize{ +#' \item \code{serFallback} (default \code{FALSE}) --- after each +#' multi-effect SuSiE-RSS fit, read susieR's finite-sample R +#' diagnostics and, when +#' \code{fit$R_finite_diagnostics$R_reliability_flag} is \code{TRUE}, +#' report the single-effect (\code{ser_model}) result for that region +#' instead. +#' \item \code{keepFullFit} (default \code{"fallback"}) --- which +#' pre-fallback multi-effect fits to retain: only the regions that fell +#' back, \code{"all"}, or \code{"none"}. Meaningful only with +#' \code{serFallback}. The retained fit and the decision are read via +#' \code{getSusieFit(res)$multiEffectFit}, +#' \code{$R_reliability_flag} and \code{$serFallbackUsed}. +#' \item \code{rFinite} --- finite-sample size for susieR's +#' \code{R_finite} correction. \code{NULL} (default) uses susieR's +#' own, except when a finite/EB mode is active (\code{serFallback} or +#' \code{rMismatch != "none"}), where it falls back to the LD panel's +#' \code{getNSamples(ldSketch)}. +#' \item \code{rMismatch} (default \code{"none"}) --- LD-mismatch +#' correction forwarded as \code{R_mismatch}: also \code{"eb"} or +#' \code{"eb_mix"}. +#' \item \code{control} --- options for +#' \code{susieR::susie_rss_control()}, built with +#' \code{\link{SusieRssControlOptions}}. This was a bare named list, +#' which meant a misspelled option was dropped silently; the +#' constructor checks the names against that function's live formals. +#' } #' @param ... Reserved for future per-method arguments. #' #' @return A \code{FineMappingResult} collection keyed by \code{(study, context, @@ -354,9 +329,26 @@ #' fineMappingPipeline(qtlDatasetExample, methods = "susie", cisWindow = 1e6) #' @export setGeneric("fineMappingPipeline", function(data, ...) { + # Checked here rather than in an ANY method: the accepted classes are + # known, so this is a validity check, and running it before dispatch + # means the message survives whatever else the call passed. + .fmAssertInputClass(data) standardGeneric("fineMappingPipeline") }) +# @noRd +.fmAssertInputClass <- function(data) { + ok <- c("QtlDataset", "MultiStudyQtlDataset", "QtlSumStats", "GwasSumStats") + if (any(map_lgl(ok, is, object = data))) { + return(invisible(NULL)) + } + abort(glue( + "fineMappingPipeline does not accept inputs of class ", + "'{class(data)[[1L]]}'. Pass a QtlDataset, MultiStudyQtlDataset, ", + "QtlSumStats, or GwasSumStats. Use summaryStatsQc() on SumStats ", + "inputs first." + )) +} # ============================================================================= # Method capability table -- unified naming, individual vs sumstat dispatch @@ -442,15 +434,14 @@ setGeneric("fineMappingPipeline", function(data, ...) { # them with a clear pointer rather than an "unknown token" error. .fmTwasOnlyTokens <- c("mrmash") - # Normalize a user-supplied `methods` argument into a character vector of # canonical tokens. Mirrors `.twasNormalizeMethods` but the fine-mapping # pipeline takes only a character vector (no preset strings, no list form). # @noRd # Normalize a user-supplied `methods` argument into `(tokens, methodArgs)`. # -# Accepts: * character vector c("susie", "susieInf") -> empty kwargs per token * -# named list list(susie = list(L = 1), ...) -> per-token kwargs +# Accepts: * character vector c("susie", "susieInf") -> empty kwargs per token +# * a FineMappingMethodsParam() record -> per-token kwargs, already checked # # Names of the returned `methodArgs` always equal `tokens` (one entry per # token, empty list when the user supplied none). The fitters then @@ -459,47 +450,70 @@ setGeneric("fineMappingPipeline", function(data, ...) { # Mirrors the convention of .twasNormalizeMethods so the two pipelines # expose the same shape on the user side. # @noRd -.fmNormalizeMethods <- function(methods, L = 10L, Lgreedy = NULL) { +.fmNormalizeMethods <- function( + methods, + inputKind, + L = 10L, + Lgreedy = NULL +) { if (is.null(methods) || length(methods) == 0L) { msg <- glue( "fineMappingPipeline: `methods` must be a non-empty character ", - "vector or named list of = entries." + "vector, a named list of per-method options, or a ", + "FineMappingMethodsParam() record." ) abort(msg) } - if (is.character(methods)) { - tokens <- unique(methods) - methodArgs <- set_names(rep(list(list()), length(tokens)), tokens) - } else if (is.list(methods)) { - if (is.null(names(methods)) || any(names(methods) == "")) { - msg <- glue( - "fineMappingPipeline: when `methods` is a list it must be ", - "named (one entry per method token)." - ) - abort(msg) - } - nonListChild <- !map_lgl(methods, is.list) - if (any(nonListChild)) { - badNames <- str_flatten(names(methods)[nonListChild], ", ") - msg <- glue( - "fineMappingPipeline: each entry of the `methods` list must ", - "itself be a list of named kwargs (got non-list value ", - "for: {badNames})." - ) - abort(msg) - } - tokens <- unique(names(methods)) - methodArgs <- methods[tokens] + parsed <- if (is.character(methods)) { + .fmMethodsFromTokens(methods) + } else if (is(methods, "MethodsSelectionParam") || is.list(methods)) { + # A plain named list is routable HERE even though the constructor + # refuses one under `methods`: this call knows its input class, so + # the overrides go into that path's slot and are checked against the + # engine that will actually receive them. + .methodsParamResolve( + .methodsParamFor( + methods, + inputKind, + "FineMappingMethodsParam", + "fineMappingPipeline" + ), + inputKind + ) + } else if (.isMethodOptions(methods)) { + # The retired FineMappingMethodsParam() record. + list( + tokens = names(methods), + methodArgs = map(as.list(methods), as.list) + ) } else { cls <- class(methods)[[1L]] msg <- glue( - "fineMappingPipeline: `methods` must be a character vector or ", - "named list. Got class '{cls}'." + "fineMappingPipeline: `methods` must be a character vector, a ", + "named list of per-method options, or a ", + "FineMappingMethodsParam() record. Got class '{cls}'." ) abort(msg) } - methodArgs <- .fmSeedSusieDefaults(methodArgs, tokens, L, Lgreedy) - list(tokens = tokens, methodArgs = methodArgs) + list( + tokens = parsed$tokens, + methodArgs = .fmSeedSusieDefaults( + parsed$methodArgs, + parsed$tokens, + L, + Lgreedy + ) + ) +} + +# A bare character vector of tokens: every token gets empty kwargs. +# @noRd +.fmMethodsFromTokens <- function(methods) { + tokens <- unique(methods) + list( + tokens = tokens, + methodArgs = set_names(rep(list(list()), length(tokens)), tokens) + ) } # SuSiE-family fit defaults live here (the single source of truth), not in CLI @@ -507,17 +521,85 @@ setGeneric("fineMappingPipeline", function(data, ...) { # already set them. # @noRd .fmSeedSusieDefaults <- function(methodArgs, tokens, L, Lgreedy) { - for (tk in intersect(tokens, c("susie", "susieInf", "susieAsh"))) { - if (is.null(methodArgs[[tk]][["L"]])) { - methodArgs[[tk]][["L"]] <- L - } - if (is.null(methodArgs[[tk]][["L_greedy"]])) { - methodArgs[[tk]][["L_greedy"]] <- Lgreedy + seeded <- intersect(tokens, c("susie", "susieInf", "susieAsh")) + if (length(seeded) == 0L) { + return(methodArgs) + } + list_assign( + methodArgs, + !!!set_names( + map( + seeded, + .fmSeedTokenDefaults, + methodArgs = methodArgs, + L = L, + Lgreedy = Lgreedy + ), + seeded + ) + ) +} + +# One token's kwargs with L / L_greedy filled in where the caller left them +# unset. A token with no kwargs at all still gets the defaults. +# @noRd +.fmSeedTokenDefaults <- function(tk, methodArgs, L, Lgreedy) { + args <- methodArgs[[tk]] %||% list() + list_assign( + args, + L = args[["L"]] %||% L, + L_greedy = args[["L_greedy"]] %||% Lgreedy + ) +} + +# Which engine a token actually reaches for a given input class. A method may +# have one entry point for individual-level data and another for summary +# statistics, and any single run uses exactly one of them -- so once the input +# class is known the argument names can be checked against that one engine +# rather than against the union of both. +# @noRd +.fmMethodCalleeFor <- function(token, inputKind) { + info <- .fineMappingMethodCapabilities[[token]] + if (is.null(info)) { + return(NULL) + } + if (identical(inputKind, "QtlDataset")) { + return(info$individualImpl) + } + info$sumstatImpl +} + +# Check each token's user arguments against the single engine this run will +# reach. Stricter than the constructor's check, which cannot know the input +# class: an argument that only `susie_rss` accepts is caught here on an +# individual-level run, and mvsusie becomes checkable on the QtlDataset path +# even though mvsusie_rss takes `...`. +# @noRd +.fmCheckMethodArgsForInput <- function(methodArgs, inputKind) { + for (token in names(methodArgs)) { + callee <- .fmMethodCalleeFor(token, inputKind) + if (is.null(callee)) { + next } + accepted <- .engineAcceptedNames(callee) + # Defaults pecotmr seeds itself are not the caller's to answer for. + given <- setdiff(names(methodArgs[[token]]), .fmSeededArgNames()) + .engineCheckExtra( + methodArgs[[token]][given], + accepted, + glue("fineMappingPipeline: method '{token}'"), + callee + ) } - methodArgs + invisible(NULL) } +# Argument names pecotmr seeds on the caller's behalf, which therefore need no +# checking against the engine. +# @noRd +.fmSeededArgNames <- function() { + c("L", "L_greedy") +} # Enforce input-class / method compatibility against the fine-mapping # capability table. Rejects TWAS-weight-oriented tokens (.fmTwasOnlyTokens, @@ -629,7 +711,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { } } - # Reject SumStats inputs that have not been QC'd via summaryStatsQc. # @noRd .fmAssertQcd <- function(sumstats) { @@ -644,7 +725,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { } } - # Given a `methods` vector, decide whether the SuSiE-inf chained-init # shortcut applies. Returns a list of (chainSusie, chainAsh, runInf, # keepInf): runInf is TRUE when susieInf must be fitted (either user @@ -667,7 +747,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { ) } - # Optional resume-cache lookup. Returns the matching FineMappingRow from # `fineMappingResult` for the tuple (study, context, trait, method), or # NULL when there is no hit. Returns NULL silently when fineMappingResult @@ -703,24 +782,26 @@ setGeneric("fineMappingPipeline", function(data, ...) { if (!is(fineMappingResult, "GwasFineMappingResult")) { return(NULL) } - idx <- .matchTupleRows( + matched <- .matchTupleRows( fineMappingResult, list(study = study, method = method) ) - if (length(idx) == 0L) { + if (length(matched) == 0L) { return(NULL) } - if (length(idx) > 1L) { - keys <- .rtlRangeKeys(fineMappingResult)[idx] - idx <- idx[keys == blockId] - if (length(idx) == 0L) { - return(NULL) - } + # Several rows share (study, method) when the study was split into blocks; + # the block key picks the one this lookup wants. + idx <- if (length(matched) == 1L) { + matched + } else { + matched[.rtlRangeKeys(fineMappingResult)[matched] == blockId] + } + if (length(idx) == 0L) { + return(NULL) } .fmrRowParts(fineMappingResult, idx[[1L]]) } - # Build a QtlFineMappingResult collection from per-tuple parallel vectors. # `jointStudies`, `jointContexts`, `jointTraits` are optional character # vectors (length matches `studies`) describing semicolon-joined joint @@ -837,12 +918,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { # GWAS resume lookup using the GwasFineMappingResult (study, method, range) # identity; NULL when no compatible cache was supplied. # @noRd -.fmCacheLookupGwasResume <- function(p, st, tk, blockId) { +.fmCacheLookupGwasResume <- function(fineMappingResult, st, tk, blockId) { if ( - !is.null(p$fineMappingResult) && - is(p$fineMappingResult, "GwasFineMappingResult") + !is.null(fineMappingResult) && + is(fineMappingResult, "GwasFineMappingResult") ) { - .fmCacheLookupGwas(p$fineMappingResult, st, tk, blockId) + .fmCacheLookupGwas(fineMappingResult, st, tk, blockId) } else { NULL } @@ -851,37 +932,14 @@ setGeneric("fineMappingPipeline", function(data, ...) { # Fit the still-to-run RSS tokens for one GWAS region and return one row-record # per fitted token. # @noRd -.fmGwasFitRows <- function(p, gr, zn, st, blockId, toRun) { - z <- zn$z - names(z) <- zn$variantIds - ldMat <- .ldFromSketch( - p$ldSketch, - zn$variantIds, - label = "fineMappingPipeline" - ) - ents <- .fmFitRssBlock( - z, - ldMat, - zn$n, +.fmGwasFitRows <- function(gr, zn, st, blockId, toRun, cfg) { + ents <- .fmFitRssBlockP( + set_names(zn$z, zn$variantIds), + zn, toRun, - p$addSusieInf, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$methodArgs, - p$verbose, - label = glue("GWAS (study='{st}', region='{blockId}')"), - af = .fmAfByVar(gr, zn$variantIds), - nVar = zn$nVar, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - serFallback = p$serFallback, - rFinite = p$rFiniteResolved, - rMismatch = p$rMismatch, - rssControl = p$rssControl, - keepFullFit = p$keepFullFit + glue("GWAS (study='{st}', region='{blockId}')"), + .fmAfByVar(gr, zn$variantIds), + cfg ) map(names(ents), .fmGwasRowFor, st = st, blockId = blockId, ents = ents) } @@ -890,29 +948,34 @@ setGeneric("fineMappingPipeline", function(data, ...) { # tokens, or an empty set when the region was screened out. Returns # list(rows, skipped) so the caller sums the skip flags functionally. # @noRd -.fmGwasEntryRows <- function(i, p) { - st <- p$studyCol[[i]] - gr <- .collectionEntry(p$data, i) - skip <- .fmEntrySkipInfo(p$data, i) +.fmGwasEntryRows <- function(i, studyCol, tokens, cfg) { + st <- studyCol[[i]] + gr <- .collectionEntry(cfg$data, i) + skip <- .fmEntrySkipInfo(cfg$data, i) if (isTRUE(skip$skipped)) { - if (p$verbose >= 1) { + if (cfg$verbose >= 1) { reason <- skip$reason - msg <- glue( + inform(glue( "fineMappingPipeline(GwasSumStats): study='{st}' region ", "skipped: {reason}" - ) - inform(msg) + )) } return(list(rows = list(), skipped = TRUE)) } zn <- .fmExtractZn( gr, glue("fineMappingPipeline(GwasSumStats): study='{st}'"), - ldSketch = p$ldSketch, - cutoffs = .panelCutoffs(p) + ldSketch = cfg$ldSketch, + cutoffs = .panelCutoffs(cfg$panelFilterArgs) ) blockId <- .fmGwasBlockId(gr) - lookups <- map(p$tokens, .fmGwasLookup, p = p, st = st, blockId = blockId) + lookups <- map( + tokens, + .fmGwasLookup, + fineMappingResult = cfg$fineMappingResult, + st = st, + blockId = blockId + ) cachedRows <- map( keep(lookups, .fmHasCached), .fmGwasRowFromLookup, @@ -923,54 +986,104 @@ setGeneric("fineMappingPipeline", function(data, ...) { if (length(toRun) == 0L) { return(list(rows = cachedRows, skipped = FALSE)) } - computed <- .fmGwasFitRows(p, gr, zn, st, blockId, toRun) + computed <- .fmGwasFitRows(gr, zn, st, blockId, toRun, cfg) list(rows = c(cachedRows, computed), skipped = FALSE) } -# Fit the still-to-run RSS tokens for one QtlSumStats entry and return one -# row-record per fitted token. +# The fine-mapping settings shared by every summary-statistics path: the +# QtlSumStats joint phase and the RSS / GWAS row builders all act on these. +# Named once here so the records built from it cannot disagree about the same +# setting. Explicitly constructed, not captured from the calling frame. # @noRd -.fmRssFitRows <- function(p, i, st, ctx, tr, toRun) { - entry <- .collectionEntry(p$data, i) - zn <- .fmExtractZn( - entry, - glue( - "fineMappingPipeline(QtlSumStats): entry {i} (study='{st}', ", - "context='{ctx}', trait='{tr}')" - ), - ldSketch = p$ldSketch, - cutoffs = .panelCutoffs(p) +.fmSsCommonCfg <- function( + data, + credibleSetArgs, + fineMappingResult, + fitRetention, + verbose, + panelFilterArgs +) { + list( + data = data, + credibleSetArgs = credibleSetArgs, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + verbose = verbose, + panelFilterArgs = panelFilterArgs + ) +} + +# The per-run settings the RSS / GWAS row builders all need: the common +# summary-statistics record plus the LD and RSS-control fields only the row +# builders use. The chain threads one record instead of twenty arguments, and +# every field is named deliberately -- this is not a capture of the calling +# frame. +# @noRd +.fmRssRunCfg <- function( + common, + ldSketch, + addSusieInf, + methodArgs, + rssArgs +) { + c( + common, + list( + ldSketch = ldSketch, + addSusieInf = addSusieInf, + methodArgs = methodArgs, + rssArgs = rssArgs + ) ) - z <- zn$z - names(z) <- zn$variantIds +} + +# .fmFitRssBlock with the per-run knobs supplied from `cfg`; callers pass only +# the block-specific arguments. The RSS analog of .fmFitXBlockP. +# @noRd +.fmFitRssBlockP <- function(z, zn, toRun, label, af, cfg) { ldMat <- .ldFromSketch( - p$ldSketch, + cfg$ldSketch, zn$variantIds, label = "fineMappingPipeline" ) - ents <- .fmFitRssBlock( + .fmFitRssBlock( z, ldMat, zn$n, toRun, - p$addSusieInf, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$methodArgs, - p$verbose, - label = glue("(study='{st}', context='{ctx}', trait='{tr}')"), - af = .fmAfByVar(entry, zn$variantIds), + cfg$addSusieInf, + cfg$methodArgs, + cfg$verbose, + label = label, + af = af, nVar = zn$nVar, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - serFallback = p$serFallback, - rFinite = p$rFiniteResolved, - rMismatch = p$rMismatch, - rssControl = p$rssControl, - keepFullFit = p$keepFullFit + credibleSetArgs = cfg$credibleSetArgs, + fitRetention = cfg$fitRetention, + rssArgs = cfg$rssArgs + ) +} + +# Fit the still-to-run RSS tokens for one QtlSumStats entry and return one +# row-record per fitted token. +# @noRd +.fmRssFitRows <- function(i, st, ctx, tr, toRun, cfg) { + entry <- .collectionEntry(cfg$data, i) + zn <- .fmExtractZn( + entry, + glue( + "fineMappingPipeline(QtlSumStats): entry {i} (study='{st}', ", + "context='{ctx}', trait='{tr}')" + ), + ldSketch = cfg$ldSketch, + cutoffs = .panelCutoffs(cfg$panelFilterArgs) + ) + ents <- .fmFitRssBlockP( + set_names(zn$z, zn$variantIds), + zn, + toRun, + glue("(study='{st}', context='{ctx}', trait='{tr}')"), + .fmAfByVar(entry, zn$variantIds), + cfg ) map(names(ents), .fmQtlRowFor, st = st, ctx = ctx, tr = tr, ents = ents) } @@ -979,14 +1092,21 @@ setGeneric("fineMappingPipeline", function(data, ...) { # tokens remain to run and the entry was not screened out) freshly-fitted # tokens. Returns list(rows, skipped) so the caller sums the skip flags. # @noRd -.fmRssEntryRows <- function(i, p) { - st <- p$studyCol[i] - ctx <- p$contextCol[i] - tr <- p$traitCol[i] +.fmRssEntryRows <- function( + i, + studyCol, + contextCol, + traitCol, + univTokens, + cfg +) { + st <- studyCol[i] + ctx <- contextCol[i] + tr <- traitCol[i] lookups <- map( - p$univTokens, + univTokens, .fmQtlLookup, - p = p, + fineMappingResult = cfg$fineMappingResult, st = st, ctx = ctx, tr = tr @@ -1002,32 +1122,29 @@ setGeneric("fineMappingPipeline", function(data, ...) { if (length(toRun) == 0L) { return(list(rows = cachedRows, skipped = FALSE)) } - skip <- .fmEntrySkipInfo(p$data, i) + skip <- .fmEntrySkipInfo(cfg$data, i) if (isTRUE(skip$skipped)) { - if (p$verbose >= 1) { + if (cfg$verbose >= 1) { reason <- skip$reason - msg <- glue( + inform(glue( "fineMappingPipeline(QtlSumStats): entry {i} ", "(study='{st}', context='{ctx}', trait='{tr}') ", "skipped: {reason}" - ) - inform(msg) + )) } return(list(rows = cachedRows, skipped = TRUE)) } - computed <- .fmRssFitRows(p, i, st, ctx, tr, toRun) + computed <- .fmRssFitRows(i, st, ctx, tr, toRun, cfg) list(rows = c(cachedRows, computed), skipped = FALSE) } # Concatenate two same-class FineMappingResult collections row-wise, carrying # forward every column (delegates to the generic `.rbindCollections`). # @noRd +#' @importFrom checkmate assertClass .rbindFineMappingResult <- function(a, b, ldSketch = NULL) { - if (!is(a, "FineMappingResultBase") || !is(b, "FineMappingResultBase")) { - abort( - ".rbindFineMappingResult expects two FineMappingResultBase inputs." - ) - } + assertClass(a, "FineMappingResultBase") + assertClass(b, "FineMappingResultBase") # Carry forward every column (blockId / joint* / ...) and reconcile the # collection-level slots via the shared combine; the concrete class # (QTL vs GWAS) is preserved and checked there. @@ -1064,51 +1181,64 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } -# Wrap one finemapping fit into a FineMappingRow via the surviving -# post-processing helpers (postprocessFinemappingFits + -# formatFinemappingOutput). Returns a bare FineMappingRow payload, ready -# to be inserted into a FineMappingResult. -# @noRd -# Look up residualization flags from the enclosing setMethod frame -# and call `getResidualized{Phenotypes,Genotypes}` with them. Each -# fineMappingPipeline / twasWeightsPipeline method exposes the four -# convenience flags listed in `.resFlagNames`; the wrapper threads them -# through to the accessor so per-call-site changes aren't needed. -.resFlagNames <- c( - "phenotypeCovariatesToResidualize", - "genotypeCovariatesToResidualize", - "residualizePhenotypeCovariates", - "residualizeGenotypeCovariates" -) - -.resPickFlags <- function() { - out <- list() - # Walk up from the immediate caller; the public setMethod frame is - # where the user-facing args live. sys.frames()[[1]] is the global - # env so stop before that. - frames <- sys.frames() - for (i in seq_along(frames)) { - fr <- frames[[i]] - for (nm in .resFlagNames) { - if ( - !is_in(nm, names(out)) && - exists(nm, envir = fr, inherits = FALSE) - ) { - out[[nm]] <- get(nm, envir = fr, inherits = FALSE) - } - } - } - out -} - -.fmResidPheno <- function(x, ...) { - resArgs <- c(list(x = x, ...), .resPickFlags()) - exec(getResidualizedPhenotypes, !!!resArgs) +# The selector arguments are named rather than carried in `...`: an omitted +# one must still fall through to the extractor's own default, so NULL entries +# are dropped instead of forwarded. discard(is.null), not compact(): compact() +# would also drop a legitimately zero-length `contexts` / `samples`. +.fmResidPheno <- function( + x, + residualizationArgs, + contexts = NULL, + traitId = NULL, + naAction = NULL +) { + sel <- discard( + list(contexts = contexts, traitId = traitId, naAction = naAction), + is.null + ) + exec( + getResidualizedPhenotypes, + !!!c( + list( + x = x, + residualizationArgs = residualizationArgs %||% + ResidualizationParam() + ), + sel + ) + ) } -.fmResidGeno <- function(x, ...) { - resArgs <- c(list(x = x, ...), .resPickFlags()) - exec(getResidualizedGenotypes, !!!resArgs) +.fmResidGeno <- function( + x, + residualizationArgs, + contexts = NULL, + traitId = NULL, + region = NULL, + cisWindow = NULL, + samples = NULL +) { + sel <- discard( + list( + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples + ), + is.null + ) + exec( + getResidualizedGenotypes, + !!!c( + list( + x = x, + residualizationArgs = residualizationArgs %||% + ResidualizationParam() + ), + sel + ) + ) } # Directional effect-allele (A1) frequency for the variants in a fitted @@ -1121,6 +1251,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # sources whose entries already carry `af`). The branch mirrors the # `.fmResidGeno` call that built `X`: `region`-driven when a joint range is # given, else `traitId` + `cisWindow` for the cis window. +#' @importFrom rlang try_fetch .fmAfForX <- function( data, X, @@ -1134,7 +1265,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (!is(data, "QtlDataset")) { return(NULL) } - afAll <- tryCatch( + afAll <- try_fetch( if (is.null(region)) { getAf( data, @@ -1145,7 +1276,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } else { getAf(data, region = region, samples = rownames(X)) }, - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(afAll) || length(afAll) == 0L) { return(NULL) @@ -1158,28 +1289,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { method, dataX, dataY, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, + credibleSetArgs, + fitRetention, csInput = NULL, af = NULL, n = NULL, region = NULL, - trim = NULL, - medianAbsCorr = NULL, - conditionIdx = NULL, - fullFit = NULL, - fullFitAlphaOnly = NULL, - includeAllCs = NULL + conditionIdx = NULL ) { - d <- .fmPostprocessDefaults( - trim, - medianAbsCorr, - fullFit, - fullFitAlphaOnly, - includeAllCs - ) .fmRunPostprocess( fit, method, @@ -1190,11 +1307,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { n, csInput, conditionIdx, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, - d + credibleSetArgs = credibleSetArgs, + fitRetention = fitRetention ) } @@ -1211,11 +1325,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { n, csInput, conditionIdx, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, - d + credibleSetArgs, + fitRetention ) { post <- postprocessFinemappingFits( fits = set_names(list(fit), method), @@ -1223,18 +1334,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { dataY = dataY, af = af, n = n, - coverage = coverage, - secondaryCoverage = secondaryCoverage, - signalCutoff = signalCutoff, - minAbsCorr = minAbsCorr, - medianAbsCorr = d$medianAbsCorr, region = region, csInput = csInput, conditionIdx = conditionIdx, - trim = d$trim, - fullFit = d$fullFit, - fullFitAlphaOnly = d$fullFitAlphaOnly, - includeAllCs = d$includeAllCs + # Both were threaded all the way down here and then not passed on, + # so every caller's credible-set settings (coverage, purity, + # signalCutoff, perCsColumns, ...) and retention level were replaced + # by postprocessFinemappingFits()'s own defaults. + credibleSetArgs = credibleSetArgs, + fitRetention = fitRetention ) out <- formatFinemappingOutput(post, primaryMethod = method) # `formatFinemappingOutput` returns $finemappingEntry as a bare row @@ -1249,27 +1357,6 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { out$finemappingEntry } -# isTRUE-normalize the postprocess knobs, applying each knob's default when a -# caller passes NULL. Callers that expose these knobs (e.g. the RSS path) thread -# them explicitly via `p$trim` / `p$medianAbsCorr`; the rest pass NULL and take -# the default (trim = TRUE, medianAbsCorr = NULL). -# @noRd -.fmPostprocessDefaults <- function( - trim, - medianAbsCorr, - fullFit, - fullFitAlphaOnly, - includeAllCs -) { - list( - trim = isTRUE(trim %||% TRUE), - medianAbsCorr = medianAbsCorr, - fullFit = isTRUE(fullFit %||% FALSE), - fullFitAlphaOnly = isTRUE(fullFitAlphaOnly %||% TRUE), - includeAllCs = isTRUE(includeAllCs %||% FALSE) - ) -} - # --- Multi-region (jointRegions) helpers ------------------------------------ # Resolve the per-trait X windows from a (region, jointRegions) pair. The cis @@ -1295,72 +1382,25 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } } -# The canonical (non-reweighted) mvSuSiE mixture prior for residual variance -# `V`: -# create_mixture_prior(R) restricted to the group's conditions. +# Rows of a TwasWeights whose method is mr.mash and whose identity matches +# every axis the caller FIXED. A NULL axis means "do not filter on it". # @noRd -.fmCanonicalPrior <- function(V, conditionNames, R) { - list( - priorVariance = mvsusieR::create_mixture_prior( - R = R, - include_indices = conditionNames - ), - residualVariance = V +.fmMrmashSelector <- function(mrmashPrior, study, trait, context) { + axes <- compact(list(study = study, trait = trait, context = context)) + reduce( + names(axes), + .fmMrmashNarrow, + mrmashPrior = mrmashPrior, + axes = axes, + .init = as.character(mrmashPrior$method) == "mrmash" ) } -# Rebuild the mvSuSiE data-driven *reweighted* mixture prior + residual variance -# from a stored mr.mash fit -- the lean payload -# (list(dataDrivenPriorMatrices, w0, V)) that mrmashWeights(retainFit = TRUE) -# attaches and twasWeightsPipeline keeps on the mrmash TwasWeightsRow. Shared -# by the fine-mapping mvsusie consumer and the twas mvsusie_weights consumer. -# -# Reproduces the deleted multivariate_pipeline.R reweighting bit-identically: -# rescaleCovW0(w0) collapses the expanded mr.mash weights onto the original -# data-driven covariance matrices ($U), filters to surviving components, and -# create_mixture_prior() wraps them, restricted to the fit's conditions -# (`conditionNames` = colnames(Y)). `V` becomes mvsusie's residual_variance. -# A NULL fit, NULL matrices, or no surviving component falls back to the -# canonical create_mixture_prior(R), matching the legacy `else` branch. -# Returns list(priorVariance, residualVariance) (residualVariance NULL only -# when no fit was supplied at all). -# @noRd -.buildMvsusieReweightedPrior <- function( - fitParts, - conditionNames, - weightsTol = 1e-10, - overrideU = NULL -) { - R <- length(conditionNames) - if (is.null(fitParts)) { - return(.fmCanonicalPrior(NULL, conditionNames, R)) - } - # `overrideU` (mode C / hybrid): reuse this fit's reweighted mixture weights - # (w0) and residual variance (V) but swap in a different set of data-driven - # covariance matrices -- the per-fold mash prior U. Components are matched - # to w0 by name, so the override U must share component names with the fit. - ddpm <- if (!is.null(overrideU)) { - overrideU - } else { - fitParts$dataDrivenPriorMatrices - } - if (is.null(ddpm) || is.null(ddpm$U)) { - return(.fmCanonicalPrior(fitParts$V, conditionNames, R)) - } - w0Updated <- rescaleCovW0(fitParts$w0) - w0Updated <- w0Updated[is_in(names(w0Updated), names(ddpm$U))] - if (length(w0Updated) == 0L) { - return(.fmCanonicalPrior(fitParts$V, conditionNames, R)) - } - mixture <- list(matrices = ddpm$U[names(w0Updated)], weights = w0Updated) - list( - priorVariance = mvsusieR::create_mixture_prior( - mixture_prior = mixture, - weights_tol = weightsTol, - include_indices = conditionNames - ), - residualVariance = fitParts$V - ) +# `.tupleColumn()` not `[[`: on a RangedTupleList `[[` extracts an ELEMENT +# (the variant set), while the identity axes live in mcols. +# @noRd +.fmMrmashNarrow <- function(sel, axis, mrmashPrior, axes) { + sel & as.character(.tupleColumn(mrmashPrior, axis)) == axes[[axis]] } # Locate the retained mr.mash fit payload {dataDrivenPriorMatrices, w0, V} for @@ -1380,30 +1420,20 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # back to the canonical prior). # @noRd .fmLookupMrmashFit <- function( - twasWeights, + mrmashPrior, study = NULL, trait = NULL, context = NULL ) { - if (is.null(twasWeights)) { + if (is.null(mrmashPrior)) { return(NULL) } # Each per-context mr.mash row of a joint group carries the SHARED joint - # fit, - # so the consumer matches the FIXED axes and leaves the jointed axis NULL - # (match-any). study/trait/context = NULL means "do not filter that axis". - sel <- as.character(twasWeights$method) == "mrmash" - if (!is.null(study)) { - sel <- sel & as.character(twasWeights$study) == study - } - if (!is.null(trait)) { - sel <- sel & as.character(twasWeights$trait) == trait - } - if (!is.null(context)) { - sel <- sel & as.character(twasWeights$context) == context - } + # fit, so the consumer matches the FIXED axes and leaves the jointed axis + # NULL (match-any). study/trait/context = NULL means "skip that axis". + sel <- .fmMrmashSelector(mrmashPrior, study, trait, context) for (i in which(sel)) { - f <- getFits(.twrRowParts(twasWeights, i)) + f <- getFits(.twrRowParts(mrmashPrior, i)) if (!is.null(f)) return(f) } NULL @@ -1417,26 +1447,17 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # NULL when no TwasWeights / no matching mr.mash CV result with fold fits. # @noRd .fmLookupMrmashCv <- function( - twasWeights, + mrmashPrior, study = NULL, trait = NULL, context = NULL ) { - if (is.null(twasWeights)) { + if (is.null(mrmashPrior)) { return(NULL) } - sel <- as.character(twasWeights$method) == "mrmash" - if (!is.null(study)) { - sel <- sel & as.character(twasWeights$study) == study - } - if (!is.null(trait)) { - sel <- sel & as.character(twasWeights$trait) == trait - } - if (!is.null(context)) { - sel <- sel & as.character(twasWeights$context) == context - } + sel <- .fmMrmashSelector(mrmashPrior, study, trait, context) for (i in which(sel)) { - cv <- getCvResult(.twrRowParts(twasWeights, i)) + cv <- getCvResult(.twrRowParts(mrmashPrior, i)) if (!is.null(cv) && !is.null(cv$foldFits)) return(cv) } NULL @@ -1462,33 +1483,61 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { foldFits <- mvCv$foldFits sp <- mvCv$samplePartition foldIds <- if (!is.null(sp)) sort(unique(sp$Fold)) else seq_along(foldFits) - out <- set_names(vector("list", length(foldIds)), as.character(foldIds)) - for (i in seq_along(foldIds)) { - # Match the fold fit by name ("fold_") when available, else by - # position. - nm <- str_c("fold_", foldIds[[i]]) - ff <- if (!is.null(names(foldFits)) && is_in(nm, names(foldFits))) { - foldFits[[nm]] - } else if (length(foldFits) >= i) { - foldFits[[i]] - } else { - NULL - } - if (is.null(ff)) { - next - } - out[[i]] <- if (!is.null(ff$w0)) { - .buildMvsusieReweightedPrior(ff, conditionNames, weightsTol) - } else { - .buildMvsusieReweightedPrior( - fullFitParts, - conditionNames, - weightsTol, - overrideU = ff$dataDrivenPriorMatrices - ) - } + # A fold with no fit keeps its NULL slot, so the result stays aligned + # with `foldIds` -- which is what `out[[i]] <- ...` left behind. + set_names( + map( + seq_along(foldIds), + .fmFoldPriorAt, + foldIds = foldIds, + foldFits = foldFits, + fullFitParts = fullFitParts, + conditionNames = conditionNames, + weightsTol = weightsTol + ), + as.character(foldIds) + ) +} + +# Fold `i`'s fit, matched by name ("fold_") when available, else by +# position. +# @noRd +.fmFoldFitAt <- function(i, foldIds, foldFits) { + nm <- str_c("fold_", foldIds[[i]]) + if (!is.null(names(foldFits)) && is_in(nm, names(foldFits))) { + return(foldFits[[nm]]) + } + if (length(foldFits) >= i) { + return(foldFits[[i]]) + } + NULL +} + +# Fold `i`'s reweighted mixture prior, or NULL when the fold has no fit. A +# fold that carries its own w0 defines the prior; otherwise the full-data fit +# does, with the fold's data-driven matrices substituted in. +# @noRd +.fmFoldPriorAt <- function( + i, + foldIds, + foldFits, + fullFitParts, + conditionNames, + weightsTol +) { + ff <- .fmFoldFitAt(i, foldIds, foldFits) + if (is.null(ff)) { + return(NULL) + } + if (!is.null(ff$w0)) { + return(.buildMvsusieReweightedPrior(ff, conditionNames, weightsTol)) } - out + .buildMvsusieReweightedPrior( + fullFitParts, + conditionNames, + weightsTol, + overrideU = ff$dataDrivenPriorMatrices + ) } # PCA-reduce a (samples x traits) phenotype matrix to its top `nPCs` principal @@ -1503,90 +1552,23 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { if (is.null(dim(Y)) || ncol(Y) < 2L) { return(NULL) } - Y <- Y[stats::complete.cases(Y), , drop = FALSE] - if (nrow(Y) < 2L) { + complete <- Y[stats::complete.cases(Y), , drop = FALSE] + if (nrow(complete) < 2L) { return(NULL) } - Y <- Y[, apply(Y, 2L, stats::var) > 0, drop = FALSE] - if (ncol(Y) < 2L) { + varying <- complete[, + apply(complete, 2L, stats::var) > 0, + drop = FALSE + ] + if (ncol(varying) < 2L) { return(NULL) } - scores <- stats::prcomp(Y, center = TRUE, scale. = TRUE)$x + scores <- stats::prcomp(varying, center = TRUE, scale. = TRUE)$x k <- min(as.integer(nPCs), ncol(scores)) if (k < 1L) { return(NULL) } - scores <- scores[, seq_len(k), drop = FALSE] - colnames(scores) <- str_c("topPC", seq_len(k)) - scores -} - -# Per-column marginal-association z-scores of y on each column of X (univariate -# regression z = betahat / sebetahat), used by the individual-level absZ screen. -# @noRd -.marginalZ <- function(X, y) { - ur <- susieR::univariate_regression(X, y) - ur$betahat / ur$sebetahat -} - -# Single-effect (SER) pre-screen, individual-level. Reports whether a -# residualized (X, y) block shows a strong enough signal (by the chosen metric) -# to be worth a full fit. `screen` is a screen spec (see .asScreen): a legacy -# PIP cutoff (numeric scalar, 0 = off) OR a resolved list(metric, cutoff) for -# one of pip / absZ / bf / logBf. Ports the deleted multivariate_pipeline.R -# `skipConditions` / susie_twas `pip_cutoff_to_skip` logic (the individual-level -# analog of the sumstat-path `.applyEntryScreen`): -# * no screen (NULL / 0 / non-scalar numeric) -> always keep. -# * pip cutoff < 0 uses the adaptive 3 / nVariants threshold. -# * absZ needs no susie fit; pip/bf/logBf fit susie L = 1 once (its -# $lbf_variable gives the per-variant logBF for bf/logBf, $pip for pip). -# * NA entries of `y` are dropped before fitting. -# The screen is advisory: too few samples/variants or a fit failure returns -# `fallback` -- TRUE (default) keeps the block rather than discard a potentially -# real signal (fineMapping / joint paths); colocboost passes FALSE to drop an -# outcome it cannot screen. This is the single L = 1 SuSiE pre-screen shared by -# .fmSerScreenColumns (joint) and .cbPipSkipOutcomes (colocboost). -# @noRd -.fmSerScreen <- function(X, y, screen, fallback = TRUE) { - scr <- .asScreen(screen) - if (is.null(scr)) { - return(TRUE) - } - ok <- !is.na(y) - if (sum(ok) < 2L || ncol(X) < 1L) { - return(fallback) - } - Xs <- X[ok, , drop = FALSE] - if (!is.double(Xs)) { - storage.mode(Xs) <- "double" - } # susieR needs double X - ys <- y[ok] - metric <- scr$metric - cutoff <- scr$cutoff - if (metric == "absZ") { - z <- tryCatch(.marginalZ(Xs, ys), error = function(e) NULL) - if (is.null(z)) { - return(fallback) - } - return(any(abs(z) > cutoff, na.rm = TRUE)) - } - fit <- tryCatch( - suppressMessages(susieR::susie(Xs, ys, L = 1L)), - error = function(e) NULL - ) - if (is.null(fit)) { - return(fallback) - } - if (metric == "pip") { - thr <- if (cutoff < 0) 3 / ncol(Xs) else cutoff - return(any(fit$pip > thr, na.rm = TRUE)) - } - maxLbf <- suppressWarnings(max(as.numeric(fit$lbf_variable), na.rm = TRUE)) - if (!is.finite(maxLbf)) { - return(fallback) - } - # bf: cutoff on the raw BF scale -> compare in log space; logBf: log scale. - maxLbf > (if (metric == "bf") log(cutoff) else cutoff) + `colnames<-`(scores[, seq_len(k), drop = FALSE], str_c("topPC", seq_len(k))) } # Is a signal screen enabled? Any spec that .asScreen resolves to a screen @@ -1678,23 +1660,66 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # max of the regions before it (a sequential offset fold, per cs_ # column). # @noRd -.fmRenumberCs <- function(tls, csCols) { - offsets <- set_names(integer(length(csCols)), csCols) - for (i in seq_along(tls)) { - tl <- tls[[i]] - for (cc in csCols) { - if (!is_in(cc, names(tl))) { - next - } - idx <- .fmCsIdx(tl[[cc]]) - tl[[cc]] <- .fmRelabelCs(tl[[cc]], offsets[[cc]]) - offsets[[cc]] <- offsets[[cc]] + max(c(0L, idx), na.rm = TRUE) - } - tls[[i]] <- tl +# The highest credible-set index table `tl` uses in column `cc`, or 0 when it +# has no such column. +# @noRd +.fmCsMaxIn <- function(tl, cc) { + if (!is_in(cc, names(tl))) { + return(0L) } - tls + max(c(0L, .fmCsIdx(tl[[cc]])), na.rm = TRUE) +} + +# How many credible sets precede each element, given per-element counts. +# @noRd +.fmExclusiveCumsum <- function(counts) { + cumsum(c(0L, counts))[seq_along(counts)] +} + +# @noRd +.fmColumnOffsets <- function(cc, tls) { + .fmExclusiveCumsum(map_int(tls, .fmCsMaxIn, cc = cc)) +} + +# @noRd +.fmTableHasCol <- function(cc, tl) { + is_in(cc, names(tl)) +} + +# @noRd +.fmRelabelColumn <- function(cc, tl, offsets, i) { + .fmRelabelCs(tl[[cc]], offsets[[cc]][[i]]) +} + +# @noRd +.fmRenumberTable <- function(i, tls, csCols, offsets) { + tl <- tls[[i]] + present <- keep(csCols, .fmTableHasCol, tl = tl) + if (length(present) == 0L) { + return(tl) + } + mutate( + tl, + !!!set_names( + map(present, .fmRelabelColumn, tl = tl, offsets = offsets, i = i), + present + ) + ) } +.fmRenumberCs <- function(tls, csCols) { + # A table's offset in a column is how many credible sets the tables + # before it contributed there -- a cumulative count, so it is known up + # front instead of being carried through the walk. + offsets <- set_names(map(csCols, .fmColumnOffsets, tls = tls), csCols) + map( + seq_along(tls), + .fmRenumberTable, + tls = tls, + csCols = csCols, + offsets = offsets + ) +} # Merge per-method user kwargs onto a base arg list. `userArgs` is the # per-token kwargs supplied by the caller (e.g. `list(L = 1, refine = @@ -1702,9 +1727,43 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # user did not set. User-supplied values always win over base, capability # defaults, and chain-derived args. Returns the merged list. # @noRd -.fmMergeUserArgs <- function(baseArgs, token, userArgs = NULL) { - if (is.null(userArgs)) { - userArgs <- list() +# Split a merged argument list into the target's own formals plus a +# `methodArgs` remainder. Callers build one flat list (base args, capability +# defaults, user overrides); this routes each name to the right place, so a +# tool option reaches the tool and an unknown name errors at the call instead +# of vanishing. A target with no `methodArgs` formal gets the list unchanged. +# @noRd +.splitMethodArgs <- function(fn, args) { + target <- match.fun(fn) + fm <- names(formals(target)) + if (!is_in("methodArgs", fm)) { + return(args) + } + isFormal <- is_in(names(args), setdiff(fm, "methodArgs")) + c( + args[isFormal], + list(methodArgs = .methodConfigLike(target, args[!isFormal])) + ) +} + +# Wrap the remainder in the record the target's `methodArgs` expects, so a +# target that demands a constructor gets one rather than the bare list it +# would refuse. The constructor is read off the target's own default -- +# `methodArgs = MvsusieOptions()` names it -- so this needs no registry and +# cannot drift from the signature. A target still defaulting to `list()` +# gets the plain list. +# @noRd +.methodConfigLike <- function(target, extra) { + d <- formals(target)$methodArgs + if (!is.call(d) || !is.name(d[[1L]])) { + return(extra) + } + exec(match.fun(as.character(d[[1L]])), !!!extra) +} + +.fmMergeUserArgs <- function(baseArgs, token, userArgs = NULL) { + if (is.null(userArgs)) { + userArgs <- list() } info <- .fineMappingMethodCapabilities[[token]] capDefaults <- if (!is.null(info) && !is.null(info$args)) { @@ -1713,16 +1772,17 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { list() } # Order matters: base < capability defaults < user overrides. - if (length(capDefaults) > 0L) { - baseArgs <- modifyList(baseArgs, capDefaults) + withCaps <- if (length(capDefaults) > 0L) { + list_modify(baseArgs, !!!compact(capDefaults)) + } else { + baseArgs } - if (length(userArgs) > 0L) { - baseArgs <- modifyList(baseArgs, userArgs) + if (length(userArgs) == 0L) { + return(withCaps) } - baseArgs + list_modify(withCaps, !!!compact(userArgs)) } - # .fmFitSusieIndiv / .fmFitSusieRss / .fmFitSusieSer (single SuSiE fits) now # live in fineMappingWrappers.R with the other method-fitting wrappers. @@ -1731,13 +1791,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # shared `.entryToSumstatDf` helper (R/sumstatsQc.R). # @noRd .fmExtractZn <- function(gr, label, ldSketch = NULL, cutoffs = NULL) { - df <- .entryToSumstatDf(gr, require = c("SNP", "Z", "N"), label = label) + allDf <- .entryToSumstatDf(gr, require = c("SNP", "Z", "N"), label = label) # Filtered HERE rather than at the LD build: z, the LD matrix and the # allele frequencies are all keyed off `variantIds`, so narrowing the id # set at its source keeps them aligned by construction instead of by three # subsetting steps staying in step with one another. - keep <- .panelKeepMask(df$variant_id, ldSketch, cutoffs, label) - df <- df[keep, , drop = FALSE] + keep <- .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label) + df <- allDf[keep, , drop = FALSE] list( variantIds = df$variant_id, z = df$z, @@ -1756,7 +1816,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # pipScreenReason); # an entry may also be empty for other reasons. Returns list(skipped, reason). .fmEntrySkipInfo <- function(data, i) { - ea <- tryCatch(getQcInfo(data)$entryAudit[[i]], error = function(e) NULL) + ea <- try_fetch(getQcInfo(data)$entryAudit[[i]], error = function(cnd) NULL) screened <- isTRUE(ea$pipScreenSkipped) entry <- .collectionEntry(data, i) empty <- is.null(entry) || length(entry) == 0L @@ -1776,7 +1836,6 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { list(skipped = isTRUE(screened || empty), reason = reason) } - # ============================================================================= # Per-fold cross-validation of fine-mapping methods # ----------------------------------------------------------------------------- @@ -1840,6 +1899,29 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { NULL } +# The minimal fold-fit payload: exactly the fields the weight extractors +# read, so K folds x (study, context, trait) does not retain K full SuSiE fits. +# `trimFinemappingFit()` is the credible-set-driven trimmer for the fit stored +# on a row; a fold fit has no credible sets to key on and is only ever used to +# re-extract weights, so it keeps a smaller set. +# @noRd +.fmLeanFoldFit <- function(fit, token) { + if (is.null(fit)) { + return(NULL) + } + keep <- c( + "pip", + "alpha", + "mu", + "X_column_scale_factors", + "theta", + "coef", + "V" + ) + lean <- fit[intersect(keep, names(fit))] + `class<-`(lean, unique(c(token, class(fit)))) +} + # Per-fold univariate-susie-family weights (susie / susieInf / susieAsh). # @noRd .fmFoldWeightsSusie <- function(token, Xtr, Ytr, coverage, userArgs) { @@ -1857,37 +1939,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { susieInf = susieInfWeights(susieInfFit = fit), susieAsh = susieAshWeights(susieAshFit = fit) ) - w <- as.numeric(w) - names(w) <- colnames(Xtr) - .fmAsMat(w) -} - -# Per-fold mvsusie weights. Reuses the data-driven reweighted prior + residual -# covariance from the full-data mr.mash fit on every fold -- the prior is over -# conditions, identical across folds (only samples are held out). NULL mvPrior -# -> canonical prior (unchanged behavior). -# @noRd -.fmFoldWeightsMv <- function(Xtr, Ytr, coverage, userArgs, mvPrior) { - baseArgs <- list( - X = Xtr, - Y = Ytr, - coverage = coverage, - prior_variance = if (is.null(mvPrior)) { - mvsusieR::create_mixture_prior(R = ncol(Ytr)) - } else { - mvPrior$priorVariance - } - ) - if (!is.null(mvPrior) && !is.null(mvPrior$residualVariance)) { - baseArgs$residual_variance <- mvPrior$residualVariance - } - mvArgs <- .fmMergeUserArgs(baseArgs, "mvsusie", userArgs) - fit <- exec(fitMvsusie, !!!mvArgs) - W <- as.matrix(mvsusieWeights(mvsusieFit = fit)) - if (is.null(rownames(W))) { - rownames(W) <- colnames(Xtr) - } - W + out <- .fmAsMat(set_names(as.numeric(w), colnames(Xtr))) + `attr<-`(out, "fit", .fmLeanFoldFit(fit, token)) } # Per-fold fsusie weights. @@ -1898,9 +1951,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { "fsusie", userArgs ) - fit <- exec(fitFsusie, !!!fsArgs) + fit <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fsArgs)) W <- fsusieWeights(fsusieFit = fit, variantIds = colnames(Xtr)) - as.matrix(W) + out <- as.matrix(W) + # fSuSiE cannot be re-extracted from a trimmed fit, so the precomputed + # weight matrix rides along as `coef` the same way the row-level trimmer + # does it. + withCoef <- list_assign(fit, coef = out) + `attr<-`(out, "fit", .fmLeanFoldFit(withCoef, "fsusie")) } # Per-fold fine-mapping fit for the CV engine. `ctx` carries mvPrior, mvPriorCv, @@ -1924,32 +1982,70 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } else { mvPrior } - weights <- list() - for (tk in tokens) { - weights[[.fmTwasMethodKey(tk)]] <- tryCatch( - .fmFoldWeights( - tk, - Xtr, - Ytr, - coverage, - methodArgs[[tk]], - pos, - mvPriorThisFold - ), - error = function(e) { - if (verbose >= 1) { - eMsg <- conditionMessage(e) - msg <- glue( - " CV fold {j}, method {tk} failed: {eMsg}", - .trim = FALSE - ) - inform(msg) - } - NULL + keys <- map_chr(tokens, .fmTwasMethodKey) + results <- map( + tokens, + .fmFoldTokenResult, + Xtr = Xtr, + Ytr = Ytr, + coverage = coverage, + methodArgs = methodArgs, + pos = pos, + mvPriorThisFold = mvPriorThisFold, + j = j, + verbose = verbose + ) + list( + weights = set_names(map(results, "weights"), keys), + fits = compact(set_names(map(results, "fit"), keys)) + ) +} + +# One token's fold result. The CV engine's fitFold contract is +# list(weights = matrix>, fits = fitted model>); the fold +# helpers attach their (lean) fit to the weight matrix, so it is split back +# out here rather than stripped in place. +# @noRd +.fmFoldTokenResult <- function( + tk, + Xtr, + Ytr, + coverage, + methodArgs, + pos, + mvPriorThisFold, + j, + verbose +) { + w <- try_fetch( + .fmFoldWeights( + tk, + Xtr, + Ytr, + coverage, + methodArgs[[tk]], + pos, + mvPriorThisFold + ), + error = function(cnd) { + if (verbose >= 1) { + eMsg <- conditionMessage(cnd) + msg <- glue( + " CV fold {j}, method {tk} failed: {eMsg}", + .trim = FALSE + ) + inform(msg) } - ) + NULL + } + ) + if (is.null(w)) { + return(list(weights = NULL, fit = NULL)) } - list(weights = weights, fits = list()) + list( + weights = `attr<-`(w, "fit", NULL), + fit = attr(w, "fit") + ) } # Cross-validate a homogeneous set of fine-mapping `tokens` over (X, Y) via the @@ -2000,12 +2096,36 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { fitFoldCtx = cvFitCtx, numThreads = numThreads, verbose = verbose, - seed = seed + seed = seed, + # Retained so twasWeightsCv can cross-validate a SuSiE-family method: + # those wrappers extract from a supplied fit and never refit, so the + # fold's own fit is the only thing that makes per-fold extraction + # possible. + fitRetention = "slim" ) + .fmCvResult(res) +} + +# The cross-validation result, with the sample partition recorded on the +# fold fits. Recorded at the producer so a consumer can refuse fits trained +# on a different split; without it a mismatched partition would leak +# held-out samples into training and inflate the CV metrics. +# @noRd +.fmCvResult <- function(res) { + foldFits <- if (is.null(res$foldFits)) { + NULL + } else { + `attr<-`( + res$foldFits, + "partitionKey", + .cvPartitionKey(res$samplePartition) + ) + } list( samplePartition = res$samplePartition, prediction = res$prediction, - performance = res$performance + performance = res$performance, + foldFits = foldFits ) } @@ -2025,10 +2145,24 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { list( samplePartition = cv$samplePartition, prediction = cv$prediction[pk], - performance = cv$performance[mk] + performance = cv$performance[mk], + foldFits = .fmSliceFoldFits(cv$foldFits, key) ) } +# One method's per-fold fits, keyed by fold, from the full CV payload. +# @noRd +.fmSliceFoldFits <- function(foldFits, key) { + if (is.null(foldFits) || length(foldFits) == 0L) { + return(NULL) + } + out <- map(foldFits, key) + if (all(map_lgl(out, is.null))) { + return(NULL) + } + `attr<-`(out, "partitionKey", attr(foldFits, "partitionKey")) +} + # Rebuild a FineMappingRow with a cvResult attached (the class is immutable). # @noRd .fmAttachCv <- function(entry, cvResult) { @@ -2043,23 +2177,37 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } - # ============================================================================= # Residualized genotype for one X window: the trait-derived cis block when # `rg` is NULL, else the explicit region. Shared by the univariate and PCA # dispatch paths. # @noRd -.fmResidGenoBlock <- function(p, ctx, traitId, rg, samples) { +.fmResidGenoBlock <- function( + ctx, + traitId, + rg, + samples, + data, + cisWindow, + residualizationArgs +) { if (is.null(rg)) { .fmResidGeno( - p$data, + data, contexts = ctx, traitId = traitId, - cisWindow = p$cisWindow, - samples = samples + cisWindow = cisWindow, + samples = samples, + residualizationArgs = residualizationArgs ) } else { - .fmResidGeno(p$data, contexts = ctx, region = rg, samples = samples) + .fmResidGeno( + data, + contexts = ctx, + region = rg, + samples = samples, + residualizationArgs = residualizationArgs + ) } } @@ -2083,28 +2231,23 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # callers pass only the block-specific arguments (design, response, tokens, # addSusieInf, context label, trait/PC label, allele frequencies). # @noRd -.fmFitXBlockP <- function(p, X, y, tokens, addSusieInf, ctx, label, afVec) { +.fmFitXBlockP <- function(X, y, tokens, addSusieInf, ctx, label, afVec, cfg) { .fmFitXBlock( X, y, tokens, addSusieInf, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$methodArgs, - p$verbose, + cfg$methodArgs, + cfg$verbose, ctx, label, - cvFolds = p$cvFolds, - cvThreads = p$cvThreads, - samplePartition = p$samplePartition, + cvFolds = cfg$crossValidationArgs$folds, + cvThreads = cfg$crossValidationArgs$numThreads, + samplePartition = cfg$crossValidationArgs$samplePartition, af = afVec, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - seed = p$seed + credibleSetArgs = cfg$credibleSetArgs, + fitRetention = cfg$fitRetention, + seed = cfg$seed ) } @@ -2112,52 +2255,65 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # Y, SER pre-screen, then .fmFitXBlock. Errors when too few shared samples # (a hard data problem), returns list() when the window screens out. # @noRd -.fmUnivBlockFit <- function(rg, p, ctx, tid, Y, toRun) { - X <- .fmResidGenoBlock(p, ctx, tid, rg, rownames(Y)) - common <- intersect(rownames(X), rownames(Y)) +.fmUnivBlockFit <- function(rg, ctx, tid, Y, toRun, cfg) { + allX <- .fmResidGenoBlock( + ctx, + tid, + rg, + rownames(Y), + data = cfg$data, + cisWindow = cfg$cisWindow, + residualizationArgs = cfg$residualizationArgs + ) + common <- intersect(rownames(allX), rownames(Y)) if (length(common) < 2L) { - msg <- glue( + abort(glue( "fineMappingPipeline: too few shared samples between ", "residualized X and Y for (context='{ctx}', trait='{tid}')." - ) - abort(msg) + )) } - X <- X[common, , drop = FALSE] - y <- Y[common, , drop = FALSE] - if (ncol(y) > 1L) { - y <- y[, 1L, drop = TRUE] + X <- allX[common, , drop = FALSE] + yBlock <- Y[common, , drop = FALSE] + y <- if (ncol(yBlock) > 1L) { + yBlock[, 1L, drop = TRUE] } else { - y <- drop(y) + drop(yBlock) } - if (!.fmSerScreen(X, y, p$screen)) { - if (p$verbose >= 1) { - msg <- glue( + if (!.fmSerScreen(X, y, cfg$screen)) { + if (cfg$verbose >= 1) { + inform(glue( "Skipping (context='{ctx}', trait='{tid}'): SER ", "pre-screen found no signal above the cutoff." - ) - inform(msg) + )) } return(list()) } afVec <- .fmAfForX( - p$data, + cfg$data, X, traitId = tid, region = rg, - cisWindow = p$cisWindow + cisWindow = cfg$cisWindow ) - .fmFitXBlockP(p, X, y, toRun, p$addSusieInf, ctx, tid, afVec) + .fmFitXBlockP(X, y, toRun, cfg$addSusieInf, ctx, tid, afVec, cfg) } # All univariate row-records for one (context, trait): cache hits, then (when # tokens remain) per-window fits merged per token. # @noRd -.fmUnivTraitRows <- function(tid, p, ctx) { - lookups <- map(p$univTokens, .fmUnivLookup, p = p, ctx = ctx, tid = tid) +.fmUnivTraitRows <- function(tid, ctx, cfg) { + lookups <- map( + cfg$univTokens, + .fmUnivLookup, + fineMappingResult = cfg$fineMappingResult, + study = cfg$study, + ctx = ctx, + tid = tid + ) cachedRows <- map( keep(lookups, .fmHasCached), .fmUnivCachedRow, - p = p, + study = cfg$study, ctx = ctx, tid = tid ) @@ -2166,21 +2322,22 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { return(cachedRows) } Y <- .fmResidPheno( - p$data, + cfg$data, contexts = ctx, traitId = tid, - naAction = p$naAction + naAction = cfg$naAction, + residualizationArgs = cfg$residualizationArgs ) blockEntries <- map( - p$xRegions, + cfg$xRegions, .fmUnivBlockFit, - p = p, ctx = ctx, tid = tid, Y = Y, - toRun = toRun + toRun = toRun, + cfg = cfg ) - computed <- .fmMergeTokenRows(p$study, ctx, tid, toRun, blockEntries) + computed <- .fmMergeTokenRows(cfg$study, ctx, tid, toRun, blockEntries) c(cachedRows, computed) } @@ -2188,120 +2345,152 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # PC scores, SER pre-screen, then univariate-susie .fmFitXBlock. Returns # list() when too few shared samples or the window screens out (soft skip). # @noRd -.fmPcaBlockFit <- function(rg, p, ctx, traits, pcName, pcY, samples) { - X <- .fmResidGenoBlock(p, ctx, traits, rg, samples) +.fmPcaBlockFit <- function(rg, ctx, traits, pcName, pcY, samples, cfg) { + X <- .fmResidGenoBlock( + ctx, + traits, + rg, + samples, + data = cfg$data, + cisWindow = cfg$cisWindow, + residualizationArgs = cfg$residualizationArgs + ) common <- intersect(rownames(X), names(pcY)) if (length(common) < 2L) { return(list()) } Xb <- X[common, , drop = FALSE] - if (!.fmSerScreen(Xb, pcY[common], p$screen)) { + if (!.fmSerScreen(Xb, pcY[common], cfg$screen)) { return(list()) } afVec <- .fmAfForX( - p$data, + cfg$data, Xb, traitId = traits, region = rg, - cisWindow = p$cisWindow + cisWindow = cfg$cisWindow ) - .fmFitXBlockP(p, Xb, pcY[common], "susie", FALSE, ctx, pcName, afVec) + # The PC path never chains susieInf: a PC is not a trait whose fit the + # susieInf stage is defined for. + .fmFitXBlockP(Xb, pcY[common], "susie", FALSE, ctx, pcName, afVec, cfg) } # Row-records for one PC pseudo-trait: a cache hit, else per-window fits merged # into the single "susie" token (trait = the PC name). # @noRd -.fmPcaScoreRows <- function(pcName, p, ctx, traits, scores) { - cached <- .fmCacheLookup(p$fineMappingResult, p$study, ctx, pcName, "susie") +.fmPcaScoreRows <- function(pcName, ctx, traits, scores, cfg) { + cached <- .fmCacheLookup( + cfg$fineMappingResult, + cfg$study, + ctx, + pcName, + "susie" + ) if (!is.null(cached)) { - return(list(.fmQtlRow(p$study, ctx, pcName, "susie", cached))) + return(list(.fmQtlRow(cfg$study, ctx, pcName, "susie", cached))) } pcY <- scores[, pcName] samples <- rownames(scores) blockEntries <- map( - p$xRegions, + cfg$xRegions, .fmPcaBlockFit, - p = p, ctx = ctx, traits = traits, pcName = pcName, pcY = pcY, - samples = samples + samples = samples, + cfg = cfg ) - .fmMergeTokenRows(p$study, ctx, pcName, "susie", blockEntries) + .fmMergeTokenRows(cfg$study, ctx, pcName, "susie", blockEntries) } # All usePCA row-records for one context: PCA-reduce the multi-trait phenotype # and fine-map each top PC. A single-trait context (or one with no usable PC # scores) contributes nothing. # @noRd -.fmPcaContextRows <- function(ctx, p) { - traits <- p$perCtxTraits[[ctx]] +.fmPcaContextRows <- function(ctx, cfg) { + traits <- cfg$perCtxTraits[[ctx]] if (length(traits) < 2L) { return(list()) } Yctx <- .fmResidPheno( - p$data, + cfg$data, contexts = ctx, traitId = traits, - naAction = p$naAction + naAction = cfg$naAction, + residualizationArgs = cfg$residualizationArgs ) - scores <- .fmTopPcScores(Yctx, p$nPCs) + scores <- .fmTopPcScores(Yctx, cfg$nPCs) if (is.null(scores)) { return(list()) } - if (p$verbose >= 1) { + if (cfg$verbose >= 1) { nPc <- ncol(scores) nTr <- length(traits) - msg <- glue( + inform(glue( "usePCA: fine-mapping {nPc} top PC(s) of context='{ctx}' ", "({nTr} traits) ..." - ) - inform(msg) + )) } list_flatten(map( colnames(scores), .fmPcaScoreRows, - p = p, ctx = ctx, traits = traits, - scores = scores + scores = scores, + cfg = cfg )) } # QtlDataset method # ============================================================================= +# The settings every QtlDataset joint-phase function forwards to the shared +# joint dispatcher: the common fine-mapping record plus the scope and +# TWAS-weight fields only the joint engine uses. +# @noRd +.fmQdsJointCfg <- function( + common, + contexts, + traitId, + mrmashPrior, + dataDrivenPriorWeightsCutoff +) { + c( + common, + list( + contexts = contexts, + traitId = traitId, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) + ) +} + # Run the joint engine for a QtlDataset with the given spec + token set. Shared # by the explicit-jointSpecification path and the auto-detected multivariate # path; only the spec and token arguments differ between them. # @noRd -.fmQdsJointDispatch <- function(p, jointSpec, tokens, methodArgs) { +.fmQdsJointDispatch <- function(jointSpec, tokens, methodArgs, cfg) { .fmDispatchJointSpecsQtlDataset( jointSpec, - p$data, + cfg$data, tokens, - p$contexts, - p$traitId, - p$cisWindow, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, + cfg$contexts, + cfg$traitId, + cfg$cisWindow, + cfg$verbose, methodArgs = methodArgs, - xRegions = p$xRegions, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff, - cvFolds = p$cvFolds, - cvThreads = p$cvThreads, - samplePartition = p$samplePartition, - pipCutoffToSkip = p$screen, - fineMappingResult = p$fineMappingResult, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - seed = p$seed + xRegions = cfg$xRegions, + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, + crossValidationArgs = cfg$crossValidationArgs, + residualizationArgs = cfg$residualizationArgs, + pipCutoffToSkip = cfg$screen, + fineMappingResult = cfg$fineMappingResult, + credibleSetArgs = cfg$credibleSetArgs, + fitRetention = cfg$fitRetention, + seed = cfg$seed ) } @@ -2309,24 +2498,18 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # copy of the dataset, and derive the X windows. Rejects the region + cisWindow # combination. Returns `p` extended with data / screen / xRegions. # @noRd -.fmQdsResolveInputs <- function(p) { - screen <- .resolveScreenMetric( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip - ) - data <- .qtlApplyFilterOverrides( - p$data, - p$mafCutoff, - p$macCutoff, - p$xvarCutoff, - p$imissCutoff, - p$keepIndel, - p$keepSamples, - p$keepVariants - ) - if (!is.null(p$region) && !is.null(p$cisWindow)) { +.fmQdsResolveInputs <- function( + data, + signalScreenArgs, + genotypeFilterArgs, + region, + cisWindow, + jointRegions +) { + .assertMethodParam(signalScreenArgs, "SignalScreenParam", "signalScreen") + screen <- .screenResolve(signalScreenArgs) + data <- .qtlApplyFilterOverrides(data, genotypeFilterArgs) + if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "fineMappingPipeline(QtlDataset): specify either `region` or ", "`cisWindow`, not both. `cisWindow` expands each trait's own ", @@ -2334,56 +2517,100 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) abort(msg) } - list_modify( - p, + list( data = data, screen = screen, - xRegions = .makeXRegions(p$region, p$jointRegions) + xRegions = .makeXRegions(region, jointRegions) ) } -# Normalize methods, capability-check them, and run any EXPLICIT -# jointSpecification up front (removing the joint methods from the per-tuple -# token set). `exhaustedByJoint` flags the case where the explicit spec -# consumed every method. +# Normalize methods, capability-check them, then hand off to the joint phase. # @noRd -.fmQdsResolveTokens <- function(p) { - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - norm <- .fmNormalizeMethods(p$methods, L = p$L, Lgreedy = p$Lgreedy) - tokens <- norm$tokens - methodArgs <- norm$methodArgs - .fmCheckMethodCapabilities(tokens, "QtlDataset") - jointResult <- NULL - hadJointSpec <- length(parsedJointSpec) > 0L - if (hadJointSpec) { - jointResult <- .fmQdsJointDispatch( - p, - parsedJointSpec, - intersect(tokens, c("mvsusie", "fsusie")), - methodArgs - ) - tokens <- setdiff(tokens, c("mvsusie", "fsusie")) - methodArgs <- methodArgs[tokens] +# The joint-specification phase for the QtlDataset path: dispatch whatever the +# spec covers, narrow the tokens the joint fits consumed, and report whether +# anything is left for the per-tuple loop. `done = TRUE` means the joint fits +# are the whole answer. +# +# Deliberately mirrors .twasQdsJointPhase -- same responsibilities, same +# done / result shape -- so the two pipelines' joint handling reads as one +# pattern. The argument sets differ because the outputs do (credible sets +# here, weights there); the structure should not. +# @noRd +.fmQdsJointPhase <- function(parsedJointSpec, norm, cfg) { + if (length(parsedJointSpec) == 0L) { + return(list( + done = FALSE, + result = NULL, + tokens = norm$tokens, + methodArgs = norm$methodArgs + )) + } + jointResult <- .fmQdsJointDispatch( + parsedJointSpec, + intersect(norm$tokens, c("mvsusie", "fsusie")), + norm$methodArgs, + cfg + ) + # The joint dispatch consumed the multivariate tokens; the univariate + # phase runs on whatever is left. + narrowed <- .fmNarrowAfterJoint(TRUE, norm$tokens, norm$methodArgs) + if (length(narrowed$tokens) == 0L) { + if (is.null(jointResult)) { + abort(glue( + "fineMappingPipeline(QtlDataset): no joint fits produced. ", + "Check that the jointSpecification scope intersects the ", + "available studies / contexts / traits." + )) + } + return(list(done = TRUE, result = jointResult)) } list( - tokens = tokens, - methodArgs = methodArgs, - jointResult = jointResult, - exhaustedByJoint = hadJointSpec && length(tokens) == 0L + done = FALSE, + result = jointResult, + tokens = narrowed$tokens, + methodArgs = narrowed$methodArgs + ) +} + +.fmQdsResolveTokens <- function(jointSpecification, methods, L, Lgreedy, cfg) { + parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) + norm <- .fmNormalizeMethods( + methods, + inputKind = "QtlDataset", + L = L, + Lgreedy = Lgreedy ) + .fmCheckMethodCapabilities(norm$tokens, "QtlDataset") + .fmCheckMethodArgsForInput(norm$methodArgs, "QtlDataset") + .fmQdsJointPhase(parsedJointSpec, norm, cfg) +} + +# The tokens (and their args) still owed a univariate fit after a joint +# dispatch ran. A run with no joint specification keeps everything. +# @noRd +.fmNarrowAfterJoint <- function(hadJointSpec, tokens, methodArgs) { + if (!hadJointSpec) { + return(list(tokens = tokens, methodArgs = methodArgs)) + } + remaining <- setdiff(tokens, c("mvsusie", "fsusie")) + list(tokens = remaining, methodArgs = methodArgs[remaining]) } # Trait ids available in one context, intersected with the requested traitId or # overlapping the requested region (mirrors twasWeightsPipeline). # @noRd -.fmQdsTraitsForContext <- function(ctx, p) { - se <- getPhenotypes(p$data, contexts = ctx) - ids <- rownames(se) - if (!is.null(p$traitId)) { - ids <- intersect(ids, p$traitId) - } else if (!is.null(p$region)) { - rr <- SummarizedExperiment::rowRanges(se) - ids <- ids[IRanges::overlapsAny(rr, p$region)] +.fmQdsTraitsForContext <- function(ctx, data, traitId, region) { + se <- getPhenotypes(data, contexts = ctx) + allIds <- rownames(se) + ids <- if (!is.null(traitId)) { + intersect(allIds, traitId) + } else if (!is.null(region)) { + allIds[IRanges::overlapsAny( + SummarizedExperiment::rowRanges(se), + region + )] + } else { + allIds } ids } @@ -2392,12 +2619,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # the per-context trait lists. Returns `p` extended with study / useCtx / # perCtxTraits / nCtx / nTraits. # @noRd -.fmQdsResolveContexts <- function(p) { - allCtx <- getContexts(p$data) - useCtx <- if (is.null(p$contexts)) { +.fmQdsResolveContexts <- function(data, contexts, traitId, region) { + allCtx <- getContexts(data) + useCtx <- if (is.null(contexts)) { allCtx } else { - bad <- setdiff(p$contexts, allCtx) + bad <- setdiff(contexts, allCtx) if (length(bad) > 0L) { badStr <- str_flatten(bad, ", ") msg <- glue( @@ -2406,17 +2633,24 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) abort(msg) } - p$contexts + contexts } - perCtxTraits <- map(useCtx, .fmQdsTraitsForContext, p = p) - names(perCtxTraits) <- useCtx + perCtxTraits <- set_names( + map( + useCtx, + .fmQdsTraitsForContext, + data = data, + traitId = traitId, + region = region + ), + useCtx + ) allTraits <- unique(list_c(perCtxTraits)) if (length(allTraits) == 0L) { abort("fineMappingPipeline(QtlDataset): no traits selected.") } - list_modify( - p, - study = getStudy(p$data), + list( + study = getStudy(data), useCtx = useCtx, perCtxTraits = perCtxTraits, nCtx = length(useCtx), @@ -2428,27 +2662,26 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # multivariate requirements (mvsusie needs multi-trait OR multi-context; fsusie # needs multi-trait per context). Returns `p` extended with the three sets. # @noRd -.fmQdsSplitTokens <- function(p) { - univTokens <- p$tokens[!is_in(p$tokens, c("mvsusie", "fsusie"))] - mvTokens <- p$tokens[p$tokens == "mvsusie"] - fsTokens <- p$tokens[p$tokens == "fsusie"] - if (length(mvTokens) > 0L && p$nCtx < 2L && p$nTraits < 2L) { +.fmQdsSplitTokens <- function(tokens, nCtx, nTraits) { + univTokens <- tokens[!is_in(tokens, c("mvsusie", "fsusie"))] + mvTokens <- tokens[tokens == "mvsusie"] + fsTokens <- tokens[tokens == "fsusie"] + if (length(mvTokens) > 0L && nCtx < 2L && nTraits < 2L) { msg <- glue( "fineMappingPipeline(QtlDataset): mvsusie requires multi-trait ", - "or multi-context input (got {p$nTraits} trait(s) x ", - "{p$nCtx} context(s))." + "or multi-context input (got {nTraits} trait(s) x ", + "{nCtx} context(s))." ) abort(msg) } - if (length(fsTokens) > 0L && p$nTraits < 2L) { + if (length(fsTokens) > 0L && nTraits < 2L) { msg <- glue( "fineMappingPipeline(QtlDataset): fsusie requires multi-trait ", - "input within a context (got {p$nTraits} trait(s))." + "input within a context (got {nTraits} trait(s))." ) abort(msg) } - list_modify( - p, + list( univTokens = univTokens, mvTokens = mvTokens, fsTokens = fsTokens @@ -2458,14 +2691,48 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # Univariate + usePCA dispatch: each (context, trait) -> merged-per-token # row-records; each multi-trait context's top PCs -> pseudo-trait rows. # @noRd -.fmQdsDispatchRows <- function(p) { - univRows <- if (length(p$univTokens) > 0L) { - list_flatten(map(p$useCtx, .fmUnivContextRows, p = p)) +# The per-run settings the univariate / PCA row builders all need: the common +# fine-mapping record plus the grid and method fields only the per-tuple +# dispatch uses. The chain threads a single record instead of two dozen +# arguments, and every field is named deliberately -- this is not a capture of +# the calling frame, so what travels is exactly what these lists declare. +# @noRd +.fmQdsRunCfg <- function( + common, + addSusieInf, + methodArgs, + nPCs, + naAction, + perCtxTraits, + study, + univTokens, + useCtx, + usePCA +) { + c( + common, + list( + addSusieInf = addSusieInf, + methodArgs = methodArgs, + nPCs = nPCs, + naAction = naAction, + perCtxTraits = perCtxTraits, + study = study, + univTokens = univTokens, + useCtx = useCtx, + usePCA = usePCA + ) + ) +} + +.fmQdsDispatchRows <- function(cfg) { + univRows <- if (length(cfg$univTokens) > 0L) { + list_flatten(map(cfg$useCtx, .fmUnivContextRows, cfg = cfg)) } else { list() } - pcaRows <- if (isTRUE(p$usePCA)) { - list_flatten(map(p$useCtx, .fmPcaContextRows, p = p)) + pcaRows <- if (isTRUE(cfg$usePCA)) { + list_flatten(map(cfg$useCtx, .fmPcaContextRows, cfg = cfg)) } else { list() } @@ -2476,22 +2743,30 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # mvsusie / fsusie WITHOUT an explicit jointSpecification, merged with any # explicit-spec result already in `p$jointResult`. # @noRd -.fmQdsAutoJoint <- function(p) { - if (length(p$mvTokens) == 0L && length(p$fsTokens) == 0L) { - return(p$jointResult) +.fmQdsAutoJoint <- function( + cfg, + mvTokens, + fsTokens, + jointResult, + methodArgs, + nCtx, + nTraits +) { + if (length(mvTokens) == 0L && length(fsTokens) == 0L) { + return(jointResult) } autoJoint <- .fmQdsJointDispatch( - p, - .fmSynthesizeJointSpec(p$nCtx, p$nTraits), - c(p$mvTokens, p$fsTokens), - p$methodArgs + .fmSynthesizeJointSpec(nCtx, nTraits), + c(mvTokens, fsTokens), + methodArgs, + cfg ) - if (is.null(p$jointResult)) { + if (is.null(jointResult)) { autoJoint } else if (is.null(autoJoint)) { - p$jointResult + jointResult } else { - .rbindFineMappingResult(p$jointResult, autoJoint, ldSketch = NULL) + .rbindFineMappingResult(jointResult, autoJoint, ldSketch = NULL) } } @@ -2499,7 +2774,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # trait-anchored cis span) combined with the joint result. Errors only when # neither path produced anything. # @noRd -.fmQdsAssemble <- function(p, rows, jointResult) { +.fmQdsAssemble <- function(data, rows, jointResult) { rowContext <- map_chr(rows, "context") rowTrait <- map_chr(rows, "trait") perTupleResult <- if (length(rows) > 0L) { @@ -2509,9 +2784,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { rowTrait, map_chr(rows, "method"), map(rows, "entry"), - traitPos = tryCatch( - .anchorVector(p$data, rowContext, rowTrait, "traitPos"), - error = function(e) NULL + traitPos = try_fetch( + .anchorVector(data, rowContext, rowTrait, "traitPos"), + error = function(cnd) NULL ), ldSketch = NULL ) @@ -2534,104 +2809,174 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = NULL) } -# QtlDataset fine-mapping worker. `p` is the setMethod's captured arguments; -# each phase extends the bundle via list_modify so the dispatch helpers read -# everything from `p`. The susieInf chaining is applied downstream inside -# .fmFitXBlock / .fmFitRssBlock (which recompute .fmResolveSusieChain), so no -# chain config is threaded here. +# Resolve the context/trait tuples, split the tokens across the univariate, +# multivariate and functional paths, dispatch one row per tuple and assemble +# the result. Carved out of .fmPipelineQtlDataset purely to shorten it -- +# every argument is one the entry point already holds, so the two still have +# to be read together. +# @noRd +.fmQdsRunAndAssemble <- function( + data, + commonCfg, + jointCfg, + contexts, + traitId, + region, + tokens, + methodArgs, + jointResult, + addSusieInf, + nPCs, + naAction, + usePCA +) { + ctxInfo <- .fmQdsResolveContexts( + data = data, + contexts = contexts, + traitId = traitId, + region = region + ) + split <- .fmQdsSplitTokens(tokens, ctxInfo$nCtx, ctxInfo$nTraits) + rows <- .fmQdsDispatchRows(.fmQdsRunCfg( + commonCfg, + addSusieInf = addSusieInf, + methodArgs = methodArgs, + nPCs = nPCs, + naAction = naAction, + perCtxTraits = ctxInfo$perCtxTraits, + study = ctxInfo$study, + univTokens = split$univTokens, + useCtx = ctxInfo$useCtx, + usePCA = usePCA + )) + .fmQdsAssemble( + data, + rows, + .fmQdsAutoJoint( + jointCfg, + mvTokens = split$mvTokens, + fsTokens = split$fsTokens, + jointResult = jointResult, + methodArgs = methodArgs, + nCtx = ctxInfo$nCtx, + nTraits = ctxInfo$nTraits + ) + ) +} + +# QtlDataset fine-mapping worker. Each stage returns only the values it +# derives, and the next stage takes them as named arguments -- nothing rides +# on a captured environment. The susieInf chaining is applied downstream +# inside .fmFitXBlock / .fmFitRssBlock (which recompute +# .fmResolveSusieChain), so no chain config is threaded here. # @noRd -.fmPipelineQtlDataset <- function(p) { - naAction <- p$naAction - p$naAction <- arg_match(naAction, c("drop", "impute")) - if (!is.null(p$seed)) { - withr::local_seed(as.integer(p$seed)) +.fmPipelineQtlDataset <- function( + data, + methods, + contexts = NULL, + traitId = NULL, + region = NULL, + cisWindow = NULL, + # Per-call genotype-filter overrides; NULL = use the QtlDataset's + # construct-time slot value (applied lazily at extraction). + genotypeFilterArgs = GenotypeFilterParam(), + jointRegions = FALSE, + jointSpecification = NULL, + addSusieInf = TRUE, + credibleSetArgs = CredibleSetParam(), + fineMappingResult = NULL, + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam(), + signalScreenArgs = SignalScreenParam(), + usePCA = FALSE, + nPCs = 10L, + seed = NULL, + mrmashPrior = NULL, + dataDrivenPriorWeightsCutoff = 1e-10, + naAction = c("drop", "impute"), + verbose = 1, + fitRetention = c("slim", "full") +) { + fitRetention <- arg_match(fitRetention) + naAction <- arg_match(naAction, c("drop", "impute")) + if (!is.null(seed)) { + withr::local_seed(as.integer(seed)) } - p <- .fmQdsResolveInputs(p) - rt <- .fmQdsResolveTokens(p) - if (rt$exhaustedByJoint) { - if (is.null(rt$jointResult)) { - msg <- glue( - "fineMappingPipeline(QtlDataset): no joint fits produced. ", - "Check that the jointSpecification scope intersects the ", - "available studies / contexts / traits." - ) - abort(msg) - } - return(rt$jointResult) + # Each stage returns only the values it derives; nothing is grafted onto a + # captured environment. + resolved <- .fmQdsResolveInputs( + data = data, + signalScreenArgs = signalScreenArgs, + genotypeFilterArgs = genotypeFilterArgs, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions + ) + data <- resolved$data + screen <- resolved$screen + xRegions <- resolved$xRegions + # The bundle is the user-facing form; below this line the existing cfg + # plumbing (and the joint engine that reads it) keeps plain scalars. + cvCfg <- .cvResolve(crossValidationArgs) + # The settings the joint phase and the per-tuple dispatch share, named + # once so the two records built from it cannot disagree. + commonCfg <- list( + data = data, + cisWindow = cisWindow, + credibleSetArgs = credibleSetArgs, + screen = screen, + xRegions = xRegions, + crossValidationArgs = cvCfg, + residualizationArgs = residualizationArgs, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + verbose = verbose, + seed = seed + ) + jointCfg <- .fmQdsJointCfg( + commonCfg, + contexts = contexts, + traitId = traitId, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) + rt <- .fmQdsResolveTokens( + jointSpecification, + methods, + credibleSetArgs$L %||% 10L, + credibleSetArgs$Lgreedy, + jointCfg + ) + if (rt$done) { + return(rt$result) } - p <- list_modify( - p, + .fmQdsRunAndAssemble( + data, + commonCfg, + jointCfg, + contexts = contexts, + traitId = traitId, + region = region, tokens = rt$tokens, methodArgs = rt$methodArgs, - jointResult = rt$jointResult + jointResult = rt$result, + addSusieInf = addSusieInf, + nPCs = nPCs, + naAction = naAction, + usePCA = usePCA ) - p <- .fmQdsSplitTokens(.fmQdsResolveContexts(p)) - rows <- .fmQdsDispatchRows(p) - .fmQdsAssemble(p, rows, .fmQdsAutoJoint(p)) } #' @rdname fineMappingPipeline -#' @importFrom purrr list_c list_flatten list_modify list_rbind +#' @importFrom purrr list_c list_flatten list_modify list_rbind list_assign +#' @importFrom purrr discard walk2 detect zap #' @export setMethod( "fineMappingPipeline", "QtlDataset", - function( - data, - methods, - contexts = NULL, - traitId = NULL, - region = NULL, - cisWindow = NULL, - # Per-call genotype-filter overrides; NULL = use the QtlDataset's - # construct-time slot value (applied lazily at extraction). - mafCutoff = NULL, - macCutoff = NULL, - xvarCutoff = NULL, - imissCutoff = NULL, - keepIndel = NULL, - keepSamples = NULL, - keepVariants = NULL, - jointRegions = FALSE, - jointSpecification = NULL, - addSusieInf = TRUE, - L = 10L, - Lgreedy = NULL, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, - fineMappingResult = NULL, - cvFolds = 0, - cvThreads = 1, - samplePartition = NULL, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, - usePCA = FALSE, - nPCs = 10L, - seed = NULL, - twasWeights = NULL, - dataDrivenPriorWeightsCutoff = 1e-10, - naAction = c("drop", "impute"), - verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - ... - ) { - .fmPipelineQtlDataset(as.list(environment())) - } + .fmPipelineQtlDataset ) - # ============================================================================= # MultiStudyQtlDataset method # ============================================================================= @@ -2645,36 +2990,37 @@ setMethod( if (length(m) == 0L) { return(NULL) } - fmArgs <- c( - list( - data = qd, - methods = m, - contexts = cfg$contexts, - traitId = cfg$traitId, - region = cfg$region, - cisWindow = cfg$cisWindow, - jointRegions = cfg$jointRegions, - jointSpecification = NULL, - addSusieInf = cfg$addSusieInf, - coverage = cfg$coverage, - secondaryCoverage = cfg$secondaryCoverage, - signalCutoff = cfg$signalCutoff, - minAbsCorr = cfg$minAbsCorr, - fineMappingResult = cfg$fineMappingResult, - cvFolds = cfg$cvFolds, - cvThreads = cfg$cvThreads, - samplePartition = cfg$samplePartition, - pipCutoffToSkip = cfg$pipCutoffToSkip, - absZCutoffToSkip = cfg$absZCutoffToSkip, - bfCutoffToSkip = cfg$bfCutoffToSkip, - logBfCutoffToSkip = cfg$logBfCutoffToSkip, - seed = cfg$seed, - naAction = cfg$naAction, - verbose = cfg$verbose - ), - cfg$dotArgs + # Every setting is named. `cfg` also carries panelFilterArgs and rssArgs, + # which belong to the summary-statistics path: a study's own genotypes + # are filtered by genotypeFilterArgs, so those two are deliberately not + # forwarded here. A name this entry point does not accept would be an + # "unused argument" error, so the only way this can go wrong is by + # OMITTING a setting -- which test_fineMappingPipeline.R pins. + fineMappingPipeline( + data = qd, + methods = m, + jointSpecification = NULL, + contexts = cfg$contexts, + traitId = cfg$traitId, + region = cfg$region, + cisWindow = cfg$cisWindow, + jointRegions = cfg$jointRegions, + addSusieInf = cfg$addSusieInf, + credibleSetArgs = cfg$credibleSetArgs, + fineMappingResult = cfg$fineMappingResult, + verbose = cfg$verbose, + crossValidationArgs = cfg$crossValidationArgs, + residualizationArgs = cfg$residualizationArgs, + seed = cfg$seed, + naAction = cfg$naAction, + signalScreenArgs = cfg$signalScreenArgs, + genotypeFilterArgs = cfg$genotypeFilterArgs, + usePCA = cfg$usePCA, + nPCs = cfg$nPCs, + fitRetention = cfg$fitRetention, + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff ) - exec(fineMappingPipeline, !!!fmArgs) } # Embedded-sumstats fine-mapping worker for .multiStudyPipelineDriver: recurse @@ -2685,141 +3031,245 @@ setMethod( if (length(m) == 0L) { return(NULL) } - fmArgs <- c( - list( - data = ss, - methods = m, - contexts = cfg$contexts, - traitId = cfg$traitId, - jointSpecification = NULL, - addSusieInf = cfg$addSusieInf, - coverage = cfg$coverage, - secondaryCoverage = cfg$secondaryCoverage, - signalCutoff = cfg$signalCutoff, - minAbsCorr = cfg$minAbsCorr, - fineMappingResult = cfg$fineMappingResult, - verbose = cfg$verbose - ), - cfg$dotArgs + # Summary statistics carry no genotypes and no per-study region + # selection: the region is already baked into the input, and there is + # nothing to residualize, screen, cross-validate or PCA. `cfg` carries + # those settings for the individual-level sibling and they are not + # forwarded here. + fineMappingPipeline( + data = ss, + methods = m, + jointSpecification = NULL, + contexts = cfg$contexts, + traitId = cfg$traitId, + addSusieInf = cfg$addSusieInf, + credibleSetArgs = cfg$credibleSetArgs, + fineMappingResult = cfg$fineMappingResult, + verbose = cfg$verbose, + panelFilterArgs = cfg$panelFilterArgs, + rssArgs = cfg$rssArgs, + fitRetention = cfg$fitRetention, + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff ) - exec(fineMappingPipeline, !!!fmArgs) } -# Resolve method tokens for a MultiStudyQtlDataset run and run any EXPLICIT -# jointSpecification (per-component axis dispatcher), removing the joint methods -# from the per-tuple recursion. Returns the still-pending tokens, the forwarded -# `methods` (kwargs-preserving), the joint result, and `exhaustedByJoint`. +# Validate the naAction choice and the region + cisWindow combination, then +# derive the X windows. Mirrors .fmQdsResolveInputs, minus the filter +# overrides the components apply themselves. # @noRd -.fmMsResolveTokens <- function(p) { - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - norm <- .fmNormalizeMethods(p$methods) - tokens <- norm$tokens - methodArgs <- norm$methodArgs - .fmCheckMethodCapabilities(tokens, "MultiStudyQtlDataset") - jointResult <- NULL - methods <- p$methods - hadJointSpec <- length(parsedJointSpec) > 0L - if (hadJointSpec) { - jointResult <- .fmDispatchJointSpecsMultiStudy( - parsedJointSpec, - p$data, - intersect(tokens, c("mvsusie", "fsusie")), - p$contexts, - p$traitId, - p$cisWindow, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, - methodArgs = methodArgs, - xRegions = p$xRegions, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff +.fmMsResolveInputs <- function(naAction, region, cisWindow, jointRegions) { + if (!is.null(region) && !is.null(cisWindow)) { + msg <- glue( + "fineMappingPipeline(MultiStudyQtlDataset): specify either ", + "`region` or `cisWindow`, not both." ) - tokens <- setdiff(tokens, c("mvsusie", "fsusie")) - methodArgs <- methodArgs[tokens] - methods <- if (length(methodArgs) > 0L) methodArgs else tokens + abort(msg) } list( - tokens = tokens, - methods = methods, - jointResult = jointResult, - exhaustedByJoint = hadJointSpec && length(tokens) == 0L + naAction = arg_match(naAction, c("drop", "impute")), + xRegions = .makeXRegions(region, jointRegions) ) } -# Assemble the per-component driver config for a MultiStudyQtlDataset run: -# individual-capable methods route to the per-study QtlDatasets, sumstat-capable -# methods (incl. the sumstat-only `ser`) to the embedded QtlSumStats. +# Run the joint engine for a MultiStudyQtlDataset with the given spec + token +# set. # @noRd -.fmMsConfig <- function(p) { - list( - methods = p$methods, - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - jointRegions = p$jointRegions, - addSusieInf = p$addSusieInf, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - minAbsCorr = p$minAbsCorr, - fineMappingResult = p$fineMappingResult, - cvFolds = p$cvFolds, - cvThreads = p$cvThreads, - samplePartition = p$samplePartition, - pipCutoffToSkip = p$pipCutoffToSkip, - absZCutoffToSkip = p$absZCutoffToSkip, - bfCutoffToSkip = p$bfCutoffToSkip, - logBfCutoffToSkip = p$logBfCutoffToSkip, - seed = p$seed, - naAction = p$naAction, - verbose = p$verbose, - dotArgs = p$dotArgs - ) -} - -# MultiStudyQtlDataset fine-mapping worker. `p` is the setMethod's captured -# arguments (plus `dotArgs`); after resolving the explicit joint spec it routes -# each remaining method to the components it supports via the shared -# multi-study driver. -# @noRd -.fmPipelineMultiStudy <- function(p) { - naAction <- p$naAction - naAction <- arg_match(naAction, c("drop", "impute")) - if (!is.null(p$region) && !is.null(p$cisWindow)) { - msg <- glue( - "fineMappingPipeline(MultiStudyQtlDataset): specify either ", - "`region` or `cisWindow`, not both." - ) - abort(msg) +.fmMsJointDispatch <- function(jointSpec, tokens, methodArgs, cfg) { + .fmDispatchJointSpecsMultiStudy( + jointSpec, + cfg$data, + tokens, + cfg$contexts, + cfg$traitId, + cfg$cisWindow, + cfg$verbose, + methodArgs = methodArgs, + xRegions = cfg$xRegions, + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff + ) +} + +# The joint-specification phase for the MultiStudyQtlDataset path: dispatch +# whatever the spec covers, narrow the tokens the joint fits consumed, and +# report whether anything is left for the per-component recursion. +# `done = TRUE` means the joint fits are the whole answer. +# +# Deliberately mirrors .fmQdsJointPhase and .twasQdsJointPhase -- same +# responsibilities, same done / result shape. +# @noRd +.fmMsJointPhase <- function(parsedJointSpec, norm, cfg) { + if (length(parsedJointSpec) == 0L) { + return(list( + done = FALSE, + result = NULL, + tokens = norm$tokens, + methodArgs = norm$methodArgs + )) } - p <- list_modify( - p, - naAction = naAction, - xRegions = .makeXRegions(p$region, p$jointRegions) + jointResult <- .fmMsJointDispatch( + parsedJointSpec, + intersect(norm$tokens, c("mvsusie", "fsusie")), + norm$methodArgs, + cfg ) - rt <- .fmMsResolveTokens(p) - if (rt$exhaustedByJoint) { - if (is.null(rt$jointResult)) { - msg <- glue( + # The joint dispatch consumed the multivariate tokens; the univariate + # phase runs on whatever is left. + narrowed <- .fmNarrowAfterJoint(TRUE, norm$tokens, norm$methodArgs) + if (length(narrowed$tokens) == 0L) { + if (is.null(jointResult)) { + abort(glue( "fineMappingPipeline(MultiStudyQtlDataset): no joint fits ", "produced. Check that the jointSpecification scope ", "intersects the available data." - ) - abort(msg) + )) } - return(rt$jointResult) + return(list(done = TRUE, result = jointResult)) } - p <- list_modify(p, methods = rt$methods) - .multiStudyPipelineDriver( - p$data, - rt$jointResult, - .fmPerStudy, + list( + done = FALSE, + result = jointResult, + tokens = narrowed$tokens, + methodArgs = narrowed$methodArgs + ) +} + +# Resolve method tokens for a MultiStudyQtlDataset run and run any EXPLICIT +# jointSpecification (per-component axis dispatcher), removing the joint methods +# from the per-tuple recursion. Returns the still-pending tokens, the forwarded +# `methods` (kwargs-preserving), the joint result, and `done`. +# @noRd +.fmMsResolveTokens <- function(jointSpecification, methods, L, Lgreedy, cfg) { + parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) + # A MultiStudyQtlDataset may hold individual-level studies AND summary + # statistics, so `methods` is translated here -- where the dataset is in + # hand -- and the Param is what travels into the per-component + # recursion. Each component then dispatches on its own class and reads + # the slot for its own path. + methods <- .methodsParamForMulti( + methods, + "FineMappingMethodsParam", + "fineMappingPipeline", + !is.null(getSumStats(cfg$data)) + ) + norm <- .fmNormalizeMethods( + methods, + inputKind = "QtlDataset", + L = L, + Lgreedy = Lgreedy + ) + .fmCheckMethodCapabilities(norm$tokens, "MultiStudyQtlDataset") + .fmCheckMethodArgsForInput(norm$methodArgs, "MultiStudyQtlDataset") + phase <- .fmMsJointPhase(parsedJointSpec, norm, cfg) + if (phase$done) { + return(phase) + } + # The per-component recursion re-enters fineMappingPipeline through + # `methods=`, so a run with no joint spec forwards the caller's own + # spelling untouched rather than the normalized tokens. + list( + done = FALSE, + result = phase$result, + tokens = phase$tokens, + methods = if (length(parsedJointSpec) == 0L) { + methods + } else if (length(phase$methodArgs) > 0L) { + phase$methodArgs + } else { + phase$tokens + } + ) +} + +# MultiStudyQtlDataset fine-mapping worker. After resolving the explicit +# joint spec it routes each remaining method to the components it supports, +# via the shared multi-study driver. +# @noRd +.fmPipelineMultiStudy <- function( + data, + methods, + contexts = NULL, + traitId = NULL, + region = NULL, + cisWindow = NULL, + genotypeFilterArgs = GenotypeFilterParam(), + panelFilterArgs = PanelFilterParam(), + jointRegions = FALSE, + jointSpecification = NULL, + addSusieInf = TRUE, + credibleSetArgs = CredibleSetParam(), + fineMappingResult = NULL, + mrmashPrior = NULL, + dataDrivenPriorWeightsCutoff = 1e-10, + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam(), + signalScreenArgs = SignalScreenParam(), + rssArgs = SusieRssParam(), + usePCA = FALSE, + nPCs = 10L, + seed = NULL, + naAction = c("drop", "impute"), + verbose = 1, + fitRetention = c("slim", "full") +) { + fitRetention <- arg_match(fitRetention) + inputs <- .fmMsResolveInputs(naAction, region, cisWindow, jointRegions) + naAction <- inputs$naAction + # One record of the settings the joint phase and the shared dispatcher + # both need, so each names them once. + jointCfg <- list( + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + credibleSetArgs = credibleSetArgs, + verbose = verbose, + xRegions = inputs$xRegions, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) + rt <- .fmMsResolveTokens( + jointSpecification, + methods, + credibleSetArgs$L %||% 10L, + credibleSetArgs$Lgreedy, + jointCfg + ) + if (rt$done) { + return(rt$result) + } + methods <- rt$methods + .multiStudyPipelineDriver( + data, + rt$result, + .fmPerStudy, .fmSumStats, - .fmMsConfig(p), + list( + methods = methods, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + addSusieInf = addSusieInf, + credibleSetArgs = credibleSetArgs, + fineMappingResult = fineMappingResult, + verbose = verbose, + crossValidationArgs = crossValidationArgs, + residualizationArgs = residualizationArgs, + seed = seed, + naAction = naAction, + signalScreenArgs = signalScreenArgs, + genotypeFilterArgs = genotypeFilterArgs, + panelFilterArgs = panelFilterArgs, + rssArgs = rssArgs, + usePCA = usePCA, + nPCs = nPCs, + fitRetention = fitRetention, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ), .rbindFineMappingResult, QtlFineMappingResult, "fineMappingPipeline" @@ -2831,116 +3281,347 @@ setMethod( setMethod( "fineMappingPipeline", "MultiStudyQtlDataset", - function( - data, - methods, - contexts = NULL, - traitId = NULL, - region = NULL, - cisWindow = NULL, - jointRegions = FALSE, - jointSpecification = NULL, - addSusieInf = TRUE, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, - fineMappingResult = NULL, - twasWeights = NULL, - dataDrivenPriorWeightsCutoff = 1e-10, - cvFolds = 0, - cvThreads = 1, - samplePartition = NULL, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, - seed = NULL, - naAction = c("drop", "impute"), - verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - ... - ) { - p <- as.list(environment()) - p$dotArgs <- list(...) - .fmPipelineMultiStudy(p) - } + .fmPipelineMultiStudy ) - # ============================================================================= # QtlSumStats method # ============================================================================= +# The settings every QtlSumStats joint-phase function forwards to the shared +# joint dispatcher: the common summary-statistics record plus the scope and +# TWAS-weight fields only the joint engine uses. +# @noRd +.fmQssJointCfg <- function( + common, + contexts, + traitId, + mrmashPrior, + dataDrivenPriorWeightsCutoff +) { + c( + common, + list( + contexts = contexts, + traitId = traitId, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) + ) +} + +# Run the joint engine for a QtlSumStats with the given spec + token set. +# Shared by the explicit-jointSpecification path and the auto-detected +# cross-context path; only the spec and token arguments differ between them. +# @noRd +.fmQssJointDispatch <- function(jointSpec, tokens, methodArgs, cfg) { + .fmDispatchJointSpecsQtlSumStats( + jointSpec, + cfg$data, + tokens, + cfg$contexts, + cfg$traitId, + cfg$verbose, + methodArgs = methodArgs, + mrmashPrior = cfg$mrmashPrior, + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, + fineMappingResult = cfg$fineMappingResult, + credibleSetArgs = cfg$credibleSetArgs, + fitRetention = cfg$fitRetention, + panelFilterArgs = cfg$panelFilterArgs %||% PanelFilterParam() + ) +} + +# The joint-specification phase for the QtlSumStats path: dispatch whatever +# the spec covers, narrow the tokens the joint fits consumed, and report +# whether anything is left for the per-tuple loop. `done = TRUE` means the +# joint fits are the whole answer. +# +# Deliberately mirrors .fmQdsJointPhase and .twasQdsJointPhase -- same +# responsibilities, same done / result shape. +# @noRd +.fmQssJointPhase <- function(parsedJointSpec, norm, cfg) { + if (length(parsedJointSpec) == 0L) { + return(list( + done = FALSE, + result = NULL, + tokens = norm$tokens, + methodArgs = norm$methodArgs + )) + } + jointResult <- .fmQssJointDispatch( + parsedJointSpec, + intersect(norm$tokens, "mvsusie"), + norm$methodArgs, + cfg + ) + # The joint dispatch consumed the multivariate tokens; the univariate + # phase runs on whatever is left. + narrowed <- .fmNarrowAfterJoint(TRUE, norm$tokens, norm$methodArgs) + if (length(narrowed$tokens) == 0L) { + if (is.null(jointResult)) { + abort(glue( + "fineMappingPipeline(QtlSumStats): no joint fits produced. ", + "Check that the jointSpecification scope intersects the ", + "available data." + )) + } + return(list(done = TRUE, result = jointResult)) + } + list( + done = FALSE, + result = jointResult, + tokens = narrowed$tokens, + methodArgs = narrowed$methodArgs + ) +} + +# --- fine-mapping method-argument constructors ------------------------------ +# +# A token can reach two susieR/mvsusieR entry points depending on whether the +# input is individual-level or summary statistics, so each constructor checks +# against BOTH, taken live from the capability table rather than transcribed. + +# The engine(s) a fine-mapping token forwards to, from the capability table. +# @noRd +.fmMethodCallees <- function(token) { + info <- .fineMappingMethodCapabilities[[token]] + unique(compact(list(info$individualImpl, info$sumstatImpl))) +} + +# Shared body for the per-engine constructors: pecotmr keeps no defaults of +# its own here (they are seeded per run from `L` / `Lgreedy`), so everything +# the caller gives is checked against that ONE engine and carried through. +# +# One constructor per engine, not per token. A method whose two input paths +# run different engines gets one for each: checking the union instead would +# accept a susie_rss-only name on an individual-level run and then drop it, +# and mvsusie could not be checked at all, since mvsusie_rss takes `...` and +# a union containing it accepts anything. +# @noRd +.fmMethodOptions <- function(callee, label, engine, extra) { + .newMethodOptions( + callee, + defaults = list(), + extra = extra, + label = label, + engine = engine + ) +} + +# The union constructor behind a token, for splicing a PLAIN LIST in the +# aggregator. A plain list declares no engine and the run's input class is +# not known yet, so it must stay acceptable for either path; the per-input +# check in .fmCheckMethodArgsForInput narrows it once the class is known. +# @noRd +#' @rdname FineMappingMethodsParam +#' @aliases FineMappingMethodsParam-class +#' @exportClass FineMappingMethodsParam +setClass("FineMappingMethodsParam", contains = "MethodsSelectionParam") + +#' @title Which Fine-Mapping Methods To Run, And How +#' @description Selects the methods \code{\link{fineMappingPipeline}} runs and +#' carries each one's engine arguments. +#' +#' A method that runs on both individual-level and summary-statistic data +#' reaches a different engine on each path, so for a +#' \code{MultiStudyQtlDataset} carrying both there is no single set of +#' arguments per method. Name such a method under +#' \code{qtlDatasetMethods} or \code{qtlSumStatsMethods} to say which +#' path its options are for; name it under \code{methods} when the path +#' need not be stated --- a single-type run, or a method with nothing +#' path-specific to configure. +#' +#' Naming a method selects it. A method belongs in exactly one of the +#' three slots. +#' @param methods Named list of per-method options whose input path need not +#' be stated. Each entry is that method's \code{*Options()} record, or +#' \code{list()} to run it with its defaults. +#' @param qtlDatasetMethods Named list of per-method options for the +#' individual-level path. +#' @param qtlSumStatsMethods Named list of per-method options for the +#' summary-statistics path. +#' @return A \code{FineMappingMethodsParam} object, a \code{\link{MethodParam}}. +#' @examples +#' FineMappingMethodsParam(methods = "susie") +#' FineMappingMethodsParam(methods = list(susie = SusieOptions(L = 20))) +#' FineMappingMethodsParam( +#' qtlDatasetMethods = list(susie = SusieOptions(L = 20)), +#' qtlSumStatsMethods = list(susie = SusieRssOptions(L = 20)) +#' ) +#' @export +FineMappingMethodsParam <- function( + methods = NULL, + qtlDatasetMethods = NULL, + qtlSumStatsMethods = NULL +) { + new( + "FineMappingMethodsParam", + methods = .methodsNormalizeSlot( + methods, + "methods", + "FineMappingMethodsParam" + ), + qtlDatasetMethods = .methodsNormalizeSlot( + qtlDatasetMethods, + "qtlDatasetMethods", + "FineMappingMethodsParam" + ), + qtlSumStatsMethods = .methodsNormalizeSlot( + qtlSumStatsMethods, + "qtlSumStatsMethods", + "FineMappingMethodsParam" + ) + ) +} + +# Every fine-mapping method that runs on one input path. GwasSumStats is a +# summary-statistics class, narrowed to the methods that accept one trait. +# @noRd +.fmMethodsFor <- function(inputKind) { + caps <- .fineMappingMethodCapabilities + keep(names(caps), .fmMethodRunsOn, caps = caps, inputKind = inputKind) +} + +# @noRd +.fmMethodRunsOn <- function(token, caps, inputKind) { + info <- caps[[token]] + if (identical(inputKind, "QtlDataset")) { + return(!is.null(info$individualImpl)) + } + if (is.null(info$sumstatImpl)) { + return(FALSE) + } + !identical(inputKind, "GwasSumStats") || isTRUE(info$gwasAllowed) +} + +# One method's Options constructor for ONE input path, validating against +# just that path's callee. +# +# Deliberately not the union of both callees: validating against the union +# would accept a name valid on only one of them -- `susie` takes 41 +# arguments on individual data and 49 on summary statistics, sharing 37, so +# the union admits 16 names that are wrong for whichever path actually runs. +# Once the caller knows its input class there is no reason to be that +# lenient. +# @noRd +.fmTokenPathConfig <- function(token, inputKind) { + force(token) + force(inputKind) + callee <- .fmMethodCalleeFor(token, inputKind) + if (is.null(callee)) { + return(NULL) + } + function(...) { + .newMethodOptions( + callee, + defaults = list(), + extra = list(...), + label = glue("method '{token}' on {inputKind}"), + engine = token + ) + } +} + +# Every method's constructor for one input path, omitting the methods that +# do not run on it -- `fsusie` has no summary-statistics implementation, +# `ser` no individual one. +# @noRd +.fmMethodCtorsFor <- function(inputKind) { + toks <- names(.fineMappingMethodCapabilities) + compact(set_names( + map(toks, .fmTokenPathConfig, inputKind = inputKind), + toks + )) +} + +#' @title Arguments For A Fine-Mapping Engine +#' @description Options forwarded to one fine-mapping engine, checked +#' against that engine's live formals. +#' +#' There is one constructor per ENGINE, not per method. A method whose +#' individual-level and summary-statistic paths run different functions +#' has one for each --- \code{SusieOptions} for \code{susieR::susie} and +#' \code{SusieRssOptions} for \code{susieR::susie_rss}, \code{MvsusieOptions} +#' and \code{MvsusieRssOptions} likewise. Checking the union of the two +#' instead would accept an \code{susie_rss}-only name on an +#' individual-level run and then silently drop it, and would leave +#' mvsusie unchecked entirely, since \code{mvsusie_rss} takes \code{...} +#' and a union containing it accepts any name at all. +#' +#' \code{SerOptions} and \code{FsusieOptions} have no sibling: SER is +#' summary-statistics-only and fSuSiE individual-only. +#' +#' Pass the result as an element of \code{\link{FineMappingMethodsParam}}, +#' or directly to the matching single-engine function. In the aggregator a +#' method accepts either of its engines' constructors, since the input +#' class is not known at that point. A plain list works there too and +#' stays checked against both; the exact engine is checked once the run's +#' input class is known. +#' @param ... Arguments for the engine, under its own names (\code{L}, +#' \code{coverage}, \code{max_iter}, ...). +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' SusieOptions(L = 5) +#' SusieRssOptions(maf_thresh = 0.01) +#' MvsusieOptions(prior_tol = 1e-9) +#' @name fineMappingMethodOptions +NULL + +# Token -> the engine constructor for each of its input paths. A method with +# both an individual-level and a summary-statistic engine accepts either +# one's constructor, since the aggregator does not know the input class. +# @noRd +.fmTokenCtorsByPath <- function() { + list( + susie = list(SusieOptions, SusieRssOptions), + susieInf = list(SusieInfOptions, SusieInfRssOptions), + susieAsh = list(SusieAshOptions, SusieAshRssOptions), + ser = list(SerOptions), + mvsusie = list(MvsusieOptions, MvsusieRssOptions), + fsusie = list(FsusieOptions) + ) +} + # Resolve the method tokens for a QtlSumStats run and run any EXPLICIT # jointSpecification up front (mvsusie via the axis dispatcher), removing the -# joint methods from the per-tuple token set. `exhaustedByJoint` flags the case +# joint methods from the per-tuple token set. `done` flags the case # where an explicit spec consumed every method, so the caller returns the joint # result directly (or errors when it produced nothing). # @noRd -.fmQssResolveTokens <- function(p) { - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - norm <- .fmNormalizeMethods(p$methods) - tokens <- norm$tokens - methodArgs <- norm$methodArgs - .fmCheckMethodCapabilities(tokens, "QtlSumStats") - jointResult <- NULL - hadJointSpec <- length(parsedJointSpec) > 0L - if (hadJointSpec) { - jointResult <- .fmDispatchJointSpecsQtlSumStats( - parsedJointSpec, - p$data, - intersect(tokens, "mvsusie"), - p$contexts, - p$traitId, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, - methodArgs = methodArgs, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff, - fineMappingResult = p$fineMappingResult, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - mafCutoff = p$mafCutoff %||% 0, - macCutoff = p$macCutoff %||% 0, - imissCutoff = p$imissCutoff %||% 1 - ) - tokens <- setdiff(tokens, c("mvsusie", "fsusie")) - methodArgs <- methodArgs[tokens] - } - list( - tokens = tokens, - methodArgs = methodArgs, - jointResult = jointResult, - exhaustedByJoint = hadJointSpec && length(tokens) == 0L +.fmQssResolveTokens <- function(jointSpecification, methods, L, Lgreedy, cfg) { + parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) + norm <- .fmNormalizeMethods( + methods, + inputKind = "QtlSumStats", + L = L, + Lgreedy = Lgreedy ) + .fmCheckMethodCapabilities(norm$tokens, "QtlSumStats") + .fmCheckMethodArgsForInput(norm$methodArgs, "QtlSumStats") + .fmQssJointPhase(parsedJointSpec, norm, cfg) } # Resolve the study/context/trait columns and the selected row indices for a # QtlSumStats run, applying the optional contexts / traitId filters. # @noRd -.fmQssSelectRows <- function(p) { - studyCol <- as.character(p$data$study) - contextCol <- as.character(p$data$context) - traitCol <- as.character(p$data$trait) - selRows <- seq_len(nrow(p$data)) - if (!is.null(p$contexts)) { - selRows <- selRows[is_in(contextCol[selRows], p$contexts)] +.fmQssSelectRows <- function( + data, + contexts, + traitId +) { + studyCol <- as.character(data$study) + contextCol <- as.character(data$context) + traitCol <- as.character(data$trait) + byContext <- if (is.null(contexts)) { + seq_len(nrow(data)) + } else { + which(is_in(contextCol, contexts)) } - if (!is.null(p$traitId)) { - selRows <- selRows[is_in(traitCol[selRows], p$traitId)] + selRows <- if (is.null(traitId)) { + byContext + } else { + byContext[is_in(traitCol[byContext], traitId)] } if (length(selRows) == 0L) { msg <- glue( @@ -2988,40 +3669,24 @@ setMethod( # Multivariate dispatch via the joint engine (auto-detected cross-context RSS # joint) for mvsusie WITHOUT an explicit jointSpecification, merged with any -# explicit-spec result already in `p$jointResult`. +# explicit-spec result the joint phase already produced. # @noRd -.fmQssAutoJoint <- function(p) { - if (length(p$mvTokens) == 0L) { - return(p$jointResult) +.fmQssAutoJoint <- function(cfg, mvTokens, methodArgs, jointResult, ldSketch) { + if (length(mvTokens) == 0L) { + return(jointResult) } - autoJoint <- .fmDispatchJointSpecsQtlSumStats( + autoJoint <- .fmQssJointDispatch( list(list(axes = "context", scope = NULL)), - p$data, - p$mvTokens, - p$contexts, - p$traitId, - p$coverage, - p$secondaryCoverage, - p$signalCutoff, - p$minAbsCorr, - p$verbose, - methodArgs = p$methodArgs, - twasWeights = p$twasWeights, - dataDrivenPriorWeightsCutoff = p$dataDrivenPriorWeightsCutoff, - fineMappingResult = p$fineMappingResult, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs, - mafCutoff = p$mafCutoff %||% 0, - macCutoff = p$macCutoff %||% 0, - imissCutoff = p$imissCutoff %||% 1 - ) - if (is.null(p$jointResult)) { + mvTokens, + methodArgs, + cfg + ) + if (is.null(jointResult)) { autoJoint } else if (is.null(autoJoint)) { - p$jointResult + jointResult } else { - .rbindFineMappingResult(p$jointResult, autoJoint, ldSketch = p$ldSketch) + .rbindFineMappingResult(jointResult, autoJoint, ldSketch = ldSketch) } } @@ -3030,7 +3695,13 @@ setMethod( # and combine with the joint result. An all-screened collection yields a valid # empty result rather than an error. # @noRd -.fmQssAssemble <- function(p, rows, nSkipped, jointResult) { +.fmQssAssemble <- function( + data, + ldSketch, + rows, + nSkipped, + jointResult +) { rowContext <- map_chr(rows, "context") rowTrait <- map_chr(rows, "trait") perTupleResult <- if (length(rows) > 0L) { @@ -3040,11 +3711,11 @@ setMethod( rowTrait, map_chr(rows, "method"), map(rows, "entry"), - traitPos = tryCatch( - .anchorVector(p$data, rowContext, rowTrait, "traitPos"), - error = function(e) NULL + traitPos = try_fetch( + .anchorVector(data, rowContext, rowTrait, "traitPos"), + error = function(cnd) NULL ), - ldSketch = p$ldSketch + ldSketch = ldSketch ) } else { NULL @@ -3060,7 +3731,7 @@ setMethod( character(0), character(0), list(), - ldSketch = p$ldSketch, + ldSketch = ldSketch, allowEmpty = TRUE )) } @@ -3071,57 +3742,178 @@ setMethod( if (is.null(perTupleResult)) { return(jointResult) } - .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = p$ldSketch) + .rbindFineMappingResult(perTupleResult, jointResult, ldSketch = ldSketch) } -# QtlSumStats fine-mapping worker. `p` is the setMethod's captured arguments; -# it is extended via list_modify with the resolved tokens / row selection / LD -# sketch so the per-entry dispatch helpers read everything from one bundle. +# The settings the joint phase and the RSS row builders share, named once +# so the two records built from them cannot disagree. # @noRd -.fmPipelineQtlSumStats <- function(p) { - .fmAssertQcd(p$data) - rt <- .fmQssResolveTokens(p) - if (rt$exhaustedByJoint) { - if (is.null(rt$jointResult)) { - msg <- glue( - "fineMappingPipeline(QtlSumStats): no joint fits produced. ", - "Check that the jointSpecification scope intersects the ", - "available data." - ) - abort(msg) - } - return(rt$jointResult) +.fmQssConfigs <- function( + data, + credibleSetArgs, + fineMappingResult, + fitRetention, + verbose, + panelFilterArgs, + contexts, + traitId, + mrmashPrior, + dataDrivenPriorWeightsCutoff +) { + common <- .fmSsCommonCfg( + data = data, + credibleSetArgs = credibleSetArgs, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + verbose = verbose, + panelFilterArgs = panelFilterArgs + ) + list( + common = common, + joint = .fmQssJointCfg( + common, + contexts = contexts, + traitId = traitId, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) + ) +} + +# QtlSumStats fine-mapping worker. The resolved tokens, row selection and LD +# sketch are ordinary locals, handed to the per-entry dispatch helpers as +# named arguments. +# @noRd +.fmPipelineQtlSumStats <- function( + data, + methods, + addSusieInf, + contexts, + traitId, + jointSpecification, + credibleSetArgs, + fineMappingResult, + mrmashPrior, + dataDrivenPriorWeightsCutoff, + verbose, + fitRetention, + rssArgs, + panelFilterArgs +) { + .fmAssertQcd(data) + cfgs <- .fmQssConfigs( + data = data, + credibleSetArgs = credibleSetArgs, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + verbose = verbose, + panelFilterArgs = panelFilterArgs, + contexts = contexts, + traitId = traitId, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) + commonCfg <- cfgs$common + jointCfg <- cfgs$joint + rt <- .fmQssResolveTokens( + jointSpecification, + methods, + credibleSetArgs$L %||% 10L, + credibleSetArgs$Lgreedy, + jointCfg + ) + if (rt$done) { + return(rt$result) } - sel <- .fmQssSelectRows(p) - split <- .fmQssSplitTokens(rt$tokens, sel) - ldSketch <- getLdSketch(p$data) - p <- list_modify( - p, - tokens = rt$tokens, + .fmQssAfterJoint( + data, + rt = rt, + commonCfg = commonCfg, + jointCfg = jointCfg, + contexts = contexts, + traitId = traitId, + addSusieInf = addSusieInf, + rssArgs = rssArgs + ) +} + +# Everything after the joint phase has had its say: select the rows the +# univariate tokens run on, resolve the LD-finiteness setting against the +# sketch, and fit. `rt` is .fmQssResolveTokens()'s record -- it carries the +# remaining tokens, their options, and whatever the joint phase produced. +# @noRd +.fmQssAfterJoint <- function( + data, + rt, + commonCfg, + jointCfg, + contexts, + traitId, + addSusieInf, + rssArgs +) { + sel <- .fmQssSelectRows(data = data, contexts = contexts, traitId = traitId) + ldSketch <- getLdSketch(data) + cfg <- .fmRssRunCfg( + commonCfg, + ldSketch = ldSketch, + addSusieInf = addSusieInf, methodArgs = rt$methodArgs, - jointResult = rt$jointResult, - studyCol = sel$studyCol, - contextCol = sel$contextCol, - traitCol = sel$traitCol, - selRows = sel$selRows, - univTokens = split$univTokens, - mvTokens = split$mvTokens, + rssArgs = .fmRssArgsResolved(rssArgs, ldSketch) + ) + .fmQssRunRows( + data, + sel = sel, + split = .fmQssSplitTokens(rt$tokens, sel), + cfg = cfg, + jointCfg = jointCfg, ldSketch = ldSketch, - rFiniteResolved = .fmResolveRFinite( - p$rFinite, - p$serFallback, - p$rMismatch, - ldSketch - ) + methodArgs = rt$methodArgs, + jointResult = rt$result ) - univOut <- if (length(p$univTokens) > 0L) { - map(p$selRows, .fmRssEntryRows, p = p) +} + +# Fine-map the selected rows with the univariate tokens, then assemble that +# with whatever the joint phase produced. `sel` and `split` travel whole: +# the row selection and the token split are each one answer, and splitting +# them back into loose columns here is what this function exists to avoid. +# @noRd +.fmQssRunRows <- function( + data, + sel, + split, + cfg, + jointCfg, + ldSketch, + methodArgs, + jointResult +) { + univOut <- if (length(split$univTokens) > 0L) { + map( + sel$selRows, + .fmRssEntryRows, + studyCol = sel$studyCol, + contextCol = sel$contextCol, + traitCol = sel$traitCol, + univTokens = split$univTokens, + cfg = cfg + ) } else { list() } - rows <- list_flatten(map(univOut, "rows")) - nSkipped <- sum(map_lgl(univOut, "skipped")) - .fmQssAssemble(p, rows, nSkipped, .fmQssAutoJoint(p)) + .fmQssAssemble( + data = data, + ldSketch = ldSketch, + rows = list_flatten(map(univOut, "rows")), + nSkipped = sum(map_lgl(univOut, "skipped")), + jointResult = .fmQssAutoJoint( + cfg = jointCfg, + mvTokens = split$mvTokens, + methodArgs = methodArgs, + jointResult = jointResult, + ldSketch = ldSketch + ) + ) } #' @rdname fineMappingPipeline @@ -3136,34 +3928,42 @@ setMethod( traitId = NULL, jointSpecification = NULL, addSusieInf = TRUE, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, + credibleSetArgs = CredibleSetParam(), fineMappingResult = NULL, - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - serFallback = FALSE, - rFinite = NULL, - rMismatch = "none", - rssControl = NULL, - keepFullFit = "fallback", - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + fitRetention = c("slim", "full"), + rssArgs = SusieRssParam(), + panelFilterArgs = PanelFilterParam(), + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam() ) { - .fmPipelineQtlSumStats(as.list(environment())) + fitRetention <- arg_match(fitRetention) + .cvRefuseOnSumstats( + crossValidationArgs, + "fineMappingPipeline", + "QtlSumStats" + ) + .fmPipelineQtlSumStats( + data = data, + methods = methods, + addSusieInf = addSusieInf, + contexts = contexts, + traitId = traitId, + jointSpecification = jointSpecification, + credibleSetArgs = credibleSetArgs, + fineMappingResult = fineMappingResult, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + fitRetention = fitRetention, + rssArgs = rssArgs, + panelFilterArgs = panelFilterArgs + ) } ) - # ============================================================================= # GwasSumStats method # ============================================================================= @@ -3173,6 +3973,24 @@ setMethod( # rFinite is unset: use the LD-panel sample size (the notebook's `B`). Shared by # the QtlSumStats and GwasSumStats workers. # @noRd +# The resolved record, still a SusieRssParam. Previously the resolved value was +# carried alongside the record as a second cfg field and spliced in with +# list_assign(as.list(...)) at the point of use, which handed everything +# downstream a bare list exactly where the value became concrete. +# @noRd +.fmRssArgsResolved <- function(rssArgs, ldSketch) { + resolved <- .fmResolveRFinite( + rssArgs$rFinite, + rssArgs$serFallback, + rssArgs$rMismatch, + ldSketch + ) + if (identical(resolved, rssArgs$rFinite)) { + return(rssArgs) + } + .rssParamWithRFinite(rssArgs, resolved) +} + .fmResolveRFinite <- function(rFinite, serFallback, rMismatch, ldSketch) { if ( is.null(rFinite) && @@ -3184,33 +4002,83 @@ setMethod( } } -# GwasSumStats fine-mapping worker. `p` is the setMethod's captured arguments -# (as.list(environment())); it is extended via list_modify with the resolved -# tokens / LD sketch / finite-sample size so the per-entry dispatch helpers -# read everything from the single bundle. One GwasSumStats is one LD -# block (the caller builds one collection per block when sweeping the genome); -# we fine-map each (study, method) tuple across the whole entry, no in-pipeline -# block partitioning. +# GwasSumStats fine-mapping worker. The resolved tokens, LD sketch and +# finite-sample size are ordinary locals, handed to the per-entry dispatch +# helpers as named arguments. One GwasSumStats is one LD block (the caller +# builds one collection per block when sweeping the genome); we fine-map each +# (study, method) tuple across the whole entry, with no in-pipeline block +# partitioning. # @noRd -.fmPipelineGwas <- function(p) { - .fmAssertQcd(p$data) - norm <- .fmNormalizeMethods(p$methods, L = p$L, Lgreedy = p$Lgreedy) +.fmPipelineGwas <- function( + data, + methods, + addSusieInf, + credibleSetArgs, + fineMappingResult, + verbose, + fitRetention, + rssArgs, + panelFilterArgs +) { + .fmAssertQcd(data) + norm <- .fmNormalizeMethods( + methods, + L = credibleSetArgs$L %||% 10L, + Lgreedy = credibleSetArgs$Lgreedy + ) .fmCheckMethodCapabilities(norm$tokens, "GwasSumStats") - ldSketch <- getLdSketch(p$data) - p <- list_modify( - p, - tokens = norm$tokens, - methodArgs = norm$methodArgs, + .fmCheckMethodArgsForInput(norm$methodArgs, "GwasSumStats") + ldSketch <- getLdSketch(data) + # Derived values are ordinary locals now, not fields grafted onto a bundle. + tokens <- norm$tokens + methodArgs <- norm$methodArgs + rssArgs <- .fmRssArgsResolved(rssArgs, ldSketch) + studyCol <- as.character(data$study) + commonCfg <- .fmSsCommonCfg( + data = data, + credibleSetArgs = credibleSetArgs, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + verbose = verbose, + panelFilterArgs = panelFilterArgs + ) + .fmGwasRunEntries( + data, + studyCol = studyCol, + tokens = tokens, + commonCfg = commonCfg, ldSketch = ldSketch, - rFiniteResolved = .fmResolveRFinite( - p$rFinite, - p$serFallback, - p$rMismatch, - ldSketch - ), - studyCol = as.character(p$data$study) + addSusieInf = addSusieInf, + methodArgs = methodArgs, + rssArgs = rssArgs + ) +} + +# Fine-map every row of the GWAS collection and assemble the result. +# @noRd +.fmGwasRunEntries <- function( + data, + studyCol, + tokens, + commonCfg, + ldSketch, + addSusieInf, + methodArgs, + rssArgs +) { + entryOut <- map( + seq_len(nrow(data)), + .fmGwasEntryRows, + studyCol = studyCol, + tokens = tokens, + cfg = .fmRssRunCfg( + commonCfg, + ldSketch = ldSketch, + addSusieInf = addSusieInf, + methodArgs = methodArgs, + rssArgs = rssArgs + ) ) - entryOut <- map(seq_len(nrow(p$data)), .fmGwasEntryRows, p = p) rows <- list_flatten(map(entryOut, "rows")) nSkipped <- sum(map_lgl(entryOut, "skipped")) # An all-screened (or empty-input) collection legitimately yields a 0-row @@ -3221,7 +4089,7 @@ setMethod( map(rows, "entry"), blockIds = map_chr(rows, "blockId"), ldSketch = ldSketch, - allowEmpty = (nSkipped > 0L || nrow(p$data) == 0L) + allowEmpty = (nSkipped > 0L || nrow(data) == 0L) ) } @@ -3234,50 +4102,35 @@ setMethod( data, methods, addSusieInf = TRUE, - L = 10L, - Lgreedy = NULL, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, + credibleSetArgs = CredibleSetParam(), fineMappingResult = NULL, verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - serFallback = FALSE, - rFinite = NULL, - rMismatch = "none", - rssControl = NULL, - keepFullFit = "fallback", - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + fitRetention = c("slim", "full"), + rssArgs = SusieRssParam(), + panelFilterArgs = PanelFilterParam(), + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam() ) { - .fmPipelineGwas(as.list(environment())) + fitRetention <- arg_match(fitRetention) + .cvRefuseOnSumstats( + crossValidationArgs, + "fineMappingPipeline", + "GwasSumStats" + ) + .fmPipelineGwas( + data = data, + methods = methods, + addSusieInf = addSusieInf, + credibleSetArgs = credibleSetArgs, + fineMappingResult = fineMappingResult, + verbose = verbose, + fitRetention = fitRetention, + rssArgs = rssArgs, + panelFilterArgs = panelFilterArgs + ) } ) - -# ============================================================================= -# ANY fallback -# ============================================================================= - -#' @rdname fineMappingPipeline -#' @export -setMethod("fineMappingPipeline", "ANY", function(data, ...) { - cls <- class(data)[[1L]] - msg <- glue( - "fineMappingPipeline does not accept inputs of class '{cls}'. ", - "Pass a QtlDataset, MultiStudyQtlDataset, QtlSumStats, or ", - "GwasSumStats. Use summaryStatsQc() on SumStats inputs first." - ) - abort(msg) -}) - # ============================================================================= # Named helpers for map/apply call sites (no inline lambdas) # ============================================================================= @@ -3298,8 +4151,16 @@ setMethod("fineMappingPipeline", "ANY", function(data, ...) { } # @noRd -.fmGwasLookup <- function(tk, p, st, blockId) { - list(tk = tk, cached = .fmCacheLookupGwasResume(p, st, tk, blockId)) +.fmGwasLookup <- function(tk, fineMappingResult, st, blockId) { + list( + tk = tk, + cached = .fmCacheLookupGwasResume( + fineMappingResult, + st, + tk, + blockId + ) + ) } # @noRd @@ -3313,8 +4174,11 @@ setMethod("fineMappingPipeline", "ANY", function(data, ...) { } # @noRd -.fmQtlLookup <- function(tk, p, st, ctx, tr) { - list(tk = tk, cached = .fmCacheLookup(p$fineMappingResult, st, ctx, tr, tk)) +.fmQtlLookup <- function(tk, fineMappingResult, st, ctx, tr) { + list( + tk = tk, + cached = .fmCacheLookup(fineMappingResult, st, ctx, tr, tk) + ) } # @noRd @@ -3388,20 +4252,398 @@ setMethod("fineMappingPipeline", "ANY", function(data, ...) { } # @noRd -.fmUnivLookup <- function(tk, p, ctx, tid) { +.fmUnivLookup <- function(tk, fineMappingResult, study, ctx, tid) { list( tk = tk, - cached = .fmCacheLookup(p$fineMappingResult, p$study, ctx, tid, tk) + cached = .fmCacheLookup(fineMappingResult, study, ctx, tid, tk) ) } # @noRd -.fmUnivCachedRow <- function(l, p, ctx, tid) { - .fmQtlRow(p$study, ctx, tid, l$tk, l$cached) +.fmUnivCachedRow <- function(l, study, ctx, tid) { + .fmQtlRow(study, ctx, tid, l$tk, l$cached) } # All univariate row-records for one context (over its per-context traits). # @noRd -.fmUnivContextRows <- function(ctx, p) { - list_flatten(map(p$perCtxTraits[[ctx]], .fmUnivTraitRows, p = p, ctx = ctx)) +.fmUnivContextRows <- function(ctx, cfg) { + list_flatten(map( + cfg$perCtxTraits[[ctx]], + .fmUnivTraitRows, + ctx = ctx, + cfg = cfg + )) +} + +# ============================================================================= +# Fine-mapping Param bundles +# ----------------------------------------------------------------------------- +# Moved here from the former pipelineParams.R: these describe fine-mapping +# stages, and are read here and in fineMappingWrappers.R / jointEngine.R even +# when another pipeline forwards them. +# +# `L` / `Lgreedy` are CredibleSetParam fields: they bound how many credible +# sets can exist. They reach the engine by a different route from the rest of +# the bundle -- .fmSeededArgNames() is c("L", "L_greedy"), seeded onto each +# SuSiE-family token's own arguments, whereas the other fields are read by +# postprocessFinemappingFits() -- so changing them needs a refit while a +# stored fit can be re-post-processed under a different coverage. +# +# `addSusieInf` is a standalone argument, not a bundle field: it selects a +# chained initialisation between methods rather than describing credible sets. +# +# `fitRetention` is a plain arg_match() enum on each pipeline, not a bundle: +# see colocPipeline(), crossValidation() and fineMappingPipeline(). +# ============================================================================= + +# --- CredibleSetParam accessors -------------------------------------------- +# Setters revalidate: slot assignment checks the declared type on its own but +# does not re-run a validity method, and this package does write those (see +# SignalScreenParam). + +#' @rdname CredibleSetParam +setMethod("getCoverage", "CredibleSetParam", function(x) x@coverage) + +#' @rdname CredibleSetParam +setMethod("setCoverage", "CredibleSetParam", function(x, value) { + x@coverage <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("getSecondaryCoverage", "CredibleSetParam", function(x) { + x@secondaryCoverage +}) + +#' @rdname CredibleSetParam +setMethod("setSecondaryCoverage", "CredibleSetParam", function(x, value) { + x@secondaryCoverage <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("getSignalCutoff", "CredibleSetParam", function(x) x@signalCutoff) + +#' @rdname CredibleSetParam +setMethod("setSignalCutoff", "CredibleSetParam", function(x, value) { + x@signalCutoff <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("getMinAbsCorr", "CredibleSetParam", function(x) x@minAbsCorr) + +#' @rdname CredibleSetParam +setMethod("setMinAbsCorr", "CredibleSetParam", function(x, value) { + x@minAbsCorr <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("getMedianAbsCorr", "CredibleSetParam", function(x) x@medianAbsCorr) + +#' @rdname CredibleSetParam +setMethod("setMedianAbsCorr", "CredibleSetParam", function(x, value) { + x@medianAbsCorr <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("getIncludeAllCs", "CredibleSetParam", function(x) x@includeAllCs) + +#' @rdname CredibleSetParam +setMethod("setIncludeAllCs", "CredibleSetParam", function(x, value) { + x@includeAllCs <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("getPerCsColumns", "CredibleSetParam", function(x) x@perCsColumns) + +#' @rdname CredibleSetParam +setMethod("setPerCsColumns", "CredibleSetParam", function(x, value) { + x@perCsColumns <- value + validObject(x) + x +}) + +#' @rdname CredibleSetParam +setMethod("getL", "CredibleSetParam", function(x) x@L) + +#' @rdname CredibleSetParam +setMethod("getLgreedy", "CredibleSetParam", function(x) x@Lgreedy) + +#' @rdname SignalScreenParam +#' @aliases SignalScreenParam-class +#' @exportClass SignalScreenParam +setClass( + "SignalScreenParam", + contains = "MethodParam", + slots = c( + pip = "numeric_OR_NULL", + absZ = "numeric_OR_NULL", + bf = "numeric_OR_NULL", + logBf = "numeric_OR_NULL" + ) +) + +#' @title Signal Pre-Screen Settings +#' @description Whether to skip a block before fitting it, and on which +#' metric. Shared by \code{\link{fineMappingPipeline}} and +#' \code{\link{colocboostPipeline}}. +#' @section One metric at a time: +#' The four metrics are mutually exclusive and the constructor enforces it, +#' so a conflicting pair fails where it is written rather than part-way +#' into a pipeline run. Leave them all unset (the default) to screen +#' nothing. +#' @param pip Posterior-inclusion-probability cutoff. A negative value uses +#' the adaptive \code{3 / nVariants} threshold. +#' @param absZ Cutoff on the maximum absolute z-score. +#' @param bf Cutoff on the maximum per-variant Bayes factor. +#' @param logBf Cutoff on the maximum per-variant log Bayes factor. +#' @return A \code{SignalScreenParam} object, a \code{\link{MethodParam}}. +#' @examples +#' SignalScreenParam(absZ = 5) +#' @export +SignalScreenParam <- function( + pip = NULL, + absZ = NULL, + bf = NULL, + logBf = NULL +) { + new("SignalScreenParam", pip = pip, absZ = absZ, bf = bf, logBf = logBf) +} + +# absZ and bf have no meaningful negative cutoff: absZ screens on max|Z| and +# a Bayes factor is positive. (pip keeps `< 0 => 3 / nVariants`, and logBf is +# a log, so both may legitimately be negative.) +# @noRd +.screenPositiveProblem <- function(screen) { + bad <- keep(c("absZ", "bf"), .screenIsNegative, screen = screen) + if (length(bad) == 0L) { + return(character(0)) + } + m <- bad[[1L]] + glue( + "`{m}` must be > 0, got {screen[[m]]}. ", + "absZ screens on max|Z| and Bayes factors are positive." + ) +} + +# @noRd +.screenIsNegative <- function(m, screen) { + v <- screen[[m]] + !is.null(v) && length(v) == 1L && !is.na(v) && v < 0 +} + +# Refuse more than one enabled metric. Enabled means set AND non-zero: 0 is +# the long-standing "off" spelling for these cutoffs, so SignalScreenParam(pip +# = 0, absZ = 5) is one screen, not two. +# @noRd +.screenOneMetricProblem <- function(screen) { + on <- names(screen)[map_lgl(as.list(screen), .screenIsOn)] + if (length(on) <= 1L) { + return(character(0)) + } + glue( + "only one screening metric may be enabled at a time; ", + "got {str_flatten(on, ', ')}." + ) +} + +setValidity("SignalScreenParam", function(object) { + problems <- c( + .screenOneMetricProblem(object), + .screenPositiveProblem(object) + ) + if (length(problems) == 0L) TRUE else as.character(problems) +}) + +# @noRd +.screenIsOn <- function(x) { + !is.null(x) && length(x) > 0L && any(as.numeric(x) != 0, na.rm = TRUE) +} + +# The one enabled metric as the polymorphic screen spec the pipelines already +# understand (see .asScreen): a bare numeric for `pip`, a list(metric, cutoff) +# for the others, NULL when nothing is enabled. A field set to 0 is off, so +# SignalScreenParam(pip = 0, absZ = 5) resolves to the absZ screen. +# @noRd +.screenResolve <- function(screen) { + on <- names(screen)[map_lgl(as.list(screen), .screenIsOn)] + if (length(on) == 0L) { + return(NULL) + } + metric <- on[[1L]] + if (metric == "pip") { + return(screen$pip) + } + list(metric = metric, cutoff = screen[[metric]]) +} + +#' @rdname CredibleSetParam +#' @aliases CredibleSetParam-class +#' @exportClass CredibleSetParam +setClass( + "CredibleSetParam", + contains = "MethodParam", + slots = c( + coverage = "numeric", + secondaryCoverage = "numeric", + signalCutoff = "numeric", + minAbsCorr = "numeric", + medianAbsCorr = "numeric_OR_NULL", + includeAllCs = "logical", + perCsColumns = "character", + L = "numeric", + Lgreedy = "numeric_OR_NULL" + ) +) + +#' @title Credible-Set Construction And Reporting +#' @description How credible sets are built from a fit and which of them are +#' reported. Every field is read by +#' \code{\link{postprocessFinemappingFits}}, so these can be changed and a +#' stored fit re-summarized without refitting. +#' @param coverage Primary credible-set coverage. Default \code{0.95}. +#' @param secondaryCoverage Additional coverages to report credible sets at. +#' Default \code{c(0.7, 0.5)}. +#' @param signalCutoff PIP cutoff for including a non-credible-set variant in +#' the top-loci table. Default \code{0.025}. +#' @param minAbsCorr Minimum absolute within-set correlation for purity. +#' Default \code{0.8}. +#' @param medianAbsCorr Median absolute within-set correlation threshold, or +#' \code{NULL} (default) to judge purity on \code{minAbsCorr} alone. +#' @param includeAllCs Logical. Report every credible set rather than only the +#' top one. Default \code{FALSE}. +#' @param perCsColumns Which per-credible-set variant-level columns are added +#' to the \code{topLoci} table. \code{"none"} (default) adds only the +#' always-on scalar \code{within_cs_pip}; \code{"alpha"} also widens +#' \code{alpha} into one \code{within_cs_pip_} column per set; +#' \code{"full"} additionally widens \code{cs_logbf_}, \code{cs_effect_} +#' and \code{cs_effect_var_}. \code{includeAllCs} decides the \code{} +#' in those names. This governs the \emph{table}; the stored fit is +#' governed by \code{fitRetention}. +#' @param L Integer. Maximum number of single effects the fit may carry, and +#' so the maximum number of credible sets that can exist. Default +#' \code{10}. Seeded onto every SuSiE-family token in \code{methods} that +#' did not set it through \code{\link{FineMappingMethodsParam}}. +#' @param Lgreedy Integer or \code{NULL}. Maximum number of single effects +#' for the greedy initialization stage, where the engine has one. +#' \code{NULL} (the default) leaves the engine's own default in place. +#' @return \code{CredibleSetParam} returns a \code{CredibleSetParam} +#' object, a \code{\link{MethodParam}}. Each \code{get*} returns that +#' setting's value; each \code{set*} returns a modified copy. \code{L} +#' and \code{Lgreedy} have no setter: they are seeded onto the fitting +#' tokens, so changing one needs a refit rather than a re-summary. +#' @examples +#' CredibleSetParam(coverage = 0.9, includeAllCs = TRUE) +#' @export +CredibleSetParam <- function( + coverage = 0.95, + secondaryCoverage = c(0.7, 0.5), + signalCutoff = 0.025, + minAbsCorr = 0.8, + medianAbsCorr = NULL, + includeAllCs = FALSE, + perCsColumns = c("none", "alpha", "full"), + L = 10L, + Lgreedy = NULL +) { + perCsColumns <- arg_match(perCsColumns) + new( + "CredibleSetParam", + coverage = coverage, + secondaryCoverage = secondaryCoverage, + signalCutoff = signalCutoff, + minAbsCorr = minAbsCorr, + medianAbsCorr = medianAbsCorr, + includeAllCs = includeAllCs, + perCsColumns = perCsColumns, + L = L, + Lgreedy = Lgreedy + ) +} + +#' @rdname SusieRssParam +#' @aliases SusieRssParam-class +#' @exportClass SusieRssParam +setClass( + "SusieRssParam", + contains = "MethodParam", + slots = c( + serFallback = "logical", + keepFullFit = "character", + rFinite = "numeric_OR_NULL", + rMismatch = "character_OR_NULL", + control = "MethodOptions_OR_NULL" + ) +) + +#' @title SuSiE-RSS Solver Settings +#' @description How the SuSiE-RSS fit is conditioned and what it falls back +#' to, on \code{QtlSumStats} / \code{GwasSumStats} input. +#' +#' SuSiE-family only, which is what the name says: every field is a +#' \code{susieR} concept --- \code{serFallback} drops to +#' \code{susie_ser}, \code{rFinite} / \code{rMismatch} are +#' \code{susie_rss}'s \code{R_finite} / \code{R_mismatch}, and +#' \code{control} is \code{susie_rss_control}. The other +#' summary-statistics engine, \code{mvsusieR::mvsusie_rss}, has none of +#' these formals and is not configured by this. +#' @param serFallback Logical. Fall back to a single-effect fit when the +#' multi-effect fit is judged unreliable. Default \code{FALSE}. +#' @param keepFullFit Which pre-fallback multi-effect fits to retain: +#' \code{"fallback"} (default) keeps them only for regions that fell back, +#' \code{"all"} for every region, \code{"none"} for none. Only meaningful +#' when \code{serFallback} is \code{TRUE}. +#' @param rFinite Sample size used for the LD matrix's finiteness check, or +#' \code{NULL} (default) to use the panel's own. +#' @param rMismatch How to treat an LD / z-score mismatch. Default +#' \code{"none"}. +#' @param control Options for \code{susieR::susie_rss_control()}, forwarded as +#' \code{susie_rss()}'s \code{control} argument. Built with +#' \code{\link{SusieRssControlOptions}}; \code{NULL} (default) leaves that +#' function's own defaults in place. +#' @return A \code{SusieRssParam} object, a \code{\link{MethodParam}}. +#' @examples +#' SusieRssParam(serFallback = TRUE, keepFullFit = "all") +#' @export +SusieRssParam <- function( + serFallback = FALSE, + keepFullFit = c("fallback", "all", "none"), + rFinite = NULL, + rMismatch = "none", + control = NULL +) { + keepFullFit <- arg_match(keepFullFit) + if (!is.null(control)) { + .assertMethodOptions(control, "SusieRssControlOptions", "control") + } + new( + "SusieRssParam", + serFallback = serFallback, + keepFullFit = keepFullFit, + rFinite = rFinite, + rMismatch = rMismatch, + control = control + ) +} + +# `rFinite` is the one field pecotmr itself fills in: it defaults to NULL +# meaning "use the LD panel's sample size", which is not knowable when the +# caller builds the record. Resolution happens once the sketch is in hand +# (see .fmRssArgsResolved). Internal, not an exported setter -- no user sets +# this, it is derived. +# @noRd +.rssParamWithRFinite <- function(x, value) { + x@rFinite <- value + validObject(x) + x } diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index fb1ce1e7b..6781533dd 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -41,19 +41,22 @@ setClass( prototype(susieFit = NULL, cvResult = NULL) ) +#' @importFrom checkmate makeAssertCollection assertList methods::setValidity("FineMappingRow", function(object) { - errors <- character(0) - if (!is.null(object@cvResult) && !is.list(object@cvResult)) { - errors <- c(errors, "cvResult must be NULL or a list") - } + coll <- makeAssertCollection() + assertList( + object@cvResult, + null.ok = TRUE, + .var.name = "cvResult", + add = coll + ) + # mcols() is an S4 DataFrame, not a data.frame, so checkDataFrame does not + # apply; the row-count contract stays a plain check. md <- mcols(object@variants, use.names = FALSE) if (!is.null(md) && nrow(md) != length(object@variants)) { - errors <- c( - errors, - "variants' metadata columns must have one row per variant" - ) + coll$push("variants' metadata columns must have one row per variant") } - if (length(errors) == 0L) TRUE else errors + coll$getMessages() }) #' @title Build One Fine-Mapping Row @@ -89,7 +92,7 @@ methods::setValidity("FineMappingRow", function(object) { #' @export fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { vids <- as.character(variantIds) - gr <- .variantIdsToGRanges(vids, "variantIds") + bare <- .variantIdsToGRanges(vids, "variantIds") tl <- as_tibble(topLoci) missingCols <- setdiff(c("variant_id", "pip"), colnames(tl)) if (nrow(tl) > 0L && length(missingCols) > 0L) { @@ -99,9 +102,9 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { ) abort(msg) } - if (nrow(tl) != length(gr)) { + if (nrow(tl) != length(bare)) { msg <- glue( - "topLoci has {nrow(tl)} rows but {length(gr)} variants were ", + "topLoci has {nrow(tl)} rows but {length(bare)} variants were ", "supplied; they must be aligned row-for-row." ) abort(msg) @@ -109,9 +112,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (nrow(tl) > 0L && is_in("variant_id", names(tl))) { .fmRowCheckIdOrder(vids, as.character(tl$variant_id)) } - for (nm in setdiff(names(tl), .fmeIdentityCols)) { - mcols(gr)[[nm]] <- tl[[nm]] - } + gr <- .fmRowAttachPayload(bare, tl) obj <- new( "FineMappingRow", variants = gr, @@ -122,6 +123,27 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { obj } +# Attach topLoci's payload columns to the variant GRanges, keeping the +# identity columns `.variantIdsToGRanges()` already put in mcols. Replacing +# mcols wholesale would drop those, and the variant ids could no longer be +# rebuilt from the row. +# @noRd +.fmRowAttachPayload <- function(gr, tl) { + payload <- setdiff(names(tl), .fmeIdentityCols) + if (length(payload) == 0L) { + return(gr) + } + existing <- S4Vectors::mcols(gr) + kept <- existing[, setdiff(colnames(existing), payload), drop = FALSE] + `mcols<-`( + gr, + value = cbind( + kept, + S4Vectors::DataFrame(tl[payload], check.names = FALSE) + ) + ) +} + # topLoci's mcols are taken POSITIONALLY, so a table listing the same variants # in a different order would silently mis-assign every column. @@ -185,31 +207,6 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { !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)) { - # Defensive guard against an upstream fsusieR rename; only reachable - # if fsusieR drops this unexported S3 method. - msg <- glue( - "fsusieR's internal update_cal_credible_band.susiF not found; ", - "cannot compute the fSuSiE credible band (upstream fsusieR API ", - "changed)." - ) - abort(msg) - } - 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) { @@ -217,7 +214,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (is.null(vid) || length(vid) == 0L) { return(NA_character_) } - tryCatch(parseVariantId(vid[1])$chrom, error = function(e) NA_character_) + try_fetch(parseVariantId(vid[1])$chrom, error = function(cnd) NA_character_) } .emptyCredibleBand <- function() { @@ -239,14 +236,13 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { fit <- .fsusiePopulateCredibleBand(fit) grid <- as.numeric(fit$outing_grid) chrom <- .fsusieChrom(fit) - parts <- map( + parts <- compact(map( seq_along(fit$cred_band), .fsusieBandRow, fit = fit, chrom = chrom, grid = grid - ) - parts <- compact(parts) + )) if (length(parts) == 0L) { return(.emptyCredibleBand()) } @@ -261,10 +257,40 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # MEMBERSHIP (not by index), which is robust to pecotmr's CS # filtering/renumbering. # @noRd +# One fit effect's variant ids, resolving positional membership through the +# fit's own variant order. +# @noRd +.fsusieEffectVariants <- function(l, fit, vids) { + raw <- fit$cs[[l]] + fv <- if (is.numeric(raw)) vids[as.integer(raw)] else raw + as.character(fv) +} + +# @noRd +.fsusieSetMatches <- function(fv, kVars) { + length(fv) > 0L && setequal(fv, kVars) +} + +# The first fit effect whose membership equals label `lab`'s, or NA. +# @noRd +.fsusieFirstMatchingEffect <- function(lab, fitSets, topLoci) { + kVars <- as.character(topLoci$variant_id[topLoci$cs_95 == lab]) + hit <- which(map_lgl(fitSets, .fsusieSetMatches, kVars = kVars)) + if (length(hit) == 0L) { + return(NA_integer_) + } + hit[[1L]] +} + +# @noRd +.fsusieLabelPurity <- function(lab, topLoci) { + as.numeric(topLoci$cs_95_purity[topLoci$cs_95 == lab][1]) +} + .fsusieCsMapFromTopLoci <- function(fit, topLoci) { L <- length(fit$cs) - label <- set_names(str_c("fsusie_", seq_len(L)), seq_len(L)) - purity <- set_names(rep(NA_real_, L), seq_len(L)) + defaultLabel <- set_names(str_c("fsusie_", seq_len(L)), seq_len(L)) + defaultPurity <- set_names(rep(NA_real_, L), seq_len(L)) vids <- names(fit$csd_X) if ( is.null(topLoci) || @@ -274,63 +300,29 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { names(topLoci) )) ) { - return(list(label = label, purity = purity)) + return(list(label = defaultLabel, purity = defaultPurity)) } retained <- unique(topLoci$cs_95[!str_detect(topLoci$cs_95, "_0$")]) - 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_tibble(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 <- map_chr( - seq_len(nrow(reg)), - .fsusieRegionDirection, - grid = grid, - reg = reg, - fit = fit + fitSets <- map(seq_len(L), .fsusieEffectVariants, fit = fit, vids = vids) + # Each retained label claims the first effect whose membership it matches; + # labels are applied in order, so a later one wins a shared effect, which + # is what the repeated assignment did. + targets <- map_int( + retained, + .fsusieFirstMatchingEffect, + fitSets = fitSets, + topLoci = topLoci ) - GenomicRanges::GRanges( - seqnames = str_c("chr", str_remove(chrom, "^chr")), - 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 + matched <- !is.na(targets) + lastWins <- matched & !duplicated(targets, fromLast = TRUE) + at <- targets[lastWins] + label <- replace(defaultLabel, at, retained[lastWins]) + purity <- replace( + defaultPurity, + at, + map_dbl(retained[lastWins], .fsusieLabelPurity, topLoci = topLoci) ) + list(label = label, purity = purity) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- @@ -378,16 +370,26 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .fsusieEntryAffectedRegions <- function(i, x) { gr <- .fmrRowFsusieAffectedRegions(.fmrRowParts(x, i)) - if (length(gr) > 0L) { - S4Vectors::mcols(gr)$study <- as.character(x$study[[i]]) - if (is_in("context", .tupleColumnNames(x))) { - S4Vectors::mcols(gr)$context <- as.character(x$context[[i]]) - } - if (is_in("trait", .tupleColumnNames(x))) { - S4Vectors::mcols(gr)$trait <- as.character(x$trait[[i]]) - } - } - gr + if (length(gr) == 0L) { + return(gr) + } + cols <- .tupleColumnNames(x) + labels <- c( + list(study = as.character(x$study[[i]])), + compact(list( + context = if (is_in("context", cols)) { + as.character(x$context[[i]]) + }, + trait = if (is_in("trait", cols)) as.character(x$trait[[i]]) + )) + ) + S4Vectors::`mcols<-`( + gr, + value = cbind( + S4Vectors::mcols(gr, use.names = FALSE), + exec(S4Vectors::DataFrame, !!!labels) + ) + ) } @@ -421,8 +423,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { 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)] + lv <- keep(as.numeric(lbf[Lidx, ]), is.finite) if (length(lv) == 0L) { return(NA_real_) } @@ -445,7 +446,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (is.null(tl) || nrow(tl) == 0L) { return(.emptyCsSummary()) } - specs <- .csSummarySpecs(tl, fit, coverage, csCol, purCol) + specs <- .csSummarySpecs(tl, fit, coverage, csCol) if (length(specs) == 0L) { return(.emptyCsSummary()) } @@ -471,13 +472,13 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # membership. Falls back to enumerating the per-variant cs_ column (the # labelled members only) for a minimal or hand-built fit with no sets. # @noRd -.csSummarySpecs <- function(tl, fit, coverage, csCol, purCol) { +.csSummarySpecs <- function(tl, fit, coverage, csCol) { setsObj <- .csSetsForCoverage(fit, coverage) hasSets <- !is.null(setsObj) && !is.null(setsObj$cs) && length(setsObj$cs) > 0L if (hasSets) { - return(.csSpecsFromFit(setsObj, fit, tl, coverage, csCol)) + return(.csSpecsFromFit(setsObj, fit, tl, csCol)) } .csSpecsFromColumn(tl, csCol) } @@ -486,7 +487,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # variant ids through the alpha column names; the effect index comes from the # sets$cs "L" names. # @noRd -.csSpecsFromFit <- function(setsObj, fit, tl, coverage, csCol) { +.csSpecsFromFit <- function(setsObj, fit, tl, csCol) { vn <- colnames(fit$alpha) eff <- .fmEffectIndices(setsObj$cs) tag <- .csMethodTag(tl, fit, csCol) @@ -567,8 +568,8 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .csMethodTag <- function(tl, fit, csCol) { if (!is.null(tl) && is_in(csCol, names(tl))) { - v <- tl[[csCol]] - v <- v[!is.na(v) & str_length(v) > 0L & !str_detect(v, "_0$")] + raw <- tl[[csCol]] + v <- raw[!is.na(raw) & str_length(raw) > 0L & !str_detect(raw, "_0$")] if (length(v) > 0L) { return(str_remove(v[1L], "_[0-9]+$")) } @@ -581,13 +582,16 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .csSummaryContext <- function(tl, fit, coverage, csCol, purCol) { 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 <- set_names(as.numeric(sp[[mc[1L]]]), rownames(sp)) - } + mc <- if (is.null(sp)) { + character(0) + } else { + intersect(c("meanAbsCorr", "mean.abs.corr"), names(sp)) + } + meanPur <- if (length(mc) == 0L) { + NULL + } else { + set_names(as.numeric(sp[[mc[1L]]]), rownames(sp)) } list( tl = tl, @@ -668,21 +672,29 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # cs_log10bf: strongest member logBF (NA when the column is absent). # @noRd .csLog10Bf <- function(m) { - if (is_in("logBF", names(m))) { - suppressWarnings(max(m$logBF, na.rm = TRUE)) - } else { - NA_real_ + if (!is_in("logBF", names(m))) { + return(NA_real_) } + # Filtering first avoids max()'s empty-input warning entirely, and keeps + # this branch agreeing with the NA_real_ returned above: an empty or + # all-NA column previously yielded -Inf. + v <- m$logBF[is.finite(m$logBF)] + if (length(v) == 0L) NA_real_ else max(v) } # cs_mean_effect: mean conditional effect over the CS (NA when absent). # @noRd .csMeanEffect <- function(m) { - if (is_in("conditional_effect", names(m))) { - suppressWarnings(mean(as.numeric(m$conditional_effect), na.rm = TRUE)) - } else { - NA_real_ + if (!is_in("conditional_effect", names(m))) { + return(NA_real_) } + # suppressWarnings covers only the coercion; the empty case is handled + # explicitly so it returns NA_real_ rather than NaN. + v <- keep( + suppressWarnings(as.numeric(m$conditional_effect)), + is.finite + ) + if (length(v) == 0L) NA_real_ else mean(v) } @@ -693,13 +705,15 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (nrow(tl) == 0L) { return(tl) } - keep <- if (is.null(signalCutoff) || signalCutoff <= 0) { + aboveCutoff <- if (is.null(signalCutoff) || signalCutoff <= 0) { rep(TRUE, nrow(tl)) } else { !is.na(tl$pip) & tl$pip > signalCutoff } - if (!is.null(minPurity)) { - keep <- keep & .fmePurityKeep(tl, minPurity) + keep <- if (is.null(minPurity)) { + aboveCutoff + } else { + aboveCutoff & .fmePurityKeep(tl, minPurity) } .projectPosteriorView(tl[keep, , drop = FALSE]) } @@ -739,8 +753,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { seqnames = str_c("chr", parsed$chrom), ranges = IRanges::IRanges(start = parsed$pos, width = 1L) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(out) - gr + S4Vectors::`mcols<-`(gr, value = S4Vectors::DataFrame(out)) } @@ -771,17 +784,22 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { alpha <- .adjustPipsRenormAlpha(spec$alpha, cols) nKeep <- length(keepIdx) varAlpha <- alpha[, seq_len(nKeep), drop = FALSE] - fit$alpha <- alpha - fit$pip <- as.numeric(1 - apply(1 - varAlpha, 2L, prod)) - if (length(spec$nullIdx) > 0L) { - fit$null_index <- nKeep + 1L - } - # Recorded BEFORE renormalization: after it every row sums to 1, so the - # share that survived is only knowable at this point. This is the §3.6 - # diagnostic -- always reported, never a filter. - fit$retained_mass <- .adjustPipsRetainedMass(spec$alpha, cols) - fit <- .adjustPipsSubsetVariantSlots(fit, keepIdx, cols, nVariants) - .adjustPipsRebuildAllSets(fit, varAlpha) + subset <- list_assign( + fit, + !!!compact(list( + alpha = alpha, + pip = as.numeric(1 - apply(1 - varAlpha, 2L, prod)), + null_index = if (length(spec$nullIdx) > 0L) nKeep + 1L, + # Recorded BEFORE renormalization: after it every row sums to 1, + # so the share that survived is only knowable at this point. This + # is the §3.6 diagnostic -- always reported, never a filter. + retained_mass = .adjustPipsRetainedMass(spec$alpha, cols) + )) + ) + .adjustPipsRebuildAllSets( + .adjustPipsSubsetVariantSlots(subset, keepIdx, cols, nVariants), + varAlpha + ) } # susieInf / susieAsh carry Omega-weighted per-variant terms whose posterior @@ -903,24 +921,30 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .adjustPipsSubsetVariantSlots <- function(fit, keepIdx, cols, nVariants) { p <- list(keepIdx = keepIdx, cols = cols, nVariants = nVariants) - fit$lbf_variable <- .adjustPipsCols( - fit[["lbf_variable"]], - p, - "lbf_variable" - ) - fit$mu <- .adjustPipsCols(fit[["mu"]], p, "mu") - fit$mu2 <- .adjustPipsCols(fit[["mu2"]], p, "mu2") - fit$mu2_diag <- .adjustPipsCols(fit[["mu2_diag"]], p, "mu2_diag") - fit$clfsr <- .adjustPipsCols(fit[["clfsr"]], p, "clfsr") - fit$coef <- .adjustPipsRows(fit[["coef"]], p, "coef") - fit$X_column_scale_factors <- .adjustPipsVec( - fit[["X_column_scale_factors"]], - p, - "X_column_scale_factors" + # compact(): a slot the fit never carried subsets to NULL, and adding it + # back as an explicit NULL element is not the same as leaving it out. + list_assign( + fit, + !!!compact(list( + lbf_variable = .adjustPipsCols( + fit[["lbf_variable"]], + p, + "lbf_variable" + ), + mu = .adjustPipsCols(fit[["mu"]], p, "mu"), + mu2 = .adjustPipsCols(fit[["mu2"]], p, "mu2"), + mu2_diag = .adjustPipsCols(fit[["mu2_diag"]], p, "mu2_diag"), + clfsr = .adjustPipsCols(fit[["clfsr"]], p, "clfsr"), + coef = .adjustPipsRows(fit[["coef"]], p, "coef"), + X_column_scale_factors = .adjustPipsVec( + fit[["X_column_scale_factors"]], + p, + "X_column_scale_factors" + ), + XtXr = .adjustPipsVec(fit[["XtXr"]], p, "XtXr"), + pi = .adjustPipsVec(fit[["pi"]], p, "pi") + )) ) - fit$XtXr <- .adjustPipsVec(fit[["XtXr"]], p, "XtXr") - fit$pi <- .adjustPipsVec(fit[["pi"]], p, "pi") - fit } # Index set for a slot measured along its variant axis: `nVariants` selects the @@ -985,22 +1009,26 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # stale. # @noRd .adjustPipsRebuildAllSets <- function(fit, varAlpha) { - if (!is.null(fit[["sets"]])) { - fit$sets <- .adjustPipsCsAtCoverage( - varAlpha, - fit[["V"]], - .adjustPipsCoverage(fit[["sets"]]) - ) - } - if (!is.null(fit[["sets_secondary"]])) { - fit$sets_secondary <- map( - fit[["sets_secondary"]], - .adjustPipsRebuildSecondary, - varAlpha = varAlpha, - V = fit[["V"]] - ) - } - fit + list_assign( + fit, + !!!compact(list( + sets = if (!is.null(fit[["sets"]])) { + .adjustPipsCsAtCoverage( + varAlpha, + fit[["V"]], + .adjustPipsCoverage(fit[["sets"]]) + ) + }, + sets_secondary = if (!is.null(fit[["sets_secondary"]])) { + map( + fit[["sets_secondary"]], + .adjustPipsRebuildSecondary, + varAlpha = varAlpha, + V = fit[["V"]] + ) + } + )) + ) } # Rebuild one secondary-coverage credible-set table at its own coverage. @@ -1009,12 +1037,14 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (is.null(entry$sets)) { return(entry) } - entry$sets <- .adjustPipsCsAtCoverage( - varAlpha, - V, - .adjustPipsCoverage(entry$sets) + list_assign( + entry, + sets = .adjustPipsCsAtCoverage( + varAlpha, + V, + .adjustPipsCoverage(entry$sets) + ) ) - entry } # Requested coverage recorded on a susie_get_cs() result (0.95 when absent). @@ -1095,8 +1125,10 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (nrow(topLoci) == 0L) { return(topLoci) } - newTopLoci <- filter(topLoci, is_in(.data$variant_id, common)) - newTopLoci$pip <- as.numeric(fit[["pip"]]) + newTopLoci <- mutate( + filter(topLoci, is_in(.data$variant_id, common)), + pip = as.numeric(fit[["pip"]]) + ) .adjustPipsRelabelCs(.adjustPipsPosterior(newTopLoci, fit), fit) } @@ -1111,20 +1143,35 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { } varAlpha <- .adjustPipsVariantAlpha(fit) label <- .adjustPipsMethodLabel(tl) - for (csCol in csCols) { - tl[[csCol]] <- .adjustPipsCsLabels( - varAlpha, - fit[["V"]], - csCol, - label, - nrow(tl) - ) - purCol <- str_c(csCol, "_purity") - if (is_in(purCol, names(tl))) { - tl[[purCol]] <- NA_real_ - } - } - tl + relabelled <- set_names( + map( + csCols, + .adjustPipsRelabelColumn, + varAlpha = varAlpha, + fit = fit, + label = label, + nRow = nrow(tl) + ), + csCols + ) + # Purity no longer describes the recomputed sets, so every purity column + # that exists alongside a relabelled one is blanked. + purCols <- intersect(str_c(csCols, "_purity"), names(tl)) + blanked <- set_names( + map(purCols, .adjustPipsBlankPurity, nRow = nrow(tl)), + purCols + ) + mutate(tl, !!!relabelled, !!!blanked) +} + +# @noRd +.adjustPipsRelabelColumn <- function(csCol, varAlpha, fit, label, nRow) { + .adjustPipsCsLabels(varAlpha, fit[["V"]], csCol, label, nRow) +} + +# @noRd +.adjustPipsBlankPurity <- function(purCol, nRow) { + rep(NA_real_, nRow) } # Membership labels at the coverage encoded in the column name: "_" @@ -1133,11 +1180,28 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { .adjustPipsCsLabels <- function(varAlpha, V, csCol, label, n) { coverage <- as.numeric(str_remove(csCol, "^cs_")) / 100 sets <- .adjustPipsCsAtCoverage(varAlpha, V, coverage) - out <- rep(str_c(label, "_0"), n) - for (k in seq_along(sets$cs)) { - out[sets$cs[[k]]] <- str_c(label, "_", sets$cs_index[[k]]) - } - out + if (length(sets$cs) == 0L) { + return(rep(str_c(label, "_0"), n)) + } + # Later sets overwrite earlier ones at a shared variant, as the running + # assignment did; one scatter replaces the per-set writes. + at <- list_c(sets$cs) + names <- list_c(map( + seq_along(sets$cs), + .adjustPipsSetLabels, + sets = sets, + label = label + )) + replace(rep(str_c(label, "_0"), n), at, names) +} + +# One set's label, repeated across its members. +# @noRd +.adjustPipsSetLabels <- function(k, sets, label) { + rep( + str_c(label, "_", sets$cs_index[[k]]), + length(sets$cs[[k]]) + ) } # The method label topLoci uses to prefix credible-set names. @@ -1146,8 +1210,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (!is_in("method", names(tl))) { return("cs") } - labels <- unique(as.character(tl$method)) - labels <- labels[!is.na(labels)] + labels <- discard(unique(as.character(tl$method)), is.na) if (length(labels) == 0L) { return("cs") } @@ -1171,15 +1234,22 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { ) { return(newTopLoci) } - newTopLoci$posterior_mean <- as.numeric(colSums(alphaMat * muMat)) + posteriorMean <- as.numeric(colSums(alphaMat * muMat)) mu2Mat <- if (!is.null(fit[["mu2"]])) as.matrix(fit[["mu2"]]) else NULL - if (!is.null(mu2Mat) && all(dim(alphaMat) == dim(mu2Mat))) { - newTopLoci$posterior_sd <- as.numeric(sqrt(pmax( - colSums(alphaMat * mu2Mat) - newTopLoci$posterior_mean^2, - 0 - ))) - } - newTopLoci + mutate( + newTopLoci, + posterior_mean = posteriorMean, + !!!compact(list( + posterior_sd = if ( + !is.null(mu2Mat) && all(dim(alphaMat) == dim(mu2Mat)) + ) { + as.numeric(sqrt(pmax( + colSums(alphaMat * mu2Mat) - posteriorMean^2, + 0 + ))) + } + )) + ) } @@ -1233,10 +1303,13 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { pip = .tlCol(tl, "pip", "numeric"), logBF = .tlCol(tl, "logBF", "numeric") ) - for (cc in .projectPosteriorExtraCols(tl)) { - out[[cc]] <- tl[[cc]] - } - out + extras <- .projectPosteriorExtraCols(tl) + mutate(out, !!!set_names(map(extras, .tlColumnOf, tl = tl), extras)) +} + +# @noRd +.tlColumnOf <- function(cc, tl) { + tl[[cc]] } # Empty posterior-view frame (canonical columns, zero rows). @@ -1382,7 +1455,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { #' @rdname adjustPips #' @noRd -setMethod("adjustPips", "FineMappingRow", function(x, keepVariants, ...) { +setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { vids <- getVariantIds(x) keepIdx <- .adjustPipsKeepIdx(vids, keepVariants) common <- vids[keepIdx] @@ -1408,17 +1481,17 @@ setMethod("adjustPips", "FineMappingRow", function(x, keepVariants, ...) { #' @rdname getVariantIds #' @export -setMethod("getVariantIds", "FineMappingRow", function(x, ...) { +setMethod("getVariantIds", "FineMappingRow", function(x) { .grVariantIds(x@variants) }) #' @rdname getSusieFit #' @export -setMethod("getSusieFit", "FineMappingRow", function(x, ...) x@susieFit) +setMethod("getSusieFit", "FineMappingRow", function(x) x@susieFit) #' @rdname getCvResult #' @export -setMethod("getCvResult", "FineMappingRow", function(x, ...) x@cvResult) +setMethod("getCvResult", "FineMappingRow", function(x) x@cvResult) #' @rdname show-methods #' @export @@ -1427,7 +1500,7 @@ setMethod("show", "FineMappingRow", function(object) { nCs <- if (nrow(tl) > 0L) { csCols <- names(tl)[str_detect(names(tl), "^cs_[0-9]+$")] if (length(csCols) > 0L) { - length(unique(unlist(map(csCols, .fmeNonNullCsLabels, tl = tl)))) + length(unique(list_c(map(csCols, .fmeNonNullCsLabels, tl = tl)))) } else { 0L } @@ -1448,4 +1521,4 @@ setMethod("show", "FineMappingRow", function(object) { setGeneric("rowVariants", function(x, ...) standardGeneric("rowVariants")) # @noRd -setMethod("rowVariants", "FineMappingRow", function(x, ...) x@variants) +setMethod("rowVariants", "FineMappingRow", function(x) x@variants) diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 19cd4134c..a891179fe 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -60,14 +60,11 @@ lbfToAlphaVector <- function(lbf, priorWeights = NULL) { #' @export lbfToAlpha <- function(lbf) { alphaMatrix <- t(apply(as.matrix(lbf), 1, lbfToAlphaVector)) - if (ncol(lbf) == 1) { - alphaMatrix <- matrix( - alphaMatrix, - ncol = 1, - dimnames = list(NULL, colnames(lbf)) - ) + if (ncol(lbf) != 1) { + return(alphaMatrix) } - return(alphaMatrix) + # t() turns a single-column lbf into a row vector; restore the shape. + matrix(alphaMatrix, ncol = 1, dimnames = list(NULL, colnames(lbf))) } formatPipColumn <- function(method) { @@ -116,15 +113,22 @@ formatCsColumn <- function(coverage, method) { map_chr(coverage, .translateOneLegacyCsColumn) } +# The legacy per-method `pip_susie` column is the plain `pip` column unless +# the table already carries one. +# @noRd +.translateLegacyTopLociNames <- function(nms) { + translated <- .translateLegacyCsColumnName(nms) + if (is_in("pip", translated)) { + return(translated) + } + if_else(translated == "pip_susie", "pip", translated) +} + .translateLegacyTopLociCsColumns <- function(topLoci) { if (!is.data.frame(topLoci)) { return(topLoci) } - names(topLoci) <- .translateLegacyCsColumnName(names(topLoci)) - if (is_in("pip_susie", names(topLoci)) && !is_in("pip", names(topLoci))) { - names(topLoci)[names(topLoci) == "pip_susie"] <- "pip" - } - topLoci + `names<-`(topLoci, .translateLegacyTopLociNames(names(topLoci))) } # Translate a camelCase pecotmr method identifier (e.g. "susieInfRss") into the @@ -161,10 +165,10 @@ formatCsColumn <- function(coverage, method) { mvsusie = "mvsusie", NULL ) - if (!is.null(methodClass)) { - class(fit) <- unique(c(methodClass, class(fit))) + if (is.null(methodClass)) { + return(fit) } - fit + `class<-`(fit, unique(c(methodClass, class(fit)))) } # Build the argument list for a SuSiE / SuSiE-ash fit initialised from a @@ -178,62 +182,87 @@ prepareSusieFromInfArgs <- function( unmappableEffects = c("none", "ash") ) { unmappableEffects <- arg_match(unmappableEffects) - L <- args[["L"]] - if (is.null(L)) { - L <- length(susieInfFit$V) - } - if (is.null(args[["refine"]]) && !is.null(refineDefault)) { - args[["refine"]] <- refineDefault - } - args[["unmappable_effects"]] <- unmappableEffects - args[["model_init"]] <- susieInfFit - if (unmappableEffects == "ash") { - args[["convergence_method"]] <- args[["convergence_method"]] %||% "pip" - } - if (!is.null(args[["L_greedy"]])) { - args[["L_greedy"]] <- min(length(susieInfFit$V), L) - } - args + L <- args[["L"]] %||% length(susieInfFit$V) + list_assign( + args, + unmappable_effects = unmappableEffects, + model_init = susieInfFit, + !!!compact(list( + refine = if (is.null(args[["refine"]])) refineDefault, + convergence_method = if (unmappableEffects == "ash") { + args[["convergence_method"]] %||% "pip" + }, + # Clamped, not passed through raw: a caller's L_greedy above the + # number of inf effects would ask susie for effects it cannot warm- + # start. + L_greedy = if (!is.null(args[["L_greedy"]])) { + min(length(susieInfFit$V), L) + } + )) + ) +} + +# Merge one stage's overrides onto the shared defaults of a two-stage SuSiE +# chain. Either may arrive as a constructor result or as the empty list that +# means "no options", so each is taken down to a plain list first: list_modify +# works on lists, not on the S4 SimpleList a constructor returns. +# @noRd +.fmChainStageArgs <- function(shared, stage) { + list_modify(as.list(shared), !!!compact(as.list(stage))) +} + +# The three argument bundles of a two-stage chain, each checked against the +# engine it reaches. `susie` and `susieInf` forward to the same two susieR +# entry points, so all three accept the same names and SusieOptions() names them +# in the error whichever bundle was at fault. +# +# The bundles default to list() rather than to SusieOptions(): a formal cannot +# default to a call on its own name -- `SusieOptions = SusieOptions()` is a +# recursive default argument reference and errors when forced. An empty list +# already means "no options" to .assertMethodOptions, so nothing is lost but the +# self-documenting signature. +# @noRd +.fmAssertChainArgs <- function(args, SusieInfOptions, SusieOptions) { + .assertMethodOptions(args, "SusieOptions", "args") + .assertMethodOptions(SusieInfOptions, "SusieInfOptions", "SusieInfOptions") + .assertMethodOptions(SusieOptions, "SusieOptions", "SusieOptions") + invisible(NULL) } -#' @importFrom utils modifyList #' @noRd fitSusieInfThenSusie <- function( X, y, args = list(), - susieInfArgs = list(), - susieArgs = list(), + SusieInfOptions = list(), + SusieOptions = list(), fittedModels = NULL ) { + .fmAssertChainArgs(args, SusieInfOptions, SusieOptions) # Two-stage chain built from the shared per-token fitter (.fmFitSusieIndiv), # so the susieInf fit arguments and the susieInf -> susie initialisation # live in one place rather than being duplicated here and in the pipeline. - if (is.null(fittedModels)) { - fittedModels <- list() - } - susieInfFit <- fittedModels[["susieInf"]] - if (is.null(susieInfFit)) { - susieInfFit <- .fmFitSusieIndiv( + cached <- fittedModels %||% list() + susieInfFit <- if (is.null(cached[["susieInf"]])) { + .fmFitSusieIndiv( X, y, "susieInf", - userArgs = modifyList(args, susieInfArgs) + userArgs = .fmChainStageArgs(args, SusieInfOptions) ) } else { - susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") + .setFinemappingFitClass(cached[["susieInf"]], "susieInf") } - susieFit <- fittedModels[["susie"]] - if (is.null(susieFit)) { - susieFit <- .fmFitSusieIndiv( + susieFit <- if (is.null(cached[["susie"]])) { + .fmFitSusieIndiv( X, y, "susie", chainFromInf = susieInfFit, - userArgs = modifyList(args, susieArgs) + userArgs = .fmChainStageArgs(args, SusieOptions) ) } else { - susieFit <- .setFinemappingFitClass(susieFit, "susie") + .setFinemappingFitClass(cached[["susie"]], "susie") } list(susie = susieFit, susieInf = susieInfFit) } @@ -248,9 +277,13 @@ fitSusieInfThenSusie <- function( #' @param z Numeric vector of z-scores. #' @param R LD correlation matrix. #' @param n Sample size (scalar). -#' @param args Default arguments forwarded to both fits. -#' @param susieInfArgs SuSiE-inf-specific overrides. -#' @param susieArgs Standard SuSiE-RSS-specific overrides. +#' @param args Defaults forwarded to both fits, built with +#' \code{\link{SusieOptions}}. A bare list is refused, since it cannot be +#' checked; \code{list()} (the default) means no options. +#' @param SusieInfOptions SuSiE-inf-specific overrides, built with +#' \code{\link{SusieInfOptions}}; they take precedence over \code{args}. +#' @param SusieOptions Standard SuSiE-RSS-specific overrides, built with +#' \code{\link{SusieOptions}}; they take precedence over \code{args}. #' @param fittedModels Optional list with pre-fitted \code{$susie} and/or #' \code{$susieInf} objects to skip re-fitting. #' @return A list with \code{susie} and \code{susieInf} fit objects. @@ -269,46 +302,44 @@ fitSusieInfThenSusie <- function( #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) #' fitSusieInfThenSusieRss(z = stat$z, R = LD, n = nrow(X)) +#' @importFrom checkmate assertNumeric assertNumber assertList #' @export fitSusieInfThenSusieRss <- function( z, R, n, args = list(), - susieInfArgs = list(), - susieArgs = list(), + SusieInfOptions = list(), + SusieOptions = list(), fittedModels = NULL ) { + assertNumeric(z) + assertNumber(n, lower = 0, finite = TRUE) + .fmAssertChainArgs(args, SusieInfOptions, SusieOptions) + assertList(fittedModels, null.ok = TRUE) # RSS analog of fitSusieInfThenSusie, built from the shared per-token RSS # fitter (.fmFitSusieRss). .fmFitSusieRss tags every fit "susieRss", so the # inf fit is re-tagged "susieInf" to preserve this wrapper's contract. - if (is.null(fittedModels)) { - fittedModels <- list() - } - susieInfFit <- fittedModels[["susieInf"]] - if (is.null(susieInfFit)) { - susieInfFit <- .fmFitSusieRss( + cached <- fittedModels %||% list() + infRaw <- cached[["susieInf"]] %||% + .fmFitSusieRss( z, R, n, "susieInf", - userArgs = modifyList(args, susieInfArgs) + userArgs = .fmChainStageArgs(args, SusieInfOptions) ) - } - susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") - susieFit <- fittedModels[["susie"]] - if (is.null(susieFit)) { - susieFit <- .fmFitSusieRss( + susieInfFit <- .setFinemappingFitClass(infRaw, "susieInf") + susieRaw <- cached[["susie"]] %||% + .fmFitSusieRss( z, R, n, "susie", chainFromInf = susieInfFit, - userArgs = modifyList(args, susieArgs) + userArgs = .fmChainStageArgs(args, SusieOptions) ) - } - susieFit <- .setFinemappingFitClass(susieFit, "susieRss") - + susieFit <- .setFinemappingFitClass(susieRaw, "susieRss") list(susie = susieFit, susieInf = susieInfFit) } @@ -329,28 +360,30 @@ fitSusieInfThenSusieRss <- function( #' MAF). Default NULL. #' @param n Optional per-variant sample size, exported as the \code{N} column. #' Default NULL -> \code{N} falls back to the fit's own scalar sample size. -#' @param coverage Primary credible-set coverage. -#' @param secondaryCoverage Additional credible-set coverages. -#' @param signalCutoff PIP cutoff for including non-CS variants in top loci. -#' @param otherQuantities Optional list carried into each method result. -#' @param priorEffTol Tolerance for retaining effects by prior variance. -#' @param minAbsCorr Minimum absolute correlation for credible-set purity. -#' @param region Optional genomic anchor (\code{"chr:start-end"} or -#' \code{GRanges}) recorded on the result; \code{NULL} to omit. -#' @param medianAbsCorr Numeric or \code{NULL}. Median absolute within-CS -#' correlation threshold for purity; \code{NULL} uses only \code{minAbsCorr}. -#' @param csInput Optional precomputed credible-set specification, or -#' \code{NULL} to derive it from the fits. -#' @param conditionIdx Integer or \code{NULL}. Index of the conditioned effect -#' (per-condition output); \code{NULL} for the unconditioned fit. -#' @param trim Logical. Trim the retained fit to the fields needed downstream. -#' Default \code{TRUE}. -#' @param fullFit Logical. Retain the full fit object on each entry. Default -#' \code{FALSE}. -#' @param fullFitAlphaOnly Logical. When retaining the full fit, keep only the -#' per-effect alpha matrix. Default \code{TRUE}. -#' @param includeAllCs Logical. Include all credible sets rather than only the -#' top one. Default \code{FALSE}. +#' @param credibleSetArgs How credible sets are built and reported, built with +#' \code{\link{CredibleSetParam}}: \code{coverage}, +#' \code{secondaryCoverage}, \code{signalCutoff} (the PIP cutoff for +#' including non-credible-set variants in top loci), \code{minAbsCorr} and +#' \code{medianAbsCorr} for purity, and \code{includeAllCs}. +#' @param fitRetention How much of each fit is kept: \code{"slim"} (default) +#' trims the retained fit to what downstream needs, \code{"full"} keeps the +#' whole fit object. The \code{topLoci} table's per-credible-set columns +#' are governed by \code{credibleSet}'s \code{perCsColumns} instead. +#' @param otherQuantities Optional named list of extra per-method quantities to +#' carry on the result untouched (returned as the \code{otherQuantities} +#' element). Default \code{NULL}. +#' @param region Optional \code{"chr:start-end"} string naming the region the +#' fits cover; recorded on the result. Default \code{NULL}. +#' @param priorEffTol Numeric (length 1). Effects whose prior variance +#' \code{V} is at or below this tolerance are dropped as unconverged before +#' the credible sets are read. Default \code{1e-9}. +#' @param csInput One of \code{"X"}, \code{"Xcorr"}, \code{"fsusie"}: how +#' credible-set purity is computed from \code{dataX}. \code{NULL} (default) +#' lets each method pick its own -- \code{"Xcorr"} for the RSS methods, +#' \code{"fsusie"} for fsusie, \code{"X"} otherwise. +#' @param conditionIdx Integer or \code{NULL}. For a multi-condition +#' (3-D) fit, the condition to slice out; \code{NULL} (default) keeps the +#' unconditioned fit. #' @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 @@ -371,22 +404,14 @@ postprocessFinemappingFits <- function( yScalar = 1, af = NULL, n = NULL, - coverage = NULL, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.1, + credibleSetArgs = CredibleSetParam(), + fitRetention = "slim", otherQuantities = NULL, region = NULL, priorEffTol = 1e-9, - minAbsCorr = 0.8, - medianAbsCorr = NULL, csInput = NULL, - conditionIdx = NULL, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE + conditionIdx = NULL ) { - p <- as.list(environment()) fits <- fits[!map_lgl(fits, is.null)] if (length(fits) == 0) { abort("At least one fine-mapping fit must be supplied.") @@ -394,22 +419,67 @@ postprocessFinemappingFits <- function( if (is.null(names(fits)) || any(names(fits) == "")) { abort("fits must be a named list; names define method identity.") } - .ppFitsCombine(.ppFitsPerMethod(fits, p)) + .ppFitsCombine(.ppFitsPerMethod( + fits, + dataX = dataX, + dataY = dataY, + xScalar = xScalar, + yScalar = yScalar, + af = af, + n = n, + credibleSetArgs = credibleSetArgs, + fitRetention = fitRetention, + otherQuantities = otherQuantities, + region = region, + priorEffTol = priorEffTol, + csInput = csInput, + conditionIdx = conditionIdx + )) } # Post-process each method's fit once (buildTopLoci per fit); the per-method # 22-column contributions are row-bound later into the single top_loci table. -.ppFitsPerMethod <- function(fits, p) { - posts <- map(names(fits), .ppOneFit, fits = fits, p = p) - names(posts) <- names(fits) - posts +.ppFitsPerMethod <- function( + fits, + dataX, + dataY, + xScalar, + yScalar, + af, + n, + credibleSetArgs, + fitRetention, + otherQuantities, + region, + priorEffTol, + csInput, + conditionIdx +) { + posts <- map( + names(fits), + .ppOneFit, + fits = fits, + dataX = dataX, + dataY = dataY, + xScalar = xScalar, + yScalar = yScalar, + af = af, + n = n, + credibleSetArgs = credibleSetArgs, + fitRetention = fitRetention, + otherQuantities = otherQuantities, + region = region, + priorEffTol = priorEffTol, + csInput = csInput, + conditionIdx = conditionIdx + ) + set_names(posts, names(fits)) } # Row-bind the per-method top_loci tables and drop them from the per-method # entries; returns the final finemappingResults + combined top_loci. .ppFitsCombine <- function(posts) { - perMethod <- map(posts, "top_loci") - perMethod <- perMethod[!map_lgl(perMethod, is.null)] + perMethod <- compact(map(posts, "top_loci")) topLoci <- if (length(perMethod) == 0L) { .emptyTopLoci() } else { @@ -522,134 +592,267 @@ postprocessFinemappingFit.susiF <- function( yScalar = 1, af = NULL, n = NULL, - coverage = NULL, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.1, + credibleSetArgs = CredibleSetParam(), + fitRetention = "slim", otherQuantities = NULL, region = NULL, priorEffTol = 1e-9, - trim = TRUE, - minAbsCorr = 0.8, - medianAbsCorr = NULL, conditionIdx = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, csInput = c("X", "Xcorr", "fsusie") ) { csInput <- arg_match(csInput) - p <- as.list(environment()) + # "slim" keeps a trimmed view of the fit; "full" the whole susie() + # return, so getSusieFit() and non-default-coverage getCs() can read + # the full posterior matrices. + trim <- identical(arg_match(fitRetention, c("slim", "full")), "slim") variantNames <- extractVariantNames(fit) - sumstats <- extractSumstats(fit, dataX, dataY, xScalar, yScalar, method) - csTables <- .ppCsTables(p, csInput) - # Always build the canonical unfiltered table; the FineMappingRow stores - # it as-is so accessors can filter by PIP at query time. - topLociFull <- .ppTopLoci(p, csTables, variantNames, sumstats) + sumstats <- extractSumstats(dataX, dataY, xScalar, yScalar, method) + csTables <- .ppCsTables( + csInput, + fit = fit, + dataX = dataX, + credibleSetArgs = credibleSetArgs, + method = method + ) + .ppFinish( + csTables, + variantNames, + sumstats, + fit = fit, + method = method, + af = af, + n = n, + dataY = dataY, + otherQuantities = otherQuantities, + region = region, + conditionIdx = conditionIdx, + credibleSetArgs = credibleSetArgs, + trim = trim, + priorEffTol = priorEffTol + ) +} + +# Build the canonical top-loci table and wrap it into the postprocess +# result. The table is always built unfiltered -- the FineMappingRow stores +# it as-is so accessors can filter by PIP at query time -- which is why +# `signalCutoff` is read here for the RESULT only, not for the table. +# @noRd +.ppFinish <- function( + csTables, + variantNames, + sumstats, + fit, + method, + af, + n, + dataY, + otherQuantities, + region, + conditionIdx, + credibleSetArgs, + trim, + priorEffTol +) { + topLociFull <- .ppTopLoci( + csTables, + variantNames, + sumstats, + fit = fit, + method = method, + af = af, + n = n, + dataY = dataY, + otherQuantities = otherQuantities, + region = region, + conditionIdx = conditionIdx, + credibleSetArgs = credibleSetArgs + ) + .ppEntryAndResult( + topLociFull, + csTables, + variantNames, + sumstats, + fit = fit, + method = method, + dataY = dataY, + otherQuantities = otherQuantities, + signalCutoff = credibleSetArgs$signalCutoff, + trim = trim, + priorEffTol = priorEffTol + ) +} + +# Wrap the finished tables into a FineMappingRow and the postprocess result +# around it. The stored fit is built here rather than earlier because `trim` +# decides how much of it survives, and nothing above this point reads it. +# @noRd +.ppEntryAndResult <- function( + topLociFull, + csTables, + variantNames, + sumstats, + fit, + method, + dataY, + otherQuantities, + signalCutoff, + trim, + priorEffTol +) { fmEntry <- fineMappingRow( variantIds = variantNames, - susieFit = .ppStoredFit(p, csTables), + susieFit = .ppStoredFit( + csTables, + fit = fit, + trim = trim, + priorEffTol = priorEffTol, + method = method + ), topLoci = topLociFull ) - .ppAssembleRes(p, topLociFull, fmEntry, sumstats) + .ppAssembleRes( + topLociFull, + fmEntry, + sumstats, + fit = fit, + method = method, + dataY = dataY, + otherQuantities = otherQuantities, + signalCutoff = signalCutoff + ) } # The fit as stored: trim = TRUE keeps a minimal subset, FALSE the full # untrimmed susie return (mu / mu2 / lbf_variable / V / ...). # @noRd -.ppStoredFit <- function(p, csTables) { - if (!isTRUE(p$trim)) { - return(p$fit) +.ppStoredFit <- function( + csTables, + fit, + trim, + priorEffTol, + method +) { + if (!isTRUE(trim)) { + return(fit) } trimFinemappingFit( - p$fit, - selectEffects(p$fit, p$priorEffTol), - p$method, + fit, + selectEffects(fit, priorEffTol), + method, csTables ) } # Credible-set tables for the fit at the requested coverages. -.ppCsTables <- function(p, csInput) { +.ppCsTables <- function( + csInput, + fit, + dataX, + credibleSetArgs, + method +) { computeCsTables( - p$fit, - dataX = p$dataX, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - method = p$method, + fit, + dataX = dataX, + coverage = credibleSetArgs$coverage, + secondaryCoverage = credibleSetArgs$secondaryCoverage, + method = method, csInput = csInput, - minAbsCorr = p$minAbsCorr, - medianAbsCorr = p$medianAbsCorr + minAbsCorr = credibleSetArgs$minAbsCorr, + medianAbsCorr = credibleSetArgs$medianAbsCorr ) } # Canonical unfiltered top-loci table (signalCutoff = 0). -.ppTopLoci <- function(p, csTables, variantNames, sumstats) { +.ppTopLoci <- function( + csTables, + variantNames, + sumstats, + fit, + method, + af, + n, + dataY, + otherQuantities, + region, + conditionIdx, + credibleSetArgs +) { buildTopLoci( - p$fit, + fit, csTables, variantNames = variantNames, sumstats = sumstats, - af = p$af, - n = p$n, - method = p$method, + af = af, + n = n, + method = method, signalCutoff = 0, - dataY = p$dataY, - otherQuantities = p$otherQuantities, - region = p$region, - conditionIdx = p$conditionIdx, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + dataY = dataY, + otherQuantities = otherQuantities, + region = region, + conditionIdx = conditionIdx, + credibleSetArgs = credibleSetArgs ) } # Assemble the wrapper-facing result: PIP-filtered top_loci (legacy behaviour # for non-S4 callers) + the entry + optional sumstats/sampleNames/context. -.ppAssembleRes <- function(p, topLociFull, fmEntry, sumstats) { - topLociWrapper <- topLociFull - if ( - !is.null(p$signalCutoff) && - p$signalCutoff > 0 && - nrow(topLociWrapper) > 0L - ) { - keep <- !is.na(topLociWrapper$pip) & - topLociWrapper$pip > p$signalCutoff - topLociWrapper <- topLociWrapper[keep, , drop = FALSE] +.ppAssembleRes <- function( + topLociFull, + fmEntry, + sumstats, + fit, + method, + dataY, + otherQuantities, + signalCutoff +) { + filtering <- !is.null(signalCutoff) && + signalCutoff > 0 && + nrow(topLociFull) > 0L + topLociWrapper <- if (!filtering) { + topLociFull + } else { + topLociFull[ + !is.na(topLociFull$pip) & topLociFull$pip > signalCutoff, + , + drop = FALSE + ] } - res <- list( - top_loci = topLociWrapper, - finemappingEntry = fmEntry, - method = p$method + c( + list( + top_loci = topLociWrapper, + finemappingEntry = fmEntry, + method = method + ), + compact(list( + sumstats = sumstats, + sampleNames = .sampleNamesFromDataY(dataY), + contextNames = if (method == "mvsusie") fit$outcome_names, + otherQuantities = otherQuantities + )) ) - if (!is.null(sumstats)) { - res$sumstats <- sumstats - } - sampleNames <- .sampleNamesFromDataY(p$dataY) - if (!is.null(sampleNames)) { - res$sampleNames <- sampleNames - } - if (p$method == "mvsusie" && !is.null(p$fit$outcome_names)) { - res$contextNames <- p$fit$outcome_names - } - if (!is.null(p$otherQuantities)) { - res$otherQuantities <- p$otherQuantities - } - res } extractVariantNames <- function(fit) { - variantNames <- names(fit$pip) - if (is.null(variantNames)) { - variantNames <- colnames(fit$alpha) - } - if (is.null(variantNames)) { - variantNames <- str_c("variant_", seq_along(fit$pip)) - } - tryCatch(normalizeVariantId(variantNames), error = function(e) variantNames) + variantNames <- names(fit$pip) %||% + colnames(fit$alpha) %||% + str_c("variant_", seq_along(fit$pip)) + try_fetch( + normalizeVariantId(variantNames), + error = function(cnd) { + msg <- glue( + "variant ids could not be normalised; using them as given. ", + "Downstream joins that assume the canonical form may not ", + "match." + ) + warn(msg, parent = cnd) + variantNames + } + ) } extractSumstats <- function( - fit, dataX, dataY, xScalar = 1, @@ -678,9 +881,12 @@ extractSumstats <- function( sumstats <- univariate_regression(dataX, dataY) yScalar <- if (is.null(yScalar) || all(yScalar == 1)) 1 else yScalar xScalar <- if (is.null(xScalar) || all(xScalar == 1)) 1 else xScalar - sumstats$betahat <- sumstats$betahat * yScalar / xScalar - sumstats$sebetahat <- sumstats$sebetahat * yScalar / xScalar - sumstats + scale <- yScalar / xScalar + list_assign( + sumstats, + betahat = sumstats$betahat * scale, + sebetahat = sumstats$sebetahat * scale + ) } .sampleNamesFromDataY <- function(dataY) { @@ -761,15 +967,11 @@ computeCsTables <- function( medianAbsCorr = NULL ) { csInput <- arg_match(csInput) - primaryCoverage <- coverage - if (is.null(primaryCoverage)) { - primaryCoverage <- fit$sets$requested_coverage - } - if (is.null(primaryCoverage)) { - primaryCoverage <- 0.95 - } - coverages <- unique(c(primaryCoverage, secondaryCoverage)) - coverages <- coverages[!is.na(coverages)] + primaryCoverage <- coverage %||% fit$sets$requested_coverage %||% 0.95 + coverages <- discard( + unique(c(primaryCoverage, secondaryCoverage)), + is.na + ) tables <- map( coverages, @@ -780,13 +982,11 @@ computeCsTables <- function( minAbsCorr = minAbsCorr, medianAbsCorr = medianAbsCorr ) - names(tables) <- map_chr( - coverages, - formatCsColumn, - method = method + named <- set_names( + tables, + map_chr(coverages, formatCsColumn, method = method) ) - attr(tables, "coverage") <- coverages - tables + `attr<-`(named, "coverage", coverages) } computeCsTable <- function( @@ -804,32 +1004,43 @@ computeCsTable <- function( .csTableSusie(fit, dataX, coverage, csInput, minAbsCorr, medianAbsCorr) } +# The credible sets with the within-CS purity attached, when fsusieR is +# available and returns one purity value per set. +# @noRd +.fsusieSetsWithPurity <- function(sets, dataX) { + if (!requireNamespace("fsusieR", quietly = TRUE)) { + return(sets) + } + purity <- try_fetch( + # cal_purity returns one length-1 numeric per credible set, so + # list_c() is exactly equivalent and refuses a non-numeric or + # non-scalar element instead of silently producing a longer + # vector that the length check below would then reject. + as.numeric(list_c(fsusieR::cal_purity(sets$cs, dataX))), + error = function(cnd) NULL + ) + if (is.null(purity) || length(purity) != length(sets$cs)) { + return(sets) + } + list_assign(sets, purity = tibble(min.abs.corr = purity)) +} + # fSuSiE credible sets: purity is the min |correlation| WITHIN each CS # (fsusieR::cal_purity), recorded as sets$purity$min.abs.corr for the canonical # .csPurityVec() reader; cs_corr keeps the BETWEEN-CS correlation matrix. .csTableFsusie <- function(fit, dataX, coverage) { - sets <- tryCatch( + sets <- try_fetch( fsusieGetCs(fit, dataX, requestedCoverage = coverage), - error = function(e) list(cs = list(), requested_coverage = coverage) + error = function(cnd) list(cs = list(), requested_coverage = coverage) ) if ( is.null(sets$cs) || length(sets$cs) == 0 || all(map_lgl(sets$cs, is.null)) ) { - sets$cs <- list() - return(list(sets = sets, pip = fit$pip)) + return(list(sets = list_assign(sets, cs = list()), pip = fit$pip)) } - if (requireNamespace("fsusieR", quietly = TRUE)) { - 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 <- tibble(min.abs.corr = purity) - } - } - list(sets = sets, pip = fit$pip) + list(sets = .fsusieSetsWithPurity(sets, dataX), pip = fit$pip) } # susieR credible sets from X (correlation computed on genotypes) or Xcorr @@ -842,13 +1053,13 @@ computeCsTable <- function( minAbsCorr, medianAbsCorr ) { - csArgs <- list(coverage = coverage) - if (!is.null(minAbsCorr)) { - csArgs$min_abs_corr <- minAbsCorr - } - if (!is.null(medianAbsCorr)) { - csArgs$median_abs_corr <- medianAbsCorr - } + csArgs <- c( + list(coverage = coverage), + compact(list( + min_abs_corr = minAbsCorr, + median_abs_corr = medianAbsCorr + )) + ) # X vs Xcorr only changes how susie_get_cs computes purity; the between-CS # correlation is derived on demand later by computeCsCorrelation(), so it is # no longer stored on the fit. @@ -904,7 +1115,7 @@ computeCsTable <- function( setMethod( "computeCsCorrelation", signature(x = "FineMappingResultBase", ldSource = "SumStatsBase"), - function(x, ldSource, ...) { + function(x, ldSource) { .rowCsCorrelationSumstats(.asFmRowPayload(x), ldSource) } ) @@ -941,7 +1152,7 @@ setMethod( setMethod( "computeCsCorrelation", signature(x = "FineMappingResultBase", ldSource = "QtlDataset"), - function(x, ldSource, ...) { + function(x, ldSource) { .rowCsCorrelationGeno(.asFmRowPayload(x), ldSource) } ) @@ -968,26 +1179,14 @@ setMethod( } } -#' @rdname computeCsCorrelation -setMethod( - "computeCsCorrelation", - signature(x = "FineMappingResultBase", ldSource = "ANY"), - function(x, ldSource, ...) { - abort(glue( - "computeCsCorrelation() requires a QtlDataset, QtlSumStats, or ", - "GwasSumStats as `ldSource`: the between-credible-set correlation ", - "is derived from that object's LD and is never stored on the fit." - )) - } -) - # 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 / +# perCsColumns = "full" -- `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). @@ -1003,10 +1202,9 @@ setMethod( scale, primaryCsPos, effectOf, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE + credibleSetArgs = CredibleSetParam(includeAllCs = FALSE) ) { + perCs <- credibleSetArgs$perCsColumns %||% "none" nV <- if (is.null(alpha) || length(dim(alpha)) < 2L) { length(primaryCsPos) } else { @@ -1015,7 +1213,7 @@ setMethod( hasAlpha <- !is.null(alpha) && length(dim(alpha)) == 2L && nrow(alpha) > 0L withinPip <- .ffcWithinPip(alpha, primaryCsPos, effectOf, nV, hasAlpha) cols <- tibble(within_cs_pip = withinPip) - if (!isTRUE(fullFit) || !hasAlpha) { + if (identical(perCs, "none") || !hasAlpha) { return(cols) } .ffcWideColumns( @@ -1027,31 +1225,34 @@ setMethod( scale, effectOf, nV, - fullFitAlphaOnly, - includeAllCs + identical(perCs, "alpha"), + credibleSetArgs$includeAllCs ) } # Per-variant PIP within its primary-coverage credible set (NA outside any CS). .ffcWithinPip <- function(alpha, primaryCsPos, effectOf, nV, hasAlpha) { - withinPip <- rep(NA_real_, nV) if (!(hasAlpha && length(primaryCsPos) == nV && length(effectOf) > 0L)) { - return(withinPip) - } - 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] - } - } + return(rep(NA_real_, nV)) + } + # Indexing with NA yields NA, so an out-of-range credible-set position + # drops out on its own rather than needing a per-variant branch. + csOk <- !is.na(primaryCsPos) & + primaryCsPos >= 1L & + primaryCsPos <= length(effectOf) + effect <- effectOf[if_else(csOk, as.integer(primaryCsPos), NA_integer_)] + effectOk <- !is.na(effect) & effect >= 1L & effect <= nrow(alpha) + if (!any(effectOk)) { + return(rep(NA_real_, nV)) } - withinPip + # Row 1 stands in wherever the effect is unusable; those entries are + # masked back to NA immediately, and it keeps the index in bounds. + picked <- alpha[cbind(if_else(effectOk, effect, 1L), seq_len(nV))] + if_else(effectOk, picked, NA_real_) } # Wide per-effect columns: within_cs_pip_ always, plus cs_logbf / cs_effect -# / cs_effect_var when fullFitAlphaOnly is FALSE. Effects come from every effect +# / cs_effect_var when perCsColumns is "full". Effects come from every effect # (includeAllCs) or only the credible-set effects. .ffcWideColumns <- function( cols, @@ -1062,7 +1263,7 @@ setMethod( scale, effectOf, nV, - fullFitAlphaOnly, + alphaOnly, includeAllCs ) { if (isTRUE(includeAllCs)) { @@ -1078,24 +1279,72 @@ setMethod( if (is.null(scale) || length(scale) != nV) { scale <- rep(1, nV) } - for (i in seq_along(effs)) { - L <- effs[[i]] - lab <- labs[[i]] - cols[[str_c("within_cs_pip_", lab)]] <- unname(alpha[L, ]) - if (!isTRUE(fullFitAlphaOnly)) { - if (!is.null(lbfMat) && L <= nrow(lbfMat)) { - cols[[str_c("cs_logbf_", lab)]] <- unname(lbfMat[L, ]) - } - if (!is.null(mu) && L <= nrow(mu)) { - cols[[str_c("cs_effect_", lab)]] <- unname(mu[L, ] / scale) - } - if (!is.null(mu) && !is.null(mu2) && L <= nrow(mu2)) { - cols[[str_c("cs_effect_var_", lab)]] <- - unname((mu2[L, ] - mu[L, ]^2) / scale^2) - } - } + perEffect <- map( + seq_along(effs), + .ffcEffectColumns, + effs = effs, + labs = labs, + alpha = alpha, + mu = mu, + mu2 = mu2, + lbfMat = lbfMat, + scale = scale, + alphaOnly = alphaOnly + ) + mutate(cols, !!!.fmwConcat(perEffect)) +} + +# Concatenate per-item lists, empty-safe. +# @noRd +.fmwConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# One effect's wide columns: the within-CS PIP always, plus the log-BF and +# effect columns when the fit carries them. +# @noRd +.ffcEffectColumns <- function( + i, + effs, + labs, + alpha, + mu, + mu2, + lbfMat, + scale, + alphaOnly +) { + L <- effs[[i]] + lab <- labs[[i]] + pip <- set_names( + list(unname(alpha[L, ])), + str_c("within_cs_pip_", lab) + ) + if (isTRUE(alphaOnly)) { + return(pip) + } + logbf <- if (!is.null(lbfMat) && L <= nrow(lbfMat)) { + set_names(list(unname(lbfMat[L, ])), str_c("cs_logbf_", lab)) + } else { + list() + } + effect <- if (!is.null(mu) && L <= nrow(mu)) { + set_names(list(unname(mu[L, ] / scale)), str_c("cs_effect_", lab)) + } else { + list() } - cols + effectVar <- if (!is.null(mu) && !is.null(mu2) && L <= nrow(mu2)) { + set_names( + list(unname((mu2[L, ] - mu[L, ]^2) / scale^2)), + str_c("cs_effect_var_", lab) + ) + } else { + list() + } + c(pip, logbf, effect, effectVar) } # Slice a susie posterior array to the active condition (3-D fit) or coerce a @@ -1124,37 +1373,64 @@ setMethod( nV, variantNames = NULL ) { - out <- integer(nV) + empty <- integer(nV) hit <- which(abs(coverageValues - targetCov) < 1e-12) if (length(hit) == 0L) { - return(out) + return(empty) } sets <- csTables[[hit[1L]]]$sets$cs if (is.null(sets) || length(sets) == 0L) { - return(out) + return(empty) } # A variant in several sets goes to the SMALLEST containing set (ties -> # lowest position, so the answer is deterministic), not to whichever set # happened to come first in the list. Every membership is recorded so the # ambiguity can be reported rather than silently resolved. + # Every (variant, set) membership, flattened. Ordering the memberships by + # set size then set index makes the first one per variant the winner -- + # smallest set, ties to the lowest position -- which is exactly what the + # running "is this smaller than the best so far" comparison decided. setSizes <- lengths(sets) - bestSize <- rep(Inf, nV) - memb <- vector("list", nV) - for (csIdx in seq_along(sets)) { - vi <- as.integer(sets[[csIdx]]) - vi <- vi[vi >= 1L & vi <= nV] - for (v in vi) { - memb[[v]] <- c(memb[[v]], csIdx) - if (setSizes[csIdx] < bestSize[v]) { - out[v] <- csIdx - bestSize[v] <- setSizes[csIdx] - } - } - } + memberships <- map(seq_along(sets), .fmCsMemberships, sets = sets, nV = nV) + variantOf <- .fmwConcatInt(map(memberships, "variant")) + csOf <- .fmwConcatInt(map(memberships, "cs")) + if (length(variantOf) == 0L) { + return(empty) + } + ord <- order(variantOf, setSizes[csOf], csOf) + firstPerVariant <- ord[!duplicated(variantOf[ord])] + winners <- csOf[firstPerVariant] + winnerAt <- variantOf[firstPerVariant] + out <- .fmScatter(empty, winnerAt, winners) + bestSize <- .fmScatter(rep(Inf, nV), winnerAt, setSizes[winners]) + memb <- split(csOf, factor(variantOf, levels = seq_len(nV))) .fmWarnMultiCs(memb, out, bestSize, sets, variantNames) out } +# Place `values` at positions `at` in `base`. The one write the scatter needs, +# named so it reads as a total operation rather than an accumulation. +# @noRd +.fmScatter <- function(base, at, values) { + replace(base, at, values) +} + +# @noRd +.fmwConcatInt <- function(pieces) { + if (length(pieces) == 0L) { + return(integer(0)) + } + list_c(pieces) +} + +# Set `csIdx`'s in-range variant memberships, as parallel (variant, cs) runs. +# @noRd +.fmCsMemberships <- function(csIdx, sets, nV) { + raw <- as.integer(sets[[csIdx]]) + vi <- raw[raw >= 1L & raw <= nV] + list(variant = vi, cs = rep(csIdx, length(vi))) +} + # Name the variants that fell in more than one credible set, and which set won. # @noRd .fmWarnMultiCs <- function(memb, out, bestSize, sets, variantNames) { @@ -1187,10 +1463,10 @@ setMethod( } e <- suppressWarnings(as.integer(str_remove(nm, "^L"))) bad <- is.na(e) - if (any(bad)) { - e[bad] <- seq_along(sets)[bad] + if (!any(bad)) { + return(e) } - e + replace(e, bad, seq_along(sets)[bad]) } # Map a per-variant set-POSITION vector onto the fit's true effect indices; @@ -1211,10 +1487,8 @@ setMethod( return(posVec) } effIdx <- .fmEffectIndices(sets) - out <- integer(length(posVec)) nz <- posVec > 0L - out[nz] <- effIdx[posVec[nz]] - out + replace(integer(length(posVec)), nz, effIdx[posVec[nz]]) } # Per-variant CS purity (min.abs.corr) at coverage `targetCov`; 0 for non-CS @@ -1277,12 +1551,10 @@ setMethod( #' @param region Optional \code{"chr:start-end"} string. Default is NULL. #' @param conditionIdx Integer or \code{NULL}. Index of the conditioned effect #' (per-condition output); \code{NULL} for the unconditioned fit. -#' @param fullFit Logical. Retain the full fit object on each entry. Default -#' \code{FALSE}. -#' @param fullFitAlphaOnly Logical. When retaining the full fit, keep only the -#' per-effect alpha matrix. Default \code{TRUE}. -#' @param includeAllCs Logical. Include all credible sets rather than only the -#' top one. Default \code{FALSE}. +#' @param credibleSetArgs How credible sets are built and reported, built with +#' \code{\link{CredibleSetParam}}. \code{perCsColumns} decides which +#' per-credible-set variant-level columns this table carries, and +#' \code{includeAllCs} their labels. #' @return A data frame in the fixed 22-column shape for this fit and method, or #' an empty data frame if nothing is retained. #' @examples @@ -1307,86 +1579,153 @@ buildTopLoci <- function( otherQuantities = NULL, region = NULL, conditionIdx = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE + credibleSetArgs = CredibleSetParam(includeAllCs = FALSE) ) { if (missing(method)) { method <- NULL } - p <- as.list(environment()) .btlValidateMethod(method) if (length(variantNames) == 0L) { return(.emptyTopLoci()) } - .btlBuild(p) + .btlBuild( + fit = fit, + csTables = csTables, + variantNames = variantNames, + sumstats = sumstats, + af = af, + n = n, + method = method, + signalCutoff = signalCutoff, + dataY = dataY, + otherQuantities = otherQuantities, + region = region, + conditionIdx = conditionIdx, + credibleSetArgs = credibleSetArgs + ) } -# Orchestrate the top-loci table from the captured argument list `p`. -.btlBuild <- function(p) { - nV <- length(p$variantNames) - cov <- .btlCoverage(p$csTables) - fc <- .btlFitConstants(p$dataY, p$otherQuantities, p$region) - post <- .btlPosterior(p$fit, p$conditionIdx, nV) - marg <- .btlMarginal(p$sumstats, nV) - cs <- .btlCsMembership(cov, p$csTables, nV, p$variantNames) +# Orchestrate the top-loci table from the buildTopLoci() arguments. +.btlBuild <- function( + fit, + csTables, + variantNames, + sumstats, + af, + n, + method, + signalCutoff, + dataY, + otherQuantities, + region, + conditionIdx, + credibleSetArgs +) { + nV <- length(variantNames) + cov <- .btlCoverage(csTables) + fc <- .btlFitConstants(dataY, otherQuantities, region) + post <- .btlPosterior(fit, conditionIdx, nV) + marg <- .btlMarginal(sumstats, nV) + cs <- .btlCsMembership(cov, csTables, nV, variantNames) fullFitBlock <- .btlFullFitBlock( - p$fit, + fit, post, cov, cs, - p$csTables, + csTables, nV, - p[c("fullFit", "fullFitAlphaOnly", "includeAllCs")] - ) - out <- .btlAssemble( - p$variantNames, - .btlParseVariants(p$variantNames), - fc, - marg, - post, - p$fit, - p$af, - p$n, - p$method, - .btlCsBlock(p$method, cs, nV), - fullFitBlock, - nV + list(credibleSetArgs = credibleSetArgs) ) - cond <- .btlConditional( - p$fit, - p$method, - p$conditionIdx, - cov, - cs$covSorted, - p$csTables, - nV + .btlAssembleFinal( + variantNames, + fc = fc, + marg = marg, + post = post, + fit = fit, + af = af, + n = n, + method = method, + cs = cs, + cov = cov, + csTables = csTables, + fullFitBlock = fullFitBlock, + nV = nV, + conditionIdx = conditionIdx, + signalCutoff = signalCutoff ) - .btlFinalize(out, cond, p$conditionIdx, p$signalCutoff) } -# Attach per-condition columns (multi-condition fits) and apply the PIP cutoff. -.btlFinalize <- function(out, cond, conditionIdx, signalCutoff) { - if (!is.null(conditionIdx)) { - out$conditional_effect <- cond$condEffect - out$lfsr <- cond$condLfsr - } - if (!is.null(signalCutoff) && signalCutoff > 0) { - out <- filter(out, !is.na(.data$pip) & .data$pip > signalCutoff) +# Assemble the per-variant table, add the conditional columns, and apply +# the signal cutoff. Split from .btlBuild() so that function reads as the +# list of pieces it derives, and this one as what is done with them. +# @noRd +.btlAssembleFinal <- function( + variantNames, + fc, + marg, + post, + fit, + af, + n, + method, + cs, + cov, + csTables, + fullFitBlock, + nV, + conditionIdx, + signalCutoff +) { + out <- .btlAssemble( + variantNames, + .btlParseVariants(variantNames), + fc, + marg, + post, + fit, + af, + n, + method, + .btlCsBlock(method, cs, nV), + fullFitBlock, + nV + ) + cond <- .btlConditional( + fit, + method, + conditionIdx, + cov, + cs$covSorted, + csTables, + nV + ) + .btlFinalize(out, cond, conditionIdx, signalCutoff) +} + +# Attach per-condition columns (multi-condition fits) and apply the PIP cutoff. +.btlFinalize <- function(out, cond, conditionIdx, signalCutoff) { + withCond <- if (is.null(conditionIdx)) { + out + } else { + mutate( + out, + conditional_effect = cond$condEffect, + lfsr = cond$condLfsr + ) } - out + if (is.null(signalCutoff) || signalCutoff <= 0) { + return(withCond) + } + filter(withCond, !is.na(.data$pip) & .data$pip > signalCutoff) } # buildTopLoci step helpers --------------------------------------------------- # `method` is required and must be a single non-empty, non-NA string. +#' @importFrom checkmate checkString .btlValidateMethod <- function(method) { - if ( - is.null(method) || - length(method) != 1L || - is.na(method) || - str_length(method) == 0L - ) { + res <- checkString(method, min.chars = 1L) + if (!isTRUE(res)) { abort( "buildTopLoci: `method` is required (e.g. \"susie\", \"susieInf\")." ) @@ -1487,13 +1826,12 @@ buildTopLoci <- function( } # Parse variant IDs to chrom/pos/A1/A2; error on missing or invalid coordinates. +#' @importFrom rlang try_fetch .btlParseVariants <- function(variantNames) { - parsed <- tryCatch( + parsed <- try_fetch( suppressWarnings(parseVariantId(variantNames)), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("buildTopLoci: parseVariantId failed: {eMsg}") - abort(msg) + error = function(cnd) { + abort("buildTopLoci: parseVariantId failed", parent = cnd) } ) if (is.null(parsed) || nrow(parsed) != length(variantNames)) { @@ -1603,7 +1941,7 @@ buildTopLoci <- function( identical(method, "mvsusie") && requireNamespace("mvsusieR", quietly = TRUE) ) { - cm <- tryCatch(mvsusieR::coef.mvsusie(fit), error = function(e) NULL) + cm <- try_fetch(mvsusieR::coef.mvsusie(fit), error = function(cnd) NULL) if (!is.null(cm)) as.matrix(cm)[-1L, , drop = FALSE] else NULL } else { NULL @@ -1646,18 +1984,53 @@ buildTopLoci <- function( return(condLfsr) } effectOf <- suppressWarnings(as.integer(str_remove(names(setsPrim), "^L"))) - 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]) - } + assignments <- compact(map( + seq_along(setsPrim), + .btlCondLfsrForSet, + setsPrim = setsPrim, + effectOf = effectOf, + clf = clf, + conditionIdx = conditionIdx, + nV = nV + )) + # Later sets overwrite earlier ones at a shared variant, as the running + # assignment did; one scatter replaces the per-set writes. + .fmScatter( + condLfsr, + .fmwConcatInt(map(assignments, "variant")), + .fmwConcatDbl(map(assignments, "value")) + ) +} + +# @noRd +.fmwConcatDbl <- function(pieces) { + if (length(pieces) == 0L) { + return(numeric(0)) + } + list_c(pieces) +} + +# One credible set's conditional-lfsr values, or NULL when its effect is out +# of range or it covers no in-range variant. +# @noRd +.btlCondLfsrForSet <- function( + csPos, + setsPrim, + effectOf, + clf, + conditionIdx, + nV +) { + L <- effectOf[csPos] + if (is.na(L) || L < 1L || L > dim(clf)[1L]) { + return(NULL) } - condLfsr + raw <- as.integer(setsPrim[[csPos]]) + vi <- raw[raw >= 1L & raw <= nV] + if (length(vi) == 0L) { + return(NULL) + } + list(variant = vi, value = as.numeric(clf[L, vi, conditionIdx])) } # Per-condition posterior quantities (NA for univariate fits). @@ -1706,6 +2079,24 @@ buildTopLoci <- function( as_tibble(csList, .name_repair = "minimal") } +# The effect indices behind the primary-coverage CS, read off the "L" names +# of its sets$cs. integer(0) when there is no such CS or it names no effects. +# @noRd +.btlPrimaryEffects <- function(coverageValues, cs, csTables) { + if (length(cs$covSorted) == 0L) { + return(integer(0)) + } + hP <- which(abs(coverageValues - cs$covSorted[1L]) < 1e-12) + if (length(hP) == 0L) { + return(integer(0)) + } + spP <- csTables[[hP[1L]]]$sets$cs + if (is.null(spP) || length(spP) == 0L) { + return(integer(0)) + } + suppressWarnings(as.integer(str_remove(names(spP), "^L"))) +} + # within_cs_pip (+ optional fullFit-wide) columns, mapping each variant to its # primary-coverage CS effect (position -> effect via the sets$cs "L" names). .btlFullFitBlock <- function( @@ -1722,18 +2113,7 @@ buildTopLoci <- function( } else { integer(nV) } - effectOfPrim <- integer(0) - if (length(cs$covSorted) > 0L) { - hP <- which(abs(coverageValues - cs$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(str_remove(names(spP), "^L")) - ) - } - } - } + effectOfPrim <- .btlPrimaryEffects(coverageValues, cs, csTables) .fullFitColumns( post$alpha, post$mu, @@ -1742,9 +2122,7 @@ buildTopLoci <- function( fit$X_column_scale_factors, primaryCsPos, effectOfPrim, - fullFit = opts$fullFit, - fullFitAlphaOnly = opts$fullFitAlphaOnly, - includeAllCs = opts$includeAllCs + credibleSetArgs = opts$credibleSetArgs ) } @@ -1842,9 +2220,10 @@ buildTopLoci <- function( ) { return(c(start = NA_integer_, end = NA_integer_)) } - pr <- tryCatch(parseRegion(as.character(regionStr)), error = function(e) { - NULL - }) + pr <- try_fetch( + parseRegion(as.character(regionStr)), + error = function(cnd) NULL + ) if (is.null(pr) || !is.data.frame(pr)) { return(c(start = NA_integer_, end = NA_integer_)) } @@ -1852,19 +2231,22 @@ buildTopLoci <- function( } trimFinemappingFit <- function(fit, effectIdx, method, csTables) { - trimmed <- .trimBaseFit(fit, effectIdx, csTables) - trimmed <- .trimAddCommon(trimmed, fit, effectIdx) - if (method == "mvsusie") { - trimmed <- .trimAddMvsusie(trimmed, fit, effectIdx) + common <- .trimBaseFit(fit, effectIdx, csTables) |> + .trimAddCommon(fit, effectIdx) + trimmed <- if (method == "mvsusie") { + .trimAddMvsusie(common, fit, effectIdx) + } else { + common } # fSuSiE: keep the precomputed variants x features TWAS weight matrix # (fsusieWeights output, attached as $coef before trimming) so downstream # TWAS can read it without the dropped wavelet slots. - if (method == "fsusie" && !is.null(fit$coef)) { - trimmed$coef <- fit$coef + withCoef <- if (method == "fsusie" && !is.null(fit$coef)) { + list_assign(trimmed, coef = fit$coef) + } else { + trimmed } - class(trimmed) <- unique(c(method, "susie")) - trimmed + `class<-`(withCoef, unique(c(method, "susie"))) } # The minimal always-kept subset of a susie fit (pip, credible sets, effect @@ -1898,30 +2280,30 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { # Optional slots common to susie/mvsusie: column scales, posterior mu/mu2 # (L x p, or L x p x R for multivariate), theta, omega_weights. .trimAddCommon <- function(trimmed, fit, effectIdx) { - if (!is.null(fit$X_column_scale_factors)) { - trimmed$X_column_scale_factors <- fit$X_column_scale_factors - } - if (!is.null(fit$mu)) { - trimmed$mu <- if (length(dim(fit$mu)) == 3) { - fit$mu[effectIdx, , , drop = FALSE] - } else { - fit$mu[effectIdx, , drop = FALSE] - } - } - if (!is.null(fit$mu2)) { - trimmed$mu2 <- if (length(dim(fit$mu2)) == 3) { - fit$mu2[effectIdx, , , drop = FALSE] - } else { - fit$mu2[effectIdx, , drop = FALSE] - } - } - if (!is.null(fit$theta)) { - trimmed$theta <- fit$theta + withCommon <- list_assign( + trimmed, + !!!compact(list( + X_column_scale_factors = fit$X_column_scale_factors, + mu = .trimEffectSlice(fit$mu, effectIdx), + mu2 = .trimEffectSlice(fit$mu2, effectIdx), + theta = fit$theta, + omega_weights = fit$omega_weights + )) + ) + .trimAddScalars(withCommon, fit) +} + +# The selected effects of a posterior array, which is L x p for a univariate +# fit and L x p x R for a multivariate one. +# @noRd +.trimEffectSlice <- function(x, effectIdx) { + if (is.null(x)) { + return(NULL) } - if (!is.null(fit$omega_weights)) { - trimmed$omega_weights <- fit$omega_weights + if (length(dim(x)) == 3) { + return(x[effectIdx, , , drop = FALSE]) } - .trimAddScalars(trimmed, fit) + x[effectIdx, , drop = FALSE] } # Cheap fields that are not effect-indexed, kept so a trimmed fit is sufficient @@ -1954,23 +2336,26 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { if (is.null(value)) { return(trimmed) } - trimmed[[nm]] <- value - trimmed + list_assign(trimmed, !!!set_names(list(value), nm)) } # mvsusie-specific slots: per-effect mu2_diag, the coefficient matrix, and the # conditional lfsr array. .trimAddMvsusie <- function(trimmed, fit, effectIdx) { - if (!is.null(fit$mu2_diag)) { - trimmed$mu2_diag <- fit$mu2_diag[effectIdx, , , drop = FALSE] - } - if (requireNamespace("mvsusieR", quietly = TRUE)) { - trimmed$coef <- mvsusieR::coef.mvsusie(fit)[-1, , drop = FALSE] - } - if (!is.null(fit$conditional_lfsr)) { - trimmed$clfsr <- fit$conditional_lfsr[effectIdx, , , drop = FALSE] - } - trimmed + list_assign( + trimmed, + !!!compact(list( + mu2_diag = if (!is.null(fit$mu2_diag)) { + fit$mu2_diag[effectIdx, , , drop = FALSE] + }, + coef = if (requireNamespace("mvsusieR", quietly = TRUE)) { + mvsusieR::coef.mvsusie(fit)[-1, , drop = FALSE] + }, + clfsr = if (!is.null(fit$conditional_lfsr)) { + fit$conditional_lfsr[effectIdx, , , drop = FALSE] + } + )) + ) } #' Format Fine-mapping Post-processing for Protocol Output @@ -2022,7 +2407,10 @@ getCsIndex <- function(snpsIdx, susieCs) { } #' @noRd getTopVariantsIdx <- function(susieOutput, signalCutoff) { - c(which(susieOutput$pip >= signalCutoff), unlist(susieOutput$sets$cs)) |> + # `sets$cs` is absent when no credible set was found; list_c() is strict + # about NULL where unlist() silently returned it. + cs <- list_c(susieOutput$sets$cs %||% list()) + c(which(susieOutput$pip >= signalCutoff), cs) |> unique() |> sort() } @@ -2063,44 +2451,45 @@ getCsInfo <- function(susieOutputSetsCs, topVariantsIdx) { #' a vector of purity metrics (for other methods and multi-element sets). #' @noRd -calPurity <- function(lCs, X, method = "min") { - tt <- list() - - for (k in seq_along(lCs)) { - csIndices <- unlist(lCs[[k]]) - if (method == "min") { - if (length(csIndices) == 1) { - tt[[k]] <- 1 - } else { - x <- abs(computeLd( - X[, csIndices, drop = FALSE], - method = "sample" - )) - x[col(x) == row(x)] <- NA - tt[[k]] <- min(x, na.rm = TRUE) - } - } else { - if (length(csIndices) == 1) { - tt[[k]] <- c(1, 1, 1) - } else { - x <- abs(computeLd( - X[, csIndices, drop = FALSE], - method = "sample" - )) - x[col(x) == row(x)] <- NA - tt[[k]] <- c( - min(x, na.rm = TRUE), - mean(x, na.rm = TRUE), - median(x, na.rm = TRUE) - ) - } +# Absolute off-diagonal correlations among one credible set's variants. The +# diagonal is blanked so a set is never judged pure by its self-correlation. +# @noRd +.cpOffDiagonalLd <- function(csIndices, X) { + x <- abs(computeLd(X[, csIndices, drop = FALSE], method = "sample")) + replace(x, col(x) == row(x), NA) +} + +# One credible set's purity: the weakest pairwise correlation, or the +# (min, mean, median) triple when more than the minimum is asked for. A +# single-variant set is pure by definition. +# @noRd +.cpSetPurity <- function(csIndices, X, method) { + if (method == "min") { + if (length(csIndices) == 1) { + return(1) } + return(min(.cpOffDiagonalLd(csIndices, X), na.rm = TRUE)) + } + if (length(csIndices) == 1) { + return(c(1, 1, 1)) } + x <- .cpOffDiagonalLd(csIndices, X) + c( + min(x, na.rm = TRUE), + mean(x, na.rm = TRUE), + median(x, na.rm = TRUE) + ) +} - return(tt) +calPurity <- function(lCs, X, method = "min") { + # Each `lCs[[k]]` is documented (and always supplied) as a plain index + # vector; the unlist() that used to sit here was a no-op that quietly + # tolerated a nested list, leaving the contract unsettled. + map(lCs, .cpSetPurity, X = X, method = method) } +#' @importFrom checkmate assertNumber #' @title Create Sets Similar to SuSiE Output from fSuSiE Object #' #' @description This function constructs a list that mimics the structure of @@ -2126,6 +2515,7 @@ calPurity <- function(lCs, X, method = "min") { #' fsusieGetCs(fit) #' @export fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { + assertNumber(requestedCoverage, lower = 0, upper = 1) # Create 'cs' set with names csNamed <- set_names( fsusieObj$cs, @@ -2133,20 +2523,21 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { ) # Create 'purity' data frame - purityDf <- bind_rows( - map(calPurity(fsusieObj$cs, X = X, method = "susie"), .asDataFrameT) + purity <- `colnames<-`( + bind_rows( + map(calPurity(fsusieObj$cs, X = X, method = "susie"), .asDataFrameT) + ), + c("minAbsCorr", "meanAbsCorr", "medianAbsCorr") ) - colnames(purityDf) <- c("minAbsCorr", "meanAbsCorr", "medianAbsCorr") # Credible-set label as a `cs` column (was rownames; tibbles carry none). - purityDf <- bind_cols(tibble(cs = names(csNamed)), purityDf) + purityDf <- bind_cols(tibble(cs = names(csNamed)), purity) # Create 'coverage' without - coverageVector <- numeric(length(fsusieObj$alpha)) - for (i in seq_along(fsusieObj$alpha)) { - alphaI <- fsusieObj$alpha[[i]] - csI <- fsusieObj$cs[[i]] - coverageVector[i] <- sum(alphaI[csI]) - } + coverageVector <- map_dbl( + seq_along(fsusieObj$alpha), + .fsusieSetCoverage, + fsusieObj = fsusieObj + ) # Combine all elements into a list sets <- list( @@ -2179,7 +2570,9 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { #' @param maxScale numeric, define the maximum of wavelet coefficients used in #' the analysis (2^maxScale). Set 10 true by default. #' @param minPurity Minimum purity threshold for credible sets to be retained. -#' @param ... Additional arguments passed to the fsusie function. +#' @param methodArgs Options forwarded to \code{fsusieR::susiF}, built with +#' \code{\link{FsusieOptions}}. A bare list is refused: it cannot be checked +#' against the engine, so a misspelled option would be silently ignored. #' @return A modified fsusie object with the susie sets list, correlations for #' cs, alpha as df like susie, and without the dummy cs that do not meet the #' minimum purity requirement. @@ -2206,41 +2599,49 @@ fsusieWrapper <- function( covLev, minPurity, maxScale, - ... + methodArgs = FsusieOptions() ) { + .assertMethodOptions(methodArgs, "FsusieOptions", "methodArgs") if (!requireNamespace("fsusieR", quietly = TRUE)) { - msg <- glue( - "To use this function, please install fsusieR: ", - "https://github.com/stephenslab/fsusieR" - ) - abort(msg) + abort("Package 'fsusieR' is required for this function.") } - fsusieObj <- fsusieR::susiF( - X = X, - Y = Y, - pos = pos, - L = L, - prior = prior, - max_SNP_EM = maxSnpEm, - cov_lev = covLev, - min_purity = minPurity, - max_scale = maxScale, - ... + callArgs <- list_modify( + list( + X = X, + Y = Y, + pos = pos, + L = L, + prior = prior, + max_SNP_EM = maxSnpEm, + cov_lev = covLev, + min_purity = minPurity, + max_scale = maxScale + ), + !!!methodArgs ) + fsusieObj <- exec(fsusieR::susiF, !!!callArgs) .fsusieWrapperPostprocess(fsusieObj, X, minPurity, covLev) } # Drop dummy credible sets below the purity threshold (else build sets + CS # correlations), then reshape alpha (per-effect list) into a single data.frame. .fsusieWrapperPostprocess <- function(fsusieObj, X, minPurity, covLev) { - if (all(abs(as.numeric(fsusieObj$purity)) < minPurity)) { - fsusieObj$cs <- list(NULL) - fsusieObj$sets <- list(cs = list(NULL), requested_coverage = covLev) + withSets <- if (all(abs(as.numeric(fsusieObj$purity)) < minPurity)) { + list_assign( + fsusieObj, + cs = list(NULL), + sets = list(cs = list(NULL), requested_coverage = covLev) + ) } else { - fsusieObj$sets <- fsusieGetCs(fsusieObj, X, requestedCoverage = covLev) + list_assign( + fsusieObj, + sets = fsusieGetCs(fsusieObj, X, requestedCoverage = covLev) + ) } - fsusieObj$alpha <- bind_rows(map(fsusieObj$alpha, .asDataFrameT)) - fsusieObj + list_assign( + withSets, + alpha = bind_rows(map(fsusieObj$alpha, .asDataFrameT)) + ) } @@ -2265,7 +2666,10 @@ fsusieWrapper <- function( #' \code{mvsusieR::create_mixture_prior(R = ncol(Y))} unless you have a #' domain-specific prior. #' @param coverage Credible set coverage (default 0.95). -#' @param ... Additional arguments forwarded to \code{mvsusieR::mvsusie}. +#' @param methodArgs Options forwarded to \code{mvsusieR::mvsusie}, built +#' with \code{\link{MvsusieOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be silently +#' ignored. #' @return The fit object returned by \code{mvsusieR::mvsusie}. #' @examples #' \donttest{ @@ -2278,15 +2682,27 @@ fsusieWrapper <- function( #' fitMvsusie(X, Y, #' prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y))) #' } +#' @importFrom checkmate assertNumber #' @export -fitMvsusie <- function(X, Y, prior_variance, coverage = 0.95, ...) { - mvsusieR::mvsusie( - X = X, - Y = Y, - prior_variance = prior_variance, - coverage = coverage, - ... +fitMvsusie <- function( + X, + Y, + prior_variance, + coverage = 0.95, + methodArgs = MvsusieOptions() +) { + .assertMethodOptions(methodArgs, "MvsusieOptions", "methodArgs") + assertNumber(coverage, lower = 0, upper = 1) + callArgs <- list_modify( + list( + X = X, + Y = Y, + prior_variance = prior_variance, + coverage = coverage + ), + !!!methodArgs ) + exec(mvsusieR::mvsusie, !!!callArgs) } #' Fit mvSuSiE-RSS on summary-statistic (Z, R, N) data @@ -2300,7 +2716,10 @@ fitMvsusie <- function(X, Y, prior_variance, coverage = 0.95, ...) { #' @param N Scalar sample size (median across conditions when N varies). #' @param prior_variance Prior variance matrix. #' @param coverage Credible set coverage (default 0.95). -#' @param ... Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}. +#' @param methodArgs Options forwarded to \code{mvsusieR::mvsusie_rss}, +#' built with \code{\link{MvsusieRssOptions}} --- the RSS entry point has +#' its own constructor, since it is a different function from +#' \code{mvsusie} with different arguments. #' @return The fit object returned by \code{mvsusieR::mvsusie_rss}. #' @examples #' data(eqtlRegionExample) @@ -2316,16 +2735,30 @@ fitMvsusie <- function(X, Y, prior_variance, coverage = 0.95, ...) { #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) #' fitMvsusieRss(Z = stat$z, R = LD, N = nrow(X), prior_variance = 1) +#' @importFrom checkmate assertNumber #' @export -fitMvsusieRss <- function(Z, R, N, prior_variance, coverage = 0.95, ...) { - mvsusieR::mvsusie_rss( - Z = Z, - R = R, - N = N, - prior_variance = prior_variance, - coverage = coverage, - ... +fitMvsusieRss <- function( + Z, + R, + N, + prior_variance, + coverage = 0.95, + methodArgs = MvsusieRssOptions() +) { + .assertMethodOptions(methodArgs, "MvsusieRssOptions", "methodArgs") + assertNumber(N, lower = 0, finite = TRUE) + assertNumber(coverage, lower = 0, upper = 1) + callArgs <- list_modify( + list( + Z = Z, + R = R, + N = N, + prior_variance = prior_variance, + coverage = coverage + ), + !!!methodArgs ) + exec(mvsusieR::mvsusie_rss, !!!callArgs) } #' Fit fSuSiE on individual-level (X, Y, pos) data @@ -2335,7 +2768,9 @@ fitMvsusieRss <- function(Z, R, N, prior_variance, coverage = 0.95, ...) { #' @param X Numeric matrix of genotypes (samples x variants). #' @param Y Numeric matrix of multi-trait outcomes (samples x traits). #' @param pos Numeric vector of trait positions (length \code{ncol(Y)}). -#' @param ... Additional arguments forwarded to \code{fsusieR::susiF}. +#' @param methodArgs Options forwarded to \code{fsusieR::susiF}, built with +#' \code{\link{FsusieOptions}}. A bare list is refused: it cannot be checked +#' against the engine, so a misspelled option would be silently ignored. #' @return The fit object returned by \code{fsusieR::susiF}. #' @examples #' data(eqtlRegionExample) @@ -2346,10 +2781,12 @@ fitMvsusieRss <- function(Z, R, N, prior_variance, coverage = 0.95, ...) { #' Y <- matrix(rep(base, each = n), n, nPos) + #' X[, 1] %o% (0.5 * cos(seq(0, pi, length.out = nPos))) #' pos <- seq_len(nPos) -#' fitFsusie(X, Y, pos = pos, L = 2) +#' fitFsusie(X, Y, pos = pos, methodArgs = FsusieOptions(L = 2)) #' @export -fitFsusie <- function(X, Y, pos, ...) { - fsusieR::susiF(X = X, Y = Y, pos = pos, ...) +fitFsusie <- function(X, Y, pos, methodArgs = FsusieOptions()) { + .assertMethodOptions(methodArgs, "FsusieOptions", "methodArgs") + callArgs <- list_modify(list(X = X, Y = Y, pos = pos), !!!methodArgs) + exec(fsusieR::susiF, !!!callArgs) } # ============================================================================= @@ -2366,8 +2803,7 @@ fitFsusie <- function(X, Y, pos, ...) { # (zero the intercept, then coef.susie without the intercept row). # @noRd .susieCoefWeights <- function(fit) { - fit$intercept <- 0 - coef.susie(fit)[-1] + coef.susie(list_assign(fit, intercept = 0))[-1] } # @param requiredFields Fields that must be present in the fit to extract @@ -2382,14 +2818,19 @@ fitFsusie <- function(X, Y, pos, ...) { .susieExtractWeights <- function( fit, X, - y, requiredFields, token = "susie", - userArgs = list(), - retainFit = FALSE + fitRetention = c("none", "slim", "full") ) { + fitRetention <- arg_match(fitRetention) if (is.null(fit)) { - fit <- .fmFitSusieIndiv(X, y, token, userArgs = userArgs) + msg <- glue( + "{token}Weights: no '{token}' fit supplied. These extract weights ", + "from an existing fit and never run fine-mapping themselves; run ", + "fineMappingPipeline() with method '{token}' first and pass the ", + "fit in." + ) + abort(msg) } if (!is.null(X) && length(fit$pip) != ncol(X)) { nPip <- length(fit$pip) @@ -2400,50 +2841,99 @@ fitFsusie <- function(X, Y, pos, ...) { ) abort(msg) } - if (all(is_in(requiredFields, names(fit)))) { - weights <- .susieCoefWeights(fit) + weights <- if (all(is_in(requiredFields, names(fit)))) { + .susieCoefWeights(fit) } else { - weights <- rep(0, length(fit$pip)) + rep(0, length(fit$pip)) } - if (retainFit) { - attr(weights, "fit") <- fit + if (identical(fitRetention, "none")) { + return(weights) } - return(weights) + `attr<-`(weights, "fit", fit) +} + +#' Compute single-effect (SER) TWAS weights +#' +#' Extracts coefficients from an existing single-effect fit, as produced by +#' \code{fineMappingPipeline(..., methods = "ser")} on summary statistics. +#' The SER model carries the same \code{alpha} / \code{mu} / +#' \code{X_column_scale_factors} structure as a SuSiE fit --- with a single +#' effect, so \code{alpha} has one row --- so extraction is identical. +#' +#' SER fits only exist on the summary-statistics path, because +#' \code{susieR::susie_ser} is the only implementation +#' \code{\link{fineMappingPipeline}} has for the \code{"ser"} method. That +#' does not restrict the weights: a fit is a fit, and weights read off an +#' RSS fit are as usable for TWAS as any from penalized regression. +#' +#' @param X Optional genotype matrix; when supplied it is only used to +#' check that the fit covers the same number of variants. +#' @param y Unused; retained for signature compatibility. +#' @param serFit Optional fitted SER object. +#' @param fitRetention How much of the fit is kept on the returned weights: +#' \code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +#' it as the \code{"fit"} attribute. These extractors hold no trimmable +#' intermediates, so the two retaining levels behave alike here. +#' @return Numeric vector of variant weights. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' z <- apply(X, 2, function(g) summary(stats::lm(y ~ g))$coefficients[2, 3]) +#' fit <- suppressWarnings(susieR::susie_ser(z = z, n = nrow(X))) +#' serWeights(serFit = fit) +#' @export +serWeights <- function( + X = NULL, + y = NULL, + serFit = NULL, + fitRetention = c("none", "slim", "full") +) { + fitRetention <- arg_match(fitRetention) + .susieExtractWeights( + serFit, + X, + requiredFields = c("alpha", "mu", "X_column_scale_factors"), + token = "ser", + fitRetention = fitRetention + ) } #' Compute SuSiE TWAS weights #' -#' Extracts coefficients from an existing SuSiE fit or fits `susieR::susie()` +#' Extracts coefficients from an existing SuSiE fit. #' from `X` and `y` before extracting weights. #' -#' @param X Genotype matrix. Required when `susieFit` is NULL. -#' @param y Phenotype vector. Required when `susieFit` is NULL. +#' @param X Optional genotype matrix; when supplied it is only used to +#' check that the fit covers the same number of variants. +#' @param y Unused; retained for signature compatibility. #' @param susieFit Optional fitted SuSiE object. -#' @param retainFit If TRUE, stores the fitted object as an attribute on the -#' returned weights. -#' @param ... Additional arguments passed to `susieR::susie()` when fitting. +#' @param fitRetention How much of the fit is kept on the returned weights: +#' \code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +#' it as the \code{"fit"} attribute. These extractors hold no trimmable +#' intermediates, so the two retaining levels behave alike here. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes -#' susieWeights(X, y) +#' fit <- susieR::susie(X, y, L = 5) +#' susieWeights(susieFit = fit) +#' @importFrom checkmate assertFlag #' @export susieWeights <- function( X = NULL, y = NULL, susieFit = NULL, - retainFit = FALSE, - ... + fitRetention = c("none", "slim", "full") ) { + fitRetention <- arg_match(fitRetention) .susieExtractWeights( susieFit, X, - y, requiredFields = c("alpha", "mu", "X_column_scale_factors"), token = "susie", - userArgs = list(...), - retainFit = retainFit + fitRetention = fitRetention ) } @@ -2452,34 +2942,36 @@ susieWeights <- function( #' Extracts coefficients from an existing SuSiE-ASH fit or fits #' `susieR::susie()` with `unmappable_effects = "ash"`. #' -#' @param X Genotype matrix. Required when `susieAshFit` is NULL. -#' @param y Phenotype vector. Required when `susieAshFit` is NULL. +#' @param X Optional genotype matrix; when supplied it is only used to +#' check that the fit covers the same number of variants. +#' @param y Unused; retained for signature compatibility. #' @param susieAshFit Optional fitted SuSiE-ASH object. -#' @param retainFit If TRUE, stores the fitted object as an attribute on the -#' returned weights. -#' @param ... Additional arguments passed to `susieR::susie()` when fitting. +#' @param fitRetention How much of the fit is kept on the returned weights: +#' \code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +#' it as the \code{"fit"} attribute. These extractors hold no trimmable +#' intermediates, so the two retaining levels behave alike here. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes -#' susieAshWeights(X, y) +#' fit <- susieR::susie(X, y, L = 5) +#' susieAshWeights(susieAshFit = fit) +#' @importFrom checkmate assertFlag #' @export susieAshWeights <- function( X = NULL, y = NULL, susieAshFit = NULL, - retainFit = FALSE, - ... + fitRetention = c("none", "slim", "full") ) { + fitRetention <- arg_match(fitRetention) .susieExtractWeights( susieAshFit, X, - y, requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieAsh", - userArgs = list(...), - retainFit = retainFit + fitRetention = fitRetention ) } @@ -2499,34 +2991,36 @@ susieAshWeights <- function( #' per-variant PIPs as a gate on whether to use the weights should be aware #' that low or zero PIPs do not imply zero TWAS weights here. #' -#' @param X Genotype matrix. Required when `susieInfFit` is NULL. -#' @param y Phenotype vector. Required when `susieInfFit` is NULL. +#' @param X Optional genotype matrix; when supplied it is only used to +#' check that the fit covers the same number of variants. +#' @param y Unused; retained for signature compatibility. #' @param susieInfFit Optional fitted SuSiE-inf object. -#' @param retainFit If TRUE, stores the fitted object as an attribute on the -#' returned weights. -#' @param ... Additional arguments passed to `susieR::susie()` when fitting. +#' @param fitRetention How much of the fit is kept on the returned weights: +#' \code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +#' it as the \code{"fit"} attribute. These extractors hold no trimmable +#' intermediates, so the two retaining levels behave alike here. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes -#' susieInfWeights(X, y) +#' fit <- susieR::susie(X, y, L = 5) +#' susieInfWeights(susieInfFit = fit) +#' @importFrom checkmate assertFlag #' @export susieInfWeights <- function( X = NULL, y = NULL, susieInfFit = NULL, - retainFit = FALSE, - ... + fitRetention = c("none", "slim", "full") ) { + fitRetention <- arg_match(fitRetention) .susieExtractWeights( susieInfFit, X, - y, requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieInf", - userArgs = list(...), - retainFit = retainFit + fitRetention = fitRetention ) } # Internal helper: extract weights from a susieRss fit. @@ -2535,16 +3029,20 @@ susieInfWeights <- function( #' @noRd .susieRssExtractWeights <- function( fit, - z, R, - n, requiredFields, token = "susie", - userArgs = list(), - retainFit = FALSE + fitRetention = c("none", "slim", "full") ) { + fitRetention <- arg_match(fitRetention) if (is.null(fit)) { - fit <- .fmFitSusieRss(z, R, n, token, userArgs = userArgs) + msg <- glue( + "{token}RssWeights: no '{token}' fit supplied. These extract ", + "weights from an existing fit and never run fine-mapping ", + "themselves; run fineMappingPipeline() with method '{token}' ", + "first and pass the fit in." + ) + abort(msg) } if (length(fit$pip) != nrow(R)) { nPip <- length(fit$pip) @@ -2555,15 +3053,15 @@ susieInfWeights <- function( ) abort(msg) } - if (all(is_in(requiredFields, names(fit)))) { - weights <- .susieCoefWeights(fit) + weights <- if (all(is_in(requiredFields, names(fit)))) { + .susieCoefWeights(fit) } else { - weights <- rep(0, length(fit$pip)) + rep(0, length(fit$pip)) } - if (retainFit) { - attr(weights, "fit") <- fit + if (identical(fitRetention, "none")) { + return(weights) } - return(weights) + `attr<-`(weights, "fit", fit) } #' Compute SuSiE-RSS TWAS weights @@ -2574,12 +3072,12 @@ susieInfWeights <- function( #' @param stat List with components \code{z} (z-scores), \code{n} (sample #' sizes). #' @param LD LD correlation matrix. -#' @param susieRssFit Optional pre-fitted SuSiE-RSS object. -#' @param retainFit If TRUE, stores the fitted object as an attribute. -#' @param methodArgs Named list of additional arguments passed to -#' \code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -#' matching of short argument names (e.g. \code{L}) to the \code{LD} -#' parameter. +#' @param susieRssFit A fitted SuSiE-RSS object. Required: these wrappers +#' extract weights and never run fine-mapping themselves. +#' @param fitRetention How much of the fit is kept on the returned weights: +#' \code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +#' it as the \code{"fit"} attribute. These extractors hold no trimmable +#' intermediates, so the two retaining levels behave alike here. #' @return Numeric vector of variant weights. #' @examples #' data(eqtlRegionExample) @@ -2594,24 +3092,24 @@ susieInfWeights <- function( #' z = vapply(ss, function(s) s[1] / s[2], numeric(1)), #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) -#' susieRssWeights(stat, LD) +#' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +#' susieRssWeights(stat, LD, susieRssFit = fit) +#' @importFrom checkmate assertList assertFlag #' @export susieRssWeights <- function( stat, LD, susieRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + fitRetention = c("slim", "none", "full") ) { + assertList(stat) + fitRetention <- arg_match(fitRetention) .susieRssExtractWeights( fit = susieRssFit, - z = stat$z, R = LD, - n = median(stat$n), requiredFields = c("alpha", "mu", "X_column_scale_factors"), token = "susie", - userArgs = methodArgs, - retainFit = retainFit + fitRetention = fitRetention ) } @@ -2636,24 +3134,24 @@ susieRssWeights <- function( #' z = vapply(ss, function(s) s[1] / s[2], numeric(1)), #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) -#' susieInfRssWeights(stat, LD) +#' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +#' susieInfRssWeights(stat, LD, susieInfRssFit = fit) +#' @importFrom checkmate assertList assertFlag #' @export susieInfRssWeights <- function( stat, LD, susieInfRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + fitRetention = c("slim", "none", "full") ) { + assertList(stat) + fitRetention <- arg_match(fitRetention) .susieRssExtractWeights( fit = susieInfRssFit, - z = stat$z, R = LD, - n = median(stat$n), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieInf", - userArgs = methodArgs, - retainFit = retainFit + fitRetention = fitRetention ) } @@ -2678,43 +3176,33 @@ susieInfRssWeights <- function( #' z = vapply(ss, function(s) s[1] / s[2], numeric(1)), #' n = rep(nrow(X), ncol(X))) #' LD <- cor(X) -#' susieAshRssWeights(stat, LD) +#' fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +#' susieAshRssWeights(stat, LD, susieAshRssFit = fit) +#' @importFrom checkmate assertList assertFlag #' @export susieAshRssWeights <- function( stat, LD, susieAshRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + fitRetention = c("slim", "none", "full") ) { + assertList(stat) + fitRetention <- arg_match(fitRetention) .susieRssExtractWeights( fit = susieAshRssFit, - z = stat$z, R = LD, - n = median(stat$n), requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), token = "susieAsh", - userArgs = methodArgs, - retainFit = retainFit + fitRetention = fitRetention ) } #' Compute mvSuSiE TWAS weights #' -#' Extracts coefficients from an existing mvSuSiE fit or fits `fitMvsusie()` -#' from `X` and `Y`. +#' Extracts coefficients from an existing mvSuSiE fit. This never fits +#' mvSuSiE itself: fine-mapping belongs to \code{fineMappingPipeline()}, and a +#' missing fit is an error rather than an invitation to refit. #' -#' @param mvsusieFit Optional fitted mvSuSiE object. -#' @param X Genotype matrix. Required when `mvsusieFit` is NULL. -#' @param Y Phenotype matrix. Required when `mvsusieFit` is NULL. -#' @param priorVariance Optional mvSuSiE prior variance list. -#' @param residualVariance Optional residual variance matrix. -#' @param L Maximum number of components. Default \code{10}, matching -#' \code{mvsusieR::mvsusie}. -#' @param LGreedy Integer or \code{NULL}. Number of greedily-added components. -#' \code{NULL} (default) disables the greedy loop and fits \code{L} -#' directly. -#' @param verbose If TRUE, prints mvSuSiE fitting progress. -#' @param ... Additional arguments passed to `fitMvsusie()` when fitting. +#' @param mvsusieFit A fitted mvSuSiE object. Required. #' @return Matrix of variant weights. #' @examples #' \donttest{ @@ -2723,63 +3211,38 @@ susieAshRssWeights <- function( #' data(multiTraitData) #' X <- multiTraitData$X[, 1:60] #' Y <- multiTraitData$Y -#' mvsusieWeights(X = X, Y = Y, L = 5, LGreedy = 2) +#' fit <- fitMvsusie(X = X, Y = Y, +#' prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y)), +#' methodArgs = MvsusieOptions(L = 5)) +#' mvsusieWeights(mvsusieFit = fit) #' } #' @export -mvsusieWeights <- function( - mvsusieFit = NULL, - X = NULL, - Y = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - verbose = FALSE, - ... -) { +mvsusieWeights <- function(mvsusieFit = NULL) { if (!requireNamespace("mvsusieR", quietly = TRUE)) { - msg <- glue( - "Package 'mvsusieR' is required. Install with: ", - "devtools::install_github('stephenslab/mvsusieR')" - ) - abort(msg) + abort("Package 'mvsusieR' is required.") } if (is.null(mvsusieFit)) { - inform("mvsusieFit is not provided; fitting mvSuSiE now ...") - if (is.null(X) || is.null(Y)) { - abort("Both X and Y must be provided if mvsusieFit is NULL.") - } - if (is.null(priorVariance)) { - priorVariance <- mvsusieR::create_mixture_prior(R = ncol(Y)) - } - if (!is.null(LGreedy)) { - LGreedy <- min(LGreedy, L) - } - - mvsusieFit <- fitMvsusie( - X = X, - Y = Y, - L = L, - L_greedy = LGreedy, - prior_variance = priorVariance, - residual_variance = residualVariance, - estimate_residual_variance = TRUE, - verbose = verbose, - ... + msg <- glue( + "mvsusieWeights: `mvsusieFit` is required. This extracts weights ", + "from an existing mvSuSiE fit and never runs fine-mapping ", + "itself; fit it via fineMappingPipeline() and pass the result in." ) + abort(msg) } - return(mvsusieR::coef.mvsusie(mvsusieFit)[-1, ]) + mvsusieR::coef.mvsusie(mvsusieFit)[-1, , drop = FALSE] } # One wavelet basis row: inverse-DWT (wr) of the unit coefficient vector e_k, # using the fit's template DWT object. # @noRd .fmReconstructUnit <- function(k, nWac, scaleCols, template) { - coeffRow <- numeric(nWac) - coeffRow[k] <- 1 - temp <- template - temp$D <- coeffRow[-scaleCols] - temp$C[length(temp$C)] <- sum(coeffRow[scaleCols]) + coeffRow <- replace(numeric(nWac), k, 1) + scaling <- replace( + template$C, + length(template$C), + sum(coeffRow[scaleCols]) + ) + temp <- list_assign(template, D = coeffRow[-scaleCols], C = scaling) as.numeric(wavethresh::wr(temp)) } @@ -2837,7 +3300,10 @@ mvsusieWeights <- function( #' \code{names(fsusieFit$csd_X)} / \code{names(fsusieFit$pip)}. #' @param featureNames Optional character vector of feature (outcome) names for #' the matrix column names. Defaults to the fit's \code{outing_grid}. -#' @param retainFit If TRUE, stores the fit as an attribute on the result. +#' @param fitRetention How much of the fit is kept on the returned weights: +#' \code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +#' it as the \code{"fit"} attribute. These extractors hold no trimmable +#' intermediates, so the two retaining levels behave alike here. #' @return A numeric matrix of variant (rows) by feature (columns) weights. #' @examples #' data(eqtlRegionExample) @@ -2860,8 +3326,9 @@ fsusieWeights <- function( Y = NULL, variantIds = NULL, featureNames = NULL, - retainFit = FALSE + fitRetention = c("none", "slim", "full") ) { + fitRetention <- arg_match(fitRetention) if (is.null(fsusieFit)) { msg <- glue( "fsusieWeights: `fsusieFit` is required. fSuSiE is functional ", @@ -2871,7 +3338,7 @@ fsusieWeights <- function( ) abort(msg) } - fast <- .fsusieWeightsFastPath(fsusieFit, variantIds, retainFit) + fast <- .fsusieWeightsFastPath(fsusieFit, variantIds, fitRetention) if (!is.null(fast)) { return(fast) } @@ -2881,34 +3348,39 @@ fsusieWeights <- function( csdX <- as.numeric(fit$csd_X) alphaList <- .fsusieAlphaList(fit$alpha) S <- .fsusieSynthesisMatrix(fit$n_wac, .fsusieScaleCols(fit)) - W <- .fsusieComputeW(fit, alphaList, csdX, S) - W <- .fsusieWeightsNames( - W, - fit, - variantIds, - featureNames, - length(csdX), - ncol(S) - ) - if (retainFit) { - attr(W, "fit") <- fit + W <- .fsusieComputeW(fit, alphaList, csdX, S) |> + .fsusieWeightsNames( + fit, + variantIds, + featureNames, + length(csdX), + ncol(S) + ) + if (identical(fitRetention, "none")) { + return(W) } - W + `attr<-`(W, "fit", fit) +} + +# Row names only mean the variants when there is one per row of the matrix. +# @noRd +.withRownamesIfSized <- function(W, variantIds) { + if (is.null(variantIds) || length(variantIds) != nrow(W)) { + return(W) + } + `rownames<-`(W, variantIds) } # Fast path: a trimmed fit carries the precomputed variants x features weight # matrix in `$coef` (fineMappingPipeline computes it eagerly while the full fit # is in hand, since trimming drops fitted_wc/csd_X/...). NULL if not applicable. -.fsusieWeightsFastPath <- function(fsusieFit, variantIds, retainFit) { +.fsusieWeightsFastPath <- function(fsusieFit, variantIds, fitRetention) { if (!(is.matrix(fsusieFit$coef) && is.null(fsusieFit$fitted_wc))) { return(NULL) } - W <- fsusieFit$coef - if (!is.null(variantIds) && length(variantIds) == nrow(W)) { - rownames(W) <- variantIds - } - if (retainFit) { - attr(W, "fit") <- fsusieFit + W <- .withRownamesIfSized(fsusieFit$coef, variantIds) + if (!identical(fitRetention, "none")) { + return(`attr<-`(W, "fit", fsusieFit)) } W } @@ -2967,66 +3439,76 @@ fsusieWeights <- function( # W = sum_l (alpha_l/csd_X-scaled fitted_wc_l) %*% S, one wavelet inverse # transform (S) applied to every SNP/effect via a matrix multiply. +# @noRd +.fsusieSetCoverage <- function(i, fsusieObj) { + sum(fsusieObj$alpha[[i]][fsusieObj$cs[[i]]]) +} + +# One effect's contribution to the weight matrix. +# @noRd +.fsusieEffectW <- function(l, fit, alphaList, invCsd, S) { + (alphaList[[l]] * invCsd * as.matrix(fit$fitted_wc[[l]])) %*% S +} + .fsusieComputeW <- function(fit, alphaList, csdX, S) { invCsd <- 1 / csdX - W <- matrix(0, nrow = length(csdX), ncol = ncol(S)) - for (l in seq_along(fit$fitted_wc)) { - wc <- as.matrix(fit$fitted_wc[[l]]) - W <- W + (alphaList[[l]] * invCsd * wc) %*% S - } - W + # W is the sum of the per-effect contributions, so it is a fold rather + # than a matrix added into repeatedly. + reduce( + map( + seq_along(fit$fitted_wc), + .fsusieEffectW, + fit = fit, + alphaList = alphaList, + invCsd = invCsd, + S = S + ), + `+`, + .init = matrix(0, nrow = length(csdX), ncol = ncol(S)) + ) } # Attach variant (row) and feature/grid (column) names to the weight matrix. .fsusieWeightsNames <- function(W, fit, variantIds, featureNames, p, nFeat) { - rn <- variantIds - if (is.null(rn)) { - rn <- names(fit$csd_X) - } - if (is.null(rn)) { - rn <- names(fit$pip) - } - if (!is.null(rn) && length(rn) == p) { - rownames(W) <- rn - } - cn <- featureNames - if ( - is.null(cn) && + rn <- variantIds %||% names(fit$csd_X) %||% names(fit$pip) + cn <- if ( + is.null(featureNames) && !is.null(fit$outing_grid) && length(fit$outing_grid) == nFeat ) { - cn <- as.character(fit$outing_grid) - } - if (!is.null(cn) && length(cn) == nFeat) { - colnames(W) <- cn + as.character(fit$outing_grid) + } else { + featureNames } - W + `dimnames<-`( + W, + list( + if (length(rn) == p) rn else rownames(W), + if (length(cn) == nFeat) cn else colnames(W) + ) + ) } #' Compute mvSuSiE-RSS TWAS weights from summary statistics #' #' Multi-context summary-statistics analog of \code{\link{mvsusieWeights}}: -#' extracts coefficients from an existing \code{mvsusieR::mvsusie_rss} fit, or -#' fits one from \code{stat$z} (variants x conditions) and \code{LD}. +#' extracts coefficients from an existing \code{mvsusieR::mvsusie_rss} fit. +#' It never runs fine-mapping itself --- \code{mvsusieRssFit} is required. #' -#' Follows the \code{*_rss_weights(stat, LD, ...)} contract. Expects -#' \code{stat$z} to be a numeric matrix (variants x conditions) and -#' \code{stat$n} a per-context vector or scalar. +#' Follows the \code{*_rss_weights(stat, LD, ...)} contract: \code{stat} and +#' \code{LD} describe the block the fit is being extracted against, and the +#' fit is checked against them rather than refitted. #' #' @param stat A list with \code{z} (matrix variants x conditions) and \code{n} -#' (numeric vector or scalar). -#' @param LD LD correlation matrix. -#' @param mvsusieRssFit Optional pre-fitted \code{mvsusieRss} object. -#' @param priorVariance Optional mvSuSiE prior variance specification. When -#' NULL, \code{mvsusieR::create_mixture_prior()} is used with \code{R = -#' ncol(stat$z)}. -#' @param residualVariance Optional residual covariance matrix. -#' @param L Maximum number of single effects. Default \code{10}, matching -#' \code{mvsusieR::mvsusie}. -#' @param LGreedy Integer or \code{NULL}. Number of greedily-added effects. -#' \code{NULL} (default) disables the greedy loop and fits \code{L} -#' directly. -#' @param retainFit If TRUE, attaches the fitted object as an attribute. -#' @param ... Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}. +#' (numeric vector or scalar), describing the block the fit came from. +#' @param LD LD correlation matrix for that block. The fit must cover the +#' same number of variants; a mismatch is an error, since weights from one +#' block are not comparable against another's LD. +#' @param mvsusieRssFit A fitted \code{mvsusieRss} object. Required: this +#' extracts weights and never runs fine-mapping itself. +#' @param fitRetention How much of the fit is kept on the returned weights: +#' \code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +#' it as the \code{"fit"} attribute. These extractors hold no trimmable +#' intermediates, so the two retaining levels behave alike here. #' #' @return A numeric matrix of per-variant per-context weights (variants x #' conditions). @@ -3051,102 +3533,74 @@ mvsusieRssWeights <- function( stat, LD, mvsusieRssFit = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - retainFit = FALSE, - ... + fitRetention = c("none", "slim", "full") ) { + assertList(stat) + fitRetention <- arg_match(fitRetention) if (!requireNamespace("mvsusieR", quietly = TRUE)) { - msg <- glue( - "Package 'mvsusieR' is required. ", - "Install with: devtools::install_github('stephenslab/mvsusieR')" - ) - abort(msg) + abort("Package 'mvsusieR' is required.") } if (is.null(mvsusieRssFit)) { - mvsusieRssFit <- .mvsusieRssBuildFit( - stat, - LD, - priorVariance, - residualVariance, - L, - LGreedy, - ... + msg <- glue( + "mvsusieRssWeights: `mvsusieRssFit` is required. This extracts ", + "weights from an existing mvSuSiE-RSS fit and never runs ", + "fine-mapping itself; fit it via fineMappingPipeline() and pass ", + "the result in." ) + abort(msg) } weights <- mvsusieR::coef.mvsusie(mvsusieRssFit)[-1, , drop = FALSE] - if (retainFit) { - attr(weights, "fit") <- mvsusieRssFit + # `stat` / `LD` describe the block the fit is being combined with. The + # susie *RssWeights wrappers check the fit against them; this one used + # to take both and read neither, so a fit from a different block was + # extracted without complaint. + .mvsusieRssAssertBlock(weights, LD) + if (identical(fitRetention, "none")) { + return(weights) } - weights + `attr<-`(weights, "fit", mvsusieRssFit) } -# Build the mvsusie-RSS fit from summary stats when the caller supplied none. +# The supplied fit must describe the LD block it is being extracted against; +# the pairing is what makes the weights comparable across a region. # @noRd -.mvsusieRssBuildFit <- function( - stat, - LD, - priorVariance, - residualVariance, - L, - LGreedy, - ... -) { - Z <- if (is.matrix(stat$z)) stat$z else as.matrix(stat$z) - if (ncol(Z) < 2) { - msg <- glue( - "mvsusieRssWeights expects stat$z to have >= 2 columns ", - "(one per context). For single-context use ", - "susieRssWeights()." - ) - abort(msg) +.mvsusieRssAssertBlock <- function(weights, LD) { + if (is.null(LD) || nrow(weights) == nrow(LD)) { + return(invisible(NULL)) } - # mvsusieR::mvsusie_rss expects N to be a single scalar - nScalar <- as.numeric(stats::median(stat$n)) - if (is.null(priorVariance)) { - priorVariance <- mvsusieR::create_mixture_prior(R = ncol(Z)) - } - if (!is.null(LGreedy)) { - LGreedy <- min(LGreedy, L) - } - fitMvsusieRss( - Z = Z, - R = LD, - N = nScalar, - L = L, - L_greedy = LGreedy, - prior_variance = priorVariance, - residual_variance = residualVariance, - ... - ) + abort(glue( + "Dimension mismatch: mvsusieRss fit has {nrow(weights)} variants ", + "but LD has {nrow(LD)} rows." + )) } + # ============================================================================= # Cross-condition credible-set merging # ============================================================================= # Identify variant IDs that are associated with more than one credible set. # @noRd +# The sets a variant belongs to, but only when it belongs to more than one. +# @noRd +.ovlMultiSets <- function(entry) { + sets <- entry[["sets"]] + if (length(sets) > 1) sets else NULL +} + .identifyOverlapSets <- function(variantsSetsAndPipsList) { - overlapSets <- list() - for (variantId in names(variantsSetsAndPipsList)) { - sets <- variantsSetsAndPipsList[[variantId]][["sets"]] - if (length(sets) > 1) { - overlapSets[[variantId]] <- sets - } - } - return(overlapSets) + compact(map(variantsSetsAndPipsList, .ovlMultiSets)) } # Union-find root of `x` following the `parent` map. # @noRd .ufFindRoot <- function(x, parent) { - while (!identical(parent[[x]], x)) { - x <- parent[[x]] + # Walking to the root recursively rather than reassigning `x`; union-find + # trees are shallow, so the depth is not a concern. + if (identical(parent[[x]], x)) { + return(x) } - x + .ufFindRoot(parent[[x]], parent) } # Union-find merge of `a` and `b` in `parent`; returns the updated parent map. @@ -3154,40 +3608,58 @@ mvsusieRssWeights <- function( .ufUnion <- function(a, b, parent) { rootA <- .ufFindRoot(a, parent) rootB <- .ufFindRoot(b, parent) - if (!identical(rootA, rootB)) { - parent[[rootB]] <- rootA + if (identical(rootA, rootB)) { + return(parent) } - parent + `[[<-`(parent, rootB, value = rootA) } # Merge overlapping credible sets using connected components (union-find). # @noRd -.mergeAndUpdateOverlapSets <- function(variantsSetsAndPipsList, overlapSets) { - allSets <- unique(unlist(overlapSets)) - if (length(allSets) == 0) { +# @noRd +.ufPair <- function(s, first) { + list(a = first, b = s) +} + +# One overlap's (first set, other set) pairs. +# @noRd +.ufOverlapPairs <- function(sets) { + if (length(sets) <= 1) { return(list()) } + map(sets[-1], .ufPair, first = sets[[1]]) +} - parent <- set_names(allSets, allSets) - for (sets in overlapSets) { - if (length(sets) > 1) { - for (s in sets[-1]) { - parent <- .ufUnion(sets[[1]], s, parent) - } - } +# @noRd +.ufUnionPair <- function(parent, pair) { + .ufUnion(pair$a, pair$b, parent) +} + +# Every member of one component mapped to that component's joint label. +# @noRd +.ufComponentLabels <- function(members) { + label <- str_flatten(sort(members), ",") + set_names(as.list(rep(label, length(members))), members) +} + +.mergeAndUpdateOverlapSets <- function(variantsSetsAndPipsList, overlapSets) { + allSets <- unique(list_c(overlapSets)) + if (length(allSets) == 0) { + return(list()) } + # Each overlap ties its sets to the first one; the merges are a fold over + # those pairs, since every union sees the map the previous one produced. + parent <- reduce( + .fmwConcat(map(overlapSets, .ufOverlapPairs)), + .ufUnionPair, + .init = set_names(allSets, allSets) + ) components <- split( names(parent), map_chr(names(parent), .ufFindRoot, parent) ) - setNameMap <- list() - for (members in components) { - label <- str_flatten(sort(members), ",") - for (s in members) { - setNameMap[[s]] <- label - } - } + setNameMap <- .fmwConcat(map(components, .ufComponentLabels)) # Update each variant's credible set names updatedCredibleSets <- map( @@ -3334,8 +3806,12 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { #' @examples #' data(qtlSumStatsExample) #' getSusieResult(qtlSumStatsExample) +#' @importFrom checkmate assertList #' @export getSusieResult <- function(conData) { + # No type guard: this is duck-typed on `$` and `length()` and returns NULL + # for anything without a `finemappingEntry`. Its own @example passes a + # QtlSumStats, which assertList rejects. if (length(conData) == 0) { return(NULL) } @@ -3355,8 +3831,10 @@ getSusieResult <- function(conData) { #' This function extracts and processes information for each Credible Set (CS) #' from finemapping results, typically obtained from a finemapping RDS file. #' -#' @param fmRow A \code{\link{fineMappingRow}} carrying the SuSiE -#' fit and variant ids (e.g. from \code{\link{getFineMappingResult}}). +#' @param fmRow A \code{\link{fineMappingRow}}, or a single-row +#' fine-mapping collection as returned by +#' \code{\link{getFineMappingResult}}, carrying the SuSiE fit and +#' variant ids. #' @param csNames Character vector. Names of the Credible Sets, usually in the #' format "L_". #' @param topLociTable Data frame. The top-loci table (e.g. from @@ -3405,8 +3883,10 @@ getSusieResult <- function(conData) { #' extractCsInfo(fe, csNames = "L_1", topLociTable = tl, #' ldSource = qtlSumStatsExample) #' +#' @importFrom checkmate assertClass assertCharacter #' @export extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { + assertCharacter(csNames, any.missing = FALSE) fm <- fmRow trimmed <- .fmrPartsSusieFit(fm) variantNames <- .fmrPartsVariantIds(fm) @@ -3428,8 +3908,10 @@ extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { #' Posterior Inclusion Probability (PIP) from finemapping results, typically #' used when no Credible Sets (CS) are identified in the analysis. #' -#' @param fmRow A \code{\link{fineMappingRow}} carrying the SuSiE -#' fit and variant ids (e.g. from \code{\link{getFineMappingResult}}). +#' @param fmRow A \code{\link{fineMappingRow}}, or a single-row +#' fine-mapping collection as returned by +#' \code{\link{getFineMappingResult}}, carrying the SuSiE fit and +#' variant ids. #' @param sumstats A list or data frame carrying a \code{z} element aligned to #' the fit's variants (\code{sumstats$z}). #' @@ -3465,6 +3947,7 @@ extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { #' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) #' extractTopPipInfo(fe, sumstats = list(z = c(1.0, 3.5, -0.5))) #' +#' @importFrom checkmate assertClass #' @export extractTopPipInfo <- function(fmRow, sumstats) { fm <- fmRow @@ -3516,8 +3999,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { return(mutate(base, cs_corr_max = NA_real_, cs_corr_min = NA_real_)) } perRow <- apply(csCorr, 1L, .extractCorrelations, simplify = FALSE) - expanded <- as_tibble(csCorr, .name_repair = "minimal") - names(expanded) <- str_c("cs_corr_", seq_len(ncol(csCorr))) + expanded <- `names<-`( + as_tibble(csCorr, .name_repair = "minimal"), + str_c("cs_corr_", seq_len(ncol(csCorr))) + ) # unname(): apply() names its result by the matrix rownames, which map_dbl # then carries into the column (tibbles preserve element names). base |> @@ -3592,10 +4077,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { coverage = coverage, unmappable_effects = info$unmappableEffects ) - if (!is.null(chainFromInf) && token != "susieInf") { + fitArgs <- if (!is.null(chainFromInf) && token != "susieInf") { # SuSiE(-ash) initialised from a SuSiE-inf fit. userArgs are folded - # into the - # arg prep (not merged afterwards) so L_greedy is clamped to + # into the arg prep (not merged afterwards) so L_greedy is clamped to # min(#inf effects, L) rather than passed through raw. chainedArgs <- prepareSusieFromInfArgs( .fmMergeUserArgs(list(), token, userArgs), @@ -3603,22 +4087,20 @@ extractTopPipInfo <- function(fmRow, sumstats) { refineDefault = if (token == "susie") TRUE else NULL, unmappableEffects = if (token == "susieAsh") "ash" else "none" ) - baseArgs <- modifyList(baseArgs, chainedArgs) - baseArgs$X <- X - baseArgs$y <- y - baseArgs$coverage <- coverage + list_assign( + list_modify(baseArgs, !!!compact(chainedArgs)), + X = X, + y = y, + coverage = coverage + ) } else { - if (token == "susieInf") { - baseArgs$convergence_method <- "pip" - baseArgs$refine <- FALSE - baseArgs$model_init <- NULL - } else if (token == "susieAsh") { - baseArgs$convergence_method <- "pip" - } - baseArgs <- .fmMergeUserArgs(baseArgs, token, userArgs) + .fmMergeUserArgs( + list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), + token, + userArgs + ) } - fit <- exec(susieR::susie, !!!baseArgs) - .setFinemappingFitClass(fit, token) + .setFinemappingFitClass(exec(susieR::susie, !!!fitArgs), token) } @@ -3638,20 +4120,24 @@ extractTopPipInfo <- function(fmRow, sumstats) { rssControl = NULL ) { info <- .fmRssValidateToken(token) - baseArgs <- list( - z = z, - R = R, - n = n, - coverage = coverage, - unmappable_effects = info$unmappableEffects + baseArgs <- .fmRssAddControl( + c( + list( + z = z, + R = R, + n = n, + coverage = coverage, + unmappable_effects = info$unmappableEffects + ), + # rFinite = NULL omits the element -> susie_rss default; these sit + # in baseArgs so they survive the chained modifyList / non-chained + # userArgs merge, while user methodArgs (folded in after) still + # override them. + compact(list(R_finite = rFinite, R_mismatch = rMismatch)) + ), + rssControl ) - # rFinite = NULL removes the element -> susie_rss default; these sit in - # baseArgs so they survive the chained modifyList / non-chained userArgs - # merge, while user methodArgs (folded in after) still override them. - baseArgs$R_finite <- rFinite - baseArgs$R_mismatch <- rMismatch - baseArgs <- .fmRssAddControl(baseArgs, rssControl) - baseArgs <- if (!is.null(chainFromInf) && token != "susieInf") { + fitArgs <- if (!is.null(chainFromInf) && token != "susieInf") { .fmRssChainedArgs( baseArgs, token, @@ -3667,7 +4153,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { } # All susie_rss fits get the "susieRss" S3 class for post-processing (drives # the Xcorr cs-input mode); token distinction stays in the `method` column. - .setFinemappingFitClass(exec(susieR::susie_rss, !!!baseArgs), "susieRss") + .setFinemappingFitClass(exec(susieR::susie_rss, !!!fitArgs), "susieRss") } # Validate the method token and return its capability record. @@ -3699,8 +4185,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { ) abort(msg) } - baseArgs$control <- exec(susieR::susie_rss_control, !!!rssControl) - baseArgs + list_assign( + baseArgs, + control = exec(susieR::susie_rss_control, !!!rssControl) + ) } # SuSiE-RSS(-ash) initialised from a SuSiE-inf fit; userArgs folded into the arg @@ -3721,24 +4209,35 @@ extractTopPipInfo <- function(fmRow, sumstats) { refineDefault = if (token == "susie") TRUE else NULL, unmappableEffects = if (token == "susieAsh") "ash" else "none" ) - baseArgs <- modifyList(baseArgs, chainedArgs) - baseArgs$z <- z - baseArgs$R <- R - baseArgs$n <- n - baseArgs$coverage <- coverage - baseArgs + list_assign( + list_modify(baseArgs, !!!compact(chainedArgs)), + z = z, + R = R, + n = n, + coverage = coverage + ) } # Non-chained fit: token-specific defaults then the user methodArgs merge. .fmRssNonChainedArgs <- function(baseArgs, token, userArgs) { + .fmMergeUserArgs( + list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), + token, + userArgs + ) +} + +# Token-specific susie defaults. `model_init` is deliberately not among them: +# baseArgs never carries one, so susieR's own default already applies. +# @noRd +.fmSusieTokenDefaults <- function(token) { if (token == "susieInf") { - baseArgs$convergence_method <- "pip" - baseArgs$refine <- FALSE - baseArgs$model_init <- NULL - } else if (token == "susieAsh") { - baseArgs$convergence_method <- "pip" + return(list(convergence_method = "pip", refine = FALSE)) + } + if (token == "susieAsh") { + return(list(convergence_method = "pip")) } - .fmMergeUserArgs(baseArgs, token, userArgs) + list() } # Single-effect (SER) sumstat fit via susieR::susie_ser on z + n. LD-free (no R, @@ -3760,15 +4259,102 @@ extractTopPipInfo <- function(fmRow, sumstats) { # univariate dispatch so the same logic serves the cis path (one block), the # jointRegions=TRUE path (one concatenated block) and the jointRegions=FALSE # path (one block per region, merged afterwards via .fmMergeEntries). +# One token's fit plus its postprocessing, or NULL when the fit did not run. +# @noRd +.fmXFitAndPostprocess <- function( + tk, + chainLocal, + infFit, + X, + y, + credibleSetArgs, + methodArgs, + verbose, + ctx, + tid, + af, + fitRetention +) { + fit <- .fmXFitOne( + tk, + chainLocal, + infFit, + X = X, + y = y, + coverage = credibleSetArgs$coverage, + methodArgs = methodArgs, + verbose = verbose, + ctx = ctx, + tid = tid + ) + if (is.null(fit)) { + return(NULL) + } + .fmXPostprocess( + fit, + tk, + X = X, + y = y, + credibleSetArgs = credibleSetArgs, + af = af, + fitRetention = fitRetention + ) +} + +# Fit every requested method on one individual-level block. The susie-inf +# pre-fit is built first because the chained methods take it as their +# starting point; `chainLocal` says which of them actually chain. +# @noRd +.fmXFitAll <- function( + toRun, + addSusieInf, + X, + y, + credibleSetArgs, + methodArgs, + verbose, + ctx, + tid, + af, + fitRetention +) { + chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) + infFit <- .fmXInfFit( + chainLocal, + X = X, + y = y, + coverage = credibleSetArgs$coverage, + methodArgs = methodArgs, + verbose = verbose, + ctx = ctx, + tid = tid + ) + compact(set_names( + map( + toRun, + .fmXFitAndPostprocess, + chainLocal = chainLocal, + infFit = infFit, + X = X, + y = y, + credibleSetArgs = credibleSetArgs, + methodArgs = methodArgs, + verbose = verbose, + ctx = ctx, + tid = tid, + af = af, + fitRetention = fitRetention + ), + toRun + )) +} + .fmFitXBlock <- function( X, y, toRun, addSusieInf, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, + credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), methodArgs, verbose, ctx, @@ -3777,47 +4363,80 @@ extractTopPipInfo <- function(fmRow, sumstats) { cvThreads = 1, samplePartition = NULL, af = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, + fitRetention = "slim", seed = NULL ) { - p <- as.list(environment()) - chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) - infFit <- .fmXInfFit(p, chainLocal) - out <- list() - for (tk in toRun) { - fit <- .fmXFitOne(tk, p, chainLocal, infFit) - if (is.null(fit)) { - next - } - out[[tk]] <- .fmXPostprocess(fit, tk, p) - } - .fmXCrossValidate(out, p) + out <- .fmXFitAll( + toRun, + addSusieInf = addSusieInf, + X = X, + y = y, + credibleSetArgs = credibleSetArgs, + methodArgs = methodArgs, + verbose = verbose, + ctx = ctx, + tid = tid, + af = af, + fitRetention = fitRetention + ) + .fmXCrossValidate( + out, + X = X, + y = y, + coverage = credibleSetArgs$coverage, + methodArgs = methodArgs, + cvFolds = cvFolds, + cvThreads = cvThreads, + samplePartition = samplePartition, + seed = seed, + verbose = verbose, + ctx = ctx, + tid = tid + ) } # Fit the shared susieInf model once, if the requested chain needs it. -.fmXInfFit <- function(p, chainLocal) { +.fmXInfFit <- function( + chainLocal, + X, + y, + coverage, + methodArgs, + verbose, + ctx, + tid +) { if (!chainLocal$runInf) { return(NULL) } - if (p$verbose >= 1) { + if (verbose >= 1) { msg <- glue( - "Fitting susieInf for (context='{p$ctx}', trait='{p$tid}') ..." + "Fitting susieInf for (context='{ctx}', trait='{tid}') ..." ) inform(msg) } .fmFitSusieIndiv( - p$X, - p$y, + X, + y, "susieInf", - coverage = p$coverage, - userArgs = p$methodArgs[["susieInf"]] + coverage = coverage, + userArgs = methodArgs[["susieInf"]] ) } # Resolve the fit for one method token; NULL means "skip this token". -.fmXFitOne <- function(tk, p, chainLocal, infFit) { +.fmXFitOne <- function( + tk, + chainLocal, + infFit, + X, + y, + coverage, + methodArgs, + verbose, + ctx, + tid +) { if (tk == "susieInf") { if (!chainLocal$keepInf) { return(NULL) @@ -3832,70 +4451,91 @@ extractTopPipInfo <- function(fmRow, sumstats) { } else { NULL } - if (p$verbose >= 1) { + if (verbose >= 1) { msg <- glue( - "Fitting {tk} for (context='{p$ctx}', trait='{p$tid}') ..." + "Fitting {tk} for (context='{ctx}', trait='{tid}') ..." ) inform(msg) } .fmFitSusieIndiv( - p$X, - p$y, + X, + y, tk, chainFromInf = chainFrom, - coverage = p$coverage, - userArgs = p$methodArgs[[tk]] + coverage = coverage, + userArgs = methodArgs[[tk]] ) } # Post-process one individual-level fit into a finemapping entry. -.fmXPostprocess <- function(fit, tk, p) { +.fmXPostprocess <- function( + fit, + tk, + X, + y, + credibleSetArgs, + af, + fitRetention +) { .fmPostprocessOne( fit = fit, method = tk, - dataX = p$X, - dataY = p$y, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - minAbsCorr = p$minAbsCorr, - af = p$af, + dataX = X, + dataY = y, + af = af, csInput = "X", - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + credibleSetArgs = credibleSetArgs, + fitRetention = fitRetention ) } # Per-fold cross-validation across the fitted methods; attach each method's # out-of-fold predictions to its entry. -.fmXCrossValidate <- function(out, p) { - if (!(p$cvFolds > 1L && length(out) > 0L)) { +.fmXCrossValidate <- function( + out, + X, + y, + coverage, + methodArgs, + cvFolds, + cvThreads, + samplePartition, + seed, + verbose, + ctx, + tid +) { + if (!(cvFolds > 1L && length(out) > 0L)) { return(out) } - if (p$verbose >= 1) { + if (verbose >= 1) { msg <- glue( - "Cross-validating ({p$cvFolds} folds) for ", - "(context='{p$ctx}', trait='{p$tid}') ..." + "Cross-validating ({cvFolds} folds) for ", + "(context='{ctx}', trait='{tid}') ..." ) inform(msg) } cv <- .fmWeightsCv( - p$X, - p$y, + X, + y, names(out), - p$methodArgs, - p$cvFolds, - samplePartition = p$samplePartition, - coverage = p$coverage, - verbose = p$verbose, - numThreads = p$cvThreads, - seed = p$seed + methodArgs, + cvFolds, + samplePartition = samplePartition, + coverage = coverage, + verbose = verbose, + numThreads = cvThreads, + seed = seed + ) + set_names( + map(names(out), .fmAttachCvAt, out = out, cv = cv), + names(out) ) - for (tk in names(out)) { - out[[tk]] <- .fmAttachCv(out[[tk]], .fmSliceCv(cv, tk)) - } - out +} + +# @noRd +.fmAttachCvAt <- function(tk, out, cv) { + .fmAttachCv(out[[tk]], .fmSliceCv(cv, tk)) } # Fit every requested RSS token on one (z, R, n) sumstat block, returning a @@ -3908,67 +4548,146 @@ extractTopPipInfo <- function(fmRow, sumstats) { n, toRun, addSusieInf, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, + credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), methodArgs, verbose, label, af = NULL, nVar = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - serFallback = FALSE, - rFinite = NULL, - rMismatch = "none", - rssControl = NULL, - keepFullFit = "fallback" + fitRetention = "slim", + rssArgs ) { - p <- as.list(environment()) chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) - infFit <- .fmRssInfFit(p, chainLocal) - out <- list() - for (tk in toRun) { - f <- .fmRssFitOne(tk, p, chainLocal, infFit) - if (is.null(f)) { - next - } - ent <- .fmRssPostprocess(f$fit, p) - if (f$isStd && isTRUE(p$serFallback)) { - ent <- .fmRssRecordFallback(ent, f, p$keepFullFit) - } - out[[tk]] <- ent + infFit <- .fmRssInfFit( + chainLocal, + z = z, + R = R, + n = n, + coverage = credibleSetArgs$coverage, + methodArgs = methodArgs, + rssArgs = rssArgs, + verbose = verbose, + label = label + ) + compact(set_names( + map( + toRun, + .fmRssFitAndPostprocess, + chainLocal = chainLocal, + infFit = infFit, + z = z, + R = R, + n = n, + credibleSetArgs = credibleSetArgs, + methodArgs = methodArgs, + rssArgs = rssArgs, + verbose = verbose, + label = label, + af = af, + nVar = nVar, + fitRetention = fitRetention + ), + toRun + )) +} + +# One RSS token's fit, postprocessed and (when it fell back to the single +# effect model) labelled as such. NULL when the fit did not run. +# @noRd +.fmRssFitAndPostprocess <- function( + tk, + chainLocal, + infFit, + z, + R, + n, + credibleSetArgs, + methodArgs, + rssArgs, + verbose, + label, + af, + nVar, + fitRetention +) { + f <- .fmRssFitOne( + tk, + chainLocal, + infFit, + z = z, + R = R, + n = n, + coverage = credibleSetArgs$coverage, + methodArgs = methodArgs, + rssArgs = rssArgs, + verbose = verbose, + label = label + ) + if (is.null(f)) { + return(NULL) } - out + entry <- .fmRssPostprocess( + f$fit, + R = R, + z = z, + credibleSetArgs = credibleSetArgs, + af = af, + nVar = nVar, + fitRetention = fitRetention + ) + if (f$isStd && isTRUE(rssArgs$serFallback)) { + return(.fmRssRecordFallback(entry, f, rssArgs$keepFullFit)) + } + entry } # Fit the shared susieInf (RSS) model once, if the requested chain needs it. -.fmRssInfFit <- function(p, chainLocal) { +.fmRssInfFit <- function( + chainLocal, + z, + R, + n, + coverage, + methodArgs, + rssArgs, + verbose, + label +) { if (!chainLocal$runInf) { return(NULL) } - if (p$verbose >= 1) { - msg <- glue("Fitting susieInf (RSS) for {p$label} ...") + if (verbose >= 1) { + msg <- glue("Fitting susieInf (RSS) for {label} ...") inform(msg) } .fmFitSusieRss( - p$z, - p$R, - p$n, + z, + R, + n, "susieInf", - coverage = p$coverage, - userArgs = p$methodArgs[["susieInf"]], - rFinite = p$rFinite, - rMismatch = p$rMismatch, - rssControl = p$rssControl + coverage = coverage, + userArgs = methodArgs[["susieInf"]], + rFinite = rssArgs$rFinite, + rMismatch = rssArgs$rMismatch, + rssControl = .rssControlList(rssArgs$control) ) } # Standard multi-effect SuSiE-RSS fit (susie / susieAsh): the only branch that # carries susieR's finite-sample R diagnostics and honours the SER fallback. -.fmRssFitStd <- function(tk, p, chainLocal, infFit) { +.fmRssFitStd <- function( + tk, + chainLocal, + infFit, + z, + R, + n, + coverage, + methodArgs, + rssArgs, + verbose, + label +) { chainFrom <- if ( (tk == "susie" && chainLocal$chainSusie) || (tk == "susieAsh" && chainLocal$chainAsh) @@ -3977,38 +4696,63 @@ extractTopPipInfo <- function(fmRow, sumstats) { } else { NULL } - if (p$verbose >= 1) { - msg <- glue("Fitting {tk} (RSS) for {p$label} ...") + if (verbose >= 1) { + msg <- glue("Fitting {tk} (RSS) for {label} ...") inform(msg) } fit <- .fmFitSusieRss( - p$z, - p$R, - p$n, + z, + R, + n, tk, chainFromInf = chainFrom, - coverage = p$coverage, - userArgs = p$methodArgs[[tk]], - rFinite = p$rFinite, - rMismatch = p$rMismatch, - rssControl = p$rssControl + coverage = coverage, + userArgs = methodArgs[[tk]], + rFinite = rssArgs$rFinite, + rMismatch = rssArgs$rMismatch, + rssControl = .rssControlList(rssArgs$control) ) + .fmRssSerFallback(fit, rssArgs) +} + +# An unreliable LD matrix makes the multi-effect fit untrustworthy, so with +# `serFallback` the single-effect model susie_rss already produced is +# returned instead -- with the multi-effect fit kept alongside it, since +# the caller may still want to inspect what was rejected. +# @noRd +.fmRssSerFallback <- function(fit, rssArgs) { rfd <- fit$R_finite_diagnostics flag <- if (!is.null(rfd) && !is.null(rfd$R_reliability_flag)) { isTRUE(rfd$R_reliability_flag) } else { NA } - multiFit <- NULL - if (isTRUE(p$serFallback) && isTRUE(flag) && !is.null(rfd$ser_model)) { - multiFit <- fit - fit <- .setFinemappingFitClass(rfd$ser_model, "susieRss") + if ( + !isTRUE(rssArgs$serFallback) || !isTRUE(flag) || is.null(rfd$ser_model) + ) { + return(list(fit = fit, flag = flag, multiFit = NULL)) } - list(fit = fit, flag = flag, multiFit = multiFit) + list( + fit = .setFinemappingFitClass(rfd$ser_model, "susieRss"), + flag = flag, + multiFit = fit + ) } # Resolve the fit for one method token; NULL means "skip this token". -.fmRssFitOne <- function(tk, p, chainLocal, infFit) { +.fmRssFitOne <- function( + tk, + chainLocal, + infFit, + z, + R, + n, + coverage, + methodArgs, + rssArgs, + verbose, + label +) { if (tk == "susieInf") { if (!chainLocal$keepInf) { return(NULL) @@ -4016,42 +4760,57 @@ extractTopPipInfo <- function(fmRow, sumstats) { return(list(fit = infFit, flag = NA, isStd = FALSE, multiFit = NULL)) } if (tk == "ser") { - if (p$verbose >= 1) { - msg <- glue("Fitting ser (RSS single-effect) for {p$label} ...") + if (verbose >= 1) { + msg <- glue("Fitting ser (RSS single-effect) for {label} ...") inform(msg) } fit <- .fmFitSusieSer( - p$z, - p$n, - coverage = p$coverage, - userArgs = p$methodArgs[["ser"]] + z, + n, + coverage = coverage, + userArgs = methodArgs[["ser"]] ) return(list(fit = fit, flag = NA, isStd = FALSE, multiFit = NULL)) } - std <- .fmRssFitStd(tk, p, chainLocal, infFit) + std <- .fmRssFitStd( + tk, + chainLocal, + infFit, + z = z, + R = R, + n = n, + coverage = coverage, + methodArgs = methodArgs, + rssArgs = rssArgs, + verbose = verbose, + label = label + ) list(fit = std$fit, flag = std$flag, isStd = TRUE, multiFit = std$multiFit) } # Post-process one RSS fit into a finemapping entry. -.fmRssPostprocess <- function(fit, p) { +.fmRssPostprocess <- function( + fit, + R, + z, + credibleSetArgs, + af, + nVar, + fitRetention +) { .fmPostprocessOne( fit = fit, method = "susieRss", - dataX = p$R, - dataY = list(z = p$z), - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - minAbsCorr = p$minAbsCorr, - af = p$af, - # Per-variant effective N (reporting-only, top_loci$N). NULL on any path - # that has no per-variant N -> buildTopLoci leaves N as NA, never 1. - # This is NOT p$n (the scalar median the RSS fit consumes). - n = p$nVar, + dataX = R, + dataY = list(z = z), + af = af, + # Per-variant effective N (reporting-only, top_loci$N). NULL on any + # path that has no per-variant N -> buildTopLoci leaves N as NA, + # never 1. This is NOT `n` (the scalar median the RSS fit consumes). + n = nVar, csInput = "Xcorr", - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + credibleSetArgs = credibleSetArgs, + fitRetention = fitRetention ) } @@ -4059,14 +4818,21 @@ extractTopPipInfo <- function(fmRow, sumstats) { # on the entry's susieFit list. Gated on serFallback so the default path is # byte-identical. .fmRssRecordFallback <- function(ent, f, keepFullFit) { - sf <- .fmrPartsSusieFit(ent) - sf$R_reliability_flag <- f$flag - sf$serFallbackUsed <- isTRUE(f$flag) - if (!is.null(f$multiFit) && is_in(keepFullFit, c("fallback", "all"))) { - sf$multiEffectFit <- f$multiFit + multiEffectFit <- if ( + !is.null(f$multiFit) && is_in(keepFullFit, c("fallback", "all")) + ) { + f$multiFit } else if (identical(keepFullFit, "all")) { - sf$multiEffectFit <- f$fit - } + f$fit + } + sf <- list_assign( + .fmrPartsSusieFit(ent), + !!!compact(list( + R_reliability_flag = f$flag, + serFallbackUsed = isTRUE(f$flag), + multiEffectFit = multiEffectFit + )) + ) # A row is immutable: rebuild it with the amended fit rather than # assigning into it. The variants and topLoci are unchanged, so this # round-trips them through the same builder the caller used. @@ -4103,38 +4869,46 @@ extractTopPipInfo <- function(fmRow, sumstats) { # Post-process one method's fit (buildTopLoci per fit). # @noRd -.ppOneFit <- function(method, fits, p) { +.ppOneFit <- function( + method, + fits, + dataX, + dataY, + xScalar, + yScalar, + af, + n, + credibleSetArgs, + fitRetention, + otherQuantities, + region, + priorEffTol, + csInput, + conditionIdx +) { fit <- .setFinemappingFitClass(fits[[method]], method) postprocessFinemappingFit( fit, method = method, - dataX = p$dataX, - dataY = p$dataY, - xScalar = p$xScalar, - yScalar = p$yScalar, - af = p$af, - n = p$n, - coverage = p$coverage, - secondaryCoverage = p$secondaryCoverage, - signalCutoff = p$signalCutoff, - otherQuantities = p$otherQuantities, - region = p$region, - priorEffTol = p$priorEffTol, - minAbsCorr = p$minAbsCorr, - medianAbsCorr = p$medianAbsCorr, - csInput = p$csInput, - conditionIdx = p$conditionIdx, - trim = p$trim, - fullFit = p$fullFit, - fullFitAlphaOnly = p$fullFitAlphaOnly, - includeAllCs = p$includeAllCs + dataX = dataX, + dataY = dataY, + xScalar = xScalar, + yScalar = yScalar, + af = af, + n = n, + credibleSetArgs = credibleSetArgs, + fitRetention = fitRetention, + otherQuantities = otherQuantities, + region = region, + priorEffTol = priorEffTol, + csInput = csInput, + conditionIdx = conditionIdx ) } # @noRd .ppDropTopLoci <- function(x) { - x$top_loci <- NULL - x + list_modify(x, top_loci = zap()) } # @noRd @@ -4249,15 +5023,15 @@ extractTopPipInfo <- function(fmRow, sumstats) { mergedSets[[variantId]] } else { str_flatten( - sort(unique(unlist(extractedResult[[variantId]]$sets))), + sort(unique(extractedResult[[variantId]]$sets)), "," ) } tibble( variant_id = variantId, credibleSetNames = credibleSetNames, - maxPip = max(unlist(extractedResult[[variantId]]$pips)), - medianPip = median(unlist(extractedResult[[variantId]]$pips)) + maxPip = max(extractedResult[[variantId]]$pips), + medianPip = median(extractedResult[[variantId]]$pips) ) } @@ -4279,8 +5053,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { return(NULL) } csIdx <- .fmCsIdx(topLoci[[csCol]]) - setNum <- unique(csIdx) - setNum <- setNum[!is.na(setNum) & setNum != 0] + uniq <- unique(csIdx) + setNum <- uniq[!is.na(uniq) & uniq != 0] if (length(setNum) == 0) { return(NULL) } @@ -4325,3 +5099,538 @@ extractTopPipInfo <- function(fmRow, sumstats) { "is derived from that object's LD and is never stored on the fit." )) } + +# The canonical (non-reweighted) mvSuSiE mixture prior for residual variance +# `V`: +# create_mixture_prior(R) restricted to the group's conditions. +# @noRd +.fmCanonicalPrior <- function(V, conditionNames, R) { + list( + priorVariance = mvsusieR::create_mixture_prior( + R = R, + include_indices = conditionNames + ), + residualVariance = V + ) +} + +# Rebuild the mvSuSiE data-driven *reweighted* mixture prior + residual variance +# from a stored mr.mash fit -- the lean payload +# (list(dataDrivenPriorMatrices, w0, V)) that mrmashWeights() attaches at +# fitRetention "slim" and twasWeightsPipeline keeps on the mrmash row. Shared +# by the fine-mapping mvsusie consumer and the twas mvsusie_weights consumer. +# +# Reproduces the deleted multivariate_pipeline.R reweighting bit-identically: +# rescaleCovW0(w0) collapses the expanded mr.mash weights onto the original +# data-driven covariance matrices ($U), filters to surviving components, and +# create_mixture_prior() wraps them, restricted to the fit's conditions +# (`conditionNames` = colnames(Y)). `V` becomes mvsusie's residual_variance. +# A NULL fit, NULL matrices, or no surviving component falls back to the +# canonical create_mixture_prior(R), matching the legacy `else` branch. +# Returns list(priorVariance, residualVariance) (residualVariance NULL only +# when no fit was supplied at all). +# @noRd +.buildMvsusieReweightedPrior <- function( + fitParts, + conditionNames, + weightsTol = 1e-10, + overrideU = NULL +) { + R <- length(conditionNames) + if (is.null(fitParts)) { + return(.fmCanonicalPrior(NULL, conditionNames, R)) + } + # `overrideU` (mode C / hybrid): reuse this fit's reweighted mixture weights + # (w0) and residual variance (V) but swap in a different set of data-driven + # covariance matrices -- the per-fold mash prior U. Components are matched + # to w0 by name, so the override U must share component names with the fit. + ddpm <- if (!is.null(overrideU)) { + overrideU + } else { + fitParts$dataDrivenPriorMatrices + } + if (is.null(ddpm) || is.null(ddpm$U)) { + return(.fmCanonicalPrior(fitParts$V, conditionNames, R)) + } + rescaled <- rescaleCovW0(fitParts$w0) + w0Updated <- rescaled[is_in(names(rescaled), names(ddpm$U))] + if (length(w0Updated) == 0L) { + return(.fmCanonicalPrior(fitParts$V, conditionNames, R)) + } + mixture <- list(matrices = ddpm$U[names(w0Updated)], weights = w0Updated) + list( + priorVariance = mvsusieR::create_mixture_prior( + mixture_prior = mixture, + weights_tol = weightsTol, + include_indices = conditionNames + ), + residualVariance = fitParts$V + ) +} + +# Per-column marginal-association z-scores of y on each column of X (univariate +# regression z = betahat / sebetahat), used by the individual-level absZ screen. +# @noRd +.marginalZ <- function(X, y) { + ur <- susieR::univariate_regression(X, y) + ur$betahat / ur$sebetahat +} + +# Single-effect (SER) pre-screen, individual-level. Reports whether a +# residualized (X, y) block shows a strong enough signal (by the chosen metric) +# to be worth a full fit. `screen` is a screen spec (see .asScreen): a legacy +# PIP cutoff (numeric scalar, 0 = off) OR a resolved list(metric, cutoff) for +# one of pip / absZ / bf / logBf. Ports the deleted multivariate_pipeline.R +# `skipConditions` / susie_twas `pip_cutoff_to_skip` logic (the individual-level +# analog of the sumstat-path `.applyEntryScreen`): +# * no screen (NULL / 0 / non-scalar numeric) -> always keep. +# * pip cutoff < 0 uses the adaptive 3 / nVariants threshold. +# * absZ needs no susie fit; pip/bf/logBf fit susie L = 1 once (its +# $lbf_variable gives the per-variant logBF for bf/logBf, $pip for pip). +# * NA entries of `y` are dropped before fitting. +# The screen is advisory: too few samples/variants or a fit failure returns +# `fallback` -- TRUE (default) keeps the block rather than discard a potentially +# real signal (fineMapping / joint paths); colocboost passes FALSE to drop an +# outcome it cannot screen. This is the single L = 1 SuSiE pre-screen shared by +# .fmSerScreenColumns (joint) and .cbPipSkipOutcomes (colocboost). +# @noRd +.fmSerScreen <- function(X, y, screen, fallback = TRUE) { + scr <- .asScreen(screen) + if (is.null(scr)) { + return(TRUE) + } + ok <- !is.na(y) + if (sum(ok) < 2L || ncol(X) < 1L) { + return(fallback) + } + raw <- X[ok, , drop = FALSE] + # susieR needs a double X. + Xs <- if (is.double(raw)) raw else `storage.mode<-`(raw, "double") + ys <- y[ok] + metric <- scr$metric + cutoff <- scr$cutoff + if (metric == "absZ") { + z <- try_fetch(.marginalZ(Xs, ys), error = function(cnd) NULL) + if (is.null(z)) { + return(fallback) + } + return(any(abs(z) > cutoff, na.rm = TRUE)) + } + fit <- try_fetch( + suppressMessages(susieR::susie(Xs, ys, L = 1L)), + error = function(cnd) NULL + ) + if (is.null(fit)) { + return(fallback) + } + if (metric == "pip") { + thr <- if (cutoff < 0) 3 / ncol(Xs) else cutoff + return(any(fit$pip > thr, na.rm = TRUE)) + } + maxLbf <- suppressWarnings(max(as.numeric(fit$lbf_variable), na.rm = TRUE)) + if (!is.finite(maxLbf)) { + return(fallback) + } + # bf: cutoff on the raw BF scale -> compare in log space; logBf: log scale. + maxLbf > (if (metric == "bf") log(cutoff) else cutoff) +} + +# Per-fold mvsusie weights. Reuses the data-driven reweighted prior + residual +# covariance from the full-data mr.mash fit on every fold -- the prior is over +# conditions, identical across folds (only samples are held out). NULL mvPrior +# -> canonical prior (unchanged behavior). +# @noRd +.fmFoldWeightsMv <- function(Xtr, Ytr, coverage, userArgs, mvPrior) { + baseArgs <- list( + X = Xtr, + Y = Ytr, + coverage = coverage, + prior_variance = if (is.null(mvPrior)) { + mvsusieR::create_mixture_prior(R = ncol(Ytr)) + } else { + mvPrior$priorVariance + } + ) + withPrior <- list_assign( + baseArgs, + !!!compact(list(residual_variance = mvPrior$residualVariance)) + ) + mvArgs <- .fmMergeUserArgs(withPrior, "mvsusie", userArgs) + fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, mvArgs)) + raw <- as.matrix(mvsusieWeights(mvsusieFit = fit)) + W <- `rownames<-`(raw, rownames(raw) %||% colnames(Xtr)) + `attr<-`(W, "fit", .fmLeanFoldFit(fit, "mvsusie")) +} + +#' @rdname fineMappingMethodOptions +#' @export +SusieOptions <- function(...) { + .fmMethodOptions("susieR::susie", "SusieOptions", "susie", list(...)) +} + +#' @rdname fineMappingMethodOptions +#' @export +SusieRssOptions <- function(...) { + .fmMethodOptions( + "susieR::susie_rss", + "SusieRssOptions", + "susieRss", + list(...) + ) +} + +#' @rdname fineMappingMethodOptions +#' @export +SusieInfOptions <- function(...) { + .fmMethodOptions("susieR::susie", "SusieInfOptions", "susieInf", list(...)) +} + +#' @rdname fineMappingMethodOptions +#' @export +SusieInfRssOptions <- function(...) { + .fmMethodOptions( + "susieR::susie_rss", + "SusieInfRssOptions", + "susieInfRss", + list(...) + ) +} + +#' @rdname fineMappingMethodOptions +#' @export +SusieAshOptions <- function(...) { + .fmMethodOptions("susieR::susie", "SusieAshOptions", "susieAsh", list(...)) +} + +#' @rdname fineMappingMethodOptions +#' @export +SusieAshRssOptions <- function(...) { + .fmMethodOptions( + "susieR::susie_rss", + "SusieAshRssOptions", + "susieAshRss", + list(...) + ) +} + +#' @rdname fineMappingMethodOptions +#' @export +SerOptions <- function(...) { + .fmMethodOptions("susieR::susie_ser", "SerOptions", "ser", list(...)) +} + +#' @rdname fineMappingMethodOptions +#' @export +MvsusieOptions <- function(...) { + .fmMethodOptions( + "mvsusieR::mvsusie", + "MvsusieOptions", + "mvsusie", + list(...) + ) +} + +#' @rdname fineMappingMethodOptions +#' @export +MvsusieRssOptions <- function(...) { + .fmMethodOptions( + "mvsusieR::mvsusie_rss", + "MvsusieRssOptions", + "mvsusieRss", + list(...) + ) +} + +#' @rdname fineMappingMethodOptions +#' @export +FsusieOptions <- function(...) { + .fmMethodOptions("fsusieR::susiF", "FsusieOptions", "fsusie", list(...)) +} + +#' @title Arguments For susieR's RSS Control Block +#' @description Options forwarded to \code{susieR::susie_rss_control()} and +#' from there to \code{susie_rss()}'s \code{control} argument. Names are +#' checked against that function's live formals, so a misspelling fails at +#' the call site rather than being dropped into an ignored list --- which is +#' what a bare named list here used to do. +#' @param ... Arguments for \code{susieR::susie_rss_control()}, under its own +#' names (\code{check_prior}, \code{mismatch_estimator}, ...). +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' SusieRssControlOptions(check_prior = TRUE) +#' @export +SusieRssControlOptions <- function(...) { + .newMethodOptions( + "susieR::susie_rss_control", + defaults = list(), + extra = list(...), + label = "SusieRssControlOptions", + engine = "susieRssControl" + ) +} + +#' @title Options for the susieR Kriging RSS Diagnostic +#' @description Build a checked record of extra arguments for +#' \code{susieR::kriging_rss()}, the engine behind +#' \code{\link{krigingOutlierQc}}. +#' @param ... Arguments for \code{susieR::kriging_rss()}: \code{r_tol} (the +#' eigenvalue tolerance below which an LD eigenvalue is treated as zero) and +#' \code{s} (the estimated proportion of LD/sumstats mismatch, which +#' defaults to \code{susieR::estimate_s_rss()}). \code{z}, \code{R} and +#' \code{n} are supplied by pecotmr and refused. +#' @return A \code{MethodOptions} record for +#' \code{krigingOutlierQc(methodArgs =)}. +#' @seealso \code{\link{krigingOutlierQc}} +#' @examples +#' KrigingOptions(r_tol = 1e-06) +#' @export +KrigingOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + z = "the caller's `zScore`", + R = "the caller's `R`", + n = "the caller's `n`" + ), + "KrigingOptions" + ) + .newMethodOptions( + "susieR::kriging_rss", + defaults = list(), + extra = extra, + label = "KrigingOptions", + engine = "kriging" + ) +} + +#' Kriging-style LD-consistency outlier QC +#' +#' Flags variants whose observed z-score is inconsistent with the value +#' predicted from its LD neighbours, using susieR's kriging diagnostic. +#' \code{susieR::kriging_rss()} computes the leave-one-out conditional +#' distribution of each \code{z_i} given the rest (with the LD-mismatch scale +#' \code{s} defaulting to \code{susieR::estimate_s_rss()}) and a per-variant +#' \code{logLR} for the allele-switch hypothesis. This helper reuses susieR's +#' own allele-switch rule --- \code{logLR > logLRThreshold & abs(z) > +#' zThreshold} (the same \code{logLR > 2 & |z| > 2} used in +#' \code{susie_rss_utils}) --- to flag variants whose sign should be flipped. +#' RSS-only helper, opt-in via \code{alleleFlipKriging}; never wired into +#' \code{alleleQc()} / \code{matchRefPanel()}. Requires a susieR that provides +#' \code{kriging_rss()} and \code{estimate_s_rss()}. +#' +#' @param zScore Numeric vector of harmonized z-scores. +#' @param R Square LD correlation matrix aligned to \code{zScore}. +#' @param n Sample size, forwarded to \code{susieR::kriging_rss()} (whose +#' default \code{s} is \code{susieR::estimate_s_rss()}). +#' @param variantIds Optional variant IDs for the diagnostics table. +#' @param zThreshold Absolute-z cutoff for the allele-switch rule (default +#' \code{2}, matching susieR). +#' @param logLRThreshold Log-likelihood-ratio cutoff for the allele-switch rule +#' (default \code{2}, matching susieR). +#' @param methodArgs Extra arguments for \code{susieR::kriging_rss()}, built +#' with \code{\link{KrigingOptions}} -- \code{r_tol} and \code{s}. +#' @return A list with \code{flip} (logical vector; \code{TRUE} = allele switch, +#' z-score should be sign-flipped) and \code{diagnostics} (data frame of +#' per-variant \code{z}, \code{condmean}, \code{z_std_diff}, \code{logLR}, and +#' the \code{flipped} flag). +#' @importFrom stats pnorm +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:20] +#' R <- cor(X) +#' krigingOutlierQc( +#' zScore = rnorm(20), R = R, n = 415, variantIds = colnames(X)) +#' @export +#' @importFrom checkmate assertMatrix +krigingOutlierQc <- function( + zScore, + R, + n, + variantIds = NULL, + zThreshold = 2, + logLRThreshold = 2, + methodArgs = KrigingOptions() +) { + .assertMethodOptions(methodArgs, "KrigingOptions", "methodArgs") + zScore <- as.numeric(zScore) + m <- length(zScore) + assertMatrix(R, nrows = m, ncols = m, .var.name = "R (LD matrix)") + if (missing(n) || length(n) != 1L || is.na(n) || !is.finite(n) || n <= 0) { + abort("krigingOutlierQc requires a single positive sample size 'n'.") + } + .krigingCheckSusie() + if (is.null(variantIds)) { + variantIds <- rownames(R) + } + # susieR kriging RSS diagnostic (kriging_rss(z, R, n)): s defaults to + # estimate_s_rss(); logLR matches susieR's allele-switch selection. + cd <- exec( + susieR::kriging_rss, + z = zScore, + R = R, + n = n, + !!!as.list(methodArgs) + )$conditional_dist + condMean <- as.numeric(cd$condmean) + zStdDiff <- as.numeric(cd$z_std_diff) + logLR <- as.numeric(cd$logLR) + # susieR's allele-switch rule (susie_rss_utils.R): logLR > 2 & |z| > 2. + flip <- !is.na(logLR) & + !is.na(zScore) & + logLR > logLRThreshold & + abs(zScore) > zThreshold + list( + flip = flip, + diagnostics = tibble( + variant_id = if (is.null(variantIds)) seq_len(m) else variantIds, + z = zScore, + condmean = condMean, + z_std_diff = zStdDiff, + logLR = logLR, + flipped = flip + ) + ) +} + +# Decide whether the z-scores of one entry clear the chosen screen. Returns +# list(ok = logical, reason = character). susie_ser is fit at most once, and +# only for the metrics that need it (absZ stays model-free). +.entryScreenPass <- function(z, n, nVar, scr) { + metric <- scr$metric + cutoff <- scr$cutoff + if (metric == "absZ") { + m <- suppressWarnings(max(abs(as.numeric(z)), na.rm = TRUE)) + return(list( + ok = is.finite(m) && m > cutoff, + reason = sprintf( + "no variant with |Z| above %g (max |Z| = %g)", + cutoff, + m + ) + )) + } + ser <- susieR::susie_ser(z = z, n = n, coverage = NULL) + if (metric == "pip") { + eff <- if (cutoff < 0) 3 / nVar else cutoff + return(list( + ok = any(ser$pip > eff), + reason = sprintf("no signals above PIP threshold %g", eff) + )) + } + maxLbf <- suppressWarnings(max(as.numeric(ser$lbf_variable), na.rm = TRUE)) + if (metric == "logBf") { + return(list( + ok = is.finite(maxLbf) && maxLbf > cutoff, + reason = sprintf( + "no variant with logBF above %g (max logBF = %g)", + cutoff, + maxLbf + ) + )) + } + # metric == "bf": compare in log space to avoid overflow of exp(maxLbf). + list( + ok = is.finite(maxLbf) && maxLbf > log(cutoff), + reason = sprintf( + "no variant with BF above %g (max BF = %g)", + cutoff, + exp(maxLbf) + ) + ) +} + +# 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 +#' @importFrom rlang try_fetch +.fsusiePopulateCredibleBand <- function(fit) { + fn <- try_fetch( + get("update_cal_credible_band.susiF", envir = asNamespace("fsusieR")), + error = function(cnd) NULL + ) + if (is.null(fn)) { + # Defensive guard against an upstream fsusieR rename; only reachable + # if fsusieR drops this unexported S3 method. + msg <- glue( + "fsusieR's internal update_cal_credible_band.susiF not found; ", + "cannot compute the fSuSiE credible band (upstream fsusieR API ", + "changed)." + ) + abort(msg) + } + indxLst <- fsusieR::gen_wavelet_indx(log2(length(fit$outing_grid))) + fn(fit, indxLst) +} + +# @noRd +.fsusieAffectedRegionsFit <- function(fit, topLoci = NULL) { + if (!.isFsusieFit(fit)) { + return(GenomicRanges::GRanges()) + } + fit <- .fsusiePopulateCredibleBand(fit) + raw <- try_fetch(fsusieR::affected_reg(fit), error = function(cnd) NULL) + if (is.null(raw) || nrow(raw) == 0L) { + return(GenomicRanges::GRanges()) + } + reg <- as_tibble(raw) + 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 <- map_chr( + seq_len(nrow(reg)), + .fsusieRegionDirection, + grid = grid, + reg = reg, + fit = fit + ) + GenomicRanges::GRanges( + seqnames = str_c("chr", str_remove(chrom, "^chr")), + 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 + ) +} + +# Require a susieR that provides the kriging RSS diagnostic. +.krigingCheckSusie <- function() { + if ( + !requireNamespace("susieR", quietly = TRUE) || + !all( + is_in( + c("estimate_s_rss", "kriging_rss"), + getNamespaceExports("susieR") + ) + ) + ) { + msg <- glue( + "krigingOutlierQc requires a susieR that provides ", + "estimate_s_rss() and kriging_rss(); the installed susieR does ", + "not. Install a susieR with the kriging RSS diagnostic, or ", + "disable alleleFlipKriging." + ) + abort(msg) + } +} + +# susieR's `control` argument is a plain named list, so the constructor +# result is flattened on the way out. NULL is preserved rather than becoming +# list(): to susie_rss() an absent control means "use susie_rss_control()'s +# own defaults", which an empty list does not. +# @noRd +.rssControlList <- function(control) { + if (is.null(control) || length(control) == 0L) { + return(NULL) + } + as.list(control) +} diff --git a/R/genotypeIo.R b/R/genotypeIo.R index f76688b38..17149aa75 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -33,8 +33,10 @@ NULL setMethod( "readGenotypes", signature(path = "character"), - function(path, format = NULL, ...) { - .genotypeExperiment(.readGenotypeHandle(path, format = format, ...)) + function(path, format = NULL, vcfArgs = list()) { + .genotypeExperiment( + .readGenotypeHandle(path, format = format, vcfArgs = vcfArgs) + ) } ) @@ -43,8 +45,43 @@ setMethod( setMethod( "readGenotypes", signature(path = "missing"), - function(path, format = NULL, ...) { - .genotypeExperiment(GenotypeHandle(...)) + function( + path, + plink1Prefix = NULL, + plink2Prefix = NULL, + bed = NULL, + bim = NULL, + fam = NULL, + pgen = NULL, + pvar = NULL, + psam = NULL, + ldMeta = NULL, + region = NULL, + genoMeta = NULL, + chroms = NULL, + format = NULL, + vcfArgs = list() + ) { + # The keyword sources are declared here rather than absorbed by `...` + # and forwarded: GenotypeHandle() is internal, so this signature is + # the only place a caller can name them, and a misspelled source + # should be an error at the call rather than a silently unset one. + .genotypeExperiment(GenotypeHandle( + plink1Prefix = plink1Prefix, + plink2Prefix = plink2Prefix, + bed = bed, + bim = bim, + fam = fam, + pgen = pgen, + pvar = pvar, + psam = psam, + ldMeta = ldMeta, + region = region, + genoMeta = genoMeta, + chroms = chroms, + format = format, + vcfArgs = vcfArgs + )) } ) @@ -52,16 +89,16 @@ setMethod( # handle-construction machinery below calls this rather than readGenotypes() # so it does not wrap and immediately unwrap a panel on every hop. # @noRd -.readGenotypeHandle <- function(path, format = NULL, ...) { +.readGenotypeHandle <- function(path, format = NULL, vcfArgs = list()) { if (is.null(format)) { format <- .h2DetectFormat(path) } switch( format, "gds" = .makeGdsHandle(path), - "vcf" = .makeVcfHandle(path, ...), - "plink1" = .makePlink1Handle(path, ...), - "plink2" = .makePlink2Handle(path, ...), + "vcf" = .makeVcfHandle(path, vcfArgs = vcfArgs), + "plink1" = .makePlink1Handle(path), + "plink2" = .makePlink2Handle(path), .abortUnsupportedFormat(format) ) } @@ -79,8 +116,7 @@ setMethod( # (unsubset) handle fileIdx == seq_len(nrow), so reads are unchanged. # @noRd .withFileIdx <- function(snpInfo) { - snpInfo$fileIdx <- seq_len(nrow(snpInfo)) - snpInfo + mutate(snpInfo, fileIdx = seq_len(nrow(snpInfo))) } # Restrict a GenotypeHandle's @snpInfo to `keep` (a logical mask or integer row @@ -107,10 +143,12 @@ setMethod( # nSamples must go to 0 alongside sampleIds, or dm (variants x nSamples) # would disagree with the now-empty derived sample dimnames. Reached only # via .emptySketch (the empty / PIP-skip path), never on a surviving region. - handle@snpInfo <- slice(getSnpInfo(handle), integer(0)) - handle@sampleIds <- character(0) - handle@nSamples <- 0L - handle + methods::initialize( + handle, + snpInfo = slice(getSnpInfo(handle), integer(0)), + sampleIds = character(0), + nSamples = 0L + ) } .subsetGenotypeHandle <- function(handle, keep) { @@ -125,10 +163,10 @@ setMethod( if (!is_in("fileIdx", names(si))) { return(handle) } # legacy handle: unsafe - handle@snpInfo <- slice(si, keepIdx) - handle + methods::initialize(handle, snpInfo = slice(si, keepIdx)) } +#' @importFrom checkmate assertFileExists #' @keywords internal .makeGdsHandle <- function(path) { if (!requireNamespace("SNPRelate", quietly = TRUE)) { @@ -137,10 +175,7 @@ setMethod( if (!requireNamespace("gdsfmt", quietly = TRUE)) { abort("Package 'gdsfmt' is required for reading GDS files.") } - if (!file.exists(path)) { - msg <- glue("GDS file not found: {path}") - abort(msg) - } + assertFileExists(path, access = "r", .var.name = "GDS file") snpInfo <- .gdsSnpInfo(path) @@ -158,15 +193,13 @@ setMethod( ) } +#' @importFrom checkmate assertFileExists #' @keywords internal -.makeVcfHandle <- function(path, ...) { +.makeVcfHandle <- function(path, vcfArgs = list()) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort("Package 'VariantAnnotation' is required for reading VCF files.") } - if (!file.exists(path)) { - msg <- glue("VCF file not found: {path}") - abort(msg) - } + assertFileExists(path, access = "r", .var.name = "VCF file") hdr <- VariantAnnotation::scanVcfHeader(path) sampleIds <- as.character(VariantAnnotation::samples(hdr)) @@ -177,7 +210,12 @@ setMethod( info = NA, geno = NA ) - vcf <- VariantAnnotation::readVcf(path, param = param, ...) + vcf <- exec( + VariantAnnotation::readVcf, + path, + param = param, + !!!vcfArgs + ) rd <- rowRanges(vcf) # pecotmr convention: A1 = ALT (effect), A2 = REF @@ -201,7 +239,7 @@ setMethod( } #' @keywords internal -.makePlink1Handle <- function(path, ...) { +.makePlink1Handle <- function(path) { if (!requireNamespace("snpStats", quietly = TRUE)) { abort("Package 'snpStats' is required for reading plink1 files.") } @@ -220,14 +258,14 @@ setMethod( # Resolve the plink1 stem and assert its .bed/.bim/.fam all exist. # @noRd +#' @importFrom checkmate assertFileExists .plink1RequireFiles <- function(path) { stem <- .plinkStem(path) - for (f in str_c(stem, c(".bed", ".bim", ".fam"))) { - if (!file.exists(f)) { - msg <- glue("Plink file not found: {f}") - abort(msg) - } - } + assertFileExists( + str_c(stem, c(".bed", ".bim", ".fam")), + access = "r", + .var.name = "Plink file" + ) stem } @@ -265,7 +303,7 @@ setMethod( } #' @keywords internal -.makePlink2Handle <- function(path, ...) { +.makePlink2Handle <- function(path) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { abort("Package 'pgenlibr' is required for reading plink2 files.") } @@ -290,9 +328,9 @@ setMethod( psam <- vroom( paths$psam, delim = "\t", - show_col_types = FALSE + show_col_types = FALSE, + .name_repair = .psamHeaderNames ) - names(psam) <- str_remove(names(psam), "^#") sampleIds <- as.character(psam$IID) pgen <- pgenlibr::NewPgen(paths$pgen) @@ -349,14 +387,12 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # Read ascending, then put the columns back in the requested order. See # .restoreRequestedOrder() for why this is not merely tidiness. ord <- order(.genotypeFilePos(handle, snpIdx)) - geno <- .extractBlockByFormat(handle, snpIdx[ord]) - if (is.null(geno)) { + raw <- .extractBlockByFormat(handle, snpIdx[ord]) + if (is.null(raw)) { return(NULL) } - geno <- .restoreRequestedOrder(geno, ord) - if (meanImpute) { - geno <- .meanImputeGeno(geno) - } + ordered <- .restoreRequestedOrder(raw, ord) + geno <- if (meanImpute) .meanImputeGeno(ordered) else ordered .blockGenotypesToSe(geno, handle, snpIdx) } @@ -431,11 +467,31 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { } else { as.matrix(genotypeCovariates) } - SummarizedExperiment::colData(panel) <- .genotypeColData( - gCov, - colnames(panel) + SummarizedExperiment::`colData<-`( + panel, + value = .genotypeColData(gCov, colnames(panel)) ) - panel +} + +# PLINK2 writes the .psam header line with a leading "#" on the first field. +# @noRd +.psamHeaderNames <- function(nms) str_remove(nms, "^#") + +# Covariate rows carry the sample identity. An unnamed matrix is only +# interpretable when it already has one row per panel sample, in order. +# @noRd +.genotypeCovariateRownames <- function(gCov, sampleIds) { + if (!is.null(rownames(gCov))) { + return(gCov) + } + if (nrow(gCov) != length(sampleIds)) { + abort(glue( + "'genotypeCovariates' has {nrow(gCov)} rows but the panel ", + "has {length(sampleIds)} samples; name its rows to align ", + "them explicitly" + )) + } + `rownames<-`(gCov, sampleIds) } # Per-sample covariates as a colData aligned to the panel's sample order. @@ -447,19 +503,11 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { if (ncol(gCov) == 0L || nrow(gCov) == 0L) { return(empty) } - if (is.null(rownames(gCov))) { - if (nrow(gCov) != length(sampleIds)) { - abort(glue( - "'genotypeCovariates' has {nrow(gCov)} rows but the panel ", - "has {length(sampleIds)} samples; name its rows to align ", - "them explicitly" - )) - } - rownames(gCov) <- sampleIds - } - aligned <- gCov[match(sampleIds, rownames(gCov)), , drop = FALSE] - rownames(aligned) <- sampleIds - S4Vectors::DataFrame(aligned, row.names = sampleIds) + named <- .genotypeCovariateRownames(gCov, sampleIds) + S4Vectors::DataFrame( + named[match(sampleIds, rownames(named)), , drop = FALSE], + row.names = sampleIds + ) } # snpInfo as rowRanges for a genotype panel: width-1 ranges at each @@ -471,17 +519,16 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # @noRd .genotypeSnpRanges <- function(genotypes, variantIds) { si <- getSnpInfo(genotypes) - gr <- GenomicRanges::GRanges( - seqnames = withChrPrefix(as.character(si$CHR)), - ranges = IRanges::IRanges(as.integer(si$BP), width = 1L) - ) - names(gr) <- variantIds - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = as.character(si$SNP), - A1 = as.character(si$A1), - A2 = as.character(si$A2) + `names<-`( + GenomicRanges::GRanges( + seqnames = withChrPrefix(as.character(si$CHR)), + ranges = IRanges::IRanges(as.integer(si$BP), width = 1L), + SNP = as.character(si$SNP), + A1 = as.character(si$A1), + A2 = as.character(si$A2) + ), + variantIds ) - gr } # Dispatch block extraction to the format-specific backend (samples x variants). @@ -509,14 +556,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) rowRanges <- GRanges( seqnames = chr, - ranges = IRanges(start = as.integer(si$BP), width = 1L) + ranges = IRanges(start = as.integer(si$BP), width = 1L), + SNP = si$SNP, + A1 = si$A1, + A2 = si$A2 ) - mcols(rowRanges) <- DataFrame(SNP = si$SNP, A1 = si$A1, A2 = si$A2) sampleIds <- getSampleIds(handle) # Transpose to Bioc convention: variants x samples. - dosage <- t(geno) - rownames(dosage) <- si$SNP - colnames(dosage) <- sampleIds + dosage <- `dimnames<-`(t(geno), list(si$SNP, sampleIds)) SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rowRanges, @@ -545,11 +592,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { } blockGlobal <- which(unifiedChr == chrom) # file-order global indices localIdx <- match(snpIdx[posInReq], blockGlobal) - th <- handle - th@path <- handle@chromPaths[[chrom]] - th@snpInfo <- slice(handle@snpInfo, blockGlobal) - th@pgenPtr <- NULL - th@chromPaths <- character(0) # treat as single-file + th <- methods::initialize( + handle, + path = handle@chromPaths[[chrom]], + snpInfo = slice(handle@snpInfo, blockGlobal), + pgenPtr = NULL, + # Treated as single-file: the view addresses one chromosome's payload. + chromPaths = character(0) + ) extractBlockGenotypes(th, localIdx, meanImpute = meanImpute) } @@ -606,7 +656,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # trips on disjoint seqlevels) and restore the requested snpIdx order. # @noRd .combineShardedSes <- function(ses, groups) { - ord <- order(unlist(groups, use.names = FALSE)) + ord <- order(unname(list_c(groups))) dosages <- map(ses, .seDosage) combinedDos <- exec(rbind, !!!dosages)[ord, , drop = FALSE] rowRangesList <- unname(map(ses, SummarizedExperiment::rowRanges)) @@ -623,8 +673,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { .withGds( .genotypeReadPath(handle), .gdsBlockGeno, - handle = handle, - snpIdx = snpIdx, + fnArgs = list(handle = handle, snpIdx = snpIdx), allow.fork = TRUE ) } @@ -649,14 +698,13 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) gt <- VariantAnnotation::geno(vcf)$GT - # Convert GT strings to ALT dosage (A1 dosage) - geno <- matrix(NA_real_, nrow = ncol(gt), ncol = nrow(gt)) - for (j in seq_len(nrow(gt))) { - g <- gt[j, ] - geno[, j] <- map_dbl(g, .gtStringToDosage) - } - - geno + # Convert GT strings to ALT dosage (A1 dosage): one column per variant, + # laid side by side rather than filled into a preallocated matrix. + matrix( + map_dbl(as.vector(t(gt)), .gtStringToDosage), + nrow = ncol(gt), + ncol = nrow(gt) + ) } #' @keywords internal @@ -671,18 +719,16 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) # snpStats as(x, "numeric") gives count of B allele (A2/bim col 6). # Flip to count A1 (bim col 5 / effect allele). - geno <- 2 - as(plinkData$genotypes, "numeric") - storage.mode(geno) <- "double" - geno + `storage.mode<-`(2 - as(plinkData$genotypes, "numeric"), "double") } #' @keywords internal +#' @importFrom rlang try_fetch .extractBlockPlink2 <- function(handle, snpIdx) { # pgenlibr::ReadList returns ALT dosage = A1 dosage in pecotmr convention. # The cached @pgenPtr does not survive saveRDS/readRDS (external pointers # become stale), so we re-open from getPath() on the fly if the cached # pointer errors out. Opening is cheap relative to dosage extraction. - ptr <- getPgenPtr(handle) paths <- resolvePlink2Paths(.genotypeReadPath(handle)) # `variant_subset` indexes the .pgen by FILE position. `snpIdx` is a # position into @snpInfo, which may have been row-subset; translate through @@ -694,16 +740,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # A sharded handle routes through a transient view with pgenPtr = NULL (one # pgen per chromosome), and a deserialized pointer is stale; open a fresh # pgen up front in those cases rather than provoking a caught read error. - if (is.null(ptr)) { - ptr <- pgenlibr::NewPgen(paths$pgen) - } - geno <- tryCatch( + ptr <- getPgenPtr(handle) %||% pgenlibr::NewPgen(paths$pgen) + geno <- try_fetch( pgenlibr::ReadList( ptr, variant_subset = variantSubset, meanimpute = FALSE ), - error = function(e) { + error = function(cnd) { reopened <- pgenlibr::NewPgen(paths$pgen) pgenlibr::ReadList( reopened, @@ -712,8 +756,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) } ) - storage.mode(geno) <- "double" - geno + `storage.mode<-`(geno, "double") } # ============================================================================= @@ -741,14 +784,20 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # Resource bracket: open the GDS at `path`, guarantee it is closed on exit, and # run `fn(gds, ...)`. `fn` is a top-level function (not an inline closure); its # per-call inputs are threaded through `...`. -.withGds <- function(path, fn, ..., readonly = TRUE, allow.fork = FALSE) { +.withGds <- function( + path, + fn, + fnArgs = list(), + readonly = TRUE, + allow.fork = FALSE +) { gds <- SNPRelate::snpgdsOpen( path, readonly = readonly, allow.fork = allow.fork ) on.exit(SNPRelate::snpgdsClose(gds)) - fn(gds, ...) + exec(fn, gds, !!!fnArgs) } #' @keywords internal @@ -756,8 +805,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { .withGds( .genotypeReadPath(handle), .gdsBlockLd, - handle = handle, - snpIdx = snpIdx, + fnArgs = list(handle = handle, snpIdx = snpIdx), allow.fork = TRUE ) } @@ -802,12 +850,15 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @keywords internal .meanImputeGeno <- function(geno) { - naCols <- which(colSums(is.na(geno)) > 0L) - for (j in naCols) { - colMean <- mean(geno[, j], na.rm = TRUE) - geno[is.na(geno[, j]), j] <- colMean + naMask <- is.na(geno) + if (!any(naMask)) { + return(geno) } - geno + # One fill over the whole matrix rather than a copy per column: geno is + # samples x variants, so rebuilding it column by column is the expensive + # way to say this. + means <- colMeans(geno, na.rm = TRUE) + replace(geno, naMask, means[col(geno)[naMask]]) } #' @keywords internal @@ -911,9 +962,10 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @importFrom SummarizedExperiment assay readBim <- function(bed) { bimf <- str_c(file_path_sans_ext(bed), ".bim") - bim <- vroom(bimf, col_names = FALSE) - colnames(bim) <- c("chrom", "id", "gpos", "pos", "a1", "a0") - return(bim) + `colnames<-`( + vroom(bimf, col_names = FALSE), + c("chrom", "id", "gpos", "pos", "a1", "a0") + ) } #' @importFrom vroom vroom @@ -926,11 +978,7 @@ readFam <- function(bed) { # open bed/bim/fam: A PLINK 1 .bed is a valid .pgen openBed <- function(bed) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install pgenlibr: ", - "https://cran.r-project.org/web/packages/pgenlibr/index.html" - ) - abort(msg) + abort("Package 'pgenlibr' is required for this function.") } rawSCt <- nrow(readFam(bed)) return(pgenlibr::NewPgen(bed, raw_sample_ct = rawSCt)) @@ -949,7 +997,9 @@ openBed <- function(bed) { #' package = "pecotmr"), "protocol_example.LD.chr22") #' readAfreq(stem) #' @export +#' @importFrom checkmate assertString readAfreq <- function(prefix) { + assertString(prefix) afreqZst <- str_c(prefix, ".afreq.zst") afreqPlain <- str_c(prefix, ".afreq") if (file.exists(afreqZst)) { @@ -969,7 +1019,7 @@ readAfreq <- function(prefix) { } # PLINK2 .afreq: REF = A2, ALT = A1, ALT_FREQS = A1 (effect allele) # frequency - af <- rename( + renamed <- rename( af, "chrom" = "#CHROM", "id" = "ID", @@ -978,15 +1028,19 @@ readAfreq <- function(prefix) { "alt_freq" = "ALT_FREQS", "obs_ct" = "OBS_CT" ) - cols <- c("chrom", "id", "A2", "A1", "alt_freq", "obs_ct") - # Stochastic genotype .afreq includes U_MIN/U_MAX for exact min-max - # inversion - if (is_in("U_MIN", colnames(af))) { - af <- rename(af, "u_min" = "U_MIN", "u_max" = "U_MAX") - cols <- c(cols, "u_min", "u_max") + # A stochastic-genotype .afreq also carries U_MIN / U_MAX, which + # invertMinmaxScaling() needs for an exact min-max inversion. + stochastic <- is_in("U_MIN", colnames(renamed)) + cols <- c( + c("chrom", "id", "A2", "A1", "alt_freq", "obs_ct"), + if (stochastic) c("u_min", "u_max") + ) + out <- if (stochastic) { + rename(renamed, "u_min" = "U_MIN", "u_max" = "U_MAX") + } else { + renamed } - af <- select(af, all_of(cols)) - return(af) + select(out, all_of(cols)) } #' Read stochastic genotype sidecar metadata (U_MIN/U_MAX). @@ -1014,16 +1068,15 @@ readStochasticMeta <- function(path, format = NULL) { return(NULL) } - if (is.null(format)) { - format <- if (str_detect(path, "\\.afreq(\\.zst)?$")) { + detected <- format %||% + if (str_detect(path, "\\.afreq(\\.zst)?$")) { "afreq" } else { "generic" } - } - format <- arg_match(format, c("afreq", "generic")) + resolved <- arg_match(detected, c("afreq", "generic")) - if (format == "afreq") { + if (resolved == "afreq") { # readAfreq expects a prefix, not a full path - strip the .afreq[.zst] # suffix prefix <- str_remove(path, "\\.afreq(\\.zst)?$") @@ -1099,8 +1152,9 @@ invertMinmaxScaling <- function(X, uMin, uMax) { ) abort(msg) } - denom <- uMax - uMin - denom[denom == 0] <- 1 # monomorphic: scaling was identity + span <- uMax - uMin + # Monomorphic variant: the forward scaling was the identity. + denom <- replace(span, span == 0, 1) # Invert: U_original = U_scaled * (u_max - u_min) / 2 + u_min sweep(sweep(X, 2, denom / 2, "*"), 2, uMin, "+") } @@ -1109,18 +1163,11 @@ invertMinmaxScaling <- function(X, uMin, uMax) { #' Resolve and validate PLINK2 file paths for a given prefix. #' @return Named list with pgen, pvar, psam paths. +#' @importFrom checkmate assertFileExists #' @noRd resolvePlink2Paths <- function(prefix) { pgen <- str_c(prefix, ".pgen") - if (!file.exists(pgen)) { - msg <- glue( - "PLINK2 .pgen file not found at: {pgen}\n", - " Note: .pgen must be uncompressed (plink2 does not ", - "compress .pgen).", - .trim = FALSE - ) - abort(msg) - } + assertFileExists(pgen, access = "r", .var.name = "PLINK2 .pgen file") # Prefer plain .pvar (fast, no extra deps); fall back to .pvar.zst pvar <- if (file.exists(str_c(prefix, ".pvar"))) { str_c(prefix, ".pvar") @@ -1131,15 +1178,7 @@ resolvePlink2Paths <- function(prefix) { abort(msg) } psam <- str_c(prefix, ".psam") - if (!file.exists(psam)) { - msg <- glue( - "PLINK2 .psam file not found at: {psam}\n", - " Note: .psam must be uncompressed (plink2 does not ", - "compress .psam).", - .trim = FALSE - ) - abort(msg) - } + assertFileExists(psam, access = "r", .var.name = "PLINK2 .psam file") list(pgen = pgen, pvar = pvar, psam = psam) } @@ -1153,11 +1192,7 @@ resolvePlink2Paths <- function(prefix) { #' @noRd readPvar <- function(pvarPath) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { - msg <- glue( - "pgenlibr is required. Install from ", - "https://cran.r-project.org/web/packages/pgenlibr/index.html" - ) - abort(msg) + abort("Package 'pgenlibr' is required.") } pvar <- pgenlibr::NewPvar(pvarPath) on.exit(pgenlibr::ClosePvar(pvar), add = TRUE) @@ -1172,6 +1207,32 @@ readPvar <- function(pvarPath) { ) } +# PLINK1 .bim files come in a 6-column form and a 9-column extended form; +# the column meanings are positional, so the width selects the header. +# @noRd +.plinkVariantColnames <- function(n, snpFilePath) { + if (n == 6) { + return(c("chrom", "id", "gpos", "pos", "A1", "A2")) + } + if (n == 9) { + return(c( + "chrom", + "id", + "gpos", + "pos", + "A1", + "A2", + "variance", + "allele_freq", + "n_nomiss" + )) + } + abort(glue( + "Unexpected number of columns ({n}) in variant file: ", + "{snpFilePath}" + )) +} + #' Read variant metadata from either .bim or .pvar/.pvar.zst file. #' #' Auto-detects the format by extension and header, then returns a standardized @@ -1184,39 +1245,17 @@ readPvar <- function(pvarPath) { #' @importFrom readr read_table cols col_character #' @noRd readVariantMetadata <- function(snpFilePath) { - isPvar <- str_detect(snpFilePath, "\\.(pvar|pvar\\.zst)$") - if (!isPvar) { - firstLine <- read_lines(snpFilePath, n_max = 1) - isPvar <- str_detect(firstLine, "^#CHROM") - } + # Extension first, then the header line: a .pvar written without its + # extension still announces itself with a #CHROM header. + byExtension <- str_detect(snpFilePath, "\\.(pvar|pvar\\.zst)$") + isPvar <- byExtension || + str_detect(read_lines(snpFilePath, n_max = 1), "^#CHROM") if (isPvar) { readPvar(snpFilePath) } else { df <- read_table(snpFilePath, col_names = FALSE, col_types = cols()) - n <- ncol(df) - if (n == 6) { - names(df) <- c("chrom", "id", "gpos", "pos", "A1", "A2") - } else if (n == 9) { - names(df) <- c( - "chrom", - "id", - "gpos", - "pos", - "A1", - "A2", - "variance", - "allele_freq", - "n_nomiss" - ) - } else { - msg <- glue( - "Unexpected number of columns ({n}) in variant file: ", - "{snpFilePath}" - ) - abort(msg) - } - df + `names<-`(df, .plinkVariantColnames(ncol(df), snpFilePath)) } } @@ -1274,10 +1313,14 @@ getRefVariantInfo <- function(source, region = NULL) { paths <- resolvePlink2Paths(dataPath) info <- readPvar(paths$pvar) afreq <- readAfreq(dataPath) - if (!is.null(afreq)) { - info$allele_freq <- afreq$alt_freq[match(info$id, afreq$id)] - } - info + mutate( + info, + !!!compact(list( + allele_freq = if (!is.null(afreq)) { + afreq$alt_freq[match(info$id, afreq$id)] + } + )) + ) } # plink1 variant info from the .bim (col5 = A1, col6 = A2). @@ -1302,9 +1345,10 @@ getRefVariantInfo <- function(source, region = NULL) { region = region, returnVariantInfo = TRUE ) - info <- result$variant_info - info$allele_freq <- colMeans(result$X, na.rm = TRUE) / 2 - info + mutate( + result$variant_info, + allele_freq = colMeans(result$X, na.rm = TRUE) / 2 + ) } # Pre-computed LD variant info: read the per-intersection bim/pvar metadata @@ -1315,9 +1359,8 @@ getRefVariantInfo <- function(source, region = NULL) { resolved$metaPath, region )$intersections$bimFilePaths - info <- bind_rows(map(bimPaths, .refReadBimMeta)) - info$id <- normalizeVariantId(info$id) - info + bind_rows(map(bimPaths, .refReadBimMeta)) |> + mutate(id = normalizeVariantId(.data$id)) } # Read one bim/pvar metadata file into a canonical variant-info data.frame, @@ -1332,12 +1375,16 @@ getRefVariantInfo <- function(source, region = NULL) { A2 = df$A2, A1 = df$A1 ) - for (col in c("variance", "allele_freq", "n_nomiss")) { - if (is_in(col, names(df))) { - out[[col]] <- df[[col]] - } - } - out + optional <- intersect(c("variance", "allele_freq", "n_nomiss"), names(df)) + mutate( + out, + !!!set_names(map(optional, .refMetaColumn, df = df), optional) + ) +} + +# @noRd +.refMetaColumn <- function(col, df) { + df[[col]] } # Filter plink2 / plink1 variant info to the requested region. @@ -1361,14 +1408,25 @@ getRefVariantInfo <- function(source, region = NULL) { # OR-mask across a multi-row (one row per chrom) parsed region. # @noRd .refMultiRegionMask <- function(infoChrom, pos, parsed) { - inRegion <- rep(FALSE, length(infoChrom)) - for (r in seq_len(nrow(parsed))) { - inRegion <- inRegion | - (infoChrom == as.character(parsed$chrom[r]) & - pos >= parsed$start[r] & - pos <= parsed$end[r]) - } - inRegion + reduce( + map( + seq_len(nrow(parsed)), + .refRegionRowMask, + infoChrom = infoChrom, + pos = pos, + parsed = parsed + ), + `|`, + .init = rep(FALSE, length(infoChrom)) + ) +} + +# Variants falling inside parsed region row `r`. +# @noRd +.refRegionRowMask <- function(r, infoChrom, pos, parsed) { + infoChrom == as.character(parsed$chrom[r]) & + pos >= parsed$start[r] & + pos <= parsed$end[r] } #' Match variant_info against a whitelist file, returning logical index. Uses @@ -1377,9 +1435,9 @@ getRefVariantInfo <- function(source, region = NULL) { #' @importFrom readr read_lines #' @noRd matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { - keepRaw <- tryCatch( + keepRaw <- try_fetch( as.data.frame(vroom(keepVariantsPath, show_col_types = FALSE)), - error = function(e) NULL + error = function(cnd) NULL ) if ( !is.null(keepRaw) && @@ -1467,16 +1525,16 @@ loadGenotypeRegion <- function( handleSnpInfo <- getSnpInfo(handle) snpIdx <- .loadGenoSnpIdx(handleSnpInfo, region) # Samples x variants matrix (pecotmr convention); callers handle missing. - result <- list( + extracted <- list( X = .dosageMatrix(handle, snpIdx, meanImpute = FALSE), variant_info = .loadGenoAttachAfreq( handle, .snpInfoToVariantInfo(slice(handleSnpInfo, snpIdx)) ) ) - result <- .loadGenoPostFilter(result, keepIndel, keepVariantsPath) + filtered <- .loadGenoPostFilter(extracted, keepIndel, keepVariantsPath) result <- .loadGenoInvertStochastic( - result, + filtered, genotype, stochasticMetaPath, stochasticMetaFormat @@ -1545,20 +1603,32 @@ loadGenotypeRegion <- function( # Apply the indel-drop and variant-whitelist post-filters to (X, variant_info). # @noRd .loadGenoPostFilter <- function(result, keepIndel, keepVariantsPath) { - if (!keepIndel) { - snpMask <- isSnpAlleles( - result$variant_info$A1, - result$variant_info$A2 + snpOnly <- if (keepIndel) { + result + } else { + .loadGenoSubsetVariants( + result, + isSnpAlleles(result$variant_info$A1, result$variant_info$A2) ) - result$X <- result$X[, snpMask, drop = FALSE] - result$variant_info <- result$variant_info[snpMask, , drop = FALSE] } - if (!is.null(keepVariantsPath)) { - keepIdx <- matchVariantsToKeep(result$variant_info, keepVariantsPath) - result$X <- result$X[, keepIdx, drop = FALSE] - result$variant_info <- result$variant_info[keepIdx, , drop = FALSE] + if (is.null(keepVariantsPath)) { + return(snpOnly) } - result + .loadGenoSubsetVariants( + snpOnly, + matchVariantsToKeep(snpOnly$variant_info, keepVariantsPath) + ) +} + +# Subset a loaded (X, variant_info) pair along the variant axis, keeping the +# dosage columns and the metadata rows in step. +# @noRd +.loadGenoSubsetVariants <- function(result, keep) { + list_assign( + result, + X = result$X[, keep, drop = FALSE], + variant_info = result$variant_info[keep, , drop = FALSE] + ) } # Detect stochastic genotype scaling and restore the original scale from a @@ -1584,19 +1654,31 @@ loadGenotypeRegion <- function( if (!any(matched)) { return(result) } - result$X[, matched] <- invertMinmaxScaling( - result$X[, matched, drop = FALSE], - smeta$u_min[idx[matched]], - smeta$u_max[idx[matched]] + inverted <- `[<-`( + result$X, + , + matched, + value = invertMinmaxScaling( + result$X[, matched, drop = FALSE], + smeta$u_min[idx[matched]], + smeta$u_max[idx[matched]] + ) + ) + restored <- list_assign( + result, + X = inverted, + variant_info = mutate( + result$variant_info, + u_min = smeta$u_min[idx], + u_max = smeta$u_max[idx] + ) ) - result$variant_info$u_min <- smeta$u_min[idx] - result$variant_info$u_max <- smeta$u_max[idx] msg <- glue( "Stochastic genotype detected: restored original scale via ", "{basename(metaPath)}" ) inform(msg) - result + restored } # Warn when non-integer dosages are present but no stochastic sidecar was found. @@ -1685,8 +1767,7 @@ loadGenotypeRegion <- function( if (is.null(geno) || length(geno) == 0) { return(NULL) } - storage.mode(geno) <- "double" - geno + `storage.mode<-`(geno, "double") } # The sample-LD matrix for `handle`'s `snpIdx` variants (NA correlations -> 0). @@ -1704,13 +1785,10 @@ loadGenotypeRegion <- function( slide = -1, verbose = FALSE ) - R <- ldMat$LD - R[is.na(R)] <- 0 + raw <- replace(ldMat$LD, is.na(ldMat$LD), 0) inv <- order(ord) - R <- R[inv, inv, drop = FALSE] ids <- getSnpInfo(handle)$SNP[snpIdx] - dimnames(R) <- list(ids, ids) - R + `dimnames<-`(raw[inv, inv, drop = FALSE], list(ids, ids)) } # The (SNP, CHR, BP, A1, A2) snpInfo frame from an open GDS. A1 = the first diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index eb742045d..2cd533f6d 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -22,41 +22,38 @@ NULL #' every row. #' @seealso \code{\link{GwasSumStats}} for the constructor and #' \code{\linkS4class{QtlSumStats}} for the QTL counterpart. +#' @importFrom checkmate makeAssertCollection assertNames assertList #' @export setClass( "GwasSumStats", contains = "SumStatsBase", validity = function(object) { # The ldSketch slot's class union enforces its type. - errors <- character() - required <- "study" - missingCols <- setdiff(required, colnames(mcols(object))) - if (length(missingCols) > 0L) { - errors <- c( - errors, - str_c("missing columns: ", str_flatten(missingCols, ", ")) - ) - } - errors <- c(errors, .sumStatsCheckGenome(object)) - if (!is.list(object@qcInfo)) { - errors <- c(errors, "'qcInfo' slot must be a list") + coll <- makeAssertCollection() + assertNames( + colnames(mcols(object)) %||% character(0), + must.include = "study", + what = "colnames", + .var.name = "mcols", + add = coll + ) + coll$push(.sumStatsCheckGenome(object)) + assertList(object@qcInfo, .var.name = "qcInfo", add = coll) + slotErrors <- coll$getMessages() + if (length(slotErrors) > 0L) { + return(slotErrors) } - if (length(errors) == 0L) { - # The elements ARE GRanges by construction now -- the container is - # a GRangesList -- so the old per-element type and length checks - # are gone. The one-seqname/one-strand invariant is enforced by - # RangedTupleList's own validity. - # Keyed on (study, range), not study alone: a study split across - # chromosomes contributes one element per seqname, so the study - # label legitimately repeats. - if (.ssHasDuplicateKeys(object, "study")) { - errors <- c( - errors, - "(study, range) must be unique" - ) - } + # The elements ARE GRanges by construction now -- the container is + # a GRangesList -- so the old per-element type and length checks + # are gone. The one-seqname/one-strand invariant is enforced by + # RangedTupleList's own validity. + # Keyed on (study, range), not study alone: a study split across + # chromosomes contributes one element per seqname, so the study + # label legitimately repeats. + if (.ssHasDuplicateKeys(object, "study")) { + return("(study, range) must be unique") } - if (length(errors) == 0L) TRUE else errors + TRUE } ) @@ -156,7 +153,11 @@ NULL #' it to carry existing keys through a rebuild; without it a rebuild would #' re-derive them as seqnames and collapse distinct blocks onto one key. #' Mutually exclusive with \code{ldBlocks}. -#' @param ... Additional per-study columns to attach to the collection. +#' @param extraCols Optional named list of additional per-study columns to +#' attach to the collection's \code{mcols}. Named rather than variadic +#' because the base class's own constructor, \code{GRangesList(...)}, uses +#' \code{...} for its \emph{elements}: a bare \code{...} here would read +#' as adding an entry rather than a metadata column. #' @param qcInfo A \code{list} recording which QC steps ran. Empty \code{list()} #' on construction; populated by \code{summaryStatsQc()} with a per-step audit #' record. Fine-mapping / TWAS pipelines reject inputs where @@ -183,7 +184,7 @@ GwasSumStats <- function( qcInfo = list(), ldBlocks = NULL, blockId = NULL, - ... + extraCols = list() ) { if (missing(study) || missing(entry) || missing(genome)) { abort("`study`, `entry`, and `genome` are all required.") @@ -192,9 +193,9 @@ GwasSumStats <- function( cols <- list( study = as.character(study), varY = varY - ) - cols <- .gwasAppendOptional(cols, nCase, nControl, nSample, study) - cols <- .gwasAppendExtras(cols, list(...)) + ) |> + .gwasAppendOptional(nCase, nControl, nSample, study) |> + .gwasAppendExtras(extraCols) dfArgs <- c(cols, list(check.names = FALSE)) # The per-study GRanges become the collection's ELEMENTS; everything else # is per-study metadata and goes in mcols. There is no `entry` column. @@ -206,13 +207,16 @@ GwasSumStats <- function( # with its metadata row replicated alongside. Splitting is unconditional: # a stored element always spans exactly one seqname. split <- .gwasSplitEntry(entry, ldBlocks, blockId, length(entry)) - grl <- GenomicRanges::GRangesList(split$entry) - md <- exec(S4Vectors::DataFrame, !!!dfArgs) - md <- md[split$fromIdx, , drop = FALSE] # `blockId` is always present, so downstream code (cTWAS in particular) can # key regions without first asking how the collection was built. - md$blockId <- split$blockId - mcols(grl) <- md + md <- cbind( + exec(S4Vectors::DataFrame, !!!dfArgs)[split$fromIdx, , drop = FALSE], + S4Vectors::DataFrame(blockId = split$blockId) + ) + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md + ) .sumStatsNewValidated("GwasSumStats", grl, ldSketch, genome, qcInfo) } @@ -225,10 +229,10 @@ GwasSumStats <- function( # The build goes into seqinfo, which is where a GRangesList keeps it and # where every Bioconductor consumer reads it from. Assigned before new() # so validity sees the finished object. - GenomeInfoDb::genome(grl) <- as.character(genome) + built <- GenomeInfoDb::`genome<-`(grl, value = as.character(genome)) obj <- methods::new( Class, - grl, + built, ldSketch = .asLdSketch(ldSketch), qcInfo = as.list(qcInfo) ) @@ -256,15 +260,18 @@ GwasSumStats <- function( # columns, so an entry that still splits further replicates its id rather # than falling out of alignment. This is what lets a rebuild (QC) carry # block keys through instead of silently re-deriving them as seqnames. - split$blockId <- if (!is.null(blockId)) { - .gwasCheckBlockId(blockId, n)[split$fromIdx] - } else { - # unname(): the seqname splitter names its pieces, and those names - # would otherwise ride into the mcols column and make it inconsistent - # with the block path, which produces a bare character vector. - unname(map_chr(split$entry, .gwasElementSeqname)) - } - split + list_assign( + split, + blockId = if (!is.null(blockId)) { + .gwasCheckBlockId(blockId, n)[split$fromIdx] + } else { + # unname(): the seqname splitter names its pieces, and those names + # would otherwise ride into the mcols column and make it + # inconsistent with the block path, which produces a bare + # character vector. + unname(map_chr(split$entry, .gwasElementSeqname)) + } + ) } # @noRd @@ -318,25 +325,26 @@ GwasSumStats <- function( # when supplied; NA for the non-case/control studies in a mixed collection). # @noRd .gwasAppendOptional <- function(cols, nCase, nControl, nSample, study) { - if (!is.null(nCase)) { - cols$nCase <- .recyclePerStudy(nCase, "nCase", study) - } - if (!is.null(nControl)) { - cols$nControl <- .recyclePerStudy(nControl, "nControl", study) - } - if (!is.null(nSample)) { - cols$nSample <- .recyclePerStudy(nSample, "nSample", study) - } - cols + c( + cols, + compact(list( + nCase = if (!is.null(nCase)) { + .recyclePerStudy(nCase, "nCase", study) + }, + nControl = if (!is.null(nControl)) { + .recyclePerStudy(nControl, "nControl", study) + }, + nSample = if (!is.null(nSample)) { + .recyclePerStudy(nSample, "nSample", study) + } + )) + ) } # Append any user-supplied extra columns (from `...`). # @noRd .gwasAppendExtras <- function(cols, extras) { - for (nm in names(extras)) { - cols[[nm]] <- extras[[nm]] - } - cols + c(cols, extras) } @@ -385,17 +393,50 @@ GwasSumStats <- function( #' collection has a single row. #' @param ranges Optional \code{GRanges} restricting the returned variants to #' those it overlaps. \code{NULL} (default) returns the study's full set. -#' @param ... Additional arguments (currently unused). +#' @param context,trait,annotateSignificance QTL-only selectors, named here so +#' that supplying one is an error rather than a silently ignored request. A +#' GWAS has no context or trait axis and carries no significance annotation; +#' leave them \code{NULL}. #' @return A \code{GRanges} object. #' @export setMethod( "getSumStats", signature(x = "GwasSumStats"), - function(x, study = NULL, ranges = NULL, ...) { + function( + x, + study = NULL, + ranges = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL + ) { + # A GWAS has no context / trait axis and no significance annotation: + # those selectors belong to QtlSumStats. They are named here, rather + # than absorbed by `...`, so asking for one is an error instead of a + # silently ignored request -- the shared SumStatsBase accessors pass + # the union of both classes' selectors. + .gwasRefuseQtlSelectors(context, trait, annotateSignificance) .ssStitchElements(x, .gwasSelectStudy(x, study), ranges) } ) +# @noRd +.gwasRefuseQtlSelectors <- function(context, trait, annotateSignificance) { + given <- c( + context = !is.null(context), + trait = !is.null(trait), + annotateSignificance = !is.null(annotateSignificance) + ) + if (!any(given)) { + return(invisible(NULL)) + } + abort(glue( + "getSumStats(GwasSumStats): {str_flatten(names(given)[given], ', ')} ", + "{if (sum(given) == 1L) 'is' else 'are'} a QtlSumStats selector. ", + "A GWAS is selected by `study` (and narrowed by `ranges`)." + )) +} + # getZ / getN / getMaf / nSnps are provided once by SumStatsBase (AllClasses.R). #' @rdname getSumStatsDf @@ -458,9 +499,11 @@ as.data.frame.GwasSumStats <- function( ... ) { gr <- getSumStats(x, study = study) - mc <- as.data.frame(mcols(gr)) - mc$CHR <- as.character(seqnames(gr)) - mc$BP <- start(gr) + mc <- mutate( + as.data.frame(mcols(gr)), + CHR = as.character(seqnames(gr)), + BP = start(gr) + ) firstCols <- c("SNP", "CHR", "BP") restCols <- setdiff(names(mc), firstCols) select(mc, all_of(c(firstCols, restCols))) diff --git a/R/h2Annotations.R b/R/h2Annotations.R index d4d8f2774..264de4e17 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -20,7 +20,7 @@ NULL setMethod( "readAnnotations", signature(paths = "character"), - function(paths, snpRanges, annotationMeta = NULL, genome = "hg19", ...) { + function(paths, snpRanges, annotationMeta = NULL, genome = "hg19") { if (is.null(names(paths))) { msg <- glue( "'paths' must be a named character vector (names = ", @@ -61,19 +61,26 @@ setMethod( if (.annotDetectFormat(p) == "bigwig") "continuous" else "binary" } +# @noRd +.readAnnotColumnAt <- function(i, paths, snpRanges, annotNames) { + .readAnnotColumn(paths[i], snpRanges, annotNames[i]) +} + # Build the (SNP x annotation) matrix by reading each annotation column. # @noRd .readAnnotMatrix <- function(paths, snpRanges, annotNames, nSnps, nAnnots) { - annotMat <- matrix(0, nrow = nSnps, ncol = nAnnots) - colnames(annotMat) <- annotNames - for (i in seq_along(paths)) { - annotMat[, i] <- .readAnnotColumn( - paths[i], - snpRanges, - annotNames[i] - ) - } - annotMat + matrix( + unname(list_c(map( + seq_along(paths), + .readAnnotColumnAt, + paths = paths, + snpRanges = snpRanges, + annotNames = annotNames + ))), + nrow = nSnps, + ncol = nAnnots, + dimnames = list(NULL, annotNames) + ) } # One annotation column, dispatched by detected format (BigWig / .annot / BED). @@ -139,8 +146,7 @@ setMethod( .readBedAnnotation <- function(bedPath, snpRanges) { regions <- rtracklayer::import(bedPath) hits <- findOverlaps(snpRanges, regions) - result <- rep(0L, length(snpRanges)) - result[queryHits(hits)] <- 1L + result <- replace(rep(0L, length(snpRanges)), queryHits(hits), 1L) as.numeric(result) } @@ -174,12 +180,12 @@ setMethod( # Match SNPs by genomic position hits <- findOverlaps(snpRanges, annotGr) - # Initialize result with default 0 - result <- rep(0, length(snpRanges)) - result[queryHits(hits)] <- + # Unmatched SNPs keep the default 0. + replace( + rep(0, length(snpRanges)), + queryHits(hits), as.numeric(dt[[annotName]][subjectHits(hits)]) - - result + ) } # (The AnnotationMatrix() constructor and the getBaseline / getCandidates tier diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index fc83e9ade..f0106bcb2 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -67,39 +67,6 @@ bplapplyBlocks <- function(blockIndices, FUN, BPPARAM = NULL, ...) { # Regression utilities # ============================================================================= -#' @title Weighted Least Squares -#' @description Compute WLS estimate with standard errors. -#' @param y Numeric vector, response. -#' @param X Numeric matrix, predictors. -#' @param w Numeric vector, weights (inverse variance). -#' @return A list with coefficients, SE, residuals, fitted values. -#' @keywords internal -weightedLs <- function(y, X, w) { - if (is.null(dim(X))) { - X <- matrix(X, ncol = 1) - } - W <- diag(sqrt(w)) - Xw <- W %*% X - yw <- W %*% y - XtX <- crossprod(Xw) - Xty <- crossprod(Xw, yw) - coef <- solve(XtX, Xty) - fitted <- X %*% coef - resid <- y - fitted - # Heteroskedasticity-robust SE (HC0) - meat <- crossprod(Xw * as.vector(resid)) - bread <- solve(XtX) - vcov <- bread %*% meat %*% bread - se <- sqrt(diag(vcov)) - list( - coef = as.vector(coef), - se = se, - residuals = as.vector(resid), - fitted = as.vector(fitted), - vcov = vcov - ) -} - #' @title Jackknife Standard Errors by Block #' @description Compute jackknife SE estimates using leave-one-block-out. #' @param estimatesFull Numeric vector, full-sample parameter estimates. @@ -120,57 +87,6 @@ jackknifeSe <- function(estimatesFull, estimatesLoo) { sqrt(jkVar) } -# ============================================================================= -# Ridge-regularized WLS -# ============================================================================= - -#' @title Ridge-Regularized Weighted Least Squares -#' @description WLS with optional L2 penalty on coefficients. -#' @param y Numeric vector, response. -#' @param X Numeric matrix, predictors. -#' @param w Numeric vector, weights (inverse variance). -#' @param lambda Numeric, ridge penalty. 0 = no penalty (delegates to -#' \code{weightedLs}). -#' @param penalizeIntercept Logical. If FALSE (default), the last column of X -#' (assumed to be the intercept) is not penalized. -#' @return Same structure as \code{weightedLs}: coef, se, residuals, fitted, -#' vcov. -#' @keywords internal -weightedLsRidge <- function(y, X, w, lambda = 0, penalizeIntercept = FALSE) { - if (lambda == 0) { - return(weightedLs(y, X, w)) - } - if (is.null(dim(X))) { - X <- matrix(X, ncol = 1) - } - p <- ncol(X) - W <- diag(sqrt(w)) - Xw <- W %*% X - yw <- W %*% y - XtX <- crossprod(Xw) - Xty <- crossprod(Xw, yw) - # Ridge penalty matrix (don't penalize intercept by default) - penalty <- diag(lambda, p) - if (!penalizeIntercept && p > 1) { - penalty[p, p] <- 0 - } - coef <- solve(XtX + penalty, Xty) - fitted <- X %*% coef - resid <- y - fitted - # Sandwich SE accounting for ridge shrinkage - bread <- solve(XtX + penalty) - meat <- crossprod(Xw * as.vector(resid)) - vcov <- bread %*% meat %*% bread - se <- sqrt(pmax(diag(vcov), 0)) - list( - coef = as.vector(coef), - se = se, - residuals = as.vector(resid), - fitted = as.vector(fitted), - vcov = vcov - ) -} - # ============================================================================= # Baseline enrichment computation # ============================================================================= @@ -183,8 +99,10 @@ weightedLsRidge <- function(y, X, w, lambda = 0, penalizeIntercept = FALSE) { return(tauSe * M / abs(h2)) } nBlocks <- nrow(tauBlocks) - h2Blocks <- as.vector(tauBlocks %*% M_a) - h2Blocks[h2Blocks == 0] <- NA + rawH2 <- as.vector(tauBlocks %*% M_a) + # A zero block h2 would divide the enrichment to Inf; NA drops the block + # from the jackknife mean instead. + h2Blocks <- replace(rawH2, rawH2 == 0, NA) enrichmentBlocks <- sweep(tauBlocks, 1, h2Blocks, FUN = "/") * M enrichmentMean <- colMeans(enrichmentBlocks, na.rm = TRUE) enrichmentVar <- (nBlocks - 1) / @@ -260,8 +178,7 @@ shrinkLd <- function( theta <- 2 * nRef / (22 * nRef + 16) # effective recombination distCm <- abs(outer(geneticMap, geneticMap, "-")) shrinkFactor <- exp(-4 * nRef * distCm / (100 * (2 * nRef + 16))) - RShrunk <- R * shrinkFactor - diag(RShrunk) <- 1 + RShrunk <- `diag<-`(R * shrinkFactor, 1) } else { # Simple constant shrinkage lambda <- 1 / sqrt(nRef) @@ -286,8 +203,7 @@ shrinkLd <- function( #' @keywords internal checkGenomeBuild <- function(...) { objects <- list(...) - genomes <- map_chr(objects, .h2GenomeOfObject) - genomes <- genomes[!is.na(genomes)] + genomes <- discard(map_chr(objects, .h2GenomeOfObject), is.na) if (n_distinct(genomes) > 1L) { msg <- glue( "Genome build mismatch: {str_flatten(genomes, ', ')}" @@ -380,20 +296,72 @@ standardizeTauStar <- function(tau, tauBlocks, sdAnnot, MRef, h2g) { NULL } +#' @title Options for the Random-Effects Meta-Analysis Engine +#' @description Build a record of extra arguments for +#' \code{metafor::rma()}, the random-effects meta-analysis engine behind +#' \code{\link{metaSldscRandom}}, +#' \code{\link{metaAnalysisPerCondition}} and +#' \code{\link{calculateFeatureScores}}. +#' @param ... Arguments for \code{metafor::rma()}: \code{test} (the +#' null-distribution choice -- \code{"knha"} is the small-\eqn{k} +#' correction, and these meta-analyses often run on few studies), +#' \code{level}, \code{weighted}, \code{tau2} and \code{control}. +#' \code{rma()}'s signature ends in \code{...}, so names cannot be +#' checked here and a misspelling is passed through. \code{yi} and +#' \code{sei} are the estimate/standard-error pair pecotmr assembles and +#' are refused, as is \code{method}: that is the caller's +#' \code{metaMethod}. +#' +#' These settings apply to the first fit. pecotmr falls back to the +#' closed-form DerSimonian-Laird estimator when an iterative one fails, and +#' the fallback carries them too. +#' @return A \code{MethodOptions} record for the \code{metaArgs} argument. +#' @seealso \code{\link{metaSldscRandom}}, +#' \code{\link{metaAnalysisPerCondition}} +#' @examples +#' RmaOptions(test = "knha") +#' @export +RmaOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + yi = "the per-study estimates pecotmr assembles", + sei = "the per-study standard errors pecotmr assembles", + method = "the caller's `metaMethod`" + ), + "RmaOptions" + ) + .newMethodOptions( + "metafor::rma", + defaults = list(), + extra = extra, + label = "RmaOptions", + engine = "rma" + ) +} + # tryCatch handler for the iterative estimators (only reached when method != # "DL", so DL is always a real fallback here): they can fail on small / # near-homogeneous inputs, so fall back to closed-form DerSimonian-Laird, which # never iterates. -.rmaMetaFallbackToDL <- function(e, means, ses, method) { +.rmaMetaFallbackToDL <- function(e, means, ses, method, metaArgs = list()) { msg <- glue( ".rmaMeta: metafor::rma(method = '{method}') failed ", "({conditionMessage(e)}); falling back to DL." ) warn(msg) - metafor::rma(yi = means, sei = ses, method = "DL") + exec( + metafor::rma, + yi = means, + sei = ses, + method = "DL", + !!!as.list(metaArgs) + ) } -.rmaMeta <- function(means, ses, method = "DL") { +#' @importFrom rlang try_fetch +.rmaMeta <- function(means, ses, method = "DL", metaArgs = list()) { k <- length(means) if (k != length(ses)) { abort(".rmaMeta: means and ses must have the same length.") @@ -407,11 +375,25 @@ standardizeTauStar <- function(tau, tauBlocks, sdAnnot, MRef, h2g) { # directly and let any error propagate. Only the iterative estimators get a # tryCatch fallback to DL. fit <- if (identical(method, "DL")) { - metafor::rma(yi = means, sei = ses, method = "DL") + exec( + metafor::rma, + yi = means, + sei = ses, + method = "DL", + !!!as.list(metaArgs) + ) } else { - tryCatch( - metafor::rma(yi = means, sei = ses, method = method), - error = function(e) .rmaMetaFallbackToDL(e, means, ses, method) + try_fetch( + exec( + metafor::rma, + yi = means, + sei = ses, + method = method, + !!!as.list(metaArgs) + ), + error = function(cnd) { + .rmaMetaFallbackToDL(cnd, means, ses, method, metaArgs) + } ) } list( @@ -483,8 +465,8 @@ NULL .lderBlockStats <- function(block, z, baselineMat) { V <- block$vectors lam <- block$values - x <- as.vector(crossprod(V, z[block$snpIdx]) / sqrt(pmax(lam, 1e-12))) - x[lam < 1e-6] <- 0 + raw <- as.vector(crossprod(V, z[block$snpIdx]) / sqrt(pmax(lam, 1e-12))) + x <- replace(raw, lam < 1e-6, 0) ldAnnot <- if (is.null(baselineMat)) { matrix(1, length(lam), 1) } else { @@ -496,11 +478,11 @@ NULL # Concatenate per-block stats into the genome-wide regression design. M_a is # the annotation SNP counts (univariate: total number of directions). .lderDesign <- function(blockStats, baselineMat) { - x <- unlist(map(blockStats, "x")) + x <- list_c(map(blockStats, "x")) ldAnnotList <- map(blockStats, "ldAnnot") list( x = x, - lam = unlist(map(blockStats, "lam")), + lam = list_c(map(blockStats, "lam")), ldAnnot = exec(rbind, !!!ldAnnotList), blockId = rep( seq_along(blockStats), @@ -614,8 +596,8 @@ NULL rough = rough, twostage = twostage ) - h2Loo <- unlist(map(loo, "h2")) - aLoo <- unlist(map(loo, "a")) + h2Loo <- map_dbl(loo, "h2") + aLoo <- map_dbl(loo, "a") tauList <- map(loo, "tau") tauBlocks <- exec(rbind, !!!tauList) jkSe <- function(v) sqrt((nB - 1) / nB * sum((v - mean(v))^2)) @@ -695,8 +677,7 @@ NULL ) looZ <- exec(rbind, !!!looRows) R <- cor(looZ) - R[is.na(R)] <- 0 - R + replace(R, is.na(R), 0) } # LDER candidate-annotation score statistics against the fitted baseline. @@ -740,8 +721,7 @@ lderUnivariate <- function( n, eigenRef, annotations = NULL, - local = FALSE, - lambda = 0 + local = FALSE ) { rough <- !getInSample(eigenRef) baselineMat <- .h2BaselineMat(annotations) @@ -941,7 +921,7 @@ NULL estHBlocks <- exec(rbind, !!!estHList) tauList <- map(loo, "tau") tauBlocks <- exec(rbind, !!!tauList) - intLoo <- unlist(map(loo, "intercept")) + intLoo <- map_dbl(loo, "intercept") jkSe <- function(v) sqrt(var(v) * (nB - 1)^2 / nB) list( h2Se = jkSe(estHBlocks[, 1]), @@ -1051,8 +1031,7 @@ NULL ) looZ <- exec(rbind, !!!looRows) Rc <- cor(looZ) - Rc[is.na(Rc)] <- 0 - Rc + replace(Rc, is.na(Rc), 0) } list(scoreZ = scoreZ, R = R) } @@ -1062,8 +1041,7 @@ gldscUnivariate <- function( n, ldRef, annotations = NULL, - local = FALSE, - lambda = 0 + local = FALSE ) { ldMatrixList <- getLdMatrixList(ldRef) if (length(ldMatrixList) == 0L) { @@ -1076,8 +1054,8 @@ gldscUnivariate <- function( M <- length(ldRef) A <- .gldscAnnotMatrix(annotations, M) preps <- map(ldMatrixList, .gldscBlockPrep, z = z, A = A) - rawNtau <- sum(unlist(map(preps, "y"))) / - sum(unlist(map(preps, "ldsc"))) + rawNtau <- sum(list_c(map(preps, "y"))) / + sum(list_c(map(preps, "ldsc"))) contrib <- map(preps, .gldscBlockGls, rawNtau = rawNtau) left <- reduce(map(contrib, "L"), `+`) right <- reduce(map(contrib, "R"), `+`) @@ -1086,24 +1064,43 @@ gldscUnivariate <- function( .gldscResult(fit, jk, annotations, preps, rawNtau, local, n, M) } +# The candidate-annotation score statistics, when candidates were supplied and +# the score test could be formed for them. NULL otherwise. +# @noRd +.gldscCandidateScores <- function(annotations, preps, rawNtau, fit) { + if (is.null(annotations)) { + return(NULL) + } + candMat <- assay(getCandidates(annotations), "annotations") + sc <- .gldscScoreStats(preps, candMat, rawNtau, fit$coef) + if (is.null(sc)) { + return(NULL) + } + list( + z = sc$scoreZ, + R = sc$R, + annotationNames = SummarizedExperiment::colData( + getCandidates(annotations) + )$name + ) +} + # Assemble the gldscUnivariate return (enrichment, local, candidate scores). .gldscResult <- function(fit, jk, annotations, preps, rawNtau, local, n, M) { baselineMat <- .h2BaselineMat(annotations) localDf <- if (local) .gldscLocal(preps, rawNtau, n) else NULL - enrichmentDf <- NULL - scoreStats <- NULL - if (!is.null(baselineMat)) { - nm <- SummarizedExperiment::colData(getBaseline(annotations))$name - enrichmentDf <- .gldscEnrichmentDf(fit, jk, baselineMat, nm, M) - } - if (!is.null(annotations)) { - candMat <- assay(getCandidates(annotations), "annotations") - sc <- .gldscScoreStats(preps, candMat, rawNtau, fit$coef) - if (!is.null(sc)) { - cn <- SummarizedExperiment::colData(getCandidates(annotations))$name - scoreStats <- list(z = sc$scoreZ, R = sc$R, annotationNames = cn) - } + enrichmentDf <- if (is.null(baselineMat)) { + NULL + } else { + .gldscEnrichmentDf( + fit, + jk, + baselineMat, + SummarizedExperiment::colData(getBaseline(annotations))$name, + M + ) } + scoreStats <- .gldscCandidateScores(annotations, preps, rawNtau, fit) tau <- if (is.null(baselineMat)) fit$h2 else fit$tau[-1] tauSe <- if (is.null(baselineMat)) jk$h2Se else jk$tauSe[-1] jkRes <- list( @@ -1169,11 +1166,13 @@ NULL nTau <- ncol(ldAnnotScaled) h2a <- param[seq_len(nTau)] int <- param[nTau + 1L] - lamh2 <- as.vector(ldAnnotScaled %*% h2a) * - lam^2 - - lam * sum(h2a) / nRef + - int * lam / n - lamh2 <- pmax(lamh2, lim) + lamh2 <- pmax( + as.vector(ldAnnotScaled %*% h2a) * + lam^2 - + lam * sum(h2a) / nRef + + int * lam / n, + lim + ) sum(log(lamh2)) + sum(bstar^2 / lamh2) } @@ -1199,8 +1198,8 @@ NULL # eigenvalue-score matrix, and M_a. Univariate uses a single all-ones score # column (l_{i,base} = 1) scaled by total M. .hdlDesign <- function(blockData, M, baselineMat) { - lam <- unlist(map(blockData, "lam")) - bstar <- unlist(map(blockData, "bstar")) + lam <- list_c(map(blockData, "lam")) + bstar <- list_c(map(blockData, "bstar")) blockId <- rep( seq_along(blockData), lengths(map(blockData, "lam")) @@ -1246,7 +1245,7 @@ NULL upper = upper ) if (warnOnBound) { - .hdlWarnIfAtBound(opt$par, lower, upper, n, nRef) + .hdlWarnIfAtBound(opt$par, upper, n, nRef) } h2a <- opt$par[seq_len(nTau)] list(h2a = h2a, int = opt$par[nTau + 1L], h2 = sum(h2a)) @@ -1269,7 +1268,7 @@ NULL # legitimate estimate for a null trait. Warning on those would fire on # healthy fits and train the reader to ignore the message. # @noRd -.hdlWarnIfAtBound <- function(par, lower, upper, n, nRef) { +.hdlWarnIfAtBound <- function(par, upper, n, nRef) { tol <- 1e-6 atUpper <- par >= upper - tol if (!any(atUpper)) { @@ -1321,7 +1320,7 @@ NULL ) h2aList <- map(loo, "h2a") h2aBlocks <- exec(rbind, !!!h2aList) - intLoo <- unlist(map(loo, "int")) + intLoo <- map_dbl(loo, "int") jkSe <- function(x) sqrt(mean((x - mean(x))^2) * (nBlocks - 1)) list( h2aSe = apply(h2aBlocks, 2, jkSe), @@ -1452,8 +1451,7 @@ NULL ) looZ <- exec(rbind, !!!looRows) R <- cor(looZ) - R[is.na(R)] <- 0 - R + replace(R, is.na(R), 0) } # ============================================================================= @@ -1465,8 +1463,7 @@ hdlUnivariate <- function( n, eigenRef, annotations = NULL, - local = FALSE, - lambda = 0 + local = FALSE ) { eigenList <- getEigenList(eigenRef) M <- length(eigenRef) @@ -1605,7 +1602,7 @@ sldscUnivariate <- function( A <- .gldscAnnotMatrix(annotations, M) scores <- .sldscScoreMatrix(ldRef, baselineMat, M) baseScore <- scores[, 1L] - blockIdx <- .sldscBlockIndex(ldRef, M) + blockIdx <- .sldscBlockIndex(ldRef) fit <- .sldscFit(chi2, scores, baseScore, n, A, nIter) jk <- .sldscJackknife(chi2, scores, baseScore, n, A, nIter, blockIdx) .sldscResult(fit, jk, annotations, baselineMat, chi2, baseScore, local, M) @@ -1629,19 +1626,28 @@ sldscUnivariate <- function( ) abort(msg) } - strat <- matrix(0, M, ncol(baselineMat)) - for (block in ldMatrixList) { - idx <- block$snpIdx - strat[idx, ] <- (block$R^2) %*% baselineMat[idx, , drop = FALSE] - } + strat <- .h2ScatterBlockRows( + matrix(0, M, ncol(baselineMat)), + map(ldMatrixList, .h2BlockAnnotScores, baselineMat = baselineMat) + ) cbind(base_l2 = base, strat) } +# One block's per-annotation LD scores from its full LD matrix. +# @noRd +.h2BlockAnnotScores <- function(block, baselineMat) { + idx <- block$snpIdx + list( + idx = idx, + values = (block$R^2) %*% baselineMat[idx, , drop = FALSE] + ) +} + # Per-block variant indices, from the LD matrices when present and otherwise # by overlapping the reference's variants with its LD blocks. The jackknife # leaves one of these out at a time. # @noRd -.sldscBlockIndex <- function(ldRef, M) { +.sldscBlockIndex <- function(ldRef) { ldMatrixList <- getLdMatrixList(ldRef) if (length(ldMatrixList) > 0L) { return(map(ldMatrixList, "snpIdx")) @@ -1707,10 +1713,10 @@ sldscUnivariate <- function( # @noRd .sldscFitUnivariate <- function(chi2, scores, baseScore, n, A, nIter) { M <- nrow(A) - keep <- chi2 < 30 - if (sum(keep) < 4L) { - keep <- rep(TRUE, length(chi2)) - } + # Too few variants survive the chi2 cap to fit on: keep everything rather + # than fit on a handful. + capped <- chi2 < 30 + keep <- if (sum(capped) < 4L) rep(TRUE, length(chi2)) else capped # One set of initial weights, formed on the full data, reused by both # steps -- upstream computes `initial_w` once and subsets it for step 1. xTot <- rowSums(scores) @@ -1748,9 +1754,13 @@ sldscUnivariate <- function( # @noRd .sldscFitPartitioned <- function(chi2, scores, baseScore, n, A) { M <- nrow(A) - keep <- chi2 < max(0.001 * n, 80) - if (sum(keep) < ncol(scores) + 2L) { - keep <- rep(TRUE, length(chi2)) + # Too few variants survive the chi2 cap for the design's width: keep + # everything rather than fit an underdetermined system. + capped <- chi2 < max(0.001 * n, 80) + keep <- if (sum(capped) < ncol(scores) + 2L) { + rep(TRUE, length(chi2)) + } else { + capped } chi2 <- chi2[keep] scores <- scores[keep, , drop = FALSE] @@ -1893,11 +1903,17 @@ sldscUnivariate <- function( local, M ) { - localDf <- if (local) .sldscLocal(chi2, baseScore, fit, M) else NULL - enrichmentDf <- NULL - if (!is.null(baselineMat)) { - nm <- SummarizedExperiment::colData(getBaseline(annotations))$name - enrichmentDf <- .gldscEnrichmentDf(fit, jk, baselineMat, nm, M) + localDf <- if (local) .sldscLocal(chi2, baseScore, fit) else NULL + enrichmentDf <- if (is.null(baselineMat)) { + NULL + } else { + .gldscEnrichmentDf( + fit, + jk, + baselineMat, + SummarizedExperiment::colData(getBaseline(annotations))$name, + M + ) } tau <- if (is.null(baselineMat)) fit$h2 else fit$tau[-1] tauSe <- if (is.null(baselineMat)) jk$h2Se else jk$tauSe[-1] @@ -1916,7 +1932,7 @@ sldscUnivariate <- function( # Per-variant local h2 contribution: the fitted non-intercept signal spread # over the variant's own LD score. # @noRd -.sldscLocal <- function(chi2, baseScore, fit, M) { +.sldscLocal <- function(chi2, baseScore, fit) { tibble( variantIdx = seq_along(chi2), chi2 = chi2, @@ -1952,15 +1968,23 @@ sldscUnivariate <- function( ldRef, annotations, local, - ... + estimatorArgs = list() ) { - switch( + # `estimatorArgs` rather than `...`: the estimators take different + # trailing arguments (`nIter` for sldsc; the others take none today), so + # an unknown name should fail here rather than at whichever estimator the + # method token happens to select. lder/gldsc/hdl used to advertise a + # ridge `lambda` here that nothing read -- upstream LDER and HDL have no + # such penalty, and the function behind it had no callers. + base <- list(z, n, ldRef, annotations, local) + fn <- switch( method, - "lder" = lderUnivariate(z, n, ldRef, annotations, local, ...), - "gldsc" = gldscUnivariate(z, n, ldRef, annotations, local, ...), - "sldsc" = sldscUnivariate(z, n, ldRef, annotations, local, ...), - "hdl" = hdlUnivariate(z, n, ldRef, annotations, local, ...) + "lder" = lderUnivariate, + "gldsc" = gldscUnivariate, + "sldsc" = sldscUnivariate, + "hdl" = hdlUnivariate ) + exec(fn, !!!base, !!!estimatorArgs) } # The estimators read `z` and the annotation rows positionally, by each LD @@ -2069,21 +2093,19 @@ setMethod( annotations = NULL, local = FALSE, study = NULL, - ... + estimatorArgs = list() ) { method <- arg_match(method, c("lder", "gldsc", "sldsc", "hdl")) .validateMethodRef(method, ldRef) study <- .estimateH2ResolveStudy(sumstats, study) .h2ValidateInputs(sumstats, study, ldRef, annotations) z <- getZ(sumstats, study = study) - n <- median(getN(sumstats, study = study)) + rawN <- median(getN(sumstats, study = study)) M <- nSnps(sumstats, study = study) # Legacy heritability-wrapper correction (separate from the SuSiE RSS # binaryTraitModel handling in the fine-mapping pipeline). varY <- getVarY(sumstats, study = study) - if (!is.null(varY)) { - n <- n / varY - } + n <- if (is.null(varY)) rawN else rawN / varY result <- .estimateH2Dispatch( method, z, @@ -2091,7 +2113,7 @@ setMethod( ldRef, annotations, local, - ... + estimatorArgs = estimatorArgs ) .h2EstimateFromResult(result, method, M, study) } @@ -2120,37 +2142,63 @@ setMethod( # computeLdScores -- LD score computation # ============================================================================= +# Write each block's rows into `base`. Deliberate scatter: the score matrices +# are variants-long and the blocks partition the rows, so every block writes +# its own slice exactly once and rows in no block keep their initial value. +# Rebuilding by rbind would require the blocks to cover every variant. +# @noRd +.h2ScatterBlockRows <- function(base, blocks) { + for (b in blocks) { + base[b$idx, ] <- b$values + } + base +} + +# One block's base LD scores. +# @noRd +.h2BlockBaseScores <- function(block) { + Vd <- sweep(block$vectors, 2, block$values, "*") + list(idx = block$snpIdx, values = rowSums(Vd^2)) +} + # Base LD scores l2[j] = sum_i (V[j,i] * d[i])^2 (since R = V D V'). .computeLdScoresBase <- function(eigenList, nSnps) { - l2 <- numeric(nSnps) - for (b in seq_along(eigenList)) { - block <- eigenList[[b]] - Vd <- sweep(block$vectors, 2, block$values, "*") - l2[block$snpIdx] <- rowSums(Vd^2) - } - matrix(l2, ncol = 1, dimnames = list(NULL, "base_l2")) + .h2ScatterBlockRows( + matrix(0, nrow = nSnps, ncol = 1, dimnames = list(NULL, "base_l2")), + map(eigenList, .h2BlockBaseScores) + ) } # Base + annotation-stratified LD scores. Stratified column a: # l2_a[j] = sum_i (V[j,i] d[i])^2 * (sum_k V[k,i]^2 annot[k,a]). .computeLdScoresStratified <- function(eigenList, annotations, nSnps) { annotMat <- assay(annotations, "annotations") - nAnnot <- ncol(annotMat) - l2Strat <- matrix(0, nrow = nSnps, ncol = 1 + nAnnot) - for (b in seq_along(eigenList)) { - block <- eigenList[[b]] - idx <- block$snpIdx - V <- block$vectors - Vd2 <- sweep(V, 2, block$values, "*")^2 - l2Strat[idx, 1] <- rowSums(Vd2) - for (a in seq_len(nAnnot)) { - annotWeights <- as.vector(crossprod(V^2, annotMat[idx, a])) - l2Strat[idx, 1 + a] <- as.vector(Vd2 %*% annotWeights) - } - } annotNames <- SummarizedExperiment::colData(annotations)$name - colnames(l2Strat) <- c("base_l2", annotNames) - l2Strat + .h2ScatterBlockRows( + matrix( + 0, + nrow = nSnps, + ncol = 1 + ncol(annotMat), + dimnames = list(NULL, c("base_l2", annotNames)) + ), + map(eigenList, .h2BlockStratScores, annotMat = annotMat) + ) +} + +# One block's base + annotation-stratified scores. All annotations are taken +# in a single matrix product rather than one column at a time. +# @noRd +.h2BlockStratScores <- function(block, annotMat) { + idx <- block$snpIdx + V <- block$vectors + Vd2 <- sweep(V, 2, block$values, "*")^2 + list( + idx = idx, + values = cbind( + rowSums(Vd2), + Vd2 %*% crossprod(V^2, annotMat[idx, , drop = FALSE]) + ) + ) } #' @rdname computeLdScores @@ -2158,7 +2206,7 @@ setMethod( setMethod( "computeLdScores", signature(ldRef = "LdEigen"), - function(ldRef, annotations = NULL, ...) { + function(ldRef, annotations = NULL) { # Reconstruct LD scores from eigendecompositions # l2[j] = sum_k r^2_{jk} = sum_b sum_{eigenvalues in b} V[j,.]^2 * d nSnps <- length(ldRef) @@ -2175,7 +2223,7 @@ setMethod( setMethod( "computeLdScores", signature(ldRef = "LdScore"), - function(ldRef, annotations = NULL, ...) { + function(ldRef, annotations = NULL) { if (is.null(annotations)) { return(getLdScores(ldRef)) } @@ -2191,29 +2239,18 @@ setMethod( abort(msg) } - nSnps <- length(ldRef) annotMat <- assay(annotations, "annotations") - nAnnot <- ncol(annotMat) - - # Base L2 + annotation-stratified columns - l2Strat <- matrix(0, nrow = nSnps, ncol = 1 + nAnnot) - l2Strat[, 1] <- getLdScores(ldRef)[, 1] - - for (b in seq_along(ldMatrixList)) { - block <- ldMatrixList[[b]] - R <- block$R - idx <- block$snpIdx - R2 <- R^2 - for (a in seq_len(nAnnot)) { - # l2_a[j] = sum_k R^2_{jk} * annot[k, a] - l2Strat[idx, 1 + a] <- as.vector(R2 %*% annotMat[idx, a]) - } - } - - annotNames <- SummarizedExperiment::colData(annotations)$name - colNames <- c("base_l2", annotNames) - colnames(l2Strat) <- colNames - l2Strat + # The stratified columns l2_a[j] = sum_k R^2_{jk} annot[k, a] are + # scattered per block; the base column comes from the reference and + # is joined on afterwards, so the scatter never touches it. + strat <- .h2ScatterBlockRows( + matrix(0, nrow = length(ldRef), ncol = ncol(annotMat)), + map(ldMatrixList, .h2BlockAnnotScores, baselineMat = annotMat) + ) + `colnames<-`( + cbind(getLdScores(ldRef)[, 1], strat), + c("base_l2", SummarizedExperiment::colData(annotations)$name) + ) } ) @@ -2224,6 +2261,7 @@ setMethod( # Converter: H2Estimate -> sldsc_wrapper list format # ============================================================================= +#' @importFrom checkmate assertClass #' @title Convert H2Estimate to S-LDSC Trait Format #' @description Convert an \code{H2Estimate} object into the list format #' expected by \code{\link{standardizeSldscTrait}} and @@ -2249,9 +2287,7 @@ setMethod( #' h2EstimateToSldscTrait(h2EstimateExample) #' @export h2EstimateToSldscTrait <- function(h2Est) { - if (!is(h2Est, "H2Estimate")) { - abort("h2Est must be an H2Estimate object") - } + assertClass(h2Est, "H2Estimate") enrichDf <- getEnrichment(h2Est) if (is.null(enrichDf)) { @@ -2265,18 +2301,13 @@ h2EstimateToSldscTrait <- function(h2Est) { cats <- as.character(enrichDf$annotation) nCats <- length(cats) - tauBlocks <- getTauBlocks(h2Est) - if (is.null(tauBlocks)) { - # Create a dummy single-block matrix from the point estimates - tauBlocks <- matrix(enrichDf$tau, nrow = 1) - colnames(tauBlocks) <- cats - nBlocks <- 1L - } else { - nBlocks <- nrow(tauBlocks) - if (is.null(colnames(tauBlocks))) { - colnames(tauBlocks) <- cats - } - } + rawTau <- getTauBlocks(h2Est) + # Without per-block estimates the point estimates stand in as one block. + tauBlocks <- `colnames<-`( + rawTau %||% matrix(enrichDf$tau, nrow = 1), + colnames(rawTau) %||% cats + ) + nBlocks <- nrow(tauBlocks) list( categories = cats, @@ -2325,8 +2356,7 @@ h2EstimateToSldscTrait <- function(h2Est) { # coordinate check in .h2CheckPositions() is the stronger guard regardless. # @noRd .h2GenomeOfRanges <- function(x) { - g <- unique(GenomeInfoDb::genome(x)) - g <- g[!is.na(g)] + g <- discard(unique(GenomeInfoDb::genome(x)), is.na) if (length(g) == 0L) { return(NA_character_) } @@ -2370,10 +2400,11 @@ h2EstimateToSldscTrait <- function(h2Est) { .lderLocalBlock(blockStats[[b]], b, N, a) } -# LDER weighted score z for candidate column `c` under the `keep` block mask. +# LDER weighted score z for candidate column `cand` under the `keep` block +# mask. # @noRd -.lderScoreForCand <- function(c, ldCand, lam, w, resid, N, keep) { - .lderCandidateScore(ldCand[, c], lam, w, resid, N, keep) +.lderScoreForCand <- function(cand, ldCand, lam, w, resid, N, keep) { + .lderCandidateScore(ldCand[, cand], lam, w, resid, N, keep) } # LDER leave-one-block-out candidate score z's for block `b`. diff --git a/R/jointEngine.R b/R/jointEngine.R index 909d3fae0..6cf2b9ca0 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -56,14 +56,17 @@ NULL if (is.null(cv)) { return(NULL) } - out <- list(samplePartition = cv$samplePartition) - if (!is.null(cv$prediction)) { - out$prediction <- map(cv$prediction, .fmCvSliceCol, r = r) - } - if (!is.null(cv$performance)) { - out$performance <- map(cv$performance, .fmCvSliceRow, r = r) - } - out + c( + list(samplePartition = cv$samplePartition), + compact(list( + prediction = if (!is.null(cv$prediction)) { + map(cv$prediction, .fmCvSliceCol, r = r) + }, + performance = if (!is.null(cv$performance)) { + map(cv$performance, .fmCvSliceRow, r = r) + } + )) + ) } # Slice a twas joint cvResult (.jointTwasCvResult output: list(samplePartition, @@ -109,11 +112,12 @@ NULL # 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). +#' @importFrom rlang try_fetch .traitPosFor <- function(data, context, trait) { if (methods::is(data, "QtlDataset")) { - se <- tryCatch( + se <- try_fetch( getPhenotypes(data, contexts = context), - error = function(e) NULL + error = function(cnd) NULL ) if (is.null(se)) { return(NULL) @@ -198,24 +202,19 @@ NULL cisWindow = NULL ) { kind <- arg_match(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]] - } - } + anchors <- map( + seq_along(traits), + .jointAnchorAt, + data = data, + contexts = contexts, + traits = traits, + kind = kind, + cisWindow = cisWindow + ) + anyFound <- any(map_lgl(anchors, "found")) + chrs <- map_chr(anchors, "chr") + starts <- map_int(anchors, "start") + ends <- map_int(anchors, "end") # Nothing resolved (e.g. a QtlSumStats with no supplied traitPos): return # NULL # so the builder omits the column entirely and getTraitPosition() reports @@ -230,6 +229,27 @@ NULL ) } +# One trait's anchor, or the chrUn sentinel when it does not resolve. `found` +# records which it was, so the caller can tell "nothing resolved" from "every +# anchor really is chrUn:1-1". +# @noRd +.jointAnchorAt <- function(i, data, contexts, traits, kind, cisWindow) { + g <- if (kind == "traitPos") { + .traitPosFor(data, contexts[[i]], traits[[i]]) + } else { + .fitRegionFor(data, contexts[[i]], traits[[i]], cisWindow) + } + if (is.null(g)) { + return(list(found = FALSE, chr = "chrUn", start = 1L, end = 1L)) + } + list( + found = TRUE, + chr = as.character(GenomicRanges::seqnames(g))[[1L]], + start = GenomicRanges::start(g)[[1L]], + end = GenomicRanges::end(g)[[1L]] + ) +} + # ---- fitters (fitJointGroup) ------------------------------------------------ # (individual, fine-mapping) -> mvSuSiE joint fit + honest per-fold CV prior. @@ -273,15 +293,18 @@ setMethod( "fsusie", args$methodArgs[["fsusie"]] ) - fit <- exec(fitFsusie, !!!fitArgs) + raw <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fitArgs)) # Collapse the functional fit to a variants x features weight matrix now # (trimming later drops fitted_wc/csd_X); store on $coef so a trimmed fit # can still yield TWAS weights. - fit$coef <- tryCatch( - fsusieWeights(fsusieFit = fit, variantIds = colnames(Xc)), - error = function(e) NULL - ) - fit <- .setFinemappingFitClass(fit, "fsusie") + fit <- list_assign( + raw, + coef = try_fetch( + fsusieWeights(fsusieFit = raw, variantIds = colnames(Xc)), + error = function(cnd) NULL + ) + ) |> + .setFinemappingFitClass("fsusie") cvM <- .jointFsusieCv(Xc, Yc, group, cfg, args, verbose) map( seq_len(nCond), @@ -296,7 +319,8 @@ setMethod( # Per-fold fsusie CV slice, or NULL when CV is disabled. # @noRd .jointFsusieCv <- function(Xc, Yc, group, cfg, args, verbose) { - cvFolds <- if (is.null(cfg$cvFolds)) 0L else cfg$cvFolds + cv <- cfg$crossValidationArgs %||% list() + cvFolds <- cv$folds %||% 0L if (cvFolds <= 1L) { return(NULL) } @@ -306,11 +330,11 @@ setMethod( "fsusie", args$methodArgs, cvFolds, - samplePartition = cfg$samplePartition, - coverage = cfg$coverage, + samplePartition = cfg$crossValidationArgs$samplePartition, + coverage = cfg$credibleSetArgs$coverage, pos = .jgTraitPos(group), verbose = verbose, - numThreads = if (is.null(cfg$cvThreads)) 1L else cfg$cvThreads, + numThreads = cv$threads %||% 1L, seed = cfg$seed ) .fmSliceCv(cv, "fsusie") @@ -318,24 +342,29 @@ setMethod( # One fsusie per-condition (trait) FineMappingRow, with its CV slice attached. # @noRd -.jointFsusieEntry <- function(r, fit, cvM, Xc, cfg) { - e <- .fmPostprocessOne( +.jointFsusieEntry <- function( + r, + fit, + cvM, + Xc, + cfg, + credibleSetArgs, + fitRetention +) { + bare <- .fmPostprocessOne( fit = fit, method = "fsusie", dataX = Xc, dataY = NULL, conditionIdx = r, - coverage = cfg$coverage, - secondaryCoverage = cfg$secondaryCoverage, - signalCutoff = cfg$signalCutoff, - minAbsCorr = cfg$minAbsCorr, csInput = "fsusie", - fullFit = cfg$fullFit, - fullFitAlphaOnly = cfg$fullFitAlphaOnly, - includeAllCs = cfg$includeAllCs + credibleSetArgs = cfg$credibleSetArgs, + fitRetention = cfg$fitRetention ) - if (!is.null(cvM)) { - e <- .fmAttachCv(e, .fmSliceCvCondition(cvM, r)) + e <- if (is.null(cvM)) { + bare + } else { + .fmAttachCv(bare, .fmSliceCvCondition(cvM, r)) } e } @@ -379,27 +408,24 @@ setMethod( # mask when active, or NULL to signal < 2 survivors (skip the whole joint). # @noRd .jointMvSerScreen <- function(Xc, Yc, nCond, args, verbose) { - keep <- rep(TRUE, nCond) if (!.fmScreenActive(args$pipCutoffToSkip)) { - return(keep) + return(rep(TRUE, nCond)) } keep <- as.logical(.fmSerScreenColumns(Xc, Yc, args$pipCutoffToSkip)) if (sum(keep) < 2L) { if (verbose >= 1) { - msg <- glue( + inform(glue( "Skipping mvsusie joint fit: < 2 of {nCond} conditions pass ", "the SER pre-screen." - ) - inform(msg) + )) } return(NULL) } if (sum(keep) < nCond && verbose >= 1) { - msg <- glue( + inform(glue( "mvsusie joint fit: SER pre-screen kept {sum(keep)} of ", "{nCond} conditions." - ) - inform(msg) + )) } keep } @@ -410,34 +436,34 @@ setMethod( .jointMvFit <- function(group, Xc, Ys, cfg, args, ddCut, verbose) { key <- .jointPriorKey(.jgConditions(group)) mvFitParts <- .fmLookupMrmashFit( - args$twasWeights, + args$mrmashPrior, key$study, key$trait, context = key$context ) mvCv <- .fmLookupMrmashCv( - args$twasWeights, + args$mrmashPrior, key$study, key$trait, context = key$context ) mvPrior <- .buildMvsusieReweightedPrior(mvFitParts, colnames(Ys), ddCut) - mvBaseArgs <- list( - X = Xc, - Y = Ys, - prior_variance = mvPrior$priorVariance, - coverage = cfg$coverage + mvBaseArgs <- c( + list( + X = Xc, + Y = Ys, + prior_variance = mvPrior$priorVariance, + coverage = cfg$credibleSetArgs$coverage + ), + compact(list(residual_variance = mvPrior$residualVariance)) ) - if (!is.null(mvPrior$residualVariance)) { - mvBaseArgs$residual_variance <- mvPrior$residualVariance - } fitArgs <- .fmMergeUserArgs( mvBaseArgs, "mvsusie", args$methodArgs[["mvsusie"]] ) - fit <- exec(fitMvsusie, !!!fitArgs) - fit <- .setFinemappingFitClass(fit, "mvsusie") + fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, fitArgs)) |> + .setFinemappingFitClass("mvsusie") cvM <- .jointMvCv( Xc, Ys, @@ -465,14 +491,12 @@ setMethod( ddCut, verbose ) { - cvFolds <- if (is.null(cfg$cvFolds)) 0L else cfg$cvFolds + cv <- cfg$crossValidationArgs %||% list() + cvFolds <- cv$folds %||% 0L if (cvFolds <= 1L) { return(NULL) } - sp <- cfg$samplePartition - if (is.null(sp) && !is.null(mvCv)) { - sp <- mvCv$samplePartition - } + sp <- cfg$crossValidationArgs$samplePartition %||% mvCv$samplePartition mvPriorCv <- .fmBuildMvsusiePriorCv(mvCv, mvFitParts, colnames(Ys), ddCut) cv <- .fmWeightsCv( Xc, @@ -481,11 +505,11 @@ setMethod( args$methodArgs, cvFolds, samplePartition = sp, - coverage = cfg$coverage, + coverage = cfg$credibleSetArgs$coverage, verbose = verbose, mvPrior = mvPrior, mvPriorCv = mvPriorCv, - numThreads = if (is.null(cfg$cvThreads)) 1L else cfg$cvThreads, + numThreads = cv$threads %||% 1L, seed = cfg$seed ) .fmSliceCv(cv, "mvsusie") @@ -494,28 +518,34 @@ setMethod( # One mvsusie per-condition entry (NULL for a screened-out column), sliced at # the condition's position in the fitted survivor set + its CV slice. # @noRd -.jointMvEntry <- function(i, fitted, Xc, keep, survivors, cfg) { +.jointMvEntry <- function( + i, + fitted, + Xc, + keep, + survivors, + cfg, + credibleSetArgs, + fitRetention +) { if (!keep[i]) { return(NULL) } r <- match(i, survivors) - e <- .fmPostprocessOne( + bare <- .fmPostprocessOne( fit = fitted$fit, method = "mvsusie", dataX = Xc, dataY = NULL, conditionIdx = r, - coverage = cfg$coverage, - secondaryCoverage = cfg$secondaryCoverage, - signalCutoff = cfg$signalCutoff, - minAbsCorr = cfg$minAbsCorr, csInput = "X", - fullFit = cfg$fullFit, - fullFitAlphaOnly = cfg$fullFitAlphaOnly, - includeAllCs = cfg$includeAllCs + credibleSetArgs = cfg$credibleSetArgs, + fitRetention = cfg$fitRetention ) - if (!is.null(fitted$cvM)) { - e <- .fmAttachCv(e, .fmSliceCvCondition(fitted$cvM, r)) + e <- if (is.null(fitted$cvM)) { + bare + } else { + .fmAttachCv(bare, .fmSliceCvCondition(fitted$cvM, r)) } e } @@ -549,7 +579,6 @@ setMethod( seq_len(ncol(.jgZ(group))), .jointRssEntry, fit = fit, - group = group, ldMat = ldMat, cfg = cfg ) @@ -567,7 +596,7 @@ setMethod( } key <- .jointPriorKey(.jgConditions(group)) mvFitParts <- .fmLookupMrmashFit( - args$twasWeights, + args$mrmashPrior, key$study, key$trait, context = key$context @@ -582,37 +611,36 @@ setMethod( R = ldMat, N = as.numeric(stats::median(.jgN(group))), prior_variance = mvPrior$priorVariance, - coverage = cfg$coverage - ) - if (!is.null(mvPrior$residualVariance)) { - mvBaseArgs$residual_variance <- mvPrior$residualVariance - } + coverage = cfg$credibleSetArgs$coverage + ) |> + c(compact(list(residual_variance = mvPrior$residualVariance))) fitArgs <- .fmMergeUserArgs( mvBaseArgs, "mvsusie", args$methodArgs[["mvsusie"]] ) - fit <- exec(fitMvsusieRss, !!!fitArgs) + fit <- exec( + fitMvsusieRss, + !!!.splitMethodArgs(fitMvsusieRss, fitArgs) + ) .setFinemappingFitClass(fit, "mvsusie") } # One RSS per-condition FineMappingRow (csInput = "Xcorr"). # @noRd -.jointRssEntry <- function(r, fit, group, ldMat, cfg) { +# `credibleSet` / `fitRetention` come off `cfg`, which is what the caller +# supplies; they were also declared as formals with no defaults, so nothing +# could ever have passed them without erroring. `group` was unused too. +.jointRssEntry <- function(r, fit, ldMat, cfg) { .fmPostprocessOne( fit = fit, method = "mvsusie", dataX = ldMat, dataY = NULL, conditionIdx = r, - coverage = cfg$coverage, - secondaryCoverage = cfg$secondaryCoverage, - signalCutoff = cfg$signalCutoff, - minAbsCorr = cfg$minAbsCorr, csInput = "Xcorr", - fullFit = cfg$fullFit, - fullFitAlphaOnly = cfg$fullFitAlphaOnly, - includeAllCs = cfg$includeAllCs + credibleSetArgs = cfg$credibleSetArgs, + fitRetention = cfg$fitRetention ) } @@ -691,7 +719,10 @@ setMethod( } else { NULL }, - foldFits = NULL + # The fine-mapping CV refits the method on each fold's training rows; + # those fits are what let a SuSiE-family method be cross-validated at + # all now that its weight wrappers never fit. + foldFits = fineMappingCv$foldFits ) } @@ -715,7 +746,7 @@ setMethod( nCond <- ncol(Yc) cond <- .jgConditions(group) methodKey <- .twasMethodKey(token) - stdz <- cfg$standardized + stdz <- cfg$standardized %||% FALSE fittedModels <- args$fittedModels %||% list() ma <- .jointTwasMethodArgs( args, @@ -768,7 +799,7 @@ setMethod( cfg, stdz ) { - ma <- if ( + supplied <- if ( !is.null(args$methodList) && is_in(methodKey, names(args$methodList)) ) { args$methodList[[methodKey]] @@ -777,23 +808,32 @@ setMethod( } else { NULL } - if (is.null(ma)) { - ma <- list() - } # FM-fit injection: an FM-derived token extracts its weights from the # precomputed fine-mapping fit rather than refitting. + withFit <- .jointTwasInjectFit( + supplied %||% list(), + token, + fittedModels + ) + if (!isTRUE(cfg$estimatePi) || !is_in(token, c("bayesC", "bayesB"))) { + return(withFit) + } + .jointTwasSpikeSlabPi(withFit, token, Xc, Yc, cond, cfg, stdz) +} + +# The method args with the precomputed fine-mapping fit injected, when the +# token has an adapter, a fit exists, and the caller did not pass one. +# @noRd +.jointTwasInjectFit <- function(ma, token, fittedModels) { adapter <- .twasFineMappingMethodAdapters[[token]] if ( - !is.null(adapter) && - !is.null(fittedModels[[token]]) && - is.null(ma[[adapter$fitArg]]) + is.null(adapter) || + is.null(fittedModels[[token]]) || + !is.null(ma[[adapter$fitArg]]) ) { - ma[[adapter$fitArg]] <- fittedModels[[token]] + return(ma) } - if (isTRUE(cfg$estimatePi) && is_in(token, c("bayesC", "bayesB"))) { - ma <- .jointTwasSpikeSlabPi(ma, token, Xc, Yc, cond, cfg, stdz) - } - ma + list_assign(ma, !!!set_names(list(fittedModels[[token]]), adapter$fitArg)) } # Spike-and-slab pi from an internal mr.ash fit (self-contained per method). @@ -806,20 +846,29 @@ setMethod( study = as.character(cond$study[1L]), context = as.character(cond$context[1L]), trait = as.character(cond$trait[1L]), - retainFits = TRUE, + fitRetention = "slim", standardized = stdz, dataType = cfg$dataType, verbose = 0, seed = cfg$seed ) piHat <- as.numeric(estimateSparsity(mrA)) - if (token == "bayesC" && is.null(ma$pi)) { - ma$pi <- piHat - } - if (token == "bayesB" && is.null(ma$probIn)) { - ma$probIn <- piHat - } - ma + list_assign( + ma, + !!!compact(list( + pi = if (token == "bayesC" && is.null(ma$pi)) piHat, + probIn = if (token == "bayesB" && is.null(ma$probIn)) piHat + )) + ) +} + +# The retention level a joint fit runs at. The engine always keeps its fit -- +# the joint layers downstream read it -- so "none" from the pipeline means +# "keep the least we can", not "keep nothing". +# @noRd +.jointRetentionLevel <- function(cfg) { + level <- cfg$fitRetention %||% "slim" + if (identical(level, "none")) "slim" else level } # Full-data TWAS weight fit for a joint group. Returns list(W, fitParts, vids); @@ -843,7 +892,7 @@ setMethod( if (!fitFullData) { return(list(W = NULL, fitParts = NULL, vids = colnames(Xc))) } - rfd <- if (is.null(cfg$retainFitDetail)) "slim" else cfg$retainFitDetail + retention <- .jointRetentionLevel(cfg) verbose <- if (is.null(cfg$verbose)) 1 else cfg$verbose tw <- learnTwasWeights( Xc, @@ -853,8 +902,7 @@ setMethod( context = as.character(cond$context[1L]), trait = as.character(cond$trait[1L]), fittedModels = fittedModels, - retainFits = TRUE, - retainFitDetail = rfd, + fitRetention = retention, standardized = stdz, dataType = cfg$dataType, verbose = verbose, @@ -862,9 +910,11 @@ setMethod( ) base <- .twrRowParts(tw, 1L) vids <- .twrPartsVariantIds(base) - W <- getWeights(base) - if (!is.matrix(W)) { - W <- matrix(W, ncol = nCond, dimnames = list(vids, NULL)) + raw <- getWeights(base) + W <- if (is.matrix(raw)) { + raw + } else { + matrix(raw, ncol = nCond, dimnames = list(vids, NULL)) } list(W = W, fitParts = getFits(base), vids = vids) } @@ -891,42 +941,107 @@ setMethod( # Cross-validated prediction result for a TWAS token: reuse fine-mapping's own # CV when available, else run twasWeightsCv (skipping all-zero-weight methods). +# Whether `token` should be cross-validated. `cvWeightMethods` is the caller's +# explicit override of the CV method set; NULL (the default) means "every +# method that produced non-zero weights", which is what the per-method +# all-zero check below enforces. # @noRd -.jointTwasCv <- function(Xc, Yc, wm, ma, W, args, cfg, token) { - cvFolds <- if (is.null(cfg$cvFolds)) 0L else cfg$cvFolds - if (cvFolds <= 1L) { - return(NULL) - } - cvRes <- .twasFmHandoffCv(args$fineMappingCv, token) - if (!is.null(cvRes) || (!is.null(W) && all(W == 0))) { - return(cvRes) +.jointTwasCvRequested <- function(cvWeightMethods, token) { + if (is.null(cvWeightMethods)) { + return(TRUE) } - .jointTwasLeakageWarn(args, ma) - verbose <- if (is.null(cfg$verbose)) 1 else cfg$verbose - sp <- if (!is.null(args$samplePartition)) { - args$samplePartition + requested <- if (is.list(cvWeightMethods)) { + names(cvWeightMethods) } else { - cfg$samplePartition + as.character(cvWeightMethods) + } + # Accept the short token, the `_weights` method key, or the + # camelCase weight function. Suffix-stripping alone is not enough for a + # multi-word token: `susie_inf_weights` strips to `susie_inf`, which is + # not the canonical `susieInf`. + canonical <- map_chr(requested, .twasFmTokenFor) + bare <- str_remove(requested, "(_weights|Weights)$") + is_in(token, c(canonical[!is.na(canonical)], bare)) +} + +# @noRd +# Whether this token is barred from cross-validation: not requested, or its +# weights are all zero so there is nothing to validate. A fine-mapping method +# with no recoverable per-fold fits is an error rather than a silent skip. +# @noRd +.jointTwasCvBlocked <- function(W, cfg, token) { + if (!.jointTwasCvRequested(cfg$crossValidationArgs$weightMethods, token)) { + return(TRUE) + } + if (!is.null(W) && all(W == 0)) { + # A method whose weights are all zero contributes nothing to + # cross-validation, and dropping it silently made an empty ensemble + # look like a modelling result. + warn(glue( + "twasWeightsPipeline: method '{token}' is excluded from ", + "cross-validation because all of its weights are zero." + )) + return(TRUE) + } + if (is_in(token, names(.twasFineMappingMethodAdapters))) { + # No handoff means this tuple's fine-mapping entry carries no CV, and + # nothing here fine-maps -- so the fold fits cannot be recovered. + # Refusing beats refitting behind the user's back. + abort(glue( + "twasWeightsPipeline: cross-validating method '{token}' needs ", + "each fold's own fine-mapping fit, and the supplied ", + "fineMappingResult has no cross-validation for this ", + "(study, context, trait). Run fineMappingPipeline() with ", + "cvFolds > 1." + )) } - mcv <- if (is.null(cfg$maxCvVariants) || cfg$maxCvVariants <= 0) { + FALSE +} + +# twasWeightsCv() over this cell, with the CV settings resolved from the +# per-call args first and the pipeline config as the fallback. +# @noRd +.jointTwasRunCv <- function(Xc, Yc, wm, args, cfg, cvFolds) { + cv <- cfg$crossValidationArgs %||% list() + maxCv <- if ((cv$maxVariants %||% -1) <= 0) { Inf } else { - cfg$maxCvVariants + cv$maxVariants } - cv <- twasWeightsCv( + twasWeightsCv( Xc, Yc, fold = cvFolds, - samplePartitions = sp, + samplePartitions = args$samplePartition %||% cv$samplePartition, weightMethods = wm, - retainFits = TRUE, - maxNumVariants = mcv, - numThreads = if (is.null(cfg$cvThreads)) 1 else cfg$cvThreads, - data_driven_priorMatricesCv = args$dataDrivenPriorMatricesCv, - verbose = verbose, + fitRetention = "slim", + maxNumVariants = maxCv, + numThreads = cfg$crossValidationArgs$threads %||% 1, + dataDrivenPriorMatricesCv = args$dataDrivenPriorMatricesCv, + verbose = cfg$verbose %||% 1, seed = cfg$seed ) - .jointTwasCvResult(cv, token) +} + +.jointTwasCv <- function(Xc, Yc, wm, ma, W, args, cfg, token) { + cv <- cfg$crossValidationArgs %||% list() + cvFolds <- cv$folds %||% 0L + if (cvFolds <= 1L) { + return(NULL) + } + # A fine-mapping handoff already carries this token's per-fold fits. + cvRes <- .twasFmHandoffCv(args$fineMappingCv, token) + if (!is.null(cvRes)) { + return(cvRes) + } + if (.jointTwasCvBlocked(W, cfg, token)) { + return(NULL) + } + .jointTwasLeakageWarn(args, ma) + .jointTwasCvResult( + .jointTwasRunCv(Xc, Yc, wm, args, cfg, cvFolds), + token + ) } # One per-condition TwasWeightsRow (empty when there are no full-data weights, @@ -964,20 +1079,19 @@ setMethod( signature("SumStatsJointGroup", "TwasJointPipeline"), function(group, pipeline, token, args) { cfg <- .jpConfig(pipeline) - rfd <- if (is.null(cfg$retainFitDetail)) "slim" else cfg$retainFitDetail weights <- mrmashRssWeights( stat = list(z = .jgZ(group), n = .jgN(group)), LD = .jgLdMatrix(group), - retainFit = TRUE, - fitDetail = rfd + fitRetention = .jointRetentionLevel(cfg) ) - vids <- rownames(weights) - if (is.null(vids)) { - vids <- rownames(.jgZ(group)) - } + vids <- rownames(weights) %||% rownames(.jgZ(group)) fitParts <- attr(weights, "fit") - if (!is.matrix(weights)) { - weights <- matrix( + # A single-condition fit comes back as a bare vector; the per-condition + # split below reads it by column either way. + wMatrix <- if (is.matrix(weights)) { + weights + } else { + matrix( weights, ncol = ncol(.jgZ(group)), dimnames = list(vids, NULL) @@ -986,10 +1100,10 @@ setMethod( # One per-condition entry: that condition's weight column + the shared # fit. map( - seq_len(ncol(weights)), + seq_len(ncol(wMatrix)), .jointColEntry, vids = vids, - weights = weights, + weights = wMatrix, fitParts = fitParts, cfg = cfg ) @@ -1016,7 +1130,7 @@ setMethod( .rbindCollections(parts, ldSketch = ldSketch) } -setMethod("construct", "FmJointPipeline", function(pipeline, records, ...) { +setMethod("construct", "FmJointPipeline", function(pipeline, records) { .buildJointResult( QtlFineMappingResult, records, @@ -1024,7 +1138,7 @@ setMethod("construct", "FmJointPipeline", function(pipeline, records, ...) { ) }) -setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { +setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .buildJointResult(TwasWeights, records, .jpConfig(pipeline)$ldSketch) }) @@ -1043,32 +1157,50 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { return(list()) } verbose <- if (is.null(args$verbose)) 1 else args$verbose - groups <- list() - for (tid in scopedTraits) { - xy <- .buildIndividualCrossContextXy( - data, - tid, - scopedContexts, - args$cisWindow, - verbose, - label = "jointCrossContext", - region = args$region - ) - if (is.null(xy)) { - next - } - groups[[length(groups) + 1L]] <- new( - "IndividualJointGroup", - conditions = tibble( - study = study, - context = xy$perTraitContexts, - trait = tid - ), - X = xy$X, - Y = xy$Y - ) + compact(map( + scopedTraits, + .enumCrossContextGroupFor, + data = data, + study = study, + scopedContexts = scopedContexts, + args = args, + verbose = verbose + )) +} + +# One trait's cross-context group, or NULL when it has no usable (X, Y). +# @noRd +.enumCrossContextGroupFor <- function( + tid, + data, + study, + scopedContexts, + args, + verbose +) { + xy <- .buildIndividualCrossContextXy( + data, + tid, + scopedContexts, + args$cisWindow, + verbose, + label = "jointCrossContext", + region = args$region, + residualizationArgs = args$residualizationArgs + ) + if (is.null(xy)) { + return(NULL) } - groups + new( + "IndividualJointGroup", + conditions = tibble( + study = study, + context = xy$perTraitContexts, + trait = tid + ), + X = xy$X, + Y = xy$Y + ) } # cross-context / sumstats. @@ -1077,45 +1209,94 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) - groups <- list() - for (s in scope$studies) { - scopedContexts <- scope$contexts[[s]] - scopedTraits <- scope$traits[[s]] - if (length(scopedContexts) < 2L) { - next - } - for (tid in scopedTraits) { - tupleRows <- which( - studyCol == s & - traitCol == tid & - is_in(contextCol, scopedContexts) - ) - if (length(tupleRows) < 2L) { - next - } - ctxNames <- contextCol[tupleRows] - jz <- .buildJointSumstatZMatrix( - data, - tupleRows, - ctxNames, - errorLabel = "jointCrossContext (QtlSumStats)", - ldSketch = ldSketch, - cutoffs = args$cutoffs - ) - groups[[length(groups) + 1L]] <- new( - "SumStatsJointGroup", - conditions = tibble( - study = s, - context = ctxNames, - trait = tid - ), - Z = jz$Z, - ldSketch = ldSketch, - N = jz$nVec - ) - } + .jeConcat(map( + scope$studies, + .enumCrossContextSumstatsForStudy, + data = data, + scope = scope, + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# Concatenate per-item lists, empty-safe. +# @noRd +.jeConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# One study's cross-context groups (none when it has fewer than two contexts). +# @noRd +.enumCrossContextSumstatsForStudy <- function( + s, + data, + scope, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + scopedContexts <- scope$contexts[[s]] + if (length(scopedContexts) < 2L) { + return(list()) } - groups + compact(map( + scope$traits[[s]], + .enumCrossContextSumstatsGroup, + data = data, + s = s, + scopedContexts = scopedContexts, + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# One (study, trait) cross-context group, or NULL when fewer than two of its +# contexts carry the trait. +# @noRd +.enumCrossContextSumstatsGroup <- function( + tid, + data, + s, + scopedContexts, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + tupleRows <- which( + studyCol == s & traitCol == tid & is_in(contextCol, scopedContexts) + ) + if (length(tupleRows) < 2L) { + return(NULL) + } + ctxNames <- contextCol[tupleRows] + jz <- .buildJointSumstatZMatrix( + data, + tupleRows, + ctxNames, + errorLabel = "jointCrossContext (QtlSumStats)", + ldSketch = ldSketch, + cutoffs = args$cutoffs + ) + new( + "SumStatsJointGroup", + conditions = tibble(study = s, context = ctxNames, trait = tid), + Z = jz$Z, + ldSketch = ldSketch, + N = jz$nVec + ) } # cross-trait / individual: one group per scoped context with >= 2 scoped @@ -1128,39 +1309,59 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { scopedContexts <- scope$contexts[[study]] scopedTraits <- scope$traits[[study]] verbose <- if (is.null(args$verbose)) 1 else args$verbose - groups <- list() - for (cx in scopedContexts) { - xy <- .buildIndividualCrossTraitXy( - data, - cx, - scopedTraits, - args$cisWindow, - verbose, - label = "jointCrossTrait", + compact(map( + scopedContexts, + .enumCrossTraitGroupFor, + data = data, + study = study, + scopedTraits = scopedTraits, + args = args, + verbose = verbose + )) +} + +# One context's cross-trait group, or NULL when it has no usable (X, Y). +# @noRd +.enumCrossTraitGroupFor <- function( + cx, + data, + study, + scopedTraits, + args, + verbose +) { + xy <- .buildIndividualCrossTraitXy( + data, + cx, + scopedTraits, + args$cisWindow, + verbose, + label = "jointCrossTrait", + study = study, + region = args$region, + residualizationArgs = args$residualizationArgs + ) + if (is.null(xy)) { + return(NULL) + } + # Functional positions (one per trait column) for fsusie's domain; mvsusie + # ignores them. Reordered to match the trait order of Y. + rr <- SummarizedExperiment::rowRanges(xy$se)[ + match(colnames(xy$Y), rownames(xy$se)) + ] + new( + "IndividualJointGroup", + conditions = tibble( study = study, - region = args$region - ) - if (is.null(xy)) { - next - } - # Functional positions (one per trait column) for fsusie's domain; - # mvsusie ignores them. Matches the trait order of Y. - rr <- SummarizedExperiment::rowRanges(xy$se) - rr <- rr[match(colnames(xy$Y), rownames(xy$se))] - traitPos <- (GenomicRanges::start(rr) + GenomicRanges::end(rr)) / 2 - groups[[length(groups) + 1L]] <- new( - "IndividualJointGroup", - conditions = tibble( - study = study, - context = cx, - trait = xy$traitsHere - ), - X = xy$X, - Y = xy$Y, - traitPos = as.numeric(traitPos) + context = cx, + trait = xy$traitsHere + ), + X = xy$X, + Y = xy$Y, + traitPos = as.numeric( + (GenomicRanges::start(rr) + GenomicRanges::end(rr)) / 2 ) - } - groups + ) } # cross-trait / sumstats. @@ -1169,40 +1370,80 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) - groups <- list() - for (s in scope$studies) { - scopedContexts <- scope$contexts[[s]] - scopedTraits <- scope$traits[[s]] - for (cx in scopedContexts) { - tupleRows <- which( - studyCol == s & contextCol == cx & is_in(traitCol, scopedTraits) - ) - if (length(tupleRows) < 2L) { - next - } - trNames <- traitCol[tupleRows] - jz <- .buildJointSumstatZMatrix( - data, - tupleRows, - trNames, - errorLabel = "jointCrossTrait (QtlSumStats)", - ldSketch = ldSketch, - cutoffs = args$cutoffs - ) - groups[[length(groups) + 1L]] <- new( - "SumStatsJointGroup", - conditions = tibble( - study = s, - context = cx, - trait = trNames - ), - Z = jz$Z, - ldSketch = ldSketch, - N = jz$nVec - ) - } + .jeConcat(map( + scope$studies, + .enumCrossTraitSumstatsForStudy, + data = data, + scope = scope, + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# @noRd +.enumCrossTraitSumstatsForStudy <- function( + s, + data, + scope, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + compact(map( + scope$contexts[[s]], + .enumCrossTraitSumstatsGroup, + data = data, + s = s, + scopedTraits = scope$traits[[s]], + args = args, + ldSketch = ldSketch, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol + )) +} + +# One (study, context) cross-trait group, or NULL when fewer than two of its +# traits are present. +# @noRd +.enumCrossTraitSumstatsGroup <- function( + cx, + data, + s, + scopedTraits, + args, + ldSketch, + studyCol, + contextCol, + traitCol +) { + tupleRows <- which( + studyCol == s & contextCol == cx & is_in(traitCol, scopedTraits) + ) + if (length(tupleRows) < 2L) { + return(NULL) } - groups + trNames <- traitCol[tupleRows] + jz <- .buildJointSumstatZMatrix( + data, + tupleRows, + trNames, + errorLabel = "jointCrossTrait (QtlSumStats)", + ldSketch = ldSketch, + cutoffs = args$cutoffs + ) + new( + "SumStatsJointGroup", + conditions = tibble(study = s, context = cx, trait = trNames), + Z = jz$Z, + ldSketch = ldSketch, + N = jz$nVec + ) } # cross-study / sumstats (no individual form: individual-level studies have @@ -1215,26 +1456,55 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { context = as.character(data$context), trait = as.character(data$trait) ) - allCtxs <- unique(unlist(scope$contexts, use.names = FALSE)) - allTrs <- unique(unlist(scope$traits, use.names = FALSE)) - groups <- list() - for (cx in allCtxs) { - for (tid in allTrs) { - g <- .enumCrossStudyGroup( - data, - scope, - args, - cols, - cx, - tid, - ldSketch - ) - if (!is.null(g)) { - groups[[length(groups) + 1L]] <- g - } - } - } - groups + allCtxs <- unique(unname(list_c(scope$contexts))) + allTrs <- unique(unname(list_c(scope$traits))) + .jeConcat(map( + allCtxs, + .enumCrossStudyForContext, + data = data, + scope = scope, + args = args, + cols = cols, + allTrs = allTrs, + ldSketch = ldSketch + )) +} + +# One context's cross-study groups, one per trait that has enough studies. +# @noRd +.enumCrossStudyForContext <- function( + cx, + data, + scope, + args, + cols, + allTrs, + ldSketch +) { + compact(map( + allTrs, + .enumCrossStudyGroupFor, + data = data, + scope = scope, + args = args, + cols = cols, + cx = cx, + ldSketch = ldSketch + )) +} + +# `map()` hands the trait first; .enumCrossStudyGroup takes it sixth. +# @noRd +.enumCrossStudyGroupFor <- function( + tid, + data, + scope, + args, + cols, + cx, + ldSketch +) { + .enumCrossStudyGroup(data, scope, args, cols, cx, tid, ldSketch) } # One cross-study joint group for a (context, trait) cell, or NULL when fewer @@ -1242,20 +1512,20 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # just that study, so the cell contributes nothing. # @noRd .enumCrossStudyGroup <- function(data, scope, args, cols, cx, tid, ldSketch) { - tupleRows <- which( + candidates <- which( cols$context == cx & cols$trait == tid & is_in(cols$study, scope$studies) ) keep <- map_lgl( - tupleRows, + candidates, .jointTupleRowInScope, studyCol = cols$study, cx = cx, tid = tid, scope = scope ) - tupleRows <- tupleRows[keep] + tupleRows <- candidates[keep] if (length(tupleRows) < 2L) { return(NULL) } @@ -1298,7 +1568,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { args$cisWindow, verbose, label = "composed", - region = args$region + region = args$region, + residualizationArgs = args$residualizationArgs ) if (is.null(xy)) { return(list()) @@ -1325,85 +1596,120 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { return(list()) } naAction <- if (is.null(args$naAction)) "drop" else args$naAction - groups <- list() - for (cx in scope$contexts[[study]]) { - se <- getPhenotypes(data, contexts = cx) - for (tid in intersect(scope$traits[[study]], rownames(se))) { - Y <- .fmResidPheno( - data, - contexts = cx, - traitId = tid, - naAction = naAction - ) - X <- if (is.null(args$region)) { - .fmResidGeno( - data, - contexts = cx, - traitId = tid, - cisWindow = args$cisWindow - ) - } else { - .fmResidGeno(data, contexts = cx, region = args$region) - } - common <- intersect(rownames(X), rownames(Y)) - if (length(common) < 2L) { - next - } - groups[[length(groups) + 1L]] <- new( - "IndividualJointGroup", - conditions = tibble( - study = study, - context = cx, - trait = tid - ), - X = X[common, , drop = FALSE], - Y = Y[common, , drop = FALSE] - ) - } + .jeConcat(map( + scope$contexts[[study]], + .enumUnivariateForContext, + data = data, + scope = scope, + args = args, + study = study, + naAction = naAction + )) +} + +# One context's univariate groups, one per trait it carries. +# @noRd +.enumUnivariateForContext <- function(cx, data, scope, args, study, naAction) { + se <- getPhenotypes(data, contexts = cx) + compact(map( + intersect(scope$traits[[study]], rownames(se)), + .enumUnivariateGroupFor, + data = data, + args = args, + study = study, + cx = cx, + naAction = naAction + )) +} + +# One (context, trait) univariate group, or NULL when fewer than two samples +# are shared between its genotypes and its phenotype. +# @noRd +.enumUnivariateGroupFor <- function(tid, data, args, study, cx, naAction) { + Y <- .fmResidPheno( + data, + contexts = cx, + traitId = tid, + naAction = naAction, + residualizationArgs = args$residualizationArgs + ) + X <- if (is.null(args$region)) { + .fmResidGeno( + data, + contexts = cx, + traitId = tid, + cisWindow = args$cisWindow, + residualizationArgs = args$residualizationArgs + ) + } else { + .fmResidGeno( + data, + contexts = cx, + region = args$region, + residualizationArgs = args$residualizationArgs + ) + } + common <- intersect(rownames(X), rownames(Y)) + if (length(common) < 2L) { + return(NULL) } - groups + new( + "IndividualJointGroup", + conditions = tibble(study = study, context = cx, trait = tid), + X = X[common, , drop = FALSE], + Y = Y[common, , drop = FALSE] + ) } # composed / sumstats: general N-axis joint. `args$axes` (subset of study / # context / trait) names the collapsed axes; rows split by the complement # (fixed) axes form one group each. Reuses .enumerateComposedSumstatGroups. .enumComposedSumstats <- function(data, scope, args = list()) { - axes <- args$axes - if (is.null(axes)) { - axes <- c("context", "trait") - } + axes <- args$axes %||% c("context", "trait") ldSketch <- getLdSketch(data) gi <- .enumerateComposedSumstatGroups(list(axes = axes), data, scope) if (is.null(gi)) { return(list()) } - groups <- list() - for (gIdx in gi$groups) { - if (length(gIdx) < 2L) { - next - } - colLabels <- map_chr(gIdx, .jointGroupColLabel, gi = gi) - jz <- .buildJointSumstatZMatrix( - data, - gIdx, - colLabels, - errorLabel = "composed (QtlSumStats)", - ldSketch = ldSketch, - cutoffs = args$cutoffs - ) - groups[[length(groups) + 1L]] <- new( - "SumStatsJointGroup", - conditions = tibble( - study = gi$studyCol[gIdx], - context = gi$contextCol[gIdx], - trait = gi$traitCol[gIdx] - ), - Z = jz$Z, - ldSketch = ldSketch, - N = jz$nVec - ) + # `gi$groups` comes from split(), so it is NAMED; map() would carry those + # names onto the groups, which the record assembly downstream does not + # expect (the loop this replaced appended positionally). + unname(compact(map( + gi$groups, + .enumComposedGroupFor, + data = data, + gi = gi, + args = args, + ldSketch = ldSketch + ))) +} + +# One composed cell's group, or NULL when it spans fewer than two tuples -- +# a "joint" fit over one tuple is just that tuple. +# @noRd +.enumComposedGroupFor <- function(gIdx, data, gi, args, ldSketch) { + if (length(gIdx) < 2L) { + return(NULL) } - groups + jz <- .buildJointSumstatZMatrix( + data, + gIdx, + map_chr(gIdx, .jointGroupColLabel, gi = gi), + errorLabel = "composed (QtlSumStats)", + ldSketch = ldSketch, + cutoffs = args$cutoffs + ) + new( + "SumStatsJointGroup", + conditions = tibble( + study = gi$studyCol[gIdx], + context = gi$contextCol[gIdx], + trait = gi$traitCol[gIdx] + ), + Z = jz$Z, + ldSketch = ldSketch, + N = jz$nVec + ) } # ---- engine ----------------------------------------------------------------- @@ -1418,41 +1724,107 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { } cfg <- .jpConfig(pipeline) cond <- .jgConditions(g) - out <- args + out <- list_assign(args, !!!.twasGroupFmArgs(args, cond)) + cv <- cfg$crossValidationArgs %||% list() + cvF <- cv$folds %||% 0L + if (cvF <= 1L || !is(g, "IndividualJointGroup")) { + return(out) + } + list_assign( + out, + samplePartition = .jointCvPartition( + fmCv = out$fineMappingCv, + userSp = args$samplePartition %||% cv$samplePartition, + sampleIds = rownames(.jgX(g)), + cvFolds = cvF + ) + ) +} + +# The group's fine-mapping fits + CV, keyed on its first condition. Empty when +# the caller supplied no fine-mapping result. +# @noRd +.twasGroupFmArgs <- function(args, cond) { fmRes <- args$fineMappingResult - if (!is.null(fmRes)) { - s1 <- as.character(cond$study[[1L]]) - c1 <- as.character(cond$context[[1L]]) - t1 <- as.character(cond$trait[[1L]]) - nR <- if (is.null(args$nRegions)) 1L else args$nRegions - bi <- if (is.null(args$regionIndex)) 1L else args$regionIndex - af <- .twasFineMappingFits(fmRes, study = s1, context = c1, trait = t1) - out$fittedModels <- if (is.null(af)) { + if (is.null(fmRes)) { + return(list()) + } + s1 <- as.character(cond$study[[1L]]) + c1 <- as.character(cond$context[[1L]]) + t1 <- as.character(cond$trait[[1L]]) + nR <- if (is.null(args$nRegions)) 1L else args$nRegions + bi <- if (is.null(args$regionIndex)) 1L else args$regionIndex + af <- .twasFineMappingFits(fmRes, study = s1, context = c1, trait = t1) + list( + fittedModels = if (is.null(af)) { list() } else { .twasFitsForRegion(af, bi, nR) + }, + fineMappingCv = .twasCvResultFor(fmRes, s1, c1, t1) + ) +} + +# The fold partition every method in this group is scored on. A fine-mapping +# CV carries fits tied to its own folds, so when one is present it governs: +# the other weight methods are cross-validated on those same folds, which is +# what makes their scores comparable to the fine-mapping method's. +# @noRd +.jointCvPartition <- function(fmCv, userSp, sampleIds, cvFolds) { + fmSp <- fmCv$samplePartition + if (is.null(fmSp)) { + if (!is.null(userSp)) { + return(userSp) } - out$fineMappingCv <- .twasCvResultFor(fmRes, s1, c1, t1) + return(.normalizeCvFolds(cvFolds, NULL, sampleIds)$samplePartition) } - cvF <- if (is.null(cfg$cvFolds)) 0L else cfg$cvFolds - if (cvF > 1L && is(g, "IndividualJointGroup")) { - sp <- args$samplePartition - if (is.null(sp)) { - sp <- cfg$samplePartition - } - if (is.null(sp) && !is.null(out$fineMappingCv)) { - sp <- out$fineMappingCv$samplePartition - } - if (is.null(sp)) { - sp <- .normalizeCvFolds( - cvF, - NULL, - rownames(.jgX(g)) - )$samplePartition - } - out$samplePartition <- sp + .jointCheckFmCvSamples(fmSp, sampleIds) + .jointCheckPartitionAgreement(fmSp, userSp) + fmSp +} + +# Every sample the fine-mapping folds name must be a sample of the dataset +# being scored. Otherwise a fold's held-out rows cannot be located here, and +# the fits would be scored against samples they were never separated from. +# @noRd +.jointCheckFmCvSamples <- function(fmSp, sampleIds) { + unmatched <- setdiff(as.character(fmSp$Sample), as.character(sampleIds)) + if (length(unmatched) == 0L) { + return(invisible(NULL)) + } + shown <- str_flatten(head(unmatched, 5L), ", ") + more <- if (length(unmatched) > 5L) { + str_c(" (and ", length(unmatched) - 5L, " more)") + } else { + "" + } + msg <- glue( + "twasWeightsPipeline: {length(unmatched)} sample(s) in the ", + "fine-mapping cross-validation folds are not in this dataset: ", + "{shown}{more}. The fold fits must come from a fineMappingPipeline() ", + "run on these same samples." + ) + abort(msg) +} + +# An explicitly supplied partition that disagrees with the fine-mapping CV's +# is ambiguous -- the fold fits belong to one of them, and silently choosing +# would score some methods on folds the others never saw. +# @noRd +.jointCheckPartitionAgreement <- function(fmSp, userSp) { + if (is.null(userSp)) { + return(invisible(NULL)) } - out + if (identical(.cvPartitionKey(userSp), .cvPartitionKey(fmSp))) { + return(invisible(NULL)) + } + msg <- glue( + "twasWeightsPipeline: the supplied `samplePartition` differs from ", + "the fine-mapping cross-validation's own folds. The fine-mapping ", + "fold fits belong to that partition, so pass it (or omit ", + "`samplePartition` and let it be reused)." + ) + abort(msg) } # Append one output record per (condition, method) to the joint-rows accumulator @@ -1460,7 +1832,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # + trait position. `grp` bundles the per-group invariants list(cond, js, jc, # jt). # @noRd -.jointEntryRecords <- function(entries, method, grp, data, cisWindow) { +.jointEntryRecords <- function(entries, method, grp, data) { cond <- grp$cond recs <- map( seq_len(min(length(entries), nrow(cond))), @@ -1469,8 +1841,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { cond = cond, method = method, grp = grp, - data = data, - cisWindow = cisWindow + data = data ) compact(recs) } @@ -1483,13 +1854,13 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # -- one method -> per-condition entries; the SR-TWAS ensemble is a layer ON TOP # of that. .runJointCell <- function(cell, pipeline, data, scope, tokens, args = list()) { - groups <- .jcEnumerate(cell)(data, scope, args) - groups <- keep(groups, .jointGroupMeetsMin, minGroup = .jcMinGroup(cell)) + groups <- .jcEnumerate(cell)(data, scope, args) |> + keep(.jointGroupMeetsMin, minGroup = .jcMinGroup(cell)) if (length(groups) == 0L) { return(NULL) } doEnsemble <- is(pipeline, "TwasJointPipeline") && - isTRUE(.jpConfig(pipeline)$ensemble) + isTRUE(.jpConfig(pipeline)$ensembleArgs$enabled) records <- list_flatten(map( groups, .jointCellGroup, @@ -1517,49 +1888,67 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { jt = .jointAxisMembers(cond, "trait") ) fitArgs <- .twasGroupArgs(g, pipeline, args) - records <- list() - perTokenEntries <- list() - for (token in tokens) { - entries <- .jointGroupTokenEntries( - g, - pipeline, - token, - fitArgs, - cond, - args - ) - if (is.null(entries) || length(entries) == 0L) { - next - } - perTokenEntries[[token]] <- entries - records <- c( - records, - .jointEntryRecords(entries, token, grp, data, args$cisWindow) - ) - } - if (doEnsemble && length(perTokenEntries) >= 2L) { - records <- c( - records, - .jointEntryRecords( - .twasEnsembleLayer(g, perTokenEntries, .jpConfig(pipeline)), - "ensemble", - grp, - data, - args$cisWindow - ) + perTokenEntries <- compact(set_names( + map( + tokens, + .jointTokenEntriesOrNull, + g = g, + pipeline = pipeline, + fitArgs = fitArgs, + cond = cond, + args = args + ), + tokens + )) + tokenRecords <- .jeConcat(map( + names(perTokenEntries), + .jointTokenRecords, + perTokenEntries = perTokenEntries, + grp = grp, + data = data + )) + if (!doEnsemble || length(perTokenEntries) < 2L) { + return(tokenRecords) + } + c( + tokenRecords, + .jointEntryRecords( + .twasEnsembleLayer(g, perTokenEntries, .jpConfig(pipeline)), + "ensemble", + grp, + data ) + ) +} + +# One token's entries, or NULL when it produced none. +# @noRd +.jointTokenEntriesOrNull <- function(token, g, pipeline, fitArgs, cond, args) { + entries <- .jointGroupTokenEntries( + g, + pipeline, + token, + fitArgs, + cond, + args + ) + if (is.null(entries) || length(entries) == 0L) { + return(NULL) } - records + entries +} + +# @noRd +.jointTokenRecords <- function(token, perTokenEntries, grp, data) { + .jointEntryRecords(perTokenEntries[[token]], token, grp, data) } # Entries for one token on one group: reuse the resume cache when it fully # covers the group's conditions, else fit. # @noRd .jointGroupTokenEntries <- function(g, pipeline, token, fitArgs, cond, args) { - entries <- .jointTokenCacheLookup(pipeline, token, cond, args$cache) - if (is.null(entries)) { - entries <- fitJointGroup(g, pipeline, token, fitArgs) - } + entries <- .jointTokenCacheLookup(pipeline, token, cond, args$cache) %||% + fitJointGroup(g, pipeline, token, fitArgs) entries } @@ -1599,18 +1988,18 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { .twasEnsembleLayer <- function(group, perTokenEntries, cfg) { tokens <- names(perTokenEntries) Y <- .jgY(group) - r2Cut <- if (is.null(cfg$ensembleR2Threshold)) { + r2Cut <- if (is.null(cfg$ensembleArgs$r2Threshold)) { 0.01 } else { - cfg$ensembleR2Threshold + cfg$ensembleArgs$r2Threshold } - solver <- if (is.null(cfg$ensembleSolver)) { + solver <- if (is.null(cfg$ensembleArgs$solver)) { "quadprog" } else { - cfg$ensembleSolver + cfg$ensembleArgs$solver } - alpha <- if (is.null(cfg$ensembleAlpha)) 1 else cfg$ensembleAlpha - stdz <- cfg$standardized + alpha <- if (is.null(cfg$ensembleArgs$alpha)) 1 else cfg$ensembleArgs$alpha + stdz <- cfg$standardized %||% FALSE map( seq_len(nrow(.jgConditions(group))), .twasEnsembleCondition, @@ -1628,39 +2017,62 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # Per-condition CV predictions + weights + R^2 across the group's methods. # Returns list(preds, wts, rsq), skipping methods with no CV / weights. # @noRd -.twasEnsembleCollect <- function(r, perTokenEntries, tokens) { - preds <- list() - wts <- list() - rsq <- c() - for (tk in tokens) { - e <- perTokenEntries[[tk]][[r]] - if (is.null(e)) { - next - } - cv <- .rowCvResult(e) - w <- .rowWeights(e) - if (is.null(cv) || is.null(cv$predictions) || is.null(w)) { - next - } - pr <- cv$predictions - preds[[str_c(tk, "_predicted")]] <- matrix( +# One token's ensemble inputs for condition `r`, or NULL when it has no +# cross-validated predictions or no weights to contribute. +# @noRd +.twasEnsembleTokenPart <- function(tk, r, perTokenEntries) { + e <- perTokenEntries[[tk]][[r]] + if (is.null(e)) { + return(NULL) + } + cv <- .rowCvResult(e) + w <- .rowWeights(e) + if (is.null(cv) || is.null(cv$predictions) || is.null(w)) { + return(NULL) + } + pr <- cv$predictions + list( + token = tk, + pred = matrix( as.numeric(pr), ncol = 1L, dimnames = list(names(pr), NULL) - ) - wts[[str_c(tk, "_weights")]] <- matrix( + ), + weights = matrix( as.numeric(w), ncol = 1L, dimnames = list(.rowVariantIds(e), NULL) - ) - mt <- cv$metrics - rsq[tk] <- if (!is.null(mt) && is_in("rsq", names(mt))) { - mt[["rsq"]] + ), + rsq = if (!is.null(cv$metrics) && is_in("rsq", names(cv$metrics))) { + cv$metrics[["rsq"]] } else { NA_real_ } + ) +} + +.twasEnsembleCollect <- function(r, perTokenEntries, tokens) { + parts <- compact(map( + tokens, + .twasEnsembleTokenPart, + r = r, + perTokenEntries = perTokenEntries + )) + if (length(parts) == 0L) { + return(list(preds = list(), wts = list(), rsq = c())) } - list(preds = preds, wts = wts, rsq = rsq) + contributing <- map_chr(parts, "token") + list( + preds = set_names( + map(parts, "pred"), + str_c(contributing, "_predicted") + ), + wts = set_names( + map(parts, "weights"), + str_c(contributing, "_weights") + ), + rsq = set_names(map_dbl(parts, "rsq"), contributing) + ) } # SR-TWAS ensemble entry for one condition: combine the R^2-passing methods @@ -1682,7 +2094,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { if (length(passing) < 2L) { return(NULL) } - ens <- tryCatch( + ens <- try_fetch( ensembleWeights( cvResults = list( prediction = coll$preds[str_c(passing, "_predicted")] @@ -1693,16 +2105,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { solver = solver, alpha = alpha ), - error = function(err) NULL + error = function(cnd) NULL ) if (is.null(ens) || is.null(ens$ensembleTwasWeights)) { return(NULL) } ew <- ens$ensembleTwasWeights - vids <- if (!is.null(names(ew))) names(ew) else rownames(ew) - if (is.null(vids)) { - vids <- getVariantIds(perTokenEntries[[passing[1L]]][[r]]) - } + vids <- (if (!is.null(names(ew))) names(ew) else rownames(ew)) %||% + getVariantIds(perTokenEntries[[passing[1L]]][[r]]) twasWeightsRow( variantIds = vids, weights = as.numeric(ew), @@ -1715,6 +2125,93 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { ) } +# Top-PC enumeration: PCA-reduce each context's multi-trait phenotype and make +# ONE group per top principal component, each a single-column Y named topPCk. +# Structurally identical to .enumUnivariateIndividual -- same residualization +# helpers, same IndividualJointGroup -- so everything downstream (CV, +# ensemble, retention) applies unchanged. It is the TWAS peer of +# fineMappingPipeline's .fmPcaContextRows, sharing .fmTopPcScores(). +# @noRd +.enumTopPcIndividual <- function(data, scope, args = list()) { + study <- getStudy(data) + if (!is_in(study, scope$studies)) { + return(list()) + } + naAction <- if (is.null(args$naAction)) "drop" else args$naAction + .jeConcat(map( + scope$contexts[[study]], + .enumTopPcForContext, + data = data, + scope = scope, + args = args, + study = study, + naAction = naAction + )) +} + +# @noRd +.enumTopPcForContext <- function(cx, data, scope, args, study, naAction) { + se <- getPhenotypes(data, contexts = cx) + traits <- intersect(scope$traits[[study]], rownames(se)) + # PCA is undefined for a single trait, matching the fine-mapping rule. + if (length(traits) < 2L) { + return(list()) + } + Y <- .fmResidPheno( + data, + contexts = cx, + traitId = traits, + naAction = naAction, + residualizationArgs = args$residualizationArgs + ) + scores <- .fmTopPcScores(Y, args$nPCs %||% 10L) + if (is.null(scores)) { + return(list()) + } + X <- .enumTopPcX(data, cx, traits, args) + common <- intersect(rownames(X), rownames(scores)) + if (length(common) < 2L) { + return(list()) + } + compact(map( + colnames(scores), + .enumTopPcGroup, + X = X[common, , drop = FALSE], + scores = scores[common, , drop = FALSE], + study = study, + cx = cx + )) +} + +# @noRd +.enumTopPcX <- function(data, cx, traits, args) { + if (is.null(args$region)) { + return(.fmResidGeno( + data, + contexts = cx, + traitId = traits, + cisWindow = args$cisWindow, + residualizationArgs = args$residualizationArgs + )) + } + .fmResidGeno( + data, + contexts = cx, + region = args$region, + residualizationArgs = args$residualizationArgs + ) +} + +# @noRd +.enumTopPcGroup <- function(pcName, X, scores, study, cx) { + new( + "IndividualJointGroup", + conditions = tibble(study = study, context = cx, trait = pcName), + X = X, + Y = scores[, pcName, drop = FALSE] + ) +} + # ---- wiring table ----------------------------------------------------------- # Valid cells are rows; invalid cells are absences (a lookup miss is the error). .jointDispatchTable <- list( @@ -1777,6 +2274,13 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { dataForm = "individual", enumerate = .enumUnivariateIndividual, minGroup = 1L + ), + new( + "JointDispatchCell", + pattern = "topPc", + dataForm = "individual", + enumerate = .enumTopPcIndividual, + minGroup = 1L ) ) @@ -1797,7 +2301,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # joint method (token) through `.runJointCell`, rbinding the per-spec results. # Shared by the fm + twas QtlDataset / QtlSumStats / MultiStudy dispatchers -- # the marker (pipeline) selects the result type and the rbind. `args` is the -# per-run engine payload (twasWeights, methodArgs, cisWindow, region, ...). +# per-run engine payload (mrmashPrior, methodArgs, cisWindow, region, ...). .runJointSpecs <- function( parsedJointSpec, data, @@ -1813,30 +2317,56 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { } ldSketch <- .jpConfig(pipeline)$ldSketch isFm <- is(pipeline, "FmJointPipeline") - out <- NULL - for (spec in parsedJointSpec) { - res <- .runOneJointSpec( - spec, - data, - dataForm, - pipeline, - jointMethods, - contexts, - traitIds, - args - ) - if (is.null(res)) { - next - } - out <- if (is.null(out)) { - res - } else if (isFm) { - .rbindFineMappingResult(out, res, ldSketch = ldSketch) - } else { - .rbindTwasWeights(out, res, ldSketch = ldSketch) - } + results <- compact(map( + parsedJointSpec, + .runOneJointSpecFor, + data = data, + dataForm = dataForm, + pipeline = pipeline, + jointMethods = jointMethods, + contexts = contexts, + traitIds = traitIds, + args = args + )) + if (length(results) == 0L) { + return(NULL) } - out + rbindFn <- if (isFm) .rbindFineMappingResult else .rbindTwasWeights + reduce( + results, + .jointRbindWithSketch, + rbindFn = rbindFn, + ldSketch = ldSketch + ) +} + +# `map()` hands the spec first, which is also where .runOneJointSpec wants it. +# @noRd +.runOneJointSpecFor <- function( + spec, + data, + dataForm, + pipeline, + jointMethods, + contexts, + traitIds, + args +) { + .runOneJointSpec( + spec, + data, + dataForm, + pipeline, + jointMethods, + contexts, + traitIds, + args + ) +} + +# @noRd +.jointRbindWithSketch <- function(acc, res, rbindFn, ldSketch) { + rbindFn(acc, res, ldSketch = ldSketch) } # Run all joint methods for ONE spec: resolve its scope (optionally @@ -1854,18 +2384,19 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { traitIds, args ) { - scope <- .fmResolveSpecScope( + resolved <- .fmResolveSpecScope( spec, data, contexts = contexts, traitIds = traitIds ) - if ( - dataForm == "individual" && - is.null(traitIds) && - !is.null(args$region) - ) { - scope <- .jointRestrictRegionTraits(scope, data, args$region) + restrictToRegion <- dataForm == "individual" && + is.null(traitIds) && + !is.null(args$region) + scope <- if (restrictToRegion) { + .jointRestrictRegionTraits(resolved, data, args$region) + } else { + resolved } pattern <- if (length(spec$axes) > 1L) "composed" else spec$axes[[1L]] cell <- .lookupJointCell(pattern, dataForm) @@ -1877,20 +2408,37 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # to the genes overlapping the locus (matches fineMappingPipeline). Gene coords # are context-independent, so the first scoped context's SE supplies them. # @noRd +# One study's traits narrowed to those inside `region`; left alone when the +# study has no context to read a phenotype from. +# @noRd +.jointStudyTraitsInRegion <- function(st, scope, data, region) { + ctxs <- scope$contexts[[st]] + if (length(ctxs) == 0L) { + return(scope$traits[[st]]) + } + se <- getPhenotypes(data, contexts = ctxs[[1L]]) + .fmTraitsInRegion( + se, + intersect(scope$traits[[st]], rownames(se)), + region + ) +} + .jointRestrictRegionTraits <- function(scope, data, region) { - for (st in names(scope$traits)) { - ctxs <- scope$contexts[[st]] - if (length(ctxs) == 0L) { - next - } - se <- getPhenotypes(data, contexts = ctxs[[1L]]) - scope$traits[[st]] <- .fmTraitsInRegion( - se, - intersect(scope$traits[[st]], rownames(se)), - region + studies <- names(scope$traits) + list_assign( + scope, + traits = set_names( + map( + studies, + .jointStudyTraitsInRegion, + scope = scope, + data = data, + region = region + ), + studies ) - } - scope + ) } # Individual-level (QtlDataset) input cannot joint over study: studies have @@ -1944,18 +2492,20 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # Build one record into a 1-row collection: wrap `entry` in a list and drop any # NA joint* axis (so the union re-adds it, padded, only when some row is joint). # @noRd +# A joint-axis column holding a lone NA means "not a joint axis", so it is +# dropped rather than carried as a column of NA. +# @noRd +.jointAxisIsAbsent <- function(value) { + !is.null(value) && length(value) == 1L && is.na(value) +} + .jointBuildRecordPart <- function(rec, constructor) { - rec$entry <- list(rec$entry) - for (jc in c("jointStudies", "jointContexts", "jointTraits")) { - if ( - !is.null(rec[[jc]]) && - length(rec[[jc]]) == 1L && - is.na(rec[[jc]]) - ) { - rec[[jc]] <- NULL - } - } - exec(constructor, !!!rec) + jointCols <- c("jointStudies", "jointContexts", "jointTraits") + absent <- jointCols[map_lgl(rec[jointCols], .jointAxisIsAbsent)] + kept <- rec[setdiff(names(rec), absent)] + # `list_assign()`, not `list_modify()`: the entry payload is itself a + # list, and list_modify would merge into it rather than wrap it. + exec(constructor, !!!list_assign(kept, entry = list(rec$entry))) } # TRUE when tuple row `r`'s study keeps context `cx` and trait `tid` in scope. @@ -1977,15 +2527,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records, ...) { # fine-mapping window is NOT recorded: the element's own span is the region # (section 4.4), and a stored window would go stale under subsetRegion(). # @noRd -.jointEntryRecordAt <- function( - i, - entries, - cond, - method, - grp, - data, - cisWindow -) { +.jointEntryRecordAt <- function(i, entries, cond, method, grp, data) { e <- entries[[i]] if (is.null(e)) { return(NULL) diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 72d7b6a46..91082fec2 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -77,6 +77,16 @@ # Return character vector of contexts in `data` (across all studies when # `study = NULL`, or for one study otherwise). # @noRd +# Concatenate a list of pieces into one, the way `c()` did, but safe on the +# empty case (`list_c()` has no zero-length identity to return). +# @noRd +.spConcat <- function(pieces, empty = list()) { + if (length(pieces) == 0L) { + return(empty) + } + list_c(pieces) +} + .spListContexts <- function(data, study = NULL) { if (is(data, "QtlDataset")) { if (!is.null(study) && !identical(study, getStudy(data))) { @@ -96,14 +106,16 @@ indDatasets <- getQtlDatasets(data) ss <- getSumStats(data) if (is.null(study)) { - out <- character(0) - for (qd in indDatasets) { - out <- c(out, getContexts(qd)) - } - if (!is.null(ss)) { - out <- c(out, unique(as.character(ss$context))) + fromInd <- .spConcat( + map(indDatasets, getContexts), + empty = character(0) + ) + fromSs <- if (is.null(ss)) { + character(0) + } else { + unique(as.character(ss$context)) } - return(unique(out)) + return(unique(c(fromInd, fromSs))) } if (is_in(study, names(indDatasets))) { return(getContexts(indDatasets[[study]])) @@ -135,10 +147,9 @@ return(character(0)) } if (is.null(context)) { - return(unique(unlist( - map(getContexts(data), .spTraitsInContext, data = data), - use.names = FALSE - ))) + return(unique(unname(list_c( + map(getContexts(data), .spTraitsInContext, data = data) + )))) } # Checked here rather than left to the accessor: `.spListTraits` answers # "which traits are in this scope", and an absent context is an empty @@ -159,14 +170,16 @@ # Must precede per-study branches so a present sumStats slot does not shadow # the individual-level studies' traits when study = NULL. if (is.null(study)) { - out <- character(0) - for (qd in indDatasets) { - out <- c(out, .spListTraits(qd, context = context)) - } - if (!is.null(ss)) { - out <- c(out, .spListTraits(ss, context = context)) + fromInd <- .spConcat( + map(indDatasets, .spListTraits, context = context), + empty = character(0) + ) + fromSs <- if (is.null(ss)) { + character(0) + } else { + .spListTraits(ss, context = context) } - return(unique(out)) + return(unique(c(fromInd, fromSs))) } if (is_in(study, names(indDatasets))) { return(.spListTraits(indDatasets[[study]], context = context)) @@ -182,13 +195,17 @@ return(.spListTraitsQtlDataset(data, study, context)) } if (is(data, "QtlSumStats")) { - keep <- rep(TRUE, nrow(data)) - if (!is.null(study)) { - keep <- keep & as.character(data$study) == study + byStudy <- if (is.null(study)) { + rep(TRUE, nrow(data)) + } else { + as.character(data$study) == study } - if (!is.null(context)) { - keep <- keep & as.character(data$context) == context + byContext <- if (is.null(context)) { + TRUE + } else { + as.character(data$context) == context } + keep <- byStudy & byContext return(unique(as.character(data$trait[keep]))) } if (is(data, "MultiStudyQtlDataset")) { @@ -363,21 +380,38 @@ parseJointSpecification <- function(jointSpecification, data) { ) abort(msg) } - out <- list() - for (s in studies) { - avail <- .spListContexts(data, s) - missing <- setdiff(contexts, avail) - if (length(missing) > 0L) { - missingStr <- str_flatten(missing, ", ") - msg <- glue( - "parseContexts: study '{s}' is missing requested ", - "context(s): {missingStr}" - ) - warn(msg) - } - out[[s]] <- intersect(contexts, avail) + set_names( + map(studies, .parseContextsAvail, data = data, contexts = contexts), + studies + ) +} + +# One study's requested contexts, warning about any it does not have. +# @noRd +.parseContextsAvail <- function(s, data, contexts) { + avail <- .spListContexts(data, s) + missing <- setdiff(contexts, avail) + if (length(missing) > 0L) { + missingStr <- str_flatten(missing, ", ") + msg <- glue( + "parseContexts: study '{s}' is missing requested ", + "context(s): {missingStr}" + ) + warn(msg) + } + intersect(contexts, avail) +} + +# One study's contexts from the named-list form: its own entry when given, +# otherwise everything it has. +# @noRd +.parseContextsListAt <- function(s, data, contexts) { + avail <- .spListContexts(data, s) + if (is_in(s, names(contexts))) { + .parseContextsStudy(as.character(contexts[[s]]), s, avail) + } else { + avail } - out } # Validate one study's explicitly-requested contexts against availability. @@ -411,16 +445,10 @@ parseJointSpecification <- function(jointSpecification, data) { msg <- glue("`contexts` references unknown studies: {badStr}") abort(msg) } - out <- list() - for (s in studies) { - avail <- .spListContexts(data, s) - out[[s]] <- if (is_in(s, names(contexts))) { - .parseContextsStudy(as.character(contexts[[s]]), s, avail) - } else { - avail - } - } - out + set_names( + map(studies, .parseContextsListAt, data = data, contexts = contexts), + studies + ) } parseContexts <- function(contexts, data) { @@ -503,11 +531,16 @@ parseContexts <- function(contexts, data) { msg <- glue("traitId[['{s}']] references unknown contexts: {badStr}") abort(msg) } - sub <- list() - for (cx in names(val)) { - sub[[cx]] <- .parseTraitIdContext(val[[cx]], s, cx, data) - } - sub + set_names( + map(names(val), .parseTraitIdContextAt, val = val, s = s, data = data), + names(val) + ) +} + +# One context's trait spec within a study. +# @noRd +.parseTraitIdContextAt <- function(cx, val, s, data) { + .parseTraitIdContext(val[[cx]], s, cx, data) } # Dispatch one study's trait spec (character vector or context-keyed list). @@ -559,14 +592,24 @@ parseTraitIds <- function(traitId, data) { msg <- glue("`traitId` references unknown studies: {badStr}") abort(msg) } - out <- list() - for (s in names(traitId)) { - out[[s]] <- .parseTraitIdStudy(traitId[[s]], s, data) - } - out + set_names( + map( + names(traitId), + .parseTraitIdStudyAt, + traitId = traitId, + data = data + ), + names(traitId) + ) } +# One study's parsed trait spec. +# @noRd +.parseTraitIdStudyAt <- function(s, traitId, data) { + .parseTraitIdStudy(traitId[[s]], s, data) +} + # ----------------------------------------------------------------------------- # parseMethods -- normalize and validate the `methods` argument with optional # `sumStatsMethods` / `qtlDatasetMethods` overrides. Validates: @@ -640,22 +683,30 @@ parseTraitIds <- function(traitId, data) { return(list(list(depth = depth, path = path, methods = unique(spec)))) } .spWalkValidate(spec, label, depth, maxDepth) - out <- list() - for (nm in names(spec)) { - out <- c( - out, - .spWalkMethods( - spec[[nm]], - label = label, - depth = depth + 1L, - maxDepth = maxDepth, - path = c(path, nm) - ) - ) - } + out <- .spConcat(map( + names(spec), + .spWalkMethodsAt, + spec = spec, + label = label, + depth = depth, + maxDepth = maxDepth, + path = path + )) out } +# Walk one named branch of a methods spec. +# @noRd +.spWalkMethodsAt <- function(nm, spec, label, depth, maxDepth, path) { + .spWalkMethods( + spec[[nm]], + label = label, + depth = depth + 1L, + maxDepth = maxDepth, + path = c(path, nm) + ) +} + # Validate one leaf method vector: non-empty character, all tokens known (in # `caps`), and none in `rejectedAtUser`. # @noRd @@ -692,6 +743,7 @@ parseTraitIds <- function(traitId, data) { # --- parseMethods helpers --------------------------------------------------- # Validate mutual exclusivity of primary vs split method specs. +#' @importFrom checkmate assertCharacter .parseMethodsValidateArgs <- function( primaryGiven, splitGiven, @@ -720,14 +772,8 @@ parseTraitIds <- function(traitId, data) { ) abort(msg) } - if (!is.character(sumStatsMethods) || length(sumStatsMethods) == 0L) { - abort("`sumStatsMethods` must be a non-empty character vector.") - } - if ( - !is.character(qtlDatasetMethods) || length(qtlDatasetMethods) == 0L - ) { - abort("`qtlDatasetMethods` must be a non-empty character vector.") - } + assertCharacter(sumStatsMethods, min.len = 1L) + assertCharacter(qtlDatasetMethods, min.len = 1L) } } @@ -751,32 +797,35 @@ parseTraitIds <- function(traitId, data) { # Study/context/trait keys of a method leaf must reference valid entities. .parseMethodsCheckPath <- function(leaf, lab, data, studyNames) { - if (leaf$depth >= 1L) { - s <- leaf$path[[1L]] - if (!is_in(s, studyNames)) { - msg <- glue("{lab}: unknown study '{s}'") - abort(msg) - } + # The path is (study, context, trait); each level is only checked once the + # leaf is deep enough to name it -- a shallower leaf has no such entry to + # read, so the depth guard has to come before the extraction. + if (leaf$depth < 1L) { + return(invisible(NULL)) } - if (leaf$depth >= 2L) { - s <- leaf$path[[1L]] - cx <- leaf$path[[2L]] - if (!is_in(cx, .spListContexts(data, s))) { - msg <- glue("{lab}: unknown context '{cx}' for study '{s}'") - abort(msg) - } + s <- leaf$path[[1L]] + if (!is_in(s, studyNames)) { + msg <- glue("{lab}: unknown study '{s}'") + abort(msg) } - if (leaf$depth >= 3L) { - s <- leaf$path[[1L]] - cx <- leaf$path[[2L]] - tr <- leaf$path[[3L]] - if (!is_in(tr, .spListTraits(data, study = s, context = cx))) { - msg <- glue( - "{lab}: unknown trait '{tr}' for (study '{s}', ", - "context '{cx}')" - ) - abort(msg) - } + if (leaf$depth < 2L) { + return(invisible(NULL)) + } + cx <- leaf$path[[2L]] + if (!is_in(cx, .spListContexts(data, s))) { + msg <- glue("{lab}: unknown context '{cx}' for study '{s}'") + abort(msg) + } + if (leaf$depth < 3L) { + return(invisible(NULL)) + } + tr <- leaf$path[[3L]] + if (!is_in(tr, .spListTraits(data, study = s, context = cx))) { + msg <- glue( + "{lab}: unknown trait '{tr}' for (study '{s}', ", + "context '{cx}')" + ) + abort(msg) } } @@ -953,42 +1002,82 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # @noRd .fmResolveSpecScope <- function(spec, data, contexts = NULL, traitIds = NULL) { scope <- spec$scope - studies <- .spListStudies(data) - if (!is.null(scope$study)) { - studies <- intersect(studies, scope$study) - } + allStudies <- .spListStudies(data) + studies <- if (is.null(scope$study)) { + allStudies + } else { + intersect(allStudies, scope$study) + } + + contextsOut <- set_names( + map( + studies, + .fmScopeAxis, + avail = .spListContexts, + scopeLimit = scope$context, + userSpec = contexts, + requireCharacter = FALSE, + data = data + ), + studies + ) + traitsOut <- set_names( + map( + studies, + .fmScopeAxis, + avail = .fmScopeTraits, + scopeLimit = scope$trait, + userSpec = traitIds, + requireCharacter = TRUE, + data = data + ), + studies + ) + list(studies = studies, contexts = contextsOut, traits = traitsOut) +} - contextsOut <- list() - traitsOut <- list() - for (s in studies) { - ctxAvail <- .spListContexts(data, s) - if (!is.null(scope$context)) { - ctxAvail <- intersect(ctxAvail, scope$context) - } - if (!is.null(contexts)) { - if (is.list(contexts) && is_in(s, names(contexts))) { - ctxAvail <- intersect(ctxAvail, contexts[[s]]) - } else if (is.character(contexts)) { - ctxAvail <- intersect(ctxAvail, contexts) - } - } - contextsOut[[s]] <- ctxAvail +# `.spListTraits` takes the study by name, so give it the same (data, s) +# shape the context lister has. +# @noRd +.fmScopeTraits <- function(data, s) { + .spListTraits(data, study = s) +} - trAvail <- .spListTraits(data, study = s) - if (!is.null(scope$trait)) { - trAvail <- intersect(trAvail, scope$trait) - } - if (!is.null(traitIds)) { - if (is.character(traitIds)) { - trAvail <- intersect(trAvail, traitIds) - } else if (is.list(traitIds) && is_in(s, names(traitIds))) { - tv <- traitIds[[s]] - if (is.character(tv)) trAvail <- intersect(trAvail, tv) - } - } - traitsOut[[s]] <- trAvail +# What a pipeline-level `contexts` / `traitIds` argument narrows study `s` to, +# or NULL when it says nothing about it. `requireCharacter` mirrors the trait +# axis, which ignores a non-character per-study entry. +# @noRd +.fmScopeUserLimit <- function(spec, s, requireCharacter) { + if (is.null(spec)) { + return(NULL) } - list(studies = studies, contexts = contextsOut, traits = traitsOut) + if (is.character(spec)) { + return(spec) + } + if (!is.list(spec) || !is_in(s, names(spec))) { + return(NULL) + } + entry <- spec[[s]] + if (!requireCharacter || is.character(entry)) entry else NULL +} + +# One axis for one study: everything it has, narrowed by the spec's scope and +# then by the caller's argument. Each narrowing is an intersect, so the chain +# is a fold rather than a variable rewritten in place. +# @noRd +.fmScopeAxis <- function( + s, + avail, + scopeLimit, + userSpec, + requireCharacter, + data +) { + limits <- compact(list( + scopeLimit, + .fmScopeUserLimit(userSpec, s, requireCharacter) + )) + reduce(limits, intersect, .init = avail(data, s)) } @@ -1010,7 +1099,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { context = as.character(data$context), trait = as.character(data$trait) ) - firstDf <- getSumStatsDf( + allDf <- getSumStatsDf( data, study = cols$study[[tupleRows[[1L]]]], context = cols$context[[tupleRows[[1L]]]], @@ -1020,58 +1109,76 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # Every entry shares one SNP order (asserted below), so filtering the first # entry's ids filters the group: Z is built against this vector and each # entry is checked against it. - firstDf <- firstDf[ - .panelKeepMask(firstDf$variant_id, ldSketch, cutoffs, errorLabel), + firstDf <- allDf[ + .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, errorLabel), , drop = FALSE ] variantIds <- firstDf$variant_id - Z <- matrix( - NA_real_, - nrow = length(variantIds), - ncol = length(tupleRows), - dimnames = list(variantIds, colLabels) - ) filled <- .jointFillSumstatZ( data, tupleRows, cols, variantIds, - Z, + colLabels, errorLabel ) list(Z = filled$Z, nVec = filled$nVec, variantIds = variantIds) } -# Read each tuple's z / N into the shared matrix. The fitters index z by -# column position, so every entry must present the same SNPs in the same order. +# One tuple's z column and median N, checked against the shared SNP order. +# @noRd +.jointSumstatEntryAt <- function( + kk, + data, + tupleRows, + cols, + variantIds, + errorLabel +) { + i <- tupleRows[[kk]] + d <- getSumStatsDf( + data, + study = cols$study[[i]], + context = cols$context[[i]], + trait = cols$trait[[i]], + require = c("SNP", "Z", "N") + ) + # Narrowed to the same set before the order check, or that check fires + # on a length mismatch the panel filter itself created. + kept <- d[is_in(d$variant_id, variantIds), , drop = FALSE] + .jointCheckSnpOrder(kept$variant_id, variantIds, errorLabel) + list(z = kept$z, n = stats::median(kept$N, na.rm = TRUE)) +} + +# Read each tuple's z / N into one matrix. The fitters index z by column +# position, so every entry must present the same SNPs in the same order -- +# which is what lets the columns simply be laid side by side here. # @noRd .jointFillSumstatZ <- function( data, tupleRows, cols, variantIds, - Z, + colLabels, errorLabel ) { - nVec <- numeric(length(tupleRows)) - for (kk in seq_along(tupleRows)) { - i <- tupleRows[[kk]] - d <- getSumStatsDf( - data, - study = cols$study[[i]], - context = cols$context[[i]], - trait = cols$trait[[i]], - require = c("SNP", "Z", "N") - ) - # Narrowed to the same set before the order check, or that check fires - # on a length mismatch the panel filter itself created. - d <- d[is_in(d$variant_id, variantIds), , drop = FALSE] - .jointCheckSnpOrder(d$variant_id, variantIds, errorLabel) - Z[, kk] <- d$z - nVec[kk] <- stats::median(d$N, na.rm = TRUE) - } - list(Z = Z, nVec = nVec) + entries <- map( + seq_along(tupleRows), + .jointSumstatEntryAt, + data = data, + tupleRows = tupleRows, + cols = cols, + variantIds = variantIds, + errorLabel = errorLabel + ) + Z <- matrix( + unname(list_c(map(entries, "z"))), + nrow = length(variantIds), + ncol = length(tupleRows), + dimnames = list(variantIds, colLabels) + ) + list(Z = Z, nVec = map_dbl(entries, "n")) } # @noRd @@ -1094,14 +1201,19 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # --- .buildIndividualCrossContextXy helpers --------------------------------- # Scoped contexts in which a trait is present; NULL if fewer than 2. +# Does context `cx` carry trait `tid`? +# @noRd +.ccContextHasTrait <- function(cx, data, tid) { + is_in(tid, rownames(getPhenotypes(data, contexts = cx))) +} + .crossContextPerTrait <- function(data, tid, scopedContexts, verbose, label) { - perTraitContexts <- character(0) - for (cx in scopedContexts) { - se <- getPhenotypes(data, contexts = cx) - if (is_in(tid, rownames(se))) { - perTraitContexts <- c(perTraitContexts, cx) - } - } + perTraitContexts <- keep( + scopedContexts, + .ccContextHasTrait, + data = data, + tid = tid + ) if (length(perTraitContexts) < 2L) { if (verbose >= 1) { nCtx <- length(perTraitContexts) @@ -1142,29 +1254,27 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) if (length(commonSamples) < 2L) { if (verbose >= 1) { - msg <- glue( + inform(glue( "{label}: trait '{tid}' has too few shared samples across ", "contexts; skipping." - ) - inform(msg) + )) } return(NULL) } - X <- X[commonSamples, , drop = FALSE] + shared <- X[commonSamples, , drop = FALSE] Y <- .crossContextY(Yres, perTraitContexts, commonSamples) keep <- stats::complete.cases(Y) if (sum(keep) < 2L) { if (verbose >= 1) { - msg <- glue( + inform(glue( "{label}: trait '{tid}' has too few complete-Y subjects; ", "skipping." - ) - inform(msg) + )) } return(NULL) } list( - X = X[keep, , drop = FALSE], + X = shared[keep, , drop = FALSE], Y = Y[keep, , drop = FALSE], perTraitContexts = perTraitContexts ) @@ -1177,7 +1287,8 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cisWindow, verbose, label, - region = NULL + region = NULL, + residualizationArgs ) { perTraitContexts <- .crossContextPerTrait( data, @@ -1189,8 +1300,20 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (is.null(perTraitContexts)) { return(NULL) } - X <- .buildResidGeno(data, perTraitContexts, tid, cisWindow, region) - Yres <- .fmResidPheno(data, contexts = perTraitContexts, traitId = tid) + X <- .buildResidGeno( + data, + perTraitContexts, + tid, + cisWindow, + region, + residualizationArgs + ) + Yres <- .fmResidPheno( + data, + contexts = perTraitContexts, + traitId = tid, + residualizationArgs = residualizationArgs + ) .crossContextAssemble(X, Yres, perTraitContexts, verbose, label, tid) } @@ -1238,7 +1361,8 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { verbose, label, study, - region = NULL + region = NULL, + residualizationArgs ) { se <- getPhenotypes(data, contexts = cx) # scopedTraits is already region-restricted upstream (.runJointSpecs) when @@ -1247,14 +1371,26 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (.crossTraitTooFew(traitsHere, cx, study, verbose, label)) { return(NULL) } - X <- .buildResidGeno(data, cx, traitsHere, cisWindow, region) - Y <- .fmResidPheno(data, contexts = cx, traitId = traitsHere) - common <- intersect(rownames(X), rownames(Y)) + allX <- .buildResidGeno( + data, + cx, + traitsHere, + cisWindow, + region, + residualizationArgs + ) + allY <- .fmResidPheno( + data, + contexts = cx, + traitId = traitsHere, + residualizationArgs = residualizationArgs + ) + common <- intersect(rownames(allX), rownames(allY)) if (length(common) < 2L) { return(NULL) } - X <- X[common, , drop = FALSE] - Y <- Y[common, , drop = FALSE] + X <- allX[common, , drop = FALSE] + Y <- allY[common, , drop = FALSE] keep <- stats::complete.cases(Y) if (sum(keep) < 2L) { return(NULL) @@ -1273,33 +1409,57 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # @noRd # Residualized genotype for the cross-* / composed builders (cis-window or an # explicit region). Shared by the individual multi-axis Xy builders. -.buildResidGeno <- function(data, contexts, traitId, cisWindow, region) { +.buildResidGeno <- function( + data, + contexts, + traitId, + cisWindow, + region, + residualizationArgs +) { if (is.null(region)) { .fmResidGeno( data, contexts = contexts, traitId = traitId, - cisWindow = cisWindow + cisWindow = cisWindow, + residualizationArgs = residualizationArgs ) } else { - .fmResidGeno(data, contexts = contexts, region = region) + .fmResidGeno( + data, + contexts = contexts, + region = region, + residualizationArgs = residualizationArgs + ) } } # --- .buildComposedIndividualXy helpers ------------------------------------- # Enumerate the in-scope (context, trait) tuples for a study; NULL if < 2. +# @noRd +.composedTuple <- function(tid, cx) { + list(context = cx, trait = tid) +} + +# The (context, trait) tuples context `cx` contributes. +# @noRd +.composedTuplesForContext <- function(cx, data, scopedTraits) { + se <- getPhenotypes(data, contexts = cx) + # scopedTraits is region-restricted upstream (.runJointSpecs) if needed. + map(intersect(scopedTraits, rownames(se)), .composedTuple, cx = cx) +} + .composedTuples <- function(data, scope, study, verbose, label) { scopedContexts <- scope$contexts[[study]] scopedTraits <- scope$traits[[study]] - tuples <- list() - for (cx in scopedContexts) { - se <- getPhenotypes(data, contexts = cx) - # scopedTraits is region-restricted upstream (.runJointSpecs) if needed. - for (tid in intersect(scopedTraits, rownames(se))) { - tuples[[length(tuples) + 1L]] <- list(context = cx, trait = tid) - } - } + tuples <- .spConcat(map( + scopedContexts, + .composedTuplesForContext, + data = data, + scopedTraits = scopedTraits + )) if (length(tuples) < 2L) { if (verbose >= 1) { nTuples <- length(tuples) @@ -1315,23 +1475,73 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # Assemble the composed response matrix (one column per tuple); NULL if < 2. -.composedYCols <- function(YresList, tuples, commonSamples) { - yCols <- list() - for (t in tuples) { - ym <- YresList[[t$context]] - if (!is_in(t$trait, colnames(ym))) { - next - } - col <- ym[commonSamples, t$trait, drop = FALSE] - colnames(col) <- str_c(t$context, t$trait, sep = ":") - yCols[[length(yCols) + 1L]] <- col +# One tuple's phenotype column, labelled "context:trait", or NULL when that +# context does not carry the trait. `colnames<-` applied as a function returns +# a relabelled copy rather than renaming a binding in place. +# @noRd +.composedYCol <- function(t, YresList, commonSamples) { + ym <- YresList[[t$context]] + if (!is_in(t$trait, colnames(ym))) { + return(NULL) } + `colnames<-`( + ym[commonSamples, t$trait, drop = FALSE], + str_c(t$context, t$trait, sep = ":") + ) +} + +.composedYCols <- function(YresList, tuples, commonSamples) { + yCols <- compact(map( + tuples, + .composedYCol, + YresList = YresList, + commonSamples = commonSamples + )) if (length(yCols) < 2L) { return(NULL) } exec(cbind, !!!yCols) } +# The residualized genotypes and the per-context residualized phenotypes +# for one composed block, both over the same context/trait span. +# @noRd +.composedResidualized <- function( + data, + allContexts, + allTraits, + cisWindow, + region, + residualizationArgs +) { + # Genotypes first, as the inline version did: reading them is what + # fails on a missing panel file, and that error must stay the one the + # caller sees rather than a downstream lm.fit() complaint. + allX <- .buildResidGeno( + data, + allContexts, + allTraits, + cisWindow, + region, + residualizationArgs + ) + resid <- .fmResidPheno( + data, + contexts = allContexts, + traitId = allTraits, + residualizationArgs = residualizationArgs + ) + list( + X = allX, + # A single context returns the bare matrix rather than a named list. + YresList = if (length(allContexts) == 1L) { + set_names(list(resid), allContexts) + } else { + resid + } + ) +} + .buildComposedIndividualXy <- function( data, scope, @@ -1339,7 +1549,8 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cisWindow, verbose, label, - region = NULL + region = NULL, + residualizationArgs ) { tuples <- .composedTuples(data, scope, study, verbose, label) if (is.null(tuples)) { @@ -1347,19 +1558,24 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } allContexts <- unique(map_chr(tuples, "context")) allTraits <- unique(map_chr(tuples, "trait")) - X <- .buildResidGeno(data, allContexts, allTraits, cisWindow, region) - YresList <- .fmResidPheno(data, contexts = allContexts, traitId = allTraits) - if (length(allContexts) == 1L) { - YresList <- set_names(list(YresList), allContexts) - } + sides <- .composedResidualized( + data, + allContexts, + allTraits, + cisWindow, + region, + residualizationArgs + ) + allX <- sides$X + YresList <- sides$YresList commonSamples <- reduce( - c(list(rownames(X)), map(YresList, rownames)), + c(list(rownames(allX)), map(YresList, rownames)), intersect ) if (length(commonSamples) < 2L) { return(NULL) } - X <- X[commonSamples, , drop = FALSE] + X <- allX[commonSamples, , drop = FALSE] Y <- .composedYCols(YresList, tuples, commonSamples) if (is.null(Y)) { return(NULL) @@ -1519,6 +1735,23 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # --- .multiStudyPipelineDriver helpers -------------------------------------- # Accumulate per-study + sumstats results (tracking the embedded LD sketch). +# rbind two results with no LD sketch -- the per-study combine. +# @noRd +.msRbindNoLd <- function(acc, x, rbindFn) { + rbindFn(acc, x, ldSketch = NULL) +} + +# Fold per-study results together, skipping studies that produced nothing. +# NULL when nothing did, which is what the callers' `out` started as. +# @noRd +.msFoldStudyResults <- function(results, rbindFn) { + kept <- compact(results) + if (length(kept) == 0L) { + return(NULL) + } + reduce(kept, .msRbindNoLd, rbindFn = rbindFn) +} + .msDriverAccumulate <- function( qtlDatasets, sumStats, @@ -1527,24 +1760,19 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cfg, rbindFn ) { - out <- NULL - embeddedLd <- NULL - for (qdName in names(qtlDatasets)) { - res <- perStudyFn(qtlDatasets[[qdName]], cfg) - if (!is.null(res)) { - out <- if (is.null(out)) res else rbindFn(out, res, ldSketch = NULL) - } + fromStudies <- .msFoldStudyResults( + map(qtlDatasets, perStudyFn, cfg), + rbindFn + ) + ssRes <- if (is.null(sumStats)) NULL else sumStatsFn(sumStats, cfg) + if (is.null(ssRes)) { + return(list(out = fromStudies, embeddedLd = NULL)) } - if (!is.null(sumStats)) { - ssRes <- sumStatsFn(sumStats, cfg) - if (!is.null(ssRes)) { - embeddedLd <- getLdSketch(ssRes) - out <- if (is.null(out)) { - ssRes - } else { - rbindFn(out, ssRes, ldSketch = embeddedLd) - } - } + embeddedLd <- getLdSketch(ssRes) + out <- if (is.null(fromStudies)) { + ssRes + } else { + rbindFn(fromStudies, ssRes, ldSketch = embeddedLd) } list(out = out, embeddedLd = embeddedLd) } @@ -1637,32 +1865,54 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, + credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), verbose, methodArgs = list(), xRegions = list(NULL), - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - cvFolds = 0, - cvThreads = 1, - samplePartition = NULL, + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam(), pipCutoffToSkip = 0, fineMappingResult = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, + fitRetention = c("slim", "none", "full"), seed = NULL ) { + fitRetention <- arg_match(fitRetention) # 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. - args <- as.list(environment()) - args$xRegions <- NULL - perRegion <- map(xRegions, .fmDispatchJointSpecRegion, args = args) - perRegion <- compact(perRegion) + # xRegions is deliberately absent: each region is supplied per call. + perRegion <- map( + xRegions, + .fmDispatchJointSpecRegion, + parsedJointSpec = parsedJointSpec, + data = data, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + credibleSetArgs = credibleSetArgs, + verbose = verbose, + methodArgs = methodArgs, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + crossValidationArgs = crossValidationArgs, + residualizationArgs = residualizationArgs, + pipCutoffToSkip = pipCutoffToSkip, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + seed = seed + ) |> + compact() + .fmCombineRegionResults(perRegion) +} + +# Merge the per-region joint results by (study, context, trait, method). A +# single block -- cis, or jointRegions = TRUE concatenated -- is returned +# directly rather than merged with itself. +# @noRd +.fmCombineRegionResults <- function(perRegion) { if (length(perRegion) == 0L) { return(NULL) } @@ -1673,30 +1923,57 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # FmJointPipeline for individual-level fine-mapping, built from the call params. -.fmJointPipeline <- function(args) { +.fmJointPipeline <- function( + credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), + dataDrivenPriorWeightsCutoff, + crossValidationArgs, + residualizationArgs, + verbose, + fitRetention = c("slim", "none", "full"), + seed +) { + fitRetention <- arg_match(fitRetention) new( "FmJointPipeline", - config = c( - args[c( - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "dataDrivenPriorWeightsCutoff", - "cvFolds", - "cvThreads", - "samplePartition", - "verbose", - "fullFit", - "fullFitAlphaOnly", - "includeAllCs", - "seed" - )], - list(ldSketch = NULL) + config = list( + credibleSetArgs = credibleSetArgs, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + crossValidationArgs = crossValidationArgs, + residualizationArgs = residualizationArgs, + verbose = verbose, + fitRetention = fitRetention, + seed = seed, + ldSketch = NULL ) ) } +# The joint pipeline record, once the spec has been checked against the +# individual-level form -- a study axis has no meaning there, and building +# a pipeline for a spec that names one would defer the error past the fit. +# @noRd +.fmJointPipelineChecked <- function( + parsedJointSpec, + credibleSetArgs, + dataDrivenPriorWeightsCutoff, + crossValidationArgs, + residualizationArgs, + verbose, + fitRetention, + seed +) { + .jointRejectStudyOnIndividual(parsedJointSpec) + .fmJointPipeline( + credibleSetArgs = credibleSetArgs, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + crossValidationArgs = crossValidationArgs, + residualizationArgs = residualizationArgs, + verbose = verbose, + fitRetention = fitRetention, + seed = seed + ) +} + .fmDispatchJointSpecsQtlDatasetOneRegion <- function( parsedJointSpec, data, @@ -1704,29 +1981,31 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, verbose, methodArgs = list(), region = NULL, - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - cvFolds = 0, - cvThreads = 1, - samplePartition = NULL, + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam(), pipCutoffToSkip = 0, fineMappingResult = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - seed = NULL + seed = NULL, + credibleSetArgs, + fitRetention ) { # Engine routing (jointEngine.R); one region block (the caller loops # regions). - .jointRejectStudyOnIndividual(parsedJointSpec) - pipeline <- .fmJointPipeline(as.list(environment())) + pipeline <- .fmJointPipelineChecked( + parsedJointSpec, + credibleSetArgs = credibleSetArgs, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + crossValidationArgs = crossValidationArgs, + residualizationArgs = residualizationArgs, + verbose = verbose, + fitRetention = fitRetention, + seed = seed + ) .runJointSpecs( parsedJointSpec, data, @@ -1736,7 +2015,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, args = list( - twasWeights = twasWeights, + mrmashPrior = mrmashPrior, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, methodArgs = methodArgs, cisWindow = cisWindow, @@ -1753,22 +2032,22 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # @noRd # FmJointPipeline for summary-statistics fine-mapping (RSS: no sample folds; # LD sketch drawn from the data). -.fmSumStatsPipeline <- function(args) { +.fmSumStatsPipeline <- function( + data, + credibleSetArgs, + dataDrivenPriorWeightsCutoff, + verbose, + fitRetention +) { new( "FmJointPipeline", - config = c( - args[c( - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "dataDrivenPriorWeightsCutoff", - "verbose", - "fullFit", - "fullFitAlphaOnly", - "includeAllCs" - )], - list(cvFolds = 0L, ldSketch = getLdSketch(args$data)) + config = list( + credibleSetArgs = credibleSetArgs, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + fitRetention = fitRetention, + crossValidationArgs = .cvResolve(CrossValidationParam()), + ldSketch = getLdSketch(data) ) ) } @@ -1779,26 +2058,25 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methods, contexts, traitIds, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, verbose, methodArgs = list(), - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, fineMappingResult = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1 + panelFilterArgs = PanelFilterParam(), + credibleSetArgs, + fitRetention ) { # Engine routing (jointEngine.R): the dispatch table + .runJointCell replace # the per-axis switch + the cross-context/trait/study/composed leaf # dispatchers. - pipeline <- .fmSumStatsPipeline(as.list(environment())) + pipeline <- .fmSumStatsPipeline( + data = data, + credibleSetArgs = credibleSetArgs, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + verbose = verbose, + fitRetention = fitRetention + ) .runJointSpecs( parsedJointSpec, data, @@ -1808,16 +2086,12 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, args = list( - twasWeights = twasWeights, + mrmashPrior = mrmashPrior, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, methodArgs = methodArgs, verbose = verbose, cache = fineMappingResult, - cutoffs = .panelCutoffs(list( - mafCutoff = mafCutoff, - macCutoff = macCutoff, - imissCutoff = imissCutoff - )) + cutoffs = .panelCutoffs(panelFilterArgs) ) ) } @@ -1855,41 +2129,73 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # Fine-map the non-study-axis specs on each individual-level QtlDataset. -.fmMultiStudyQtlLoop <- function(nonStudyAxisSpecs, qtlDatasets, args) { - out <- NULL +.fmMultiStudyQtlLoop <- function( + nonStudyAxisSpecs, + qtlDatasets, + methods, + contexts, + traitIds, + cisWindow, + credibleSetArgs, + verbose, + methodArgs, + xRegions, + mrmashPrior, + dataDrivenPriorWeightsCutoff +) { if (length(nonStudyAxisSpecs) == 0L) { - return(out) - } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "cisWindow", - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "verbose", - "methodArgs", - "xRegions", - "twasWeights", - "dataDrivenPriorWeightsCutoff" - )] - for (qdName in names(qtlDatasets)) { - qdArgs <- c( - list(nonStudyAxisSpecs, qtlDatasets[[qdName]]), - fwd - ) - qdRes <- exec(.fmDispatchJointSpecsQtlDataset, !!!qdArgs) - if (!is.null(qdRes)) { - out <- if (is.null(out)) { - qdRes - } else { - .rbindFineMappingResult(out, qdRes, ldSketch = NULL) - } - } + return(NULL) } - out + .msFoldStudyResults( + map( + qtlDatasets, + .fmDispatchForStudy, + nonStudyAxisSpecs = nonStudyAxisSpecs, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + credibleSetArgs = credibleSetArgs, + verbose = verbose, + methodArgs = methodArgs, + xRegions = xRegions, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ), + .rbindFineMappingResult + ) +} + +# `map()` hands the dataset first; the dispatcher wants the specs first. +# @noRd +.fmDispatchForStudy <- function( + qd, + nonStudyAxisSpecs, + methods, + contexts, + traitIds, + cisWindow, + verbose, + methodArgs, + xRegions, + mrmashPrior, + dataDrivenPriorWeightsCutoff, + credibleSetArgs +) { + .fmDispatchJointSpecsQtlDataset( + nonStudyAxisSpecs, + qd, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + credibleSetArgs = credibleSetArgs, + verbose = verbose, + methodArgs = methodArgs, + xRegions = xRegions, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) } # Fine-map all specs on the sumstats collection; rbind onto `out`. @@ -1898,8 +2204,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { sumStats, studyAxisSpecs, out, - args, - verbose + methods, + contexts, + traitIds, + verbose, + methodArgs, + mrmashPrior, + dataDrivenPriorWeightsCutoff, + credibleSetArgs ) { if (is.null(sumStats)) { if (length(studyAxisSpecs) > 0L && verbose >= 1) { @@ -1911,24 +2223,18 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } return(out) } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "coverage", - "secondaryCoverage", - "signalCutoff", - "minAbsCorr", - "verbose", - "methodArgs", - "twasWeights", - "dataDrivenPriorWeightsCutoff" - )] - ssArgs <- c( - list(parsedJointSpec, sumStats), - fwd - ) - ssRes <- exec(.fmDispatchJointSpecsQtlSumStats, !!!ssArgs) + ssRes <- .fmDispatchJointSpecsQtlSumStats( + parsedJointSpec, + sumStats, + methods = methods, + contexts = contexts, + traitIds = traitIds, + credibleSetArgs = credibleSetArgs, + verbose = verbose, + methodArgs = methodArgs, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) if (is.null(ssRes)) { return(out) } @@ -1947,29 +2253,43 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, + credibleSetArgs, verbose, methodArgs = list(), xRegions = list(NULL), - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10 ) { - args <- as.list(environment()) qtlDatasets <- getQtlDatasets(data) sumStats <- getSumStats(data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .fmMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) - out <- .fmMultiStudyQtlLoop(specs$nonStudy, qtlDatasets, args) + out <- .fmMultiStudyQtlLoop( + specs$nonStudy, + qtlDatasets, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + credibleSetArgs = credibleSetArgs, + verbose = verbose, + methodArgs = methodArgs, + xRegions = xRegions, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + ) .fmMultiStudySumStats( parsedJointSpec, sumStats, specs$study, out, - args, - verbose + methods = methods, + contexts = contexts, + traitIds = traitIds, + verbose = verbose, + methodArgs = methodArgs, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff ) } @@ -2024,14 +2344,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { dataType, verbose, xRegions = list(NULL), - retainFit = TRUE, - retainFitDetail = "slim", + fitRetention = c("slim", "none", "full"), seed = NULL ) { + fitRetention <- arg_match(fitRetention) # 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. - perRegion <- map( + allRegions <- map( xRegions, .twasDispatchJointSpecRegion, parsedJointSpec = parsedJointSpec, @@ -2042,14 +2362,13 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cisWindow = cisWindow, dataType = dataType, verbose = verbose, - retainFit = retainFit, - retainFitDetail = retainFitDetail, + fitRetention = fitRetention, seed = seed ) - labs <- map_chr(xRegions, .twasRegionLabel) - keep <- !map_lgl(perRegion, is.null) - perRegion <- perRegion[keep] - labs <- labs[keep] + allLabs <- map_chr(xRegions, .twasRegionLabel) + keep <- !map_lgl(allRegions, is.null) + perRegion <- allRegions[keep] + labs <- allLabs[keep] if (length(perRegion) == 0L) { return(NULL) } @@ -2069,19 +2388,18 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { dataType, verbose, region = NULL, - retainFit = TRUE, - retainFitDetail = "slim", + fitRetention = c("slim", "none", "full"), seed = NULL ) { + fitRetention <- arg_match(fitRetention) # Engine routing (jointEngine.R); one region block (the caller loops # regions). .jointRejectStudyOnIndividual(parsedJointSpec) pipeline <- new( "TwasJointPipeline", config = list( - retainFitDetail = retainFitDetail, dataType = dataType, - cvFolds = 0L, + crossValidationArgs = .cvResolve(CrossValidationParam()), fitFullData = TRUE, standardized = FALSE, seed = seed, @@ -2116,19 +2434,16 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { traitIds, dataType, verbose, - retainFit = TRUE, - retainFitDetail = "slim", - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1 + fitRetention = c("slim", "none", "full"), + panelFilterArgs = PanelFilterParam() ) { + fitRetention <- arg_match(fitRetention) # Engine routing (jointEngine.R). pipeline <- new( "TwasJointPipeline", config = list( - retainFitDetail = retainFitDetail, dataType = dataType, - cvFolds = 0L, + crossValidationArgs = .cvResolve(CrossValidationParam()), fitFullData = TRUE, standardized = TRUE, ldSketch = getLdSketch(data) @@ -2145,11 +2460,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { args = list( methodArgs = list(), verbose = verbose, - cutoffs = .panelCutoffs(list( - mafCutoff = mafCutoff, - macCutoff = macCutoff, - imissCutoff = imissCutoff - )) + cutoffs = .panelCutoffs(panelFilterArgs) ) ) } @@ -2175,38 +2486,69 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } # Learn weights for the non-study-axis specs on each individual-level dataset. -.twasMultiStudyQtlLoop <- function(nonStudyAxisSpecs, qtlDatasets, args) { - out <- NULL +.twasMultiStudyQtlLoop <- function( + nonStudyAxisSpecs, + qtlDatasets, + methods, + contexts, + traitIds, + cisWindow, + dataType, + verbose, + xRegions, + fitRetention, + seed +) { if (length(nonStudyAxisSpecs) == 0L) { - return(out) - } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "cisWindow", - "dataType", - "verbose", - "xRegions", - "retainFit", - "retainFitDetail", - "seed" - )] - for (qdName in names(qtlDatasets)) { - qdArgs <- c( - list(nonStudyAxisSpecs, qtlDatasets[[qdName]]), - fwd - ) - qdRes <- exec(.twasDispatchJointSpecsQtlDataset, !!!qdArgs) - if (!is.null(qdRes)) { - out <- if (is.null(out)) { - qdRes - } else { - .rbindTwasWeights(out, qdRes, ldSketch = NULL) - } - } + return(NULL) } - out + .msFoldStudyResults( + map( + qtlDatasets, + .twasDispatchForStudy, + nonStudyAxisSpecs = nonStudyAxisSpecs, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + dataType = dataType, + verbose = verbose, + xRegions = xRegions, + fitRetention = fitRetention, + seed = seed + ), + .rbindTwasWeights + ) +} + +# `map()` hands the dataset first; the dispatcher wants the specs first. +# @noRd +.twasDispatchForStudy <- function( + qd, + nonStudyAxisSpecs, + methods, + contexts, + traitIds, + cisWindow, + dataType, + verbose, + xRegions, + fitRetention, + seed +) { + .twasDispatchJointSpecsQtlDataset( + nonStudyAxisSpecs, + qd, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + dataType = dataType, + verbose = verbose, + xRegions = xRegions, + fitRetention = fitRetention, + seed = seed + ) } # Learn weights for all specs on the sumstats collection; rbind onto `out`. @@ -2215,8 +2557,12 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { sumStats, studyAxisSpecs, out, - args, - verbose + methods, + contexts, + traitIds, + dataType, + verbose, + fitRetention ) { if (is.null(sumStats)) { if (length(studyAxisSpecs) > 0L && verbose >= 1) { @@ -2228,20 +2574,16 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { } return(out) } - fwd <- args[c( - "methods", - "contexts", - "traitIds", - "dataType", - "verbose", - "retainFit", - "retainFitDetail" - )] - ssArgs <- c( - list(parsedJointSpec, sumStats), - fwd - ) - ssRes <- exec(.twasDispatchJointSpecsQtlSumStats, !!!ssArgs) + ssRes <- .twasDispatchJointSpecsQtlSumStats( + parsedJointSpec, + sumStats, + methods = methods, + contexts = contexts, + traitIds = traitIds, + dataType = dataType, + verbose = verbose, + fitRetention = fitRetention + ) if (is.null(ssRes)) { return(out) } @@ -2263,23 +2605,38 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { dataType, verbose, xRegions = list(NULL), - retainFit = TRUE, - retainFitDetail = "slim", + fitRetention = c("slim", "none", "full"), seed = NULL ) { - args <- as.list(environment()) + fitRetention <- arg_match(fitRetention) qtlDatasets <- getQtlDatasets(data) sumStats <- getSumStats(data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .twasMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) - out <- .twasMultiStudyQtlLoop(specs$nonStudy, qtlDatasets, args) + out <- .twasMultiStudyQtlLoop( + specs$nonStudy, + qtlDatasets, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + dataType = dataType, + verbose = verbose, + xRegions = xRegions, + fitRetention = fitRetention, + seed = seed + ) .twasMultiStudySumStats( parsedJointSpec, sumStats, specs$study, out, - args, - verbose + methods = methods, + contexts = contexts, + traitIds = traitIds, + dataType = dataType, + verbose = verbose, + fitRetention = fitRetention ) } @@ -2295,9 +2652,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # One context's response column on the shared samples, named by the context. # @noRd .crossContextYCol <- function(cx, Yres, commonSamples) { - ym <- Yres[[cx]][commonSamples, , drop = FALSE] - colnames(ym) <- cx - ym + `colnames<-`(Yres[[cx]][commonSamples, , drop = FALSE], cx) } # TRUE when sumstats row `i`'s (study, context, trait) is entirely in scope. @@ -2359,9 +2714,46 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # One region's FM joint-spec dispatch; `args` bundles the shared call arguments. # @noRd -.fmDispatchJointSpecRegion <- function(rg, args) { - regionArgs <- c(args, list(region = rg)) - exec(.fmDispatchJointSpecsQtlDatasetOneRegion, !!!regionArgs) +.fmDispatchJointSpecRegion <- function( + rg, + parsedJointSpec, + data, + methods, + contexts, + traitIds, + cisWindow, + credibleSetArgs, + verbose, + methodArgs, + mrmashPrior, + dataDrivenPriorWeightsCutoff, + crossValidationArgs, + residualizationArgs, + pipCutoffToSkip, + fineMappingResult, + fitRetention, + seed +) { + .fmDispatchJointSpecsQtlDatasetOneRegion( + parsedJointSpec = parsedJointSpec, + data = data, + methods = methods, + contexts = contexts, + traitIds = traitIds, + cisWindow = cisWindow, + credibleSetArgs = credibleSetArgs, + verbose = verbose, + methodArgs = methodArgs, + mrmashPrior = mrmashPrior, + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + crossValidationArgs = crossValidationArgs, + residualizationArgs = residualizationArgs, + pipCutoffToSkip = pipCutoffToSkip, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + seed = seed, + region = rg + ) } # One region's TWAS joint-spec dispatch over a QtlDataset. @@ -2376,8 +2768,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cisWindow, dataType, verbose, - retainFit, - retainFitDetail, + fitRetention, seed = NULL ) { .twasDispatchJointSpecsQtlDatasetOneRegion( @@ -2390,8 +2781,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { dataType, verbose, region = rg, - retainFit = retainFit, - retainFitDetail = retainFitDetail, + fitRetention = fitRetention, seed = seed ) } diff --git a/R/ld.R b/R/ld.R index 6f294c6a7..0379fba4e 100644 --- a/R/ld.R +++ b/R/ld.R @@ -1,11 +1,13 @@ +#' @include MethodParam.R +NULL + #' Deduplicate and sort genomic regions by chromosome and start position. #' @importFrom dplyr distinct arrange #' @noRd orderDedupRegions <- function(df) { - df$chrom <- canonChrom(df$chrom) - df <- distinct(df, .data$chrom, .data$start, .keep_all = TRUE) |> + mutate(df, chrom = canonChrom(.data$chrom)) |> + distinct(.data$chrom, .data$start, .keep_all = TRUE) |> arrange(chromOrder(.data$chrom), .data$start) - df } #' Find the first and last rows of genomicData that overlap a query region. @@ -133,12 +135,15 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { # Split the comma-joined path column into LD (+ optional bim) path columns. .regionalLdParsePaths <- function(genomicData) { parts <- str_split(genomicData$path, ",", simplify = TRUE) - filePath <- as_tibble(parts, .name_repair = "minimal") - names(filePath) <- if (ncol(parts) == 2) { + pathNames <- if (ncol(parts) == 2) { c("LD_file_path", "bim_file_path") } else { "LD_file_path" } + filePath <- `names<-`( + as_tibble(parts, .name_repair = "minimal"), + pathNames + ) bind_cols(genomicData, filePath) |> select(-any_of("path")) } @@ -164,23 +169,37 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { list(ldPaths = ldPaths, bimPaths = bimPaths) } +# A metadata row recorded as start=0, end=0 covers the whole chromosome +# rather than an empty interval, so widen its end before any overlap test. +# @noRd +.ldMetaWidenWholeChrom <- function(meta) { + mutate( + meta, + end = if_else( + .data$start == 0 & .data$end == 0, + Inf, + as.numeric(.data$end) + ) + ) +} + getRegionalLdMeta <- function( ldReferenceMetaFile, region, completeCoverageRequired = FALSE ) { - genomicData <- vroom(ldReferenceMetaFile) - region <- parseRegion(region) - names(genomicData) <- c("chrom", "start", "end", "path") - names(region) <- c("chrom", "start", "end") - # Treat start=0, end=0 as "covers all regions" (whole-chromosome files). - wholeChrom <- genomicData$start == 0 & genomicData$end == 0 - if (any(wholeChrom)) { - genomicData$end[wholeChrom] <- Inf - } - genomicData <- orderDedupRegions(genomicData) - region <- orderDedupRegions(region) - genomicData <- .regionalLdParsePaths(genomicData) + genomicData <- `names<-`( + vroom(ldReferenceMetaFile), + c("chrom", "start", "end", "path") + ) |> + .ldMetaWidenWholeChrom() |> + orderDedupRegions() |> + .regionalLdParsePaths() + region <- `names<-`( + parseRegion(region), + c("chrom", "start", "end") + ) |> + orderDedupRegions() intersectionRows <- findIntersectionRows( genomicData, region$chrom, @@ -237,44 +256,49 @@ getRegionalLdMeta <- function( # Read + normalise the LD variant metadata (canonical chrom / variant id / GD). .processLdVariants <- function(snpFilePath) { - ldVariants <- readVariantMetadata(snpFilePath) - isPvar <- !is_in("gpos", names(ldVariants)) - ldVariants <- ldVariants |> - mutate( - chrom = canonChrom(.data$chrom), - variants = normalizeVariantId(.data$id) - ) - if (isPvar) { - ldVariants <- rename(ldVariants, GD = "pos") - ldVariants$GD <- ldVariants$pos <- map_int( - ldVariants$variants, - .ldVariantPos - ) - } else { - ldVariants <- rename(ldVariants, GD = "gpos") + raw <- readVariantMetadata(snpFilePath) + isPvar <- !is_in("gpos", names(raw)) + ldVariants <- mutate( + raw, + chrom = canonChrom(.data$chrom), + variants = normalizeVariantId(.data$id) + ) + if (!isPvar) { + return(rename(ldVariants, GD = "gpos")) } - ldVariants + # A .pvar carries no genetic distance, so GD and pos both take the + # position parsed back out of the variant id. + parsedPos <- map_int(ldVariants$variants, .ldVariantPos) + rename(ldVariants, GD = "pos") |> + mutate(GD = parsedPos, pos = parsedPos) } processLdMatrix <- function(ldFilePath, snpFilePath = NULL) { ldFileCon <- xzfile(ldFilePath) - ldMatrix <- scan(ldFileCon, quiet = TRUE) + ldValues <- scan(ldFileCon, quiet = TRUE) close(ldFileCon) - ldMatrix <- matrix(ldMatrix, ncol = sqrt(length(ldMatrix)), byrow = TRUE) snpFilePath <- .processLdSnpFile(ldFilePath, snpFilePath) - ldVariants <- .processLdVariants(snpFilePath) + rawVariants <- .processLdVariants(snpFilePath) # Label and symmetrize the matrix. - colnames(ldMatrix) <- rownames(ldMatrix) <- ldVariants$variants - if (all(ldMatrix[lower.tri(ldMatrix)] == 0)) { - ldMatrix[lower.tri(ldMatrix)] <- t(ldMatrix)[lower.tri(ldMatrix)] + labelled <- `dimnames<-`( + matrix(ldValues, ncol = sqrt(length(ldValues)), byrow = TRUE), + list(rawVariants$variants, rawVariants$variants) + ) + # Only one triangle is stored on disk; mirror whichever one is empty. + lower <- lower.tri(labelled) + upper <- upper.tri(labelled) + ldMatrix <- if (all(labelled[lower] == 0)) { + replace(labelled, lower, t(labelled)[lower]) } else { - ldMatrix[upper.tri(ldMatrix)] <- t(ldMatrix)[upper.tri(ldMatrix)] + replace(labelled, upper, t(labelled)[upper]) } # Order variants by genomic position. - posOrder <- order(map_int(ldVariants$variants, .ldVariantPos)) - ldVariants <- slice(ldVariants, posOrder) - ldMatrix <- ldMatrix[ldVariants$variants, ldVariants$variants] - list(ldMatrix = ldMatrix, ldVariants = ldVariants) + posOrder <- order(map_int(rawVariants$variants, .ldVariantPos)) + ldVariants <- slice(rawVariants, posOrder) + list( + ldMatrix = ldMatrix[ldVariants$variants, ldVariants$variants], + ldVariants = ldVariants + ) } #' Subset an LD matrix and variant info to a genomic region, optionally further @@ -282,57 +306,65 @@ processLdMatrix <- function(ldFilePath, snpFilePath = NULL) { #' @importFrom dplyr mutate select inner_join #' @noRd extractLdForRegion <- function(ldMatrix, variants, region, extractCoordinates) { - extracted <- filter( + inRegion <- filter( variants, .data$chrom == region$chrom & .data$pos >= region$start & .data$pos <= region$end ) - - if (!is.null(extractCoordinates)) { - extractCoordinates <- extractCoordinates |> - mutate(chrom = canonChrom(.data$chrom)) |> - select("chrom", "pos") - extracted <- extracted |> - mutate(chrom = canonChrom(.data$chrom)) |> - inner_join(extractCoordinates, by = c("chrom", "pos")) - keepCols <- intersect( - c( - "chrom", - "variants", - "pos", - "GD", - "A1", - "A2", - "variance", - "allele_freq", - "n_nomiss" - ), - names(extracted) - ) - extracted <- select(extracted, all_of(keepCols)) + extracted <- if (is.null(extractCoordinates)) { + inRegion + } else { + .ldRestrictToCoordinates(inRegion, extractCoordinates) } - mat <- ldMatrix[extracted$variants, extracted$variants, drop = FALSE] list(extractedLdMatrix = mat, extractedLdVariants = extracted) } +# The region's variants restricted to an explicit (chrom, pos) list, keeping +# only the variant-info columns the callers read back. +# @noRd +.ldRestrictToCoordinates <- function(inRegion, extractCoordinates) { + wanted <- extractCoordinates |> + mutate(chrom = canonChrom(.data$chrom)) |> + select("chrom", "pos") + joined <- inRegion |> + mutate(chrom = canonChrom(.data$chrom)) |> + inner_join(wanted, by = c("chrom", "pos")) + keepCols <- intersect( + c( + "chrom", + "variants", + "pos", + "GD", + "A1", + "A2", + "variance", + "allele_freq", + "n_nomiss" + ), + names(joined) + ) + select(joined, all_of(keepCols)) +} + # Concatenate per-block variant-id lists into one deduplicated vector, dropping # a repeated boundary variant shared between adjacent blocks. # @noRd .ldMergeVariants <- function(variantList) { - merged <- character(0) - for (v in variantList) { - ids <- if (is.list(v) && !is.null(v$variants)) v$variants else v - if (length(ids) == 0) { - next - } - if (length(merged) > 0 && tail(merged, 1) == ids[1]) { - ids <- ids[-1] - } - merged <- c(merged, ids) + # Only the running tail decides whether a block's first id is a repeated + # boundary variant, so the merge is a fold. + reduce(variantList, .ldAppendBlockVariants, .init = character(0)) +} + +# @noRd +.ldAppendBlockVariants <- function(merged, v) { + ids <- if (is.list(v) && !is.null(v$variants)) v$variants else v + if (length(ids) == 0) { + return(merged) } - merged + repeatsBoundary <- length(merged) > 0 && tail(merged, 1) == ids[1] + c(merged, if (repeatsBoundary) ids[-1] else ids) } #' Combine multiple block-level LD matrices into one, handling boundary @@ -348,7 +380,9 @@ createLdMatrix <- function(ldMatrices, variants) { dimnames = list(allVariants, allVariants) ) - # Place each block into the combined matrix + # Deliberate preallocate-and-scatter: `combined` is variants x variants, + # so building it by folding full-size copies would multiply the memory + # this function needs by the number of blocks. for (i in seq_along(ldMatrices)) { v <- rownames(ldMatrices[[i]]) idx <- match(v, allVariants) @@ -400,9 +434,11 @@ createLdMatrix <- function(ldMatrices, variants) { if (length(dupIdx) == 0) { return(result) } - corr <- getCorrelation(result) - if (!is.null(corr)) { - corr <- corr[-dupIdx, -dupIdx, drop = FALSE] + full <- getCorrelation(result) + corr <- if (is.null(full)) { + NULL + } else { + full[-dupIdx, -dupIdx, drop = FALSE] } LdData( correlation = corr, @@ -565,7 +601,7 @@ loadLdMatrix <- function( seed, nSample ) { - result <- if (byRegion) { + loaded <- if (byRegion) { .loadLdFromMeta( source, key, @@ -574,12 +610,13 @@ loadLdMatrix <- function( nSample ) } else { - .loadLdFromIndexed(source, key, returnGenotype) + .loadLdFromIndexed(source, key) } - result <- .loadLdDedup(result) - result <- .ldApplyMonomorphic(result, dropMonomorphic) - result <- .ldApplySubsample(result, maxVariants, seed, key) - .ldApplyMaterialize(result, materializeGenotypes) + loaded |> + .loadLdDedup() |> + .ldApplyMonomorphic(dropMonomorphic) |> + .ldApplySubsample(maxVariants, seed, key) |> + .ldApplyMaterialize(materializeGenotypes) } # Coordinate-free sources, addressed by block index: an `ldInfo` table (the @@ -587,7 +624,7 @@ loadLdMatrix <- function( # single in-memory matrix, or a list of them. Every source returns an LdData, # so callers never have to branch on what they loaded from. # @noRd -.loadLdFromIndexed <- function(source, block, returnGenotype) { +.loadLdFromIndexed <- function(source, block) { if (is.data.frame(source)) { return(.ldInfoBlock(source, block)) } @@ -659,16 +696,16 @@ loadLdMatrix <- function( # identity comes from the dimnames when present. # @noRd .ldDataFromMatrix <- function(mat, isGenotype) { - ids <- if (isGenotype) colnames(mat) else rownames(mat) n <- if (isGenotype) ncol(mat) else nrow(mat) - if (is.null(ids)) { - ids <- str_c("v", seq_len(n)) - } - gr <- GRanges( - seqnames = rep("chrNA", n), - ranges = IRanges::IRanges(start = seq_len(n), width = 1L) + named <- if (isGenotype) colnames(mat) else rownames(mat) + ids <- named %||% str_c("v", seq_len(n)) + gr <- S4Vectors::`mcols<-`( + GRanges( + seqnames = rep("chrNA", n), + ranges = IRanges::IRanges(start = seq_len(n), width = 1L) + ), + value = S4Vectors::DataFrame(variant_id = ids) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(variant_id = ids) LdData( correlation = if (isGenotype) NULL else mat, genotypeHandle = if (isGenotype) mat else NULL, @@ -736,20 +773,23 @@ loadLdMatrix <- function( # genotypes consistent with the ranges. # @noRd .ldSubsetData <- function(ld, idx) { - R <- ld@correlation - if (!is.null(R) && is.matrix(R)) { - R <- R[idx, idx, drop = FALSE] + full <- ld@correlation + R <- if (!is.null(full) && is.matrix(full)) { + full[idx, idx, drop = FALSE] + } else { + full } - gh <- ld@genotypeHandle - if (is.matrix(gh)) { - gh <- gh[, idx, drop = FALSE] - } else if (!is.null(ld@snpIdx)) { - ld@snpIdx <- ld@snpIdx[idx] + raw <- ld@genotypeHandle + gh <- if (is.matrix(raw)) raw[, idx, drop = FALSE] else raw + snpIdx <- if (is.matrix(raw) || is.null(ld@snpIdx)) { + ld@snpIdx + } else { + ld@snpIdx[idx] } LdData( correlation = R, genotypeHandle = gh, - snpIdx = if (is.matrix(gh)) NULL else ld@snpIdx, + snpIdx = if (is.matrix(gh)) NULL else snpIdx, variants = getVariantInfo(ld)[idx], blockMetadata = getBlockMetadata(ld), nRef = getNRef(ld) @@ -842,10 +882,12 @@ isGenotypeSource <- function(path) { #' @importFrom vroom vroom #' @noRd # Read + validate the first row of an LD metadata TSV (>=4 columns). +#' @importFrom checkmate checkFileExists .resolveLdReadMeta <- function(path) { - if (!file.exists(path)) { + res <- checkFileExists(path, access = "r") + if (!isTRUE(res)) { msg <- glue( - "LD metadata file not found: {path}", + "LD metadata file: {res}", "\n Expected: a TSV file with columns chrom, start, end, path.", .trim = FALSE ) @@ -859,8 +901,10 @@ isGenotypeSource <- function(path) { ) abort(msg) } - colnames(meta)[seq_len(4)] <- c("chrom", "start", "end", "path") - meta + `colnames<-`( + meta, + replace(colnames(meta), seq_len(4), c("chrom", "start", "end", "path")) + ) } # Genotype source descriptor for the resolved path, or NULL if pre-computed. @@ -914,9 +958,9 @@ resolveLdSource <- function(path) { #' @noRd resolveGenotypePathForRegion <- function(metaPath, region) { parsed <- parseRegion(region) - meta <- as.data.frame(vroom(metaPath, show_col_types = FALSE)) - colnames(meta) <- c("chrom", "start", "end", "path") - meta$chrom <- canonChrom(meta$chrom) + meta <- as.data.frame(vroom(metaPath, show_col_types = FALSE)) |> + `colnames<-`(c("chrom", "start", "end", "path")) |> + mutate(chrom = canonChrom(.data$chrom)) queryChrom <- canonChrom(parsed$chrom) matching <- meta[meta$chrom == queryChrom, , drop = FALSE] @@ -946,10 +990,10 @@ resolveGenotypePathForRegion <- function(metaPath, region) { genotypePath, nSample ) { - refPanel <- parseVariantId(variantIds) - refPanel$variant_id <- variantIds afreq <- readAfreq(genotypePath) - if (!is.null(afreq)) { + alleleFreq <- if (is.null(afreq)) { + colMeans(X, na.rm = TRUE) / 2 + } else { freqMatch <- match(variantInfo$id, afreq$id) nUnmatched <- sum(is.na(freqMatch)) if (nUnmatched > 0) { @@ -960,16 +1004,27 @@ resolveGenotypePathForRegion <- function(metaPath, region) { ) warn(msg) } - refPanel$allele_freq <- afreq$alt_freq[freqMatch] - } else { - refPanel$allele_freq <- colMeans(X, na.rm = TRUE) / 2 + afreq$alt_freq[freqMatch] } - if (!is.null(nSample)) { - p <- refPanel$allele_freq - refPanel$variance <- 2 * p * (1 - p) * nSample / (nSample - 1) - refPanel$n_nomiss <- nSample + mutate( + parseVariantId(variantIds), + variant_id = variantIds, + allele_freq = alleleFreq, + !!!.ldPanelSampleCols(alleleFreq, nSample) + ) +} + +# The panel's per-variant variance / non-missing count, which are only +# derivable once the caller declares the sample size behind the frequencies. +# @noRd +.ldPanelSampleCols <- function(p, nSample) { + if (is.null(nSample)) { + return(list()) } - refPanel + list( + variance = 2 * p * (1 - p) * nSample / (nSample - 1), + n_nomiss = nSample + ) } # Single-block metadata spanning the loaded region. @@ -1017,7 +1072,6 @@ loadLdFromGenotype <- function( region = region, returnVariantInfo = TRUE ) - X <- result$X variantInfo <- result$variant_info variantIds <- normalizeVariantId(formatVariantId( variantInfo$chrom, @@ -1025,7 +1079,7 @@ loadLdFromGenotype <- function( variantInfo$A2, variantInfo$A1 )) - colnames(X) <- variantIds + X <- `colnames<-`(result$X, variantIds) refPanel <- .loadLdGtRefPanel( X, variantInfo, @@ -1132,7 +1186,9 @@ loadLdFromGenotype <- function( if (methods::is(x, "GenotypeHandle")) { return(.subsetGenotypeHandle(x, keep)) } - x[keep, ] + # `drop = FALSE`: the fallback shape is the matrix sketch, which a + # one-variant `keep` would otherwise collapse to a vector. + x[keep, , drop = FALSE] } # A sketch trimmed to zero variants, every other property preserved. Used when @@ -1265,18 +1321,6 @@ loadLdFromGenotype <- function( length(.ldSketchSampleIds(x)) } -# The BP / A1 / A2 vectors under the names the panel-comparison error messages -# report, so the message can name the column a user would recognise. -# @noRd -.ldRangesColumns <- function(gr) { - mc <- S4Vectors::mcols(gr) - list( - BP = as.character(GenomicRanges::start(gr)), - A1 = as.character(mc$A1), - A2 = as.character(mc$A2) - ) -} - # Dosage for a variant subset, samples x variants. # # Read through the assay, so the DelayedArray seed -- and with it the file @@ -1368,14 +1412,16 @@ loadLdFromGenotype <- function( # the caller's frame exactly as `.cbFlipPairToCanonical()` does: # LD_ij -> sign_i * sign_j * LD_ij. A no-op on a harmonized panel, where # every sign is +1. - if (any(matched$sign < 0)) { - ldMat <- ldMat * outer(matched$sign, matched$sign) + signed <- if (any(matched$sign < 0)) { + ldMat * outer(matched$sign, matched$sign) + } else { + ldMat } - dimnames(ldMat) <- list(matched$keptIds, matched$keptIds) + named <- `dimnames<-`(signed, list(matched$keptIds, matched$keptIds)) if (onMissing == "drop") { - attr(ldMat, "keptVariantIds") <- matched$keptIds + return(`attr<-`(named, "keptVariantIds", matched$keptIds)) } - ldMat + named } # ---------- LD sketch: per-variant panel statistics and filtering ---------- @@ -1432,8 +1478,9 @@ loadLdFromGenotype <- function( # not carry them. A malformed sidecar must not take the whole filter down, so # it degrades to "no frequencies here" and the caller falls back to dosage. # @noRd +#' @importFrom rlang try_fetch .panelAfreqTable <- function(prefix) { - af <- tryCatch(readAfreq(prefix), error = function(e) NULL) + af <- try_fetch(readAfreq(prefix), error = function(cnd) NULL) if (is.null(af) || !all(is_in(c("id", "alt_freq"), colnames(af)))) { return(NULL) } @@ -1473,13 +1520,8 @@ loadLdFromGenotype <- function( # sidecar (its observation count is an ALLELE count, whose ploidy the mask # would have to guess), so an imissCutoff always takes the dosage path. # @noRd -.panelDropMask <- function( - ldSketch, - matched, - mafCutoff, - macCutoff, - imissCutoff -) { +.panelDropMask <- function(ldSketch, matched, panelFilterArgs) { + imissCutoff <- panelFilterArgs$imissCutoff if (imissCutoff >= 1) { # Keyed on the PANEL's own variant labels, not the caller's: .afreq # carries the .pvar ids, while `keptIds` is whatever id form the @@ -1490,8 +1532,8 @@ loadLdFromGenotype <- function( maf <- .panelAfreqMaf(.ldSketchHandle(ldSketch), panelIds) if (!is.null(maf)) { effMaf <- .panelEffectiveMaf( - mafCutoff, - macCutoff, + panelFilterArgs$mafCutoff, + panelFilterArgs$macCutoff, .ldSketchNSamples(ldSketch) ) return(is.na(maf) | maf < effMaf) @@ -1499,7 +1541,11 @@ loadLdFromGenotype <- function( } dosage <- .ldSketchDosage(ldSketch, matched$idx, meanImpute = FALSE) stats <- .panelVariantStats(dosage) - effMaf <- .panelEffectiveMaf(mafCutoff, macCutoff, nrow(dosage)) + effMaf <- .panelEffectiveMaf( + panelFilterArgs$mafCutoff, + panelFilterArgs$macCutoff, + nrow(dosage) + ) is.na(stats$maf) | stats$maf < effMaf | stats$missRate > imissCutoff } @@ -1514,15 +1560,13 @@ loadLdFromGenotype <- function( .panelVariantFilter <- function( ldSketch, variantIds, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, + panelFilterArgs = PanelFilterParam(), label = ".panelVariantFilter" ) { - mafCutoff <- mafCutoff %||% 0 - macCutoff <- macCutoff %||% 0 - imissCutoff <- imissCutoff %||% 1 - if (mafCutoff <= 0 && macCutoff <= 0 && imissCutoff >= 1) { + # .panelCutoffs answers NULL for a filter that would keep everything, + # which is also the cheap exit here. + cutoffs <- .panelCutoffs(panelFilterArgs) + if (is.null(cutoffs)) { return(variantIds) } if (is.null(ldSketch) || length(variantIds) == 0L) { @@ -1532,13 +1576,7 @@ loadLdFromGenotype <- function( if (is.null(matched)) { return(variantIds) } - drop <- .panelDropMask( - ldSketch, - matched, - mafCutoff, - macCutoff, - imissCutoff - ) + drop <- .panelDropMask(ldSketch, matched, cutoffs) variantIds[!is_in(variantIds, matched$keptIds[drop])] } @@ -1549,14 +1587,7 @@ loadLdFromGenotype <- function( if (is.null(ldSketch) || is.null(cutoffs)) { return(rep(TRUE, length(variantIds))) } - kept <- .panelVariantFilter( - ldSketch, - variantIds, - mafCutoff = cutoffs$mafCutoff, - macCutoff = cutoffs$macCutoff, - imissCutoff = cutoffs$imissCutoff, - label = label - ) + kept <- .panelVariantFilter(ldSketch, variantIds, cutoffs, label = label) keep <- is_in(variantIds, kept) nDropped <- sum(!keep) if (nDropped > 0L) { @@ -1572,10 +1603,13 @@ loadLdFromGenotype <- function( # The panel-filter cutoffs a pipeline call carries, or NULL when none is set # (so the filter short-circuits without touching the panel). # @noRd -.panelCutoffs <- function(p) { - maf <- p$mafCutoff %||% 0 - mac <- p$macCutoff %||% 0 - imiss <- p$imissCutoff %||% 1 +.panelCutoffs <- function(panelFilterArgs = PanelFilterParam()) { + # NULL fields are how the pipelines spell "not set"; normalise them to the + # no-op values so the short-circuit below is the only place that decides + # whether a filter is worth running. + maf <- panelFilterArgs$mafCutoff %||% 0 + mac <- panelFilterArgs$macCutoff %||% 0 + imiss <- panelFilterArgs$imissCutoff %||% 1 if (maf <= 0 && mac <= 0 && imiss >= 1) { return(NULL) } @@ -1673,10 +1707,10 @@ loadLdFromGenotype <- function( } # str_c propagates NA, which would make a variant with an unknown allele # match nothing on either side; an empty field keeps it comparable. - a1 <- as.character(mc$A1) - a2 <- as.character(mc$A2) - a1 <- if_else(is.na(a1), "", a1) - a2 <- if_else(is.na(a2), "", a2) + rawA1 <- as.character(mc$A1) + rawA2 <- as.character(mc$A2) + a1 <- if_else(is.na(rawA1), "", rawA1) + a2 <- if_else(is.na(rawA2), "", rawA2) str_c(stem, ":", if_else(a1 < a2, a1, a2), ":", if_else(a1 < a2, a2, a1)) } @@ -1935,30 +1969,46 @@ standardizeGenotypeHwe <- function(X, alleleFreq) { # Build the reference panel: variant ids + merged per-variant annotations, # deriving variance from nSample + allele_freq when it is otherwise absent. +# One annotation column aligned to the panel's variant order. +# @noRd +.ldAnnotationColumn <- function(col, mergedVariantList, ids) { + mergedVariantList[[col]][match(ids, mergedVariantList$variants)] +} + .loadLdRefPanel <- function(ldMatrix, extractedLdVariantsList, nSample) { - refPanel <- parseVariantId(rownames(ldMatrix)) - mergedVariantList <- bind_rows(extractedLdVariantsList) ids <- rownames(ldMatrix) - refPanel$variant_id <- ids - for (col in c("allele_freq", "variance", "n_nomiss")) { - if (is_in(col, colnames(mergedVariantList))) { - refPanel[[col]] <- mergedVariantList[[col]][ - match(ids, mergedVariantList$variants) - ] - } - } - needVar <- !is_in("variance", colnames(refPanel)) || - all(is.na(refPanel$variance)) + mergedVariantList <- bind_rows(extractedLdVariantsList) + annotations <- intersect( + c("allele_freq", "variance", "n_nomiss"), + colnames(mergedVariantList) + ) + panel <- mutate( + parseVariantId(ids), + variant_id = ids, + !!!set_names( + map( + annotations, + .ldAnnotationColumn, + mergedVariantList = mergedVariantList, + ids = ids + ), + annotations + ) + ) + needVar <- !is_in("variance", colnames(panel)) || all(is.na(panel$variance)) if ( - !is.null(nSample) && - needVar && - is_in("allele_freq", colnames(refPanel)) + is.null(nSample) || + !needVar || + !is_in("allele_freq", colnames(panel)) ) { - p <- refPanel$allele_freq - refPanel$variance <- 2 * p * (1 - p) * nSample / (nSample - 1) - refPanel$n_nomiss <- nSample + return(panel) } - refPanel + p <- panel$allele_freq + mutate( + panel, + variance = 2 * p * (1 - p) * nSample / (nSample - 1), + n_nomiss = nSample + ) } loadLdFromBlocks <- function( @@ -2017,11 +2067,14 @@ loadLdFromBlocks <- function( #' variantIds = c("chr22:16050000:A:G", "chr22:17000000:C:T"), #' ldReferenceMetaFile = meta) #' @export +#' @importFrom checkmate assertCharacter assertFlag filterVariantsByLdReference <- function( variantIds, ldReferenceMetaFile, keepIndel = TRUE ) { + assertCharacter(variantIds, any.missing = FALSE) + assertFlag(keepIndel) variantsDf <- parseVariantId(variantIds) # Derive region to scope the reference lookup @@ -2035,11 +2088,11 @@ filterVariantsByLdReference <- function( refKey <- str_c(refChrom, ":", refInfo$pos) variantKey <- str_c(variantsDf$chrom, ":", variantsDf$pos) - keepIndices <- which(is_in(variantKey, refKey)) - - if (!keepIndel) { - snpIdx <- which(isSnpAlleles(variantsDf$A1, variantsDf$A2)) - keepIndices <- intersect(keepIndices, snpIdx) + inRef <- which(is_in(variantKey, refKey)) + keepIndices <- if (keepIndel) { + inRef + } else { + intersect(inRef, which(isSnpAlleles(variantsDf$A1, variantsDf$A2))) } nDropped <- length(variantIds) - length(keepIndices) @@ -2091,14 +2144,9 @@ filterVariantsByLdReference <- function( ) { abort("Empty or NULL LD matrix provided.") } - if ( - is.null(rownames(combinedMatrix)) || - is.null(colnames(combinedMatrix)) || - !identical(rownames(combinedMatrix), variantIds) || - !identical(colnames(combinedMatrix), variantIds) - ) { - rownames(combinedMatrix) <- variantIds - colnames(combinedMatrix) <- variantIds + wanted <- list(variantIds, variantIds) + if (!identical(dimnames(combinedMatrix), wanted)) { + return(`dimnames<-`(combinedMatrix, wanted)) } combinedMatrix } @@ -2106,7 +2154,7 @@ filterVariantsByLdReference <- function( # Drop blocks with invalid/out-of-range indices; renumber the survivors. .partitionFilterBlocks <- function(blockMetadata, nVariants) { validBlocks <- map_lgl( - seq_len(nrow(blockMetadata)), + seq_along(blockMetadata), .ldBlockValid, blockMetadata = blockMetadata, nVariants = nVariants @@ -2125,60 +2173,114 @@ filterVariantsByLdReference <- function( "out-of-range indices." ) inform(msg) - blockMetadata <- filter(blockMetadata, validBlocks) - blockMetadata$blockId <- seq_len(nrow(blockMetadata)) + kept <- blockMetadata[validBlocks] + kept$blockId <- seq_along(kept) + return(kept) } blockMetadata } +#' @importFrom checkmate assertClass partitionLdMatrix <- function( ldData, mergeSmallBlocks = TRUE, minMergedBlockSize = 500, maxMergedBlockSize = 10000 ) { - if (!is(ldData, "LdData")) { - abort("ldData must be an LdData object") - } - combinedMatrix <- getCorrelation(ldData) - blockMetadata <- getBlockMetadata(ldData) - if (is(blockMetadata, "GRanges")) { - blockMetadata <- as_tibble(blockMetadata) - } + assertClass(ldData, "LdData") variantIds <- getVariantIds(ldData) - combinedMatrix <- .partitionValidateMatrix(combinedMatrix, variantIds) - blockMetadata <- .partitionFilterBlocks(blockMetadata, length(variantIds)) + combinedMatrix <- .partitionValidateMatrix( + getCorrelation(ldData), + variantIds + ) + # The slot is always a GRanges now, so no flattening: every consumer + # below reads it as one (mcols via `$`, blocks via `[` and length()). + blocks <- .partitionFilterBlocks( + getBlockMetadata(ldData), + length(variantIds) + ) # Validate the block structure of the matrix (skip if only one block). - if (nrow(blockMetadata) > 1) { - validateBlockStructure(combinedMatrix, blockMetadata, variantIds) - } - if ( - mergeSmallBlocks && - any(blockMetadata$size < minMergedBlockSize) && - nrow(blockMetadata) > 1 - ) { - blockMetadata <- mergeBlocks( - blockMetadata, - minMergedBlockSize, - maxMergedBlockSize - ) + if (length(blocks) > 1) { + validateBlockStructure(combinedMatrix, blocks, variantIds) + } + merging <- mergeSmallBlocks && + any(blocks$size < minMergedBlockSize) && + length(blocks) > 1 + blockMetadata <- if (merging) { + mergeBlocks(blocks, minMergedBlockSize, maxMergedBlockSize) + } else { + blocks } extractBlockMatrices(combinedMatrix, blockMetadata, variantIds) } +# Blocks must not overlap. The merge logic only ever considers i - 1 and +# i + 1, so a block's position in the table has to mean its position on the +# chromosome; that held by convention -- the loaders sort by position -- but +# nothing checked it, and a violation would silently merge non-neighbours. +# As a GRanges it is one call. Width-0 blocks are skipped: they mark an +# out-of-range index range that .partitionFilterBlocks() drops anyway. +# @noRd +.ldBlockOrderAssert <- function(blockMetadata) { + spanned <- blockMetadata[GenomicRanges::width(blockMetadata) > 0L] + if (length(spanned) < 2L || GenomicRanges::isDisjoint(spanned)) { + return(invisible(NULL)) + } + abort( + "LD blocks overlap: each block must cover a span of its own." + ) +} + +# Every (i, j) block pair with i < j. +# @noRd +.ldUpperPairs <- function(nBlocks) { + grid <- expand.grid(i = seq_len(nBlocks), j = seq_len(nBlocks)) + grid[grid$i < grid$j, , drop = FALSE] +} + +# @noRd +.blockPairMessagesAt <- function( + k, + pairs, + blockMetadata, + matrix, + variantIds, + n +) { + .blockPairMessages( + pairs$i[[k]], + pairs$j[[k]], + blockMetadata, + matrix, + variantIds, + n + ) +} + +# Concatenate per-item message vectors, empty-safe. +# @noRd +.ldConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + as.character(list_c(pieces)) +} + #' Validate that cross-block entries are zero (excluding boundary variants). #' @noRd validateBlockStructure <- function(matrix, blockMetadata, variantIds) { - msgs <- character(0) + .ldBlockOrderAssert(blockMetadata) n <- length(variantIds) - for (i in seq_len(nrow(blockMetadata) - 1)) { - for (j in (i + 1):nrow(blockMetadata)) { - msgs <- c( - msgs, - .blockPairMessages(i, j, blockMetadata, matrix, variantIds, n) - ) - } - } + pairs <- .ldUpperPairs(length(blockMetadata)) + msgs <- .ldConcatChr(map( + seq_len(nrow(pairs)), + .blockPairMessagesAt, + pairs = pairs, + blockMetadata = blockMetadata, + matrix = matrix, + variantIds = variantIds, + n = n + )) if (length(msgs) > 0) { msgList <- str_flatten(msgs, collapse = "\n") msg <- glue( @@ -2229,7 +2331,8 @@ validateBlockStructure <- function(matrix, blockMetadata, variantIds) { #' within `maxSize`)? Indexes the columns directly rather than slicing rows. #' @noRd canMerge <- function(blockMetadata, i, j, maxSize) { - blockMetadata$chrom[i] == blockMetadata$chrom[j] && + chrom <- as.character(GenomicRanges::seqnames(blockMetadata)) + chrom[i] == chrom[j] && (blockMetadata$size[i] + blockMetadata$size[j]) <= maxSize } @@ -2240,67 +2343,84 @@ mergeTwoBlocks <- function(blockMetadata, idx1, idx2) { idx1 <- idx2 idx2 <- tmp } - result <- blockMetadata - result$endIdx[idx1] <- blockMetadata$endIdx[idx2] - result$size[idx1] <- blockMetadata$size[idx1] + blockMetadata$size[idx2] - result <- slice(result, -idx2) - result$blockId <- seq_len(nrow(result)) - result + merged <- blockMetadata + merged$endIdx[idx1] <- blockMetadata$endIdx[idx2] + merged$size[idx1] <- blockMetadata$size[idx1] + + blockMetadata$size[idx2] + # The merged block spans both, so its RANGE has to grow with its index + # range. While this was a data.frame the two could drift apart unnoticed, + # because nothing read blockStart / blockEnd. + GenomicRanges::end(merged)[idx1] <- + GenomicRanges::end(blockMetadata)[idx2] + merged <- merged[-idx2] + merged$blockId <- seq_along(merged) + merged } #' Find blocks below minSize and identify the best neighbor to merge with. #' @noRd findMergeCandidates <- function(blockMetadata, minSize, maxSize) { - candidates <- tibble( - block_idx = integer(), - merge_with = integer() - ) - for (i in seq_len(nrow(blockMetadata))) { - if (blockMetadata$size[i] >= minSize) { - next - } - prevOk <- i > 1 && canMerge(blockMetadata, i, i - 1, maxSize) - nextOk <- i < nrow(blockMetadata) && - canMerge(blockMetadata, i, i + 1, maxSize) - mergeWith <- if (prevOk && nextOk) { - if (blockMetadata$size[i - 1] <= blockMetadata$size[i + 1]) { - i - 1 - } else { - i + 1 - } - } else if (prevOk) { + found <- compact(map( + seq_along(blockMetadata), + .ldMergeCandidateFor, + blockMetadata = blockMetadata, + minSize = minSize, + maxSize = maxSize + )) + if (length(found) == 0L) { + return(tibble(block_idx = integer(), merge_with = integer())) + } + bind_rows(found) +} + +# Which neighbour block `i` should merge into (the smaller one when both +# qualify), or NULL when it is big enough already or neither neighbour can +# take it. +# @noRd +.ldMergeCandidateFor <- function(i, blockMetadata, minSize, maxSize) { + if (blockMetadata$size[i] >= minSize) { + return(NULL) + } + prevOk <- i > 1 && canMerge(blockMetadata, i, i - 1, maxSize) + nextOk <- i < length(blockMetadata) && + canMerge(blockMetadata, i, i + 1, maxSize) + mergeWith <- if (prevOk && nextOk) { + if (blockMetadata$size[i - 1] <= blockMetadata$size[i + 1]) { i - 1 - } else if (nextOk) { - i + 1 } else { - next + i + 1 } - candidates <- bind_rows( - candidates, - tibble(block_idx = i, merge_with = mergeWith) - ) + } else if (prevOk) { + i - 1 + } else if (nextOk) { + i + 1 + } else { + return(NULL) } - candidates + tibble(block_idx = i, merge_with = mergeWith) } #' Iteratively merge blocks below minSize with their smallest neighbor. #' @noRd mergeBlocks <- function(blockMetadata, minSize, maxSize) { - if (nrow(blockMetadata) <= 1) { + if (length(blockMetadata) <= 1) { return(blockMetadata) } - repeat { - candidates <- findMergeCandidates(blockMetadata, minSize, maxSize) - if (nrow(candidates) == 0) { - break - } - blockMetadata <- mergeTwoBlocks( + candidates <- findMergeCandidates(blockMetadata, minSize, maxSize) + if (nrow(candidates) == 0) { + return(blockMetadata) + } + # Each merge changes which blocks are still too small, so this is a fixed + # point: recurse on the merged metadata rather than rebinding it. + mergeBlocks( + mergeTwoBlocks( blockMetadata, candidates$block_idx[1], candidates$merge_with[1] - ) - } - blockMetadata + ), + minSize, + maxSize + ) } # Helper function to extract block matrices @@ -2327,34 +2447,79 @@ mergeBlocks <- function(blockMetadata, minSize, maxSize) { ) } -extractBlockMatrices <- function(matrix, blockMetadata, variantIds) { - ldMatrices <- list() - variantMapping <- tibble( - variant_id = character(), - blockId = integer() - ) - for (i in seq_len(nrow(blockMetadata))) { - block <- .extractOneBlock( - matrix, - variantIds, - blockMetadata$startIdx[i], - blockMetadata$endIdx[i], - i - ) - if (is.null(block)) { - next - } - ldMatrices[[i]] <- block$matrix - variantMapping <- bind_rows(variantMapping, block$mapping) +# @noRd +.ldExtractBlockAt <- function(i, matrix, variantIds, blockMetadata) { + .extractOneBlock( + matrix, + variantIds, + blockMetadata$startIdx[i], + blockMetadata$endIdx[i], + i + ) +} + +# `x[[i]] <- v` in a loop never extends past the last assigned position, so +# trailing skipped blocks leave no entry at all. +# @noRd +.ldTrimTrailingNull <- function(xs) { + filled <- which(!map_lgl(xs, is.null)) + if (length(filled) == 0L) { + return(list()) } + xs[seq_len(max(filled))] +} + +extractBlockMatrices <- function(matrix, blockMetadata, variantIds) { + blocks <- map( + seq_along(blockMetadata), + .ldExtractBlockAt, + matrix = matrix, + variantIds = variantIds, + blockMetadata = blockMetadata + ) + kept <- compact(blocks) + mappings <- map(kept, "mapping") list( - ldMatrices = ldMatrices, - variantIndices = variantMapping, + # A skipped block leaves a hole, as `ldMatrices[[i]] <- ...` did: + # positions stay aligned with blockMetadata rows. + ldMatrices = .ldTrimTrailingNull(map(blocks, "matrix")), + variantIndices = if (length(mappings) == 0L) { + tibble(variant_id = character(), blockId = integer()) + } else { + bind_rows(mappings) + }, blockMetadata = blockMetadata ) } +# The PSD repair `method` asks for, or the matrix unchanged when it is +# already positive definite. Returns list(R, methodApplied). +# @noRd +.checkLdRepair <- function(R, eig, vals, method, isPd, shrinkage, p, rTol) { + if (isPd) { + return(list(R = R, methodApplied = "none")) + } + if (method == "shrink") { + return(list( + R = (1 - shrinkage) * R + shrinkage * diag(p), + methodApplied = "shrink" + )) + } + if (method != "eigenfix") { + return(list(R = R, methodApplied = "none")) + } + # Negative eigenvalues raised to a small POSITIVE value, not zero: rTol + # makes the result strictly positive definite, which the Cholesky-based + # methods (PRS-CS, SDPR) require; exactly zero would be PSD but not PD. + rebuilt <- eig$vectors %*% diag(pmax(vals, rTol)) %*% t(eig$vectors) + # Restore exact symmetry and unit diagonal. + list( + R = `diag<-`((rebuilt + t(rebuilt)) / 2, 1), + methodApplied = "eigenfix" + ) +} + #' Check and optionally repair LD matrix quality #' #' Diagnoses positive-definiteness of an LD correlation matrix and optionally @@ -2430,24 +2595,9 @@ checkLd <- function( isPsd <- !any(vals < -rTol) isPd <- all(vals > rTol) - methodApplied <- "none" - Rout <- R - - if (method == "shrink" && !isPd) { - Rout <- (1 - shrinkage) * R + shrinkage * diag(p) - methodApplied <- "shrink" - } else if (method == "eigenfix" && !isPd) { - # Set negative eigenvalues to a small positive value and reconstruct. - # Using rTol (not zero) ensures the result is strictly positive - # definite, which is required by methods that use Cholesky decomposition - # (PRS-CS, SDPR). Setting to exactly zero would produce PSD but not PD. - valsFixed <- pmax(vals, rTol) - Rout <- eig$vectors %*% diag(valsFixed) %*% t(eig$vectors) - # Restore exact symmetry and unit diagonal - Rout <- (Rout + t(Rout)) / 2 - diag(Rout) <- 1 - methodApplied <- "eigenfix" - } + fixed <- .checkLdRepair(R, eig, vals, method, isPd, shrinkage, p, rTol) + Rout <- fixed$R + methodApplied <- fixed$methodApplied list( R = Rout, @@ -2462,6 +2612,8 @@ checkLd <- function( # hclust (single-linkage) LD pruning: keep one representative per |cor| cluster. .ldPruneHclust <- function(X, corThres, verbose) { + # Engine-call exception: Rfast::cora is a fast drop-in for base cor(), a + # numeric primitive rather than an analysis engine. p <- ncol(X) if (requireNamespace("Rfast", quietly = TRUE)) { cor.X <- Rfast::cora(X, large = TRUE) @@ -2471,18 +2623,16 @@ checkLd <- function( Sigma.distance <- as.dist(1 - abs(cor.X)) fit <- hclust(Sigma.distance, method = "single") clusters <- cutree(fit, h = 1 - corThres) - ind.delete <- NULL - for (ig in unique(clusters)) { - temp.group <- which(clusters == ig) - if (length(temp.group) > 1) { - ind.delete <- c(ind.delete, temp.group[-1]) - } - } - ind.delete <- unique(ind.delete) + # Keep the first member of each cluster and drop the rest -- which is + # exactly the entries that repeat a cluster already seen. + ind.delete <- which(duplicated(clusters)) X.new <- X filter.id <- seq_len(p) if (length(ind.delete) > 0) { - X.new <- as.matrix(X[, -ind.delete]) + # drop = FALSE keeps the column names when a single column survives; + # without it the result degrades to a vector and the names have to be + # recomputed by index arithmetic afterwards. + X.new <- as.matrix(X[, -ind.delete, drop = FALSE]) filter.id <- filter.id[-ind.delete] if (verbose) { nDel <- length(ind.delete) @@ -2498,12 +2648,50 @@ checkLd <- function( ) inform(msg) } - if (ncol(X.new) == 1) { - colnames(X.new) <- colnames(X)[-ind.delete] - } list(X.new = X.new, filter.id = filter.id) } +#' @title Options for the SNPRelate LD-Pruning Backend +#' @description Build a checked record of extra arguments for +#' \code{SNPRelate::snpgdsLDpruning()}, the engine behind +#' \code{ldPruneByCorrelation(backend = "snprelate")}. +#' @param ... Arguments for \code{SNPRelate::snpgdsLDpruning()} -- in +#' practice the window controls \code{slide.max.bp} and +#' \code{slide.max.n} (pruning is greedy within a window, so the window +#' bounds which pairs are ever compared), \code{maf}, +#' \code{missing.rate}, \code{remove.monosnp} and \code{num.thread}. +#' \code{gdsobj}, \code{method}, \code{ld.threshold} and \code{verbose} +#' are supplied by pecotmr and refused. The temporary GDS pecotmr writes +#' holds every sample and variant of \code{X} on one synthetic chromosome, +#' so \code{sample.id}, \code{snp.id} and \code{autosome.only} are not +#' meaningful selectors here. +#' @return A \code{MethodOptions} record for +#' \code{ldPruneByCorrelation(methodArgs =)}. +#' @seealso \code{\link{ldPruneByCorrelation}} +#' @examples +#' LdPruningOptions(slide.max.bp = 1e6) +#' @export +LdPruningOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + gdsobj = "the temporary GDS pecotmr writes from `X`", + method = "fixed at 'corr' by this backend", + ld.threshold = "the caller's `corThres`", + verbose = "the caller's `verbose`" + ), + "LdPruningOptions" + ) + .newMethodOptions( + "SNPRelate::snpgdsLDpruning", + defaults = list(), + extra = extra, + label = "LdPruningOptions", + engine = "ldPruning" + ) +} + #' Prune columns by pairwise correlation (LD-style prune) #' #' Performs LD pruning using one of two backends. The default \code{"hclust"} @@ -2528,6 +2716,12 @@ checkLd <- function( #' \code{SNPRelate::snpgdsLDpruning(method = "corr")}.} #' } #' @param verbose Logical. If TRUE, print progress messages. Default FALSE. +#' @param methodArgs Extra arguments for +#' \code{SNPRelate::snpgdsLDpruning()}, built with +#' \code{\link{LdPruningOptions}} -- the window controls in particular. +#' Only the \code{"snprelate"} backend has an engine to configure, so +#' supplying options alongside \code{backend = "hclust"} is an error +#' rather than a silent no-op. #' #' @return A list with: #' \describe{ @@ -2549,11 +2743,26 @@ ldPruneByCorrelation <- function( X, corThres = 0.8, backend = c("hclust", "snprelate"), - verbose = FALSE + verbose = FALSE, + methodArgs = LdPruningOptions() ) { backend <- arg_match(backend) + .assertMethodOptions(methodArgs, "LdPruningOptions", "methodArgs") if (backend == "snprelate") { - return(.ldPruneSnprelate(X, corThres = corThres, verbose = verbose)) + return(.ldPruneSnprelate( + X, + corThres = corThres, + verbose = verbose, + methodArgs = methodArgs + )) + } + if (length(methodArgs) > 0L) { + msg <- glue( + "ldPruneByCorrelation: `methodArgs` configures ", + "SNPRelate::snpgdsLDpruning(), which backend 'hclust' does not ", + "call. Pass backend = 'snprelate', or drop `methodArgs`." + ) + abort(msg) } .ldPruneHclust(X, corThres, verbose) } @@ -2575,8 +2784,7 @@ ldPruneByCorrelation <- function( # Write X (rounded to integer genotype codes) to a temporary GDS for SNPRelate. .ldPruneSnprelateCreateGds <- function(tmpGds, X, snpNames, p) { - genoInt <- round(X) - storage.mode(genoInt) <- "integer" + genoInt <- `storage.mode<-`(round(X), "integer") SNPRelate::snpgdsCreateGeno( gds.fn = tmpGds, genmat = t(genoInt), @@ -2589,7 +2797,7 @@ ldPruneByCorrelation <- function( ) } -.ldPruneSnprelate <- function(X, corThres, verbose) { +.ldPruneSnprelate <- function(X, corThres, verbose, methodArgs) { .ldPruneSnprelateDeps() p <- ncol(X) snpNames <- colnames(X) %||% str_c("snp", seq_len(p)) @@ -2598,13 +2806,15 @@ ldPruneByCorrelation <- function( .ldPruneSnprelateCreateGds(tmpGds, X, snpNames, p) gds <- SNPRelate::snpgdsOpen(tmpGds, allow.duplicate = TRUE) on.exit(SNPRelate::snpgdsClose(gds), add = TRUE) - keepList <- SNPRelate::snpgdsLDpruning( + keepList <- exec( + SNPRelate::snpgdsLDpruning, gds, method = "corr", ld.threshold = corThres, - verbose = verbose + verbose = verbose, + !!!as.list(methodArgs) ) - keepIds <- sort(unlist(keepList, use.names = FALSE)) + keepIds <- sort(unname(list_c(keepList))) X.new <- X[, keepIds, drop = FALSE] if (verbose) { nKept <- length(keepIds) @@ -2655,29 +2865,29 @@ ldPruneByCorrelation <- function( #' @noRd # Correlation strategy: drop the most-connected column (random tie-break at 2). .dropCollinearPickCor <- function(X, problematicCols, verbose, seed = NULL) { - corMatrix <- abs(cor(X[, problematicCols, drop = FALSE])) - diag(corMatrix) <- 0 + corMatrix <- `diag<-`( + abs(cor(X[, problematicCols, drop = FALSE])), + 0 + ) if (length(problematicCols) == 2) { if (!is.null(seed)) { withr::local_seed(seed) } colToRemove <- sample(problematicCols, 1) if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: two candidates, randomly removing ", "{colToRemove}" - ) - inform(msg) + )) } return(colToRemove) } colToRemove <- problematicCols[which.max(colSums(corMatrix))] if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: highest sum |cor| -> removing ", "{colToRemove}" - ) - inform(msg) + )) } colToRemove } @@ -2695,11 +2905,10 @@ ldPruneByCorrelation <- function( variances <- apply(X[, problematicCols, drop = FALSE], 2, var) colToRemove <- problematicCols[which.min(variances)] if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: smallest variance -> removing ", "{colToRemove}" - ) - inform(msg) + )) } return(colToRemove) } @@ -2707,11 +2916,10 @@ ldPruneByCorrelation <- function( return(.dropCollinearPickCor(X, problematicCols, verbose, seed = seed)) } if (is.null(response)) { - msg <- glue( + abort(glue( "response must be supplied for strategy = ", "'responseCorrelation'" - ) - abort(msg) + )) } corWithResponse <- apply( X[, problematicCols, drop = FALSE], @@ -2721,11 +2929,10 @@ ldPruneByCorrelation <- function( ) colToRemove <- problematicCols[which.min(abs(corWithResponse))] if (verbose) { - msg <- glue( + inform(glue( "dropCollinearColumns: smallest |cor| with response -> ", "removing {colToRemove}" - ) - inform(msg) + )) } colToRemove } @@ -2767,8 +2974,14 @@ dropCollinearColumns <- function( # @noRd .ldBuildDesign <- function(X, C) { XD <- cbind(1, X, C) - colnames(XD)[seq_len(ncol(X) + 1L)] <- c("Intercept", colnames(X)) - XD + `colnames<-`( + XD, + replace( + colnames(XD), + seq_len(ncol(X) + 1L), + c("Intercept", colnames(X)) + ) + ) } # --- enforceDesignFullRank helpers ------------------------------------------ @@ -2799,20 +3012,18 @@ dropCollinearColumns <- function( if (qr(tempDesign)$rank == ncol(tempDesign)) { if (verbose) { nCol <- length(problematicColnames) - msg <- glue( + inform(glue( "enforceDesignFullRank: full rank after batch-removing ", "{nCol} column(s)" - ) - inform(msg) + )) } return(FALSE) } if (verbose) { - msg <- glue( + inform(glue( "enforceDesignFullRank: batch removal insufficient, ", "skipping to correlation-pruning fallback" - ) - inform(msg) + )) } TRUE } @@ -2827,6 +3038,9 @@ dropCollinearColumns <- function( verbose, seed = NULL ) { + # Deliberate iteration: each round drops collinear columns and re-tests + # the rank, and `X` is a samples x variants genotype matrix -- recursing + # would hold every intermediate copy alive on the stack. iteration <- 0L Xdesign <- .ldBuildDesign(X, C) matrixRank <- qr(Xdesign)$rank @@ -2848,19 +3062,17 @@ dropCollinearColumns <- function( iteration <- iteration + 1L if (verbose) { nCol <- ncol(Xdesign) - msg <- glue( + inform(glue( "enforceDesignFullRank: iter {iteration} rank ", "{matrixRank} / {nCol}" - ) - inform(msg) + )) } } if (iteration == maxIterations) { - msg <- glue( + warn(glue( "enforceDesignFullRank: maxIterations reached; design may ", "still be rank-deficient" - ) - warn(msg) + )) } X } @@ -2964,8 +3176,10 @@ enforceDesignFullRank <- function( inform(msg) } skipIterative <- .edfrCheckBatch(X, C, Xdesign, matrixRank, verbose) - if (!skipIterative) { - X <- .edfrIterate( + iterated <- if (skipIterative) { + X + } else { + .edfrIterate( X, C, strategy, @@ -2975,46 +3189,39 @@ enforceDesignFullRank <- function( seed = seed ) } - X <- .edfrCorrelationFallback(X, C, corrThresholds, verbose) - if (ncol(X) == 1L && initialNcol == 1L) { - colnames(X) <- originalColnames + reduced <- .edfrCorrelationFallback(iterated, C, corrThresholds, verbose) + if (ncol(reduced) == 1L && initialNcol == 1L) { + return(`colnames<-`(reduced, originalColnames)) } - X + reduced } # Require the bigsnpr/bigstatsr packages used for score-based LD clumping. .ldClumpCheckDeps <- function() { if (!requireNamespace("bigsnpr", quietly = TRUE)) { - msg <- glue( - "Package 'bigsnpr' is required. Install from CRAN: ", - "install.packages('bigsnpr')" - ) - abort(msg) + abort("Package 'bigsnpr' is required.") } if (!requireNamespace("bigstatsr", quietly = TRUE)) { - msg <- glue( - "Package 'bigstatsr' is required. Install from CRAN: ", - "install.packages('bigstatsr')" - ) - abort(msg) + abort("Package 'bigstatsr' is required.") } } # Validate the clumping inputs (dimensions of score/chr/pos vs X). +#' @importFrom checkmate assertVector .ldClumpValidate <- function(X, score, chr, pos) { + # NOT assertMatrix: X may be a bigstatsr FBM, which is not a base matrix. if (ncol(X) < 1L) { abort("ldClumpByScore: X must have at least one column") } - if (!is.null(score) && length(score) != ncol(X)) { - abort("ldClumpByScore: length(score) must equal ncol(X)") - } - if (length(chr) != ncol(X) || length(pos) != ncol(X)) { - abort("ldClumpByScore: chr and pos must have length equal to ncol(X)") - } + assertVector(score, len = ncol(X), null.ok = TRUE) + assertVector(chr, len = ncol(X)) + assertVector(pos, len = ncol(X)) } # Wrap X as a bigstatsr FBM (pass through if already one). .ldClumpFbm <- function(X) { + # Engine-call exception: bigstatsr::FBM.code256 builds a file-backed + # matrix -- a data structure the clumping step needs, not an engine. if (inherits(X, "FBM")) { return(X) } @@ -3074,6 +3281,10 @@ ldClumpByScore <- function( windowKb = 100 / r2, verbose = FALSE ) { + # Engine-call exception: bigsnpr::snp_clumping is an LD algorithm, and + # ld.R is the LD module that owns it -- neither a pipeline nor a wrapper, + # and the call's only consumer. A one-function ldWrapper.R would separate + # the call from the module whose job it is. .ldClumpCheckDeps() .ldClumpValidate(X, score, chr, pos) if (ncol(X) == 1L) { @@ -3118,11 +3329,10 @@ ldClumpByScore <- function( #' @param wantGenotype Logical; if TRUE, extract the genotype matrix (via #' \code{getGenotypes()}). #' @return A matrix. +#' @importFrom checkmate assertClass #' @noRd extractLdMatrix <- function(ld, wantGenotype = FALSE) { - if (!is(ld, "LdData")) { - abort("ld must be an LdData object") - } + assertClass(ld, "LdData") if (wantGenotype && hasGenotypes(ld)) { return(getGenotypes(ld)) } @@ -3229,13 +3439,25 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { } # The handle stays here on purpose: the GDS on-disk LD routine reads the # file directly, which is a seed-level operation with no assay equivalent. - R <- .computeBlockLdGds(.ldSketchHandle(X), idx) - diag(R) <- 1.0 - R[is.na(R) | is.nan(R)] <- 0 - if (shrinkage > 0 && shrinkage <= 1) { - R <- (1 - shrinkage) * R + shrinkage * diag(nrow(R)) + R <- .ldCleanCorrelation(.computeBlockLdGds(.ldSketchHandle(X), idx)) + .ldShrinkToIdentity(R, shrinkage) +} + +# A raw estimator output made a usable correlation matrix: unit diagonal and +# no NA / NaN cells. +# @noRd +.ldCleanCorrelation <- function(R) { + unitDiag <- `diag<-`(R, 1.0) + replace(unitDiag, is.na(unitDiag) | is.nan(unitDiag), 0) +} + +# Optional shrinkage toward the identity (lassosum, Mak et al 2017). +# @noRd +.ldShrinkToIdentity <- function(R, shrinkage) { + if (shrinkage <= 0 || shrinkage > 1) { + return(R) } - R + (1 - shrinkage) * R + shrinkage * diag(nrow(R)) } # --- computeLd method helpers ----------------------------------------------- @@ -3252,6 +3474,8 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { # Sample correlation (N-1 denominator) via the requested backend. .computeLdSample <- function(X, backend) { + # Engine-call exception: Rfast::cora stands in for base cor() (see the + # backend note below) -- a numeric primitive, not an analysis engine. if (backend == "snprelate") { return(.computeLdSnprelate(X)) } @@ -3260,12 +3484,7 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { } # internal backend: Rfast::cora if available, else base cor(). Mean-impute # only when NAs exist (PLINK2 data typically has none). - X_imp <- X - if (anyNA(X_imp)) { - colMeansX <- colMeans(X_imp, na.rm = TRUE) - naPos <- which(is.na(X_imp), arr.ind = TRUE) - X_imp[naPos] <- colMeansX[naPos[, 2]] - } + X_imp <- if (anyNA(X)) .ldMeanImputeColumns(X) else X if (requireNamespace("Rfast", quietly = TRUE)) { # large=FALSE uses tcrossprod internally, ~40x faster than large=TRUE. Rfast::cora(X_imp, large = FALSE) @@ -3274,6 +3493,14 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { } } +# Every missing cell replaced by its column mean. +# @noRd +.ldMeanImputeColumns <- function(X) { + colMeansX <- colMeans(X, na.rm = TRUE) + naPos <- which(is.na(X), arr.ind = TRUE) + replace(X, naPos, colMeansX[naPos[, 2]]) +} + # Population variance (N denominator, GCTA-style; missing set to column mean 0). .computeLdPopulation <- function(X, trimSamples) { if (trimSamples) { @@ -3299,8 +3526,9 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { warn(msg) } } - X_c <- sweep(X, 2, colMeansX) - X_c[is.na(X_c)] <- 0 + # Centering keeps the NA pattern (colMeansX is finite wherever a column + # has data), so a missing cell contributes nothing to the crossprod. + X_c <- replace(sweep(X, 2, colMeansX), is.na(X), 0) covMat <- crossprod(X_c) / N sdVec <- sqrt(colVarsX) covMat / outer(sdVec, sdVec) @@ -3310,8 +3538,7 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { # tracks per-pair non-missing counts and applies a correction term. .gctaCovariance <- function(X, colMeansX, N, p) { notNa <- !is.na(X) - X_zero <- X - X_zero[is.na(X_zero)] <- 0 + X_zero <- replace(X, !notNa, 0) pairCounts <- crossprod(notNa * 1.0) # E_i2[i,j] = pairSums[i,j] / N: mean of SNP i over samples where j is # observed; p x p, row i col j = sum of X_i where j non-missing, / N. @@ -3339,10 +3566,10 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { covMat <- .gctaCovariance(X, colMeansX, N, p) sdVec <- sqrt(colVarsX) sdOuter <- outer(sdVec, sdVec) - R <- matrix(0.001, p, p) + # A zero-variance pair has no defined correlation; it keeps the 0.001 + # floor GCTA writes there. valid <- sdOuter > 0 - R[valid] <- covMat[valid] / sdOuter[valid] - R + replace(matrix(0.001, p, p), valid, covMat[valid] / sdOuter[valid]) } #' @title Compute an LD Correlation Matrix @@ -3433,23 +3660,17 @@ computeLd <- function( # @noRd .computeLdMatrix <- function(X, method, backend, trimSamples, shrinkage) { nms <- colnames(X) - if (method == "sample") { - R <- .computeLdSample(X, backend) + raw <- if (method == "sample") { + .computeLdSample(X, backend) } else if (method == "population") { .computeLdRequireInternal(backend) - R <- .computeLdPopulation(X, trimSamples) + .computeLdPopulation(X, trimSamples) } else { .computeLdRequireInternal(backend) - R <- .computeLdGcta(X, trimSamples) - } - diag(R) <- 1.0 - R[is.na(R) | is.nan(R)] <- 0 - # Optional shrinkage toward identity (lassosum, Mak et al 2017). - if (shrinkage > 0 && shrinkage <= 1) { - R <- (1 - shrinkage) * R + shrinkage * diag(nrow(R)) + .computeLdGcta(X, trimSamples) } - colnames(R) <- rownames(R) <- nms - R + R <- .ldShrinkToIdentity(.ldCleanCorrelation(raw), shrinkage) + `dimnames<-`(R, list(nms, nms)) } #' Compute LD via SNPRelate (creates a temporary GDS file from the dosage @@ -3469,9 +3690,8 @@ computeLd <- function( on.exit(unlink(tmpGds), add = TRUE) # Round to integer dosage for GDS (0/1/2) - X_int <- round(X) - storage.mode(X_int) <- "integer" - X_int[is.na(X_int)] <- 3L # GDS missing code + # 3L is the GDS missing code. + X_int <- replace(`storage.mode<-`(round(X), "integer"), is.na(X), 3L) snpIds <- colnames(X) %||% seq_len(ncol(X)) sampleIds <- rownames(X) %||% seq_len(nrow(X)) @@ -3509,17 +3729,13 @@ computeLd <- function( # snpStats expects counts of the B allele as raw codes: 1=AA, 2=AB, 3=BB, # 0=NA pecotmr dosage is ALT count (0/1/2), so map: 0->1, 1->2, 2->3, NA->0 - X_raw <- round(X) + 1L - X_raw[is.na(X) | X_raw < 1L] <- 0L - X_raw[X_raw > 3L] <- 3L - storage.mode(X_raw) <- "raw" - sm <- new("SnpMatrix", X_raw) + shifted <- round(X) + 1L + coded <- pmin(replace(shifted, is.na(X) | shifted < 1L, 0L), 3L) + sm <- new("SnpMatrix", `storage.mode<-`(coded, "raw")) - R <- as.matrix(snpStats::ld(sm, stats = "R", depth = ncol(X) - 1L)) + raw <- as.matrix(snpStats::ld(sm, stats = "R", depth = ncol(X) - 1L)) # snpStats::ld returns a sparse-like matrix; ensure full dense - R[is.na(R)] <- 0 - diag(R) <- 1 - R + .ldCleanCorrelation(raw) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- @@ -3564,3 +3780,48 @@ computeLd <- function( e >= s && e <= nVariants } + +#' @rdname PanelFilterParam +#' @aliases PanelFilterParam-class +#' @exportClass PanelFilterParam +setClass( + "PanelFilterParam", + contains = "MethodParam", + slots = c( + mafCutoff = "numeric", + macCutoff = "numeric", + imissCutoff = "numeric" + ) +) + +#' @title LD Reference Panel Filtering Options +#' @description Which of an LD panel's variants are kept before the panel is +#' used, as one checked bundle. Narrower than +#' \code{\link{GenotypeFilterParam}}: a panel is not a study's genotypes, so +#' there is no sample restriction and no variance cutoff, and the +#' missingness default is \code{1} (no filter) rather than \code{0}. +#' @param mafCutoff Minor-allele-frequency floor. Default \code{0}. +#' @param macCutoff Minor-allele-count floor; the stricter of this and +#' \code{mafCutoff} applies, using the panel's own sample count. Default +#' \code{0}. +#' @param imissCutoff Per-variant missingness ceiling. Default \code{1}, which +#' filters nothing and lets the allele-frequency sidecar be read instead of +#' materializing dosage. +#' @return A \code{PanelFilterParam} object, a \code{\link{MethodParam}}. +#' @seealso \code{\link{GenotypeFilterParam}}, +#' \code{\link{SumstatsFilterParam}} +#' @examples +#' PanelFilterParam(mafCutoff = 0.001) +#' @export +PanelFilterParam <- function( + mafCutoff = 0, + macCutoff = 0, + imissCutoff = 1 +) { + new( + "PanelFilterParam", + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff + ) +} diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index 5f9330f77..f7b9656d3 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -30,17 +30,14 @@ NULL # Read a manifest into a tibble. A data.frame/tibble is passed through; a # single path is read by extension (.csv -> read_csv, else read_tsv). +#' @importFrom checkmate assertString +#' @importFrom checkmate assertFileExists .readManifest <- function(manifest) { if (is.data.frame(manifest)) { return(as_tibble(manifest, .name_repair = "minimal")) } - if (!is.character(manifest) || length(manifest) != 1L) { - abort("`manifest` must be a data.frame or a single file path.") - } - if (!file.exists(manifest)) { - msg <- glue("manifest file not found: {manifest}") - abort(msg) - } + assertString(manifest, .var.name = "manifest (data.frame or file path)") + assertFileExists(manifest, access = "r", .var.name = "manifest file") if (str_detect(manifest, regex("\\.csv$", ignore_case = TRUE))) { readr::read_csv(manifest, show_col_types = FALSE, progress = FALSE) } else { @@ -77,24 +74,84 @@ NULL # `required` canonical columns are present. `aliases` is a named list keyed by # canonical name; each value is the character vector of accepted source names # (including the canonical name itself). The first alias present wins. -.canonManifestCols <- function(df, aliases, required, label) { - for (canon in names(aliases)) { - if (is_in(canon, names(df))) { - next - } - hit <- intersect(aliases[[canon]], names(df)) - if (length(hit) >= 1L) { - names(df)[match(hit[[1L]], names(df))] <- canon - } +# The QtlDataset pass-through arguments, asserted at the loader so a bad value +# is reported against the argument the caller passed rather than surfacing from +# QtlDataset's validity several hundred lines later. Types match +# .qtlValidateScalars exactly, so this tightens nothing. +# @noRd +#' @importFrom checkmate assertLogical assertNumber assertFlag assertCharacter +.assertQtlPassThrough <- function(scaleResiduals, genotypeFilterArgs) { + assertLogical(scaleResiduals, len = 1L) + .assertMethodParam( + genotypeFilterArgs, + "GenotypeFilterParam", + "genotypeFilter" + ) + # Only what the caller actually set: an unset field defers to QtlDataset's + # own default and has nothing to check here. + walk( + c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff"), + .assertQtlFilterNumber, + genotypeFilterArgs = genotypeFilterArgs + ) + walk( + c("keepSamples", "keepVariants"), + .assertQtlFilterCharacter, + genotypeFilterArgs = genotypeFilterArgs + ) + if (!is.null(genotypeFilterArgs$keepIndel)) { + assertFlag(genotypeFilterArgs$keepIndel) } - missingCols <- setdiff(required, names(df)) - if (length(missingCols) > 0L) { - msg <- glue( - "{label} manifest is missing required column(s): ", - "{str_flatten(missingCols, ', ')}" - ) - abort(msg) + invisible(NULL) +} + +# @noRd +.assertQtlFilterNumber <- function(field, genotypeFilterArgs) { + v <- genotypeFilterArgs[[field]] + if (!is.null(v)) { + assertNumber(v, lower = 0, finite = TRUE, .var.name = field) + } + invisible(NULL) +} + +# @noRd +.assertQtlFilterCharacter <- function(field, genotypeFilterArgs) { + v <- genotypeFilterArgs[[field]] + if (!is.null(v)) { + assertCharacter(v, .var.name = field) + } + invisible(NULL) +} + +#' @importFrom checkmate assertNames +# The existing column an alias set points at, or NULL when the canonical name +# is already present or nothing matches. +# @noRd +.manifestAliasHit <- function(canon, aliases, df) { + if (is_in(canon, names(df))) { + return(NULL) } + hit <- intersect(aliases[[canon]], names(df)) + if (length(hit) == 0L) { + return(NULL) + } + hit[[1L]] +} + +.canonManifestCols <- function(df, aliases, required, label) { + # Each alias resolves against the ORIGINAL names, so renaming one cannot + # change what another matches. + renames <- compact(set_names( + map(names(aliases), .manifestAliasHit, aliases = aliases, df = df), + names(aliases) + )) + df <- rename(df, !!!renames) + assertNames( + names(df), + must.include = required, + what = "colnames", + .var.name = str_c(label, " manifest") + ) df } @@ -102,8 +159,9 @@ NULL # both as a constant manifest column and as a function argument. The column (if # present) must be constant; a supplied argument must agree with it. .reconcileScalar <- function(colValues, arg, name, required = TRUE) { - colVal <- NULL - if (!is.null(colValues)) { + colVal <- if (is.null(colValues)) { + NULL + } else { v <- unique(as.character(colValues[ !is.na(colValues) & str_length(as.character(colValues)) > 0L @@ -115,7 +173,7 @@ NULL ) abort(msg) } - if (length(v) == 1L) colVal <- v + if (length(v) == 1L) v else NULL } if (!is.null(arg) && !is.null(colVal)) { if (!identical(as.character(arg), colVal)) { @@ -238,12 +296,13 @@ NULL if (!is.null(open)) { return(open) } - colSpec <- NULL # is_in guard, not `!is.null(df$ldSketchPath)`: on a tibble `$` for an # absent column NULLs but WARNS ("Unknown or uninitialised column"), where a # data.frame was silent. ldSketchPath is optional (LD may come via # `ldSketch`). - if (is_in("ldSketchPath", names(df))) { + colSpec <- if (!is_in("ldSketchPath", names(df))) { + NULL + } else { v <- unique(as.character(df$ldSketchPath[ !is.na(df$ldSketchPath) & str_length(as.character(df$ldSketchPath)) > 0L @@ -251,13 +310,13 @@ NULL if (length(v) > 1L) { abort("`ldSketchPath` column must be constant across the manifest.") } - if (length(v) == 1L) colSpec <- .resolveRel(v, base) + if (length(v) == 1L) .resolveRel(v, base) else NULL } - spec <- ldSketch + spec <- ldSketch %||% colSpec if ( - !is.null(spec) && + !is.null(ldSketch) && !is.null(colSpec) && - !identical(as.character(spec), as.character(colSpec)) + !identical(as.character(ldSketch), as.character(colSpec)) ) { msg <- glue( "`ldSketch` argument disagrees with the manifest ", @@ -265,7 +324,6 @@ NULL ) abort(msg) } - spec <- spec %||% colSpec if (is.null(spec)) { msg <- glue( "`ldSketch` must be provided as an argument or an ", @@ -295,10 +353,9 @@ NULL # empty entries contribute nothing; NA seqnames are dropped. Always returns a # character vector (character(0) when nothing is present, never NULL). .entriesChroms <- function(entries) { - ch <- as.character(unlist( - map(entries, .mlEntryChroms), - use.names = FALSE - )) + # as.character() is load-bearing: an all-empty list concatenates to NULL, + # and this helper promises character(0). + ch <- as.character(unname(list_c(map(entries, .mlEntryChroms)))) unique(ch[!is.na(ch)]) } @@ -487,7 +544,7 @@ NULL if (is.null(gr)) { return(emptyDf) } - lines <- unlist(Rsamtools::scanTabix(tf, param = gr), use.names = FALSE) + lines <- unname(list_c(Rsamtools::scanTabix(tf, param = gr))) if (length(lines) == 0L) { return(emptyDf) } @@ -562,6 +619,7 @@ NULL # standard key (chrom/pos/variant_id/...) to the source column name. Accepts a # named list/vector, or a path to a YAML file of `standardName: sourceName` # entries (the xqtl-protocol column-mapping format). +#' @importFrom checkmate assertFileExists .readColumnMapping <- function(columnMapping) { if (is.null(columnMapping)) { return(NULL) @@ -574,10 +632,11 @@ NULL return(map_chr(columnMapping, as.character)) } if (is.character(columnMapping) && length(columnMapping) == 1L) { - if (!file.exists(columnMapping)) { - msg <- glue("columnMapping file not found: {columnMapping}") - abort(msg) - } + assertFileExists( + columnMapping, + access = "r", + .var.name = "columnMapping file" + ) mapping <- yaml::read_yaml(columnMapping) if ( !is.list(mapping) || @@ -649,14 +708,19 @@ NULL .resolveSumstatCols <- function(df, columnMapping, label, allowNoN = FALSE) { # Strip a leading '#' from the first column name so a '#CHR'-style header # (common in GWAS TSVs) resolves the same on plain-text and tabix reads. - if (ncol(df) > 0L) { - names(df)[1L] <- str_remove(names(df)[1L], "^#") + unhashed <- if (ncol(df) == 0L) { + df + } else { + `names<-`( + df, + replace(names(df), 1L, str_remove(names(df)[1L], "^#")) + ) } mapping <- .readColumnMapping(columnMapping) - resolved <- .resolveSumstatRequired(df, mapping, label) - z <- .resolveSumstatZ(df, mapping, label) - n <- .resolveSumstatN(df, mapping, label, allowNoN) - .buildSumstatOut(df, resolved, z, n, mapping, label) + resolved <- .resolveSumstatRequired(unhashed, mapping, label) + z <- .resolveSumstatZ(unhashed, mapping, label) + n <- .resolveSumstatN(unhashed, mapping, label, allowNoN) + .buildSumstatOut(unhashed, resolved, z, n, mapping, label) } # Resolve + validate the always-required columns (chrom/pos/variant_id/A1/A2). @@ -735,42 +799,97 @@ NULL # Assemble the standardized sumstat data.frame (chrom/pos/SNP/A1/A2/Z, optional # N / N_CASE / N_CONTROL, and any present BETA/SE/P/MAF/INFO). # @noRd -.buildSumstatOut <- function(df, resolved, z, n, mapping, label) { - out <- tibble( +# The source columns named by explicit mappings, so an auto-detected key never +# re-reads a column another key already claimed. +# @noRd +.sumstatClaimedCols <- function(mapping) { + if (is.null(mapping)) { + return(character()) + } + unname(as.character(mapping)) +} + +# The identity columns every summary-statistic table carries. +# @noRd +.sumstatIdentityCols <- function(df, resolved) { + tibble( chrom = as.character(df[[resolved$chrom]]), pos = as.integer(df[[resolved$pos]]), SNP = as.character(df[[resolved$variant_id]]), A1 = as.character(df[[resolved$A1]]), A2 = as.character(df[[resolved$A2]]) ) - out$Z <- if (z$hasZ) { - as.numeric(df[[z$zSrc]]) - } else { - as.numeric(df[[z$betaSrc]]) / as.numeric(df[[z$seSrc]]) - } - if (n$hasN) { - out$N <- as.numeric(df[[n$nSrc]]) - } - if (n$hasCounts) { - out$N_CASE <- as.numeric(df[[n$ncaseSrc]]) - out$N_CONTROL <- as.numeric(df[[n$ncontrolSrc]]) - } - # `claimed` = the source columns named by explicit mappings, so an - # auto-detected key never re-reads a column another key already claimed. - claimed <- if (is.null(mapping)) { - character() - } else { - unname(as.character(mapping)) - } - afSrc <- .resolveSumstatKey("AF", df, mapping, label, claimed) - for (key in c("BETA", "SE", "P", "AF", "MAF", "INFO")) { - src <- .resolveSumstatKey(key, df, mapping, label, claimed) - if (!is.na(src) && !is.null(src)) { - out[[key]] <- as.numeric(df[[src]]) +} + +# N, or the case / control pair, whichever the manifest supplied. +# @noRd +.sumstatSampleSizeCols <- function(df, n) { + c( + if (n$hasN) list(N = as.numeric(df[[n$nSrc]])) else list(), + if (n$hasCounts) { + list( + N_CASE = as.numeric(df[[n$ncaseSrc]]), + N_CONTROL = as.numeric(df[[n$ncontrolSrc]]) + ) + } else { + list() } - } - .warnAfProvenance(out, afSrc, label) - out + ) +} + +# The optional statistic columns that `df` actually carries, keyed by the +# canonical name each will be written under. +# @noRd +.sumstatOptionalSources <- function(df, mapping, label, claimed) { + optionalKeys <- c("BETA", "SE", "P", "AF", "MAF", "INFO") + sources <- set_names( + map( + optionalKeys, + .resolveSumstatKeyFor, + df = df, + mapping = mapping, + label = label, + claimed = claimed + ), + optionalKeys + ) + keep(sources, .sumstatSourceFound) +} + +.buildSumstatOut <- function(df, resolved, z, n, mapping, label) { + claimed <- .sumstatClaimedCols(mapping) + present <- .sumstatOptionalSources(df, mapping, label, claimed) + result <- mutate( + .sumstatIdentityCols(df, resolved), + Z = if (z$hasZ) { + as.numeric(df[[z$zSrc]]) + } else { + as.numeric(df[[z$betaSrc]]) / as.numeric(df[[z$seSrc]]) + }, + !!!.sumstatSampleSizeCols(df, n), + !!!map(present, .sumstatNumericColumn, df = df) + ) + .warnAfProvenance( + result, + .resolveSumstatKey("AF", df, mapping, label, claimed), + label + ) + result +} + +# @noRd +.resolveSumstatKeyFor <- function(key, df, mapping, label, claimed) { + .resolveSumstatKey(key, df, mapping, label, claimed) +} + +# @noRd +.sumstatSourceFound <- function(src) { + !is.null(src) && !is.na(src) +} + +# @noRd +.sumstatNumericColumn <- function(src, df) { + as.numeric(df[[src]]) } # An exported af of NA must never be silent, and the two ways to get one are @@ -845,9 +964,11 @@ NULL # effect allele (A1) is ALT; the other allele (A2) is REF. Stats come from the # per-study FORMAT fields ES/SE/LP/SS/EAF, with Z = ES / SE. .vcfToSumstatDf <- function(vcf, sampleSelect, formatMapping, label) { - fmap <- modifyList( + fmap <- list_modify( .gwasVcfFormatDefaults, - if (is.null(formatMapping)) list() else as.list(formatMapping) + !!!compact( + if (is.null(formatMapping)) list() else as.list(formatMapping) + ) ) rr <- SummarizedExperiment::rowRanges(vcf) altList <- VariantAnnotation::alt(vcf) @@ -884,13 +1005,13 @@ NULL BETA = es, SE = se ) - if (!is.null(lp)) { - out$P <- 10^(-lp) - } - if (!is.null(eaf)) { - out$MAF <- pmin(eaf, 1 - eaf) - } - out + mutate( + out, + !!!compact(list( + P = if (!is.null(lp)) 10^(-lp), + MAF = if (!is.null(eaf)) pmin(eaf, 1 - eaf) + )) + ) } # Read one GWAS-VCF sumstats file (region-restricted only when bgzipped + @@ -898,8 +1019,8 @@ NULL .readSumStatsVcf <- function(path, region, sampleSelect, formatMapping, label) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { msg <- glue( - "{label}: reading VCF sumstats requires the 'VariantAnnotation' ", - "package; please install it." + "{label}: reading VCF sumstats requires the ", + "'VariantAnnotation' package." ) abort(msg) } @@ -1003,13 +1124,9 @@ NULL # parseVariantId() reads an id as chr:pos:A2:A1 (pecotmr's canonical # order), so "A2A1" is a straight take and "A1A2" is the swap. if (identical(order, "A2A1")) { - df$A1 <- parsed$A1 - df$A2 <- parsed$A2 - } else { - df$A1 <- parsed$A2 - df$A2 <- parsed$A1 + return(mutate(df, A1 = parsed$A1, A2 = parsed$A2)) } - df + mutate(df, A1 = parsed$A2, A2 = parsed$A1) } # @noRd @@ -1061,13 +1178,13 @@ NULL col_types = readr::cols(.default = readr::col_character()) ) } - raw <- .applySumstatPrefilters( + filtered <- .applySumstatPrefilters( raw, prefilters, .readColumnMapping(columnMapping), label ) - .resolveSumstatCols(raw, columnMapping, label, allowNoN = allowNoN) + .resolveSumstatCols(filtered, columnMapping, label, allowNoN = allowNoN) } # Dispatch a sumstats file to the text or GWAS-VCF reader. BCF is rejected. @@ -1141,12 +1258,12 @@ NULL readr::read_tsv(path, show_col_types = FALSE, progress = FALSE), check.names = FALSE ) - rn <- as.character(raw[[1L]]) - m <- as.matrix(raw[, -1L, drop = FALSE]) - rownames(m) <- rn - storage.mode(m) <- "double" + m <- `rownames<-`( + `storage.mode<-`(as.matrix(raw[, -1L, drop = FALSE]), "double"), + as.character(raw[[1L]]) + ) if (transpose) { - m <- t(m) + return(t(m)) } m } @@ -1208,17 +1325,22 @@ NULL ) abort(msg) } - meta <- bed[, c(chrCol, startCol, endCol, geneCol)] - names(meta) <- c("chrom", "start", "end", "gene_id") + meta <- `names<-`( + bed[, c(chrCol, startCol, endCol, geneCol)], + c("chrom", "start", "end", "gene_id") + ) sampleCols <- setdiff(names(bed), .bedReservedCols()) - expr <- as.matrix(bed[, sampleCols, drop = FALSE]) - storage.mode(expr) <- "double" - rownames(expr) <- meta$gene_id - rr <- GenomicRanges::GRanges( - seqnames = meta$chrom, - ranges = IRanges::IRanges(start = meta$start + 1L, end = meta$end) - ) - names(rr) <- meta$gene_id + expr <- `rownames<-`( + `storage.mode<-`(as.matrix(bed[, sampleCols, drop = FALSE]), "double"), + meta$gene_id + ) + rr <- `names<-`( + GenomicRanges::GRanges( + seqnames = meta$chrom, + ranges = IRanges::IRanges(start = meta$start + 1L, end = meta$end) + ), + meta$gene_id + ) list(expr = expr, rr = rr) } @@ -1334,26 +1456,33 @@ NULL ) abort(msg) } - covPath <- NULL - if (is_in("covariatePath", names(sub))) { - covs <- unique(sub$covariatePath[ - !is.na(sub$covariatePath) & - str_length(as.character(sub$covariatePath)) > 0L - ]) - if (length(covs) > 1L) { - msg <- glue( - "Context '{cx}' (study '{study}') references multiple ", - "covariatePath values: {str_flatten(covs, ', ')}" - ) - abort(msg) - } - if (length(covs) == 1L) { - covPath <- .resolveRel(covs[[1L]], base) - } - } + covPath <- .oneContextCovariatePath(sub, cx, study, base) .buildContextSe(.resolveRel(pths[[1L]], base), covPath, transposeCov) } +# The single covariate path a context declares, or NULL when the manifest has +# no covariatePath column or the context leaves it blank. +# @noRd +.oneContextCovariatePath <- function(sub, cx, study, base) { + if (!is_in("covariatePath", names(sub))) { + return(NULL) + } + covs <- unique(sub$covariatePath[ + !is.na(sub$covariatePath) & + str_length(as.character(sub$covariatePath)) > 0L + ]) + if (length(covs) > 1L) { + abort(glue( + "Context '{cx}' (study '{study}') references multiple ", + "covariatePath values: {str_flatten(covs, ', ')}" + )) + } + if (length(covs) == 0L) { + return(NULL) + } + .resolveRel(covs[[1L]], base) +} + # The genotype handle: an override panel/path, else the study's single # genotypePath (auto-detecting the format). # @noRd @@ -1429,10 +1558,10 @@ NULL #' a genotype path/prefix; reconciled with a \code{genotypePath} column. #' @param genotypeCovariates A numeric matrix (samples x covariates) or a path #' to a covariate TSV; reconciled with a \code{genotypeCovariatePath} column. -#' @param scaleResiduals,mafCutoff,macCutoff,xvarCutoff Pass-through -#' \code{\link{QtlDataset}} arguments (stored as lazy QC slots). -#' @param imissCutoff,keepSamples,keepVariants,keepIndel Pass-through -#' \code{\link{QtlDataset}} arguments (stored as lazy QC slots). +#' @param scaleResiduals Pass-through \code{\link{QtlDataset}} argument. +#' @param genotypeFilterArgs Pass-through \code{\link{QtlDataset}} filtering +#' options, built with \code{\link{GenotypeFilterParam}} and stored as lazy +#' QC slots. #' @param transposeCovariates Transpose covariate TSVs (QTLtools layout) before #' treating them as samples-as-rows. #' @return A \code{QtlDataset} object. @@ -1443,6 +1572,7 @@ NULL #' study = "s1", genotypePath = file.path(d, "example.chr22")) #' loadQtlDatasetFromManifest(manifest = manifest, study = "s1") #' @importFrom stringr str_ends +#' @importFrom checkmate assertString assertFlag #' @export loadQtlDatasetFromManifest <- function( manifest, @@ -1450,15 +1580,12 @@ loadQtlDatasetFromManifest <- function( genotypes = NULL, genotypeCovariates = NULL, scaleResiduals = TRUE, - mafCutoff = 0, - macCutoff = 0, - xvarCutoff = 0, - imissCutoff = 0, - keepSamples = character(0), - keepVariants = character(0), - keepIndel = TRUE, + genotypeFilterArgs = GenotypeFilterParam(), transposeCovariates = FALSE ) { + assertString(study, null.ok = TRUE) + assertFlag(transposeCovariates) + .assertQtlPassThrough(scaleResiduals, genotypeFilterArgs) base <- .manifestBase(manifest) df <- .canonManifestCols( .readManifest(manifest), @@ -1469,16 +1596,7 @@ loadQtlDatasetFromManifest <- function( # df[["study"]] (not df$study): study is optional here (it may be passed as # the `study` arg instead), and a tibble `$` on an absent column warns. study <- .reconcileScalar(df[["study"]], study, "study") - qc <- list( - scaleResiduals = scaleResiduals, - mafCutoff = mafCutoff, - macCutoff = macCutoff, - xvarCutoff = xvarCutoff, - imissCutoff = imissCutoff, - keepSamples = keepSamples, - keepVariants = keepVariants, - keepIndel = keepIndel - ) + qc <- .msqQcArgs(scaleResiduals, genotypeFilterArgs) .buildQtlDatasetFromRows( df, study, @@ -1550,6 +1668,25 @@ loadQtlDatasetFromManifest <- function( isTRUE(ccOk) || isTRUE(nOk) } +# Materialise the LD sketch reading only the chromosomes the sumstats +# cover, then run the deferred per-study containment checks and trim to +# range. The checks sit between the two steps because containment is only +# answerable once the sketch is read, and trimming would hide a miss. +# @noRd +.manifestGwasLdSketch <- function( + ldSketchSpec, + entries, + df, + minLdOverlapWarn +) { + materialized <- .materializeLdSketch( + ldSketchSpec, + .entriesChroms(entries) + ) + .checkGwasLdContainment(materialized, entries, df, minLdOverlapWarn) + .subsetSketchToRange(materialized, entries) +} + #' @title Load a GwasSumStats collection from a manifest #' @description Build a \code{\link{GwasSumStats}} from a manifest with one row #' per study. No QC is run (the result carries \code{qcInfo = list()}). Each @@ -1628,16 +1765,19 @@ loadGwasSumStatsFromManifest <- function( formatMapping = formatMapping, ns = ns ) - # Materialise the LD sketch reading only the chromosomes the sumstats cover, - # then run the deferred per-study containment checks and trim to range. - ldSketch <- .materializeLdSketch(ldSketchSpec, .entriesChroms(entries)) - .checkGwasLdContainment(ldSketch, entries, df, minLdOverlapWarn) - ldSketch <- .subsetSketchToRange(ldSketch, entries) - gwasArgs <- .gwasSumStatsArgs(df, entries, genome, ldSketch, ns) + ldSketch <- .manifestGwasLdSketch( + ldSketchSpec, + entries, + df, + minLdOverlapWarn + ) # Without a block manifest a genome-wide file splits by chromosome, which # is too coarse for cTWAS; with one, each study becomes one element per LD # block. The constructor does the splitting either way. - gwasArgs$ldBlocks <- ldBlocks + gwasArgs <- list_assign( + .gwasSumStatsArgs(df, entries, genome, ldSketch, ns), + ldBlocks = ldBlocks + ) exec(GwasSumStats, !!!gwasArgs) } @@ -1715,25 +1855,20 @@ loadGwasSumStatsFromManifest <- function( # GwasSumStats() constructor args, including any present study scalars + varY. # @noRd .gwasSumStatsArgs <- function(df, entries, genome, ldSketch, ns) { - args <- list( - study = as.character(df$study), - entry = entries, - genome = genome, - ldSketch = ldSketch + c( + list( + study = as.character(df$study), + entry = entries, + genome = genome, + ldSketch = ldSketch + ), + compact(list( + nCase = ns$nCase, + nControl = ns$nControl, + nSample = ns$nSample, + varY = if (is_in("varY", names(df))) as.numeric(df$varY) + )) ) - if (!is.null(ns$nCase)) { - args$nCase <- ns$nCase - } - if (!is.null(ns$nControl)) { - args$nControl <- ns$nControl - } - if (!is.null(ns$nSample)) { - args$nSample <- ns$nSample - } - if (is_in("varY", names(df))) { - args$varY <- as.numeric(df$varY) - } - args } # Build the entry list for a QtlSumStats manifest. `allowNoN` is an optional @@ -1853,9 +1988,12 @@ loadQtlSumStatsFromManifest <- function( # Materialise the LD sketch reading only the chromosomes the summary stats # cover (skips other shards of a chrom-sharded panel), check containment, # then trim its snpInfo to the summary stats' per-chromosome position span. - ldSketch <- .materializeLdSketch(ldSketchSpec, .entriesChroms(entries)) - .qtlSumStatsCheckContainment(ldSketch, entries, df, minLdOverlapWarn) - ldSketch <- .subsetSketchToRange(ldSketch, entries) + materialized <- .materializeLdSketch( + ldSketchSpec, + .entriesChroms(entries) + ) + .qtlSumStatsCheckContainment(materialized, entries, df, minLdOverlapWarn) + ldSketch <- .subsetSketchToRange(materialized, entries) exec( QtlSumStats, @@ -1921,13 +2059,13 @@ loadQtlSumStatsFromManifest <- function( genome = genome, ldSketch = ldSketch ) - if (!is.null(nSampleCol)) { - args$nSample <- nSampleCol - } - if (is_in("varY", names(df))) { - args$varY <- as.numeric(df$varY) - } - args + c( + args, + compact(list( + nSample = nSampleCol, + varY = if (is_in("varY", names(df))) as.numeric(df$varY) + )) + ) } #' @title Load a MultiStudyQtlDataset from manifests @@ -1944,10 +2082,11 @@ loadQtlSumStatsFromManifest <- function( #' @param columnMapping,sampleSelect,formatMapping Passed to the QtlSumStats #' loader for \code{sumStatsManifest}. #' @param transposeCovariates Transpose covariate TSVs (QTLtools layout). -#' @param scaleResiduals,mafCutoff,macCutoff,xvarCutoff Pass-through -#' \code{\link{QtlDataset}} arguments applied to every study. -#' @param imissCutoff,keepSamples,keepVariants,keepIndel Pass-through -#' \code{\link{QtlDataset}} arguments applied to every study. +#' @param scaleResiduals Pass-through \code{\link{QtlDataset}} argument, +#' applied to every study. +#' @param genotypeFilterArgs Pass-through \code{\link{QtlDataset}} filtering +#' options, built with \code{\link{GenotypeFilterParam}} and applied to +#' every study. #' @return A \code{MultiStudyQtlDataset} object. #' @examples #' d <- system.file("extdata", "qtl_mini", package = "pecotmr") @@ -1955,6 +2094,7 @@ loadQtlSumStatsFromManifest <- function( #' phenotypePath = file.path(d, "example_geneexpr.bed.gz"), #' genotypePath = file.path(d, "example.chr22")) #' loadMultiStudyQtlDatasetFromManifest(qtlDatasetsManifest = manifest) +#' @importFrom checkmate assertFlag assertNumber #' @export loadMultiStudyQtlDatasetFromManifest <- function( qtlDatasetsManifest, @@ -1968,24 +2108,12 @@ loadMultiStudyQtlDatasetFromManifest <- function( formatMapping = NULL, transposeCovariates = FALSE, scaleResiduals = TRUE, - mafCutoff = 0, - macCutoff = 0, - xvarCutoff = 0, - imissCutoff = 0, - keepSamples = character(0), - keepVariants = character(0), - keepIndel = TRUE + genotypeFilterArgs = GenotypeFilterParam() ) { - qc <- .msqQcArgs( - scaleResiduals, - mafCutoff, - macCutoff, - xvarCutoff, - imissCutoff, - keepSamples, - keepVariants, - keepIndel - ) + assertFlag(transposeCovariates) + assertNumber(minLdOverlapWarn, lower = 0, upper = 1) + .assertQtlPassThrough(scaleResiduals, genotypeFilterArgs) + qc <- .msqQcArgs(scaleResiduals, genotypeFilterArgs) qtlDatasets <- .msqBuildDatasets( qtlDatasetsManifest, transposeCovariates, @@ -2004,27 +2132,14 @@ loadMultiStudyQtlDatasetFromManifest <- function( MultiStudyQtlDataset(qtlDatasets = qtlDatasets, sumStats = sumStats) } -# Bundle the per-study QC / sample-filter arguments into a list. +# Bundle the per-study QC / sample-filter arguments into a list. What remains +# after GenotypeFilterParam() absorbed the seven filter fields: this is what is +# spliced into QtlDataset(). # @noRd -.msqQcArgs <- function( - scaleResiduals, - mafCutoff, - macCutoff, - xvarCutoff, - imissCutoff, - keepSamples, - keepVariants, - keepIndel -) { +.msqQcArgs <- function(scaleResiduals, genotypeFilterArgs) { list( scaleResiduals = scaleResiduals, - mafCutoff = mafCutoff, - macCutoff = macCutoff, - xvarCutoff = xvarCutoff, - imissCutoff = imissCutoff, - keepSamples = keepSamples, - keepVariants = keepVariants, - keepIndel = keepIndel + genotypeFilterArgs = genotypeFilterArgs ) } diff --git a/R/mashPipeline.R b/R/mashPipeline.R index 2bcff321a..41c33167d 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -1,3 +1,151 @@ +#' @include MethodParam.R +NULL + +# Declared here rather than beside its constructor (far below) because +# MashComponentSelection references it and MashPriorParam needs that union. +#' @rdname MashComponentParam +#' @aliases MashComponentParam-class +#' @exportClass MashComponentParam +setClass( + "MashComponentParam", + contains = "MethodParam", + slots = c(components = "list_OR_NULL") +) + +# Both take either a name or that component/engine's own record, which is why +# neither is arg_match()ed in the constructor: collapsing one to a string +# would discard the options travelling with it. +# +# `components` is now exact -- only a MashComponentParam, not any +# MethodOptions. `engine` stays open to MethodOptions and always will: +# CovEdOptions() and CovUdrOptions() are external-engine argument bags, not +# pecotmr settings, so they never become Params. +# No character arm: a name is translated to the record it stands for by the +# constructor, so each slot has ONE shape. + +# A name is a user-facing convenience, so it is translated to the record it +# stands for at the boundary rather than carried as a second slot shape. +# Both entry points use these: MashPriorParam() and mashPriorCovariances(), +# which is exported with the same convenience arguments. +# +# The alternative -- storing the string and resolving at use -- is what this +# replaced, and it made every consumer handle two shapes for one setting. +# @noRd +.mashNormalizeComponents <- function(v) { + if (is(v, "MashComponentParam")) { + return(v) + } + if (!is.character(v)) { + abort(glue( + "`components` must be component names or a ", + "MashComponentParam() record; got {class(v)[[1L]]}" + )) + } + .mashValidateComponents(v, "MashPriorParam") + exec( + MashComponentParam, + !!!set_names(rep(list(list()), length(v)), v) + ) +} + +# "none" has no constructor, so it is the absent engine: NULL. The default +# resolves to CovEdOptions(), so NULL in the slot is unambiguous. +# @noRd +.mashNormalizeEngine <- function(v) { + if (.isMethodOptions(v)) { + return(.mashAssertEngineRecord(v)) + } + if (!is.character(v)) { + abort(glue( + "`engine` must be 'covEd', 'covUdr', 'none', or that engine's ", + "Options record; got {class(v)[[1L]]}" + )) + } + # arg_match() needs a symbol and would then report on the local name; + # arg_match0() takes the user-facing name explicitly, so the message + # says `engine` rather than whatever this binding is called. + nm <- arg_match0( + v[[1L]], + c(names(.mashEngineCtors()), "none"), + arg_nm = "engine" + ) + if (identical(nm, "none")) { + return(NULL) + } + .mashEngineCtors()[[nm]]() +} + +# @noRd +.mashAssertEngineRecord <- function(v) { + known <- names(.mashEngineCtors()) + got <- metadata(v)$engine + if (is.null(got) || !is_in(got, known)) { + abort(glue( + "`engine`: these options are for '{got %||% 'unknown'}', which ", + "does not refine mash prior covariances. Use ", + "{str_flatten(str_c(known, 'Options()'), ' or ')}." + )) + } + v +} + +#' @rdname MashPriorParam +#' @aliases MashPriorParam-class +#' @exportClass MashPriorParam +setClass( + "MashPriorParam", + contains = "MethodParam", + slots = c( + priorCovariances = "list_OR_NULL", + components = "MashComponentParam", + engine = "MethodOptions_OR_NULL", + nPcs = "numeric_OR_NULL" + ) +) + +#' @title mash Prior-Covariance Settings +#' @description How the prior covariance matrices (the \code{Ulist} mash +#' consumes) are obtained: supplied outright, or built from components and +#' refined by an engine. Exactly the arguments +#' \code{\link{mashPriorCovariances}} takes for that job, so the bundle +#' travels there whole. +#' +#' Supplying \code{priorCovariances} short-circuits the rest: the +#' components are not built and the engine does not run. +#' @param priorCovariances Optional named list of square covariance matrices, +#' or a \code{\link{MashPrior}}. \code{NULL} (default) builds them. +#' @param components Which prior-covariance components to build: any of +#' \code{"canonical"}, \code{"pca"}, \code{"flash"}, +#' \code{"flashNonneg"}, or a \code{\link{MashComponentParam}} record to +#' configure them. Ignored when \code{priorCovariances} is supplied. +#' @param engine How the data-driven components are refined: +#' \code{"covEd"} (default), \code{"covUdr"} or \code{"none"}, or the +#' matching constructor --- \code{\link{CovEdOptions}} / +#' \code{\link{CovUdrOptions}} --- to configure it at the same time. +#' Ignored when \code{priorCovariances} is supplied. +#' @param nPcs Optional integer; principal components seeded into +#' \code{mashr::cov_pca()}. Defaults to \code{ncol} of the data. Read +#' only when \code{components} includes \code{"pca"}. +#' @return A \code{MashPriorParam} object, a \code{\link{MethodParam}}. +#' @examples +#' MashPriorParam(components = c("canonical", "pca"), nPcs = 3) +#' @importFrom rlang arg_match0 +#' @export +MashPriorParam <- function( + priorCovariances = NULL, + components = c("canonical", "pca", "flash", "flashNonneg"), + engine = c("covEd", "covUdr", "none"), + nPcs = NULL +) { + new( + "MashPriorParam", + priorCovariances = priorCovariances, + components = .mashNormalizeComponents(components), + engine = .mashNormalizeEngine(engine), + nPcs = nPcs + ) +} + #' @title Run mashr Across Multi-Context QTL or GWAS Summary Statistics #' @description End-to-end driver: from `(strong, random, null)` sumstats #' collections, builds the variant x context Bhat / Shat matrices, estimates @@ -41,18 +189,12 @@ #' entry; \code{"mle"} needs \code{"random"} plus a supplied #' \code{priorCovariances} to refine against. A named method whose #' requirement is unmet is a hard error, not a silent fallback. -#' @param priorCovariances Optional named list of square covariance matrices -#' (the \code{Ulist} \code{mashr::mash()} consumes), or a -#' \code{\link{mashPriorCovariances}} result, which is unwrapped to its -#' \code{U}. When supplied, replaces -#' the canonical + PCA + flash + ED chain (\code{cov_canonical} / -#' \code{cov_pca} / \code{cov_flash} / \code{cov_ed}) entirely; mash sees only -#' the supplied matrices. Every entry must be a \code{ncol(Bhat) x ncol(Bhat)} -#' matrix. Useful when \code{U} was learnt on a larger reference and shipped -#' as a static artefact (the legacy MWE pattern). -#' @param nPcs Optional integer; number of principal components seeded into -#' \code{mashr::cov_pca()}. Defaults to \code{ncol(Bhat) - 1}. Ignored when -#' \code{priorCovariances} is supplied. +#' @param prior How the prior covariance matrices are obtained, built with +#' \code{\link{MashPriorParam}}: \code{priorCovariances} supplies them +#' outright (short-circuiting the rest), otherwise \code{components} +#' chooses which to build, \code{engine} how the data-driven ones are +#' refined, and \code{nPcs} parametrises the \code{pca} component. +#' Forwarded whole to \code{\link{mashPriorCovariances}}. #' @param inputScale One of \code{"auto"} (default), \code{"beta"}, #' \code{"z"}. Controls which (Bhat, Shat) pair is extracted from each #' sumstats entry: @@ -68,6 +210,17 @@ #' } #' \code{alpha} should be chosen consistently with the resolved scale: #' typically \code{alpha = 0} for beta, \code{alpha = 1} for z. +#' @param mashDataArgs Extra arguments for +#' \code{mashr::mash_set_data()}, built with +#' \code{\link{MashDataOptions}} -- for example +#' \code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +#' \code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +#' are refused by the constructor. +#' @param mashArgs Extra arguments for \code{mashr::mash()}, built with +#' \code{\link{MashOptions}} -- for example \code{nullweight}, +#' \code{optmethod} or \code{verbose}. \code{data}, \code{Ulist}, +#' \code{outputlevel} and \code{seed} are owned by pecotmr and are +#' refused by the constructor. #' @param setSeed Integer. RNG seed for reproducibility of #' \code{mashr::cov_flash} and \code{mashr::cov_ed}. Default 999. #' @return A list with elements \code{U} (the combined covariance list: @@ -76,7 +229,7 @@ #' data(qtlSumStatsMulticontextExample) #' ss <- qtlSumStatsMulticontextExample #' sumStatsList <- list(strong = ss, random = ss) -#' mashPipeline(sumStatsList, alpha = 0, nPcs = 2L) +#' mashPipeline(sumStatsList, alpha = 0, prior = MashPriorParam(nPcs = 2L)) #' @export mashPipeline <- function( sumStatsList, @@ -89,13 +242,18 @@ mashPipeline <- function( "corshrink", "mle" ), - priorCovariances = NULL, - nPcs = NULL, + prior = MashPriorParam(), inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + mashArgs = MashOptions(), setSeed = 999 ) { inputScale <- arg_match(inputScale) residualCorrelationMethod <- arg_match(residualCorrelationMethod) + .mashPipelineAssert(prior, mashDataArgs, mashArgs) + # Needed here as well as in the prior fit: the 'mle' Vhat estimator + # refines against the supplied prior. + priorCovariances <- prior$priorCovariances .mashRequirePriorPackages() # Accept either a base list or a S4Vectors::SimpleList. if (methods::is(sumStatsList, "SimpleList")) { @@ -109,20 +267,60 @@ mashPipeline <- function( inputScale, residualCorrelation, residualCorrelationMethod, - priorCovariances + priorCovariances, + mashDataArgs ) - # mashPriorCovariances() owns the cov_* chain, the supplied-prior bypass, - # and the mash() weight fit; mashPipeline just forwards its arguments. - prior <- mashPriorCovariances( + fitted <- .mashPipelinePrior( sumStatsList, alpha, vhat = vhat, - priorCovariances = priorCovariances, - nPcs = nPcs, + prior = prior, + inputScale = inputScale, + mashDataArgs = mashDataArgs, + mashArgs = mashArgs + ) + list(U = fitted$U, w = fitted$w) +} + +# Every bundle mashPipeline() takes, checked together. +# @noRd +.mashPipelineAssert <- function(prior, mashDataArgs, mashArgs) { + .assertMethodParam(prior, "MashPriorParam", "prior") + .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") + .assertMethodOptions(mashArgs, "MashOptions", "mashArgs") +} + +# mashPriorCovariances() owns the cov_* chain, the supplied-prior bypass and +# the mash() weight fit; it takes the prior settings as plain arguments, so +# the bundle is unrolled here -- the one place that knows MashPriorParam()'s +# defaults for an unset field. +# @noRd +.mashPipelinePrior <- function( + sumStatsList, + alpha, + vhat, + prior, + inputScale, + mashDataArgs, + mashArgs +) { + # Normalized to a Param first: `prior` may be list() for "no settings", + # and reading $engine off that would give NULL -- which now MEANS + # "none" -- rather than the default engine. + prior <- if (is(prior, "MashPriorParam")) prior else MashPriorParam() + mashPriorCovariances( + sumStatsList, + alpha, + vhat = vhat, + components = prior$components, + engine = prior$engine, + priorCovariances = prior$priorCovariances, + nPcs = prior$nPcs, inputScale = inputScale, + mashDataArgs = mashDataArgs, + mashArgs = mashArgs, setSeed = NULL ) - list(U = prior$U, w = prior$w) } # `sumStatsList` must be a named list of strong[/random/null] partitions; @@ -218,7 +416,8 @@ mashPipeline <- function( inputScale, residualCorrelation, method, - priorCovariances + priorCovariances, + mashDataArgs = MashDataOptions() ) { if (!is.null(residualCorrelation)) { return(residualCorrelation) @@ -230,6 +429,7 @@ mashPipeline <- function( method = method, priorCovariances = priorCovariances, inputScale = inputScale, + mashDataArgs = mashDataArgs, setSeed = NULL ) } @@ -261,6 +461,12 @@ mashPipeline <- function( #' EM iterations). #' @param inputScale SumStats -> matrix conversion scale (\code{"auto"} / #' \code{"beta"} / \code{"z"}). +#' @param mashDataArgs Extra arguments for +#' \code{mashr::mash_set_data()}, built with +#' \code{\link{MashDataOptions}} -- for example +#' \code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +#' \code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +#' are refused by the constructor. #' @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). @@ -280,16 +486,22 @@ mashResidualCorrelation <- function( nSubset = 6000L, maxIter = 6L, inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), setSeed = 999 ) { - method <- arg_match(method) + # `method` takes a NAME or that estimator's own constructor, the same + # character-or-constructor rule mashPriorCovariances(engine =) uses. + chosen <- .resolveEngineChoice( + if (is.character(method)) method[[1L]] else method, + c("simple", "identity", "mle", "corshrink", "simpleSpecific"), + "method" + ) + method <- chosen$engine + corArgs <- chosen$args + .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") inputScale <- arg_match(inputScale) if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) + abort("Package 'mashr' is required for this function.") } if (methods::is(sumStatsList, "SimpleList")) { sumStatsList <- as.list(sumStatsList) @@ -297,6 +509,35 @@ mashResidualCorrelation <- function( if (!is.null(setSeed)) { withr::local_seed(setSeed) } + .mashResidCorDispatch( + method, + sumStatsList, + alpha, + inputScale, + priorCovariances, + nSubset, + maxIter, + mashDataArgs, + corArgs + ) +} + +# Run the chosen estimator. Split from mashResidualCorrelation() so that +# function is only the resolve-and-validate preamble: the five estimators +# share nothing but their return shape, so the choice reads as one table +# rather than as the tail of a longer function. +# @noRd +.mashResidCorDispatch <- function( + method, + sumStatsList, + alpha, + inputScale, + priorCovariances, + nSubset, + maxIter, + mashDataArgs, + corArgs +) { if (method == "identity") { strongMats <- .mashSumStatsToMatrices( sumStatsList$strong, @@ -306,7 +547,13 @@ mashResidualCorrelation <- function( return(diag(rep(1, ncol(strongMats$b)))) } if (method == "simple") { - return(.mashResidCorSimple(sumStatsList, alpha, inputScale)) + return(.mashResidCorSimple( + sumStatsList, + alpha, + inputScale, + mashDataArgs, + corArgs + )) } if (method == "mle") { return(.mashResidCorMle( @@ -315,153 +562,12 @@ mashResidualCorrelation <- function( inputScale, priorCovariances, nSubset, - maxIter - )) - } - .mashResidCorNullBased(sumStatsList, alpha, inputScale, method) -} - -# method 'simple': mashr's estimate_null_correlation_simple on the null set. -# @noRd -.mashResidCorSimple <- function(sumStatsList, alpha, inputScale) { - if (is.null(sumStatsList$null)) { - msg <- glue( - "mashResidualCorrelation: method 'simple' requires a 'null' entry ", - "in `sumStatsList`." - ) - abort(msg) - } - nullMats <- .mashSumStatsToMatrices( - sumStatsList$null, - "null", - inputScale = inputScale - ) - mashr::estimate_null_correlation_simple( - mashr::mash_set_data( - nullMats$b, - Shat = nullMats$s, - alpha, - zero_Bhat_Shat_reset = 1000 - ) - ) -} - -# method 'mle': EM refinement of V against the prior U over a random subset. -# @noRd -.mashResidCorMle <- function( - sumStatsList, - alpha, - inputScale, - priorCovariances, - nSubset, - maxIter -) { - if (is.null(sumStatsList$random)) { - msg <- glue( - "mashResidualCorrelation: method 'mle' requires a 'random' entry ", - "in `sumStatsList`." - ) - abort(msg) - } - if (is.null(priorCovariances)) { - msg <- glue( - "mashResidualCorrelation: method 'mle' requires ", - "`priorCovariances` ", - "(the prior U the EM refines V against)." - ) - abort(msg) - } - priorCovariances <- .mashAsUlist(priorCovariances) - 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 - ) - fit$V -} - -# methods 'corshrink' / 'simpleSpecific': estimate V on the null z-matrix. The -# `null` partition is already the null variants (max|z| < 2), so no -# re-thresholding is needed. -# @noRd -.mashResidCorNullBased <- function(sumStatsList, alpha, inputScale, method) { - if (is.null(sumStatsList$null)) { - msg <- glue( - "mashResidualCorrelation: method '{method}' requires a 'null' ", - "entry in `sumStatsList` (the null variants V is estimated on)." - ) - abort(msg) - } - nullMats <- .mashSumStatsToMatrices( - sumStatsList$null, - "null", - inputScale = inputScale - ) - nullZ <- nullMats$b / nullMats$s - if (method == "simpleSpecific") { - return(as.matrix( - Matrix::nearPD( - stats::cov(nullZ), - conv.tol = 1e-06, - doSym = TRUE, - corr = TRUE - )$mat + maxIter, + mashDataArgs, + corArgs )) } - if (!requireNamespace("CorShrink", quietly = TRUE)) { - msg <- glue( - "mashResidualCorrelation: method 'corshrink' needs the CorShrink ", - "package. Install it, or use 'simple' / 'simpleSpecific'." - ) - abort(msg) - } - 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, flashNonneg) so a -# given `components` set reproduces the same ordering everywhere. RNG is -# consumed only by cov_flash / cov_flash(nonneg). Shared by mashPriorCovariances -# and the exported mashCovarianceComponents. -# @noRd -.mashBuildComponents <- function(mashData, components, nPcs = NULL) { - comps <- list() - if (is_in("canonical", components)) { - comps <- c(comps, mashr::cov_canonical(mashData)) - } - if (is_in("pca", components)) { - if (is.null(nPcs)) { - nPcs <- ncol(mashData$Bhat) - 1 - } - comps <- c(comps, mashr::cov_pca(mashData, npc = nPcs)) - } - if (is_in("flash", components)) { - comps <- c(comps, mashr::cov_flash(mashData)) - } - if (is_in("flashNonneg", components)) { - comps <- c(comps, mashr::cov_flash(mashData, factors = "nonneg")) - } - comps + .mashResidCorNullBased(sumStatsList, inputScale, method, corArgs) } #' @title Build mash Data-Driven Covariance Components @@ -480,6 +586,12 @@ mashResidualCorrelation <- function( #' \code{"flashNonneg"}. Built in that fixed order. #' @param nPcs PCs seeded into \code{cov_pca}. Default \code{ncol(Bhat) - 1}. #' @param inputScale SumStats -> matrix conversion scale. +#' @param mashDataArgs Extra arguments for +#' \code{mashr::mash_set_data()}, built with +#' \code{\link{MashDataOptions}} -- for example +#' \code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +#' \code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +#' are refused by the constructor. #' @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). @@ -497,8 +609,10 @@ mashCovarianceComponents <- function( components = c("canonical", "pca", "flash", "flashNonneg"), nPcs = NULL, inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), setSeed = 999 ) { + .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") inputScale <- arg_match(inputScale) .mashValidateComponents(components, "mashCovarianceComponents") .mashRequirePriorPackages() @@ -513,9 +627,35 @@ mashCovarianceComponents <- function( "strong", vhat, alpha, - inputScale + inputScale, + mashDataArgs + ) + # This function's contract is one flat named list of covariance matrices, + # so the role split that .mashBuildComponents keeps for the engine is + # collapsed again here, canonical first as before. + built <- .mashBuildComponents( + mashData, + components = components, + nPcs = nPcs + ) + c(built$canonical, built$dataDriven) +} + +# `components` and `engine` each take a name or that choice's own +# constructor, so both resolve to a (name, options) pair the same way. +# @noRd +# Both arguments arrive already normalized -- a MashComponentParam and an +# Options record or NULL -- so this only splits them into the shapes the +# cov_* chain downstream expects. NULL engine is "none": no refinement. +# @noRd +.mashResolvePriorChoice <- function(components, engine) { + entries <- slot(components, "components") %||% list() + list( + components = names(entries), + componentArgs = entries, + engine = if (is.null(engine)) "none" else metadata(engine)$engine, + engineArgs = engine ) - .mashBuildComponents(mashData, components = components, nPcs = nPcs) } #' @title Estimate mash Prior Covariances and Mixture Weights @@ -534,14 +674,18 @@ mashCovarianceComponents <- function( #' @param components Data-driven covariance components, any of #' \code{"canonical"}, \code{"pca"}, \code{"flash"} (default #' \code{cov_flash}), \code{"flashNonneg"} (\code{cov_flash(factors = -#' "nonneg")}). Built in that fixed order. Ignored by the \code{"ud"} / -#' \code{"ud_ted"} engines. -#' @param engine Covariance-refinement engine. \code{"cov_ed"} (default; mashr's -#' 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). +#' "nonneg")}). Built in that fixed order. May instead be a +#' \code{\link{MashComponentParam}} record, which names the components and +#' carries each one's options. +#' @param engine Covariance-refinement engine, either a name or the matching +#' constructor carrying that engine's settings. \code{"covEd"} (default; +#' \code{\link{CovEdOptions}} -- 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{"covUdr"} +#' (\code{\link{CovUdrOptions}} -- \pkg{udr} ED / TED updates, returning +#' weights directly -- OPT-IN, known numerical issues, so not the default; +#' \code{UdFitOptions(unconstrained.update = "ted")} additionally needs +#' i.i.d. (z-scale) data); \code{"none"} to skip refinement. #' @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, or a @@ -557,12 +701,18 @@ mashCovarianceComponents <- function( #' 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 mashDataArgs Extra arguments for +#' \code{mashr::mash_set_data()}, built with +#' \code{\link{MashDataOptions}} -- for example +#' \code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +#' \code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +#' are refused by the constructor. +#' @param mashArgs Extra arguments for \code{mashr::mash()}, built with +#' \code{\link{MashOptions}} -- for example \code{nullweight}, +#' \code{optmethod} or \code{verbose}. \code{data}, \code{Ulist}, +#' \code{outputlevel} and \code{seed} are owned by pecotmr and are +#' refused by the constructor. #' @param setSeed Integer seed, or \code{NULL} to leave the ambient RNG #' untouched. #' @return \code{list(U, w, loglik)}: the covariance list, the @@ -580,17 +730,29 @@ mashPriorCovariances <- function( alpha, vhat = NULL, components = c("canonical", "pca", "flash", "flashNonneg"), - engine = c("cov_ed", "ud", "ud_ted"), + engine = c("covEd", "covUdr", "none"), nPcs = NULL, priorCovariances = NULL, priorComponents = NULL, - udControl = list(), inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + mashArgs = MashOptions(), setSeed = 999 ) { - engine <- arg_match(engine) + .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") + .assertMethodOptions(mashArgs, "MashOptions", "mashArgs") inputScale <- arg_match(inputScale) - .mashValidateComponents(components) + # Exported with the same convenience arguments as MashPriorParam(), so + # it normalizes through the same helpers rather than resolving a second + # time in its own way. + choice <- .mashResolvePriorChoice( + .mashNormalizeComponents(components), + .mashNormalizeEngine(engine) + ) + components <- choice$components + componentArgs <- choice$componentArgs + engine <- choice$engine + engineArgs <- choice$engineArgs .mashRequirePriorPackages() if (methods::is(sumStatsList, "SimpleList")) { sumStatsList <- as.list(sumStatsList) @@ -603,29 +765,188 @@ mashPriorCovariances <- function( "strong", vhat, alpha, - inputScale + inputScale, + mashDataArgs ) - result <- if (!is.null(priorCovariances)) { - .mashUserPriorCovariances(priorCovariances, mashData) - } else { - .mashDataDrivenCovariances( - mashData, - priorComponents, - components, - nPcs, - udControl, - engine - ) - } - if (is.null(result$w)) { - m <- mashr::mash(mashData, Ulist = result$U, outputlevel = 1) - result$w <- mashr::get_estimated_pi(m) + .mashPriorFit( + mashData, + priorCovariances = priorCovariances, + priorComponents = priorComponents, + components = components, + nPcs = nPcs, + engine = engine, + engineArgs = engineArgs, + componentArgs = componentArgs, + mashArgs = mashArgs + ) +} + +# --- prior-covariance constructors ------------------------------------------ +# +# mashr draws three roles that pecotmr had collapsed into one list. Canonical +# components are shape-driven -- fixed structural hypotheses built from the +# condition count. PCA and FLASH are data-driven GENERATORS: data in, +# covariances out, independent of each other. ED and udr are REFINERS, which +# consume a generator's output. mashr's own eQTL vignette refines only the +# data-driven components and passes canonical to mash() untouched. + +# udr checks these names but not their VALUES, and a bad one fails deep and +# obscurely: udr::compute_penalty is two `if (update.type == ...)` branches +# with no else, so an unrecognised value assigns nothing and the function +# dies on `object 'log_penalty' not found` -- a variable the caller has +# never heard of. It is reached whenever `lambda` is non-zero, which +# .mashUdControl always sets. +# +# The vocabulary is transcribed, which this design normally refuses to do. +# The trade is three stable values against an error naming an internal +# variable: "ed" and "ted" are compute_penalty's own two branches, and +# "none" plus NA are resolved by udr::assign_prior_covariance_updates. +# +# ONLY this field. The sibling updates have their OWN vocabularies -- +# scaled.update is "fa"/"none", rank1.update "ted"/"fa"/"none" -- and I have +# not traced their failure modes, so guessing at them would risk rejecting +# something udr accepts. +# @noRd +.udAssertUnconstrainedUpdate <- function(extra) { + v <- extra[["unconstrained.update"]] + if (is.null(v) || length(v) != 1L) { + return(invisible(NULL)) + } + if (is.logical(v) && is.na(v)) { + return(invisible(NULL)) + } + if (is.character(v) && is_in(v, c("ed", "ted", "none"))) { + return(invisible(NULL)) + } + abort(glue( + "UdFitOptions: `unconstrained.update` must be 'ed', 'ted', 'none' ", + "or NA (NA lets udr choose from the data); got ", + "'{as.character(v)[[1L]]}'. udr accepts the name but not the ", + "value, and fails later inside compute_penalty()." + )) +} + +# The generator constructors, keyed by the component name `components` +# accepts. flashNonneg shares cov_flash's options; pecotmr sets `factors`. +# @noRd +.mashComponentCtors <- function() { + list( + canonical = CovCanonicalOptions, + pca = CovPcaOptions, + flash = CovFlashOptions, + flashNonneg = CovFlashOptions + ) +} + +# The refiner constructors, keyed by the name `engine` accepts. +# @noRd +.mashEngineCtors <- function() { + list(covEd = CovEdOptions, covUdr = CovUdrOptions) +} + +# --- mashr fit / data / posterior settings ---------------------------------- +# +# These three were the audit's top finding: the core mash fit had zero user +# control. Each names the ONE mashr function it configures, so the accepted +# set is that function's live formals. +# +# `seed` is refused by all of them: pecotmr owns run-to-run reproducibility +# through `setSeed`, and two seeds that disagree is worse than one that +# cannot be set. + +# --- residual-correlation estimator settings -------------------------------- +# +# `mashResidualCorrelation(method =)` already picks the estimator, so these +# follow the character-or-constructor rule the file already uses for +# `engine =`: the argument takes either the estimator's NAME or that +# estimator's constructor, which carries the identity in metadata(). + +#' @title Per-Component Arguments For mashPriorCovariances +#' @description Options for each prior-covariance component, keyed by +#' component name. Each entry may be a plain list or the matching +#' constructor -- a plain list is spliced into that constructor, so it gets +#' the same defaults and the same checking either way. +#' +#' Naming a component here also selects it, so \code{components} need not +#' be given separately. +#' @param canonical Options for \code{\link{CovCanonicalOptions}}. +#' @param pca Options for \code{\link{CovPcaOptions}}. +#' @param flash,flashNonneg Options for \code{\link{CovFlashOptions}}. +#' @return A \code{MashComponentParam} object, a \code{\link{MethodParam}}. +#' \code{names()} lists the components that were named, which is also the +#' set that was selected. +#' @examples +#' MashComponentParam( +#' pca = list(subset = 1:50), +#' canonical = CovCanonicalOptions() +#' ) +#' @export +MashComponentParam <- function( + canonical = NULL, + pca = NULL, + flash = NULL, + flashNonneg = NULL +) { + # discard(is.null), not compact(): compact() also drops zero-length + # elements, and an unconfigured constructor is a legitimately empty + # record -- naming a component with default options must still select it. + given <- discard( + list( + canonical = canonical, + pca = pca, + flash = flash, + flashNonneg = flashNonneg + ), + is.null + ) + # One named-list slot rather than one nullable slot per component, so a + # record selecting pca shows that and not three NULLs. The formals stay + # named, so R still rejects a misspelled component. + entries <- .mashComponentEntries(given) + new( + "MashComponentParam", + components = if (length(entries) == 0L) NULL else entries + ) +} + +# Each entry validated and built the same way: a plain list is spliced into +# that component's constructor, an already-built record passes through, and +# one built by the WRONG constructor is refused. +# +# There is no "unknown component" check because it cannot fail any more: the +# four components are now formals, so R rejects a misspelled one as an +# unused argument before this is reached. +# @noRd +.mashComponentEntries <- function(given) { + if (length(given) == 0L) { + return(list()) } - list(U = result$U, w = result$w, loglik = result$loglik) + ctors <- .mashComponentCtors() + .nestedAssertEngines(given, ctors, NULL, "MashComponentParam") + imap(given, .nestedElement, ctors = ctors, label = "MashComponentParam") } # Reject unknown prior-covariance component names. # @noRd +# `components` may be a character vector or a MashComponentParam() record. +# Naming a component in the record selects it, so the two forms carry the +# same information and the record additionally carries per-component options. +# @noRd +.mashResolveComponentChoice <- function(components) { + if (is(components, "MashComponentParam")) { + entries <- slot(components, "components") %||% list() + return(list(names = names(entries), args = entries)) + } + if (!is.character(components)) { + abort(glue( + "mashPriorCovariances: `components` must be a character vector ", + "or a MashComponentParam() record." + )) + } + .mashValidateComponents(components) + list(names = components, args = NULL) +} + .mashValidateComponents <- function( components, caller = "mashPriorCovariances" @@ -646,35 +967,28 @@ mashPriorCovariances <- function( # @noRd .mashRequirePriorPackages <- function() { if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) + abort("Package 'mashr' is required for this function.") } if (!requireNamespace("flashier", quietly = TRUE)) { - msg <- glue( - "To use this function, please install flashier: ", - "https://github.com/willwerscheid/flashier" - ) - abort(msg) + abort("Package 'flashier' is required for this function.") } } # mashr mash_set_data over the STRONG effects (V defaults to identity). # @noRd -.mashMakeMashData <- function(partition, label, vhat, alpha, inputScale) { +.mashMakeMashData <- function( + partition, + label, + vhat, + alpha, + inputScale, + mashDataArgs +) { mats <- .mashSumStatsToMatrices(partition, label, inputScale = inputScale) if (is.null(vhat)) { vhat <- diag(rep(1, ncol(mats$b))) } - mashr::mash_set_data( - mats$b, - Shat = mats$s, - V = vhat, - alpha, - zero_Bhat_Shat_reset = 1000 - ) + .mashSetData(mats$b, mats$s, alpha, vhat, mashDataArgs) } # Caller-supplied prior covariance matrices (bypasses the cov_* chain; mashr @@ -716,20 +1030,37 @@ mashPriorCovariances <- function( priorComponents, components, nPcs, - udControl, - engine + engine, + engineArgs = NULL, + componentArgs = NULL ) { comps <- .mashResolveComponents( priorComponents, mashData, components, - nPcs + nPcs, + componentArgs = componentArgs ) - if (engine == "cov_ed") { - .mashEngineCovEd(mashData, comps) + # Canonical components are fixed structural hypotheses: they go to the + # mash fit as they are. Only the data-driven set is refined -- the split + # mashr's own eQTL vignette makes. + refined <- if (engine == "none" || length(comps$dataDriven) == 0L) { + list(U = comps$dataDriven, w = NULL, loglik = NULL) + } else if (engine == "covEd") { + .mashEngineCovEd(mashData, comps$dataDriven, engineArgs) } else { - .mashEngineUd(mashData, engine, udControl) + .mashEngineUd( + mashData, + comps$dataDriven, + comps$canonical, + engineArgs + ) } + list( + U = c(refined$U, comps$canonical), + w = refined$w, + loglik = refined$loglik + ) } # Raw covariance components: caller-supplied `priorComponents` (validated) or @@ -739,14 +1070,16 @@ mashPriorCovariances <- function( priorComponents, mashData, components, - nPcs + nPcs, + componentArgs = NULL ) { priorComponents <- .mashAsUlist(priorComponents) if (is.null(priorComponents)) { return(.mashBuildComponents( mashData, components = components, - nPcs = nPcs + nPcs = nPcs, + componentArgs = componentArgs )) } if ( @@ -762,182 +1095,63 @@ mashPriorCovariances <- function( ) abort(msg) } - priorComponents -} - -# cov_ed engine: mashr's exported extreme-deconvolution wrapper (default -# algorithm = bovy) refines the components; mash() (upstream) learns the -# mixture weights. Returns list(U, w = NULL, loglik = NULL). -# @noRd -.mashEngineCovEd <- function(mashData, comps) { - U.ed <- mashr::cov_ed(mashData, Ulist_init = comps) - list(U = c(comps, U.ed), w = NULL, loglik = NULL) + # Caller-supplied components are covariances estimated from data, so they + # are the engine's input rather than fixed hypotheses. + list(canonical = NULL, dataDriven = priorComponents) } -# udr control list for the ud / ud_ted engines. +# udr control list for the ud / ud_ted engines: pecotmr's own settings, +# overlaid with whatever UdFitOptions() carried. No name translation -- +# `fitOpts` is already spelled the way udr spells it, which is the point of +# splitting ud_init's arguments out of this bundle. +# +# `unconstrained.update` is left to udr where udr chooses well, and pinned +# where it does not. udr defaults it to NA and resolves that in +# assign_prior_covariance_updates() as +# `ifelse(is.matrix(fit$V), "ted", "none")`: +# +# z scale (alpha = 1) fit$V stays a single shared matrix, so udr picks +# TED -- its own and the better estimator. Omit the +# field and let it. +# beta scale (alpha = 0) ud_init() expands the shared V into a per-variant +# one, so udr would pick "none" and leave the +# n_unconstrained components .mashEngineUd +# generated at their initialisation -- handing mash +# an unrefined prior with no error. Pin "ed", which +# does not need i.i.d. data. +# +# A caller overrides either way through UdFitOptions(), NA included. # @noRd -.mashUdControl <- function(engine, udControl, nCond) { - list( - unconstrained.update = if (engine == "ud_ted") "ted" else "ed", +.mashUdControl <- function(fitOpts, nCond, iid) { + defaults <- list( scaled.update = "fa", resid.update = "none", lambda = nCond, penalty.type = "iw", - maxiter = udControl$maxiter, - tol = udControl$tol, - tol.lik = udControl$tol.lik - ) -} - -# ud_fit with a directed error for the ud_ted / non-i.i.d. (per-variant SE) -# incompatibility. -# @noRd -.mashUdFit <- function(fit0, mashData, engine, udControl) { - control <- .mashUdControl(engine, udControl, ncol(mashData$Bhat)) - tryCatch( - udr::ud_fit(fit0, control = control, verbose = FALSE), - error = function(e) { - if ( - engine == "ud_ted" && str_detect(conditionMessage(e), "i.i.d") - ) { - msg <- glue( - "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." - ) - abort(msg) - } - # Not the ud_ted i.i.d. case rewrapped above -- re-raise the - # original condition unchanged so unrelated udr failures surface - # (and aren't swallowed as a NULL fit). - cnd_signal(e) - } + maxiter = 1000L, + tol = 1e-2, + tol.lik = 1e-2 ) + if (!iid) { + defaults$unconstrained.update <- "ed" + } + list_modify(defaults, !!!compact(as.list(fitOpts))) } -# ud / ud_ted engine (OPT-IN; udr with known numerical issues). Seeds canonical -# as the scaled prior and generates n_unconstrained data-driven matrices, -# returning U + weights + loglik directly. Returns list(U, w, loglik). +# One half of a covUdr selection, defaulting to that half's empty bundle: +# `engine = "covUdr"` as a bare string carries no options at all. # @noRd -.mashEngineUd <- function(mashData, engine, udControl) { - if (!requireNamespace("udr", quietly = TRUE)) { - msg <- glue( - "mashPriorCovariances: engine '{engine}' needs the udr package. ", - "Install it, or use the default 'cov_ed'." - ) - abort(msg) +.mashUdHalf <- function(engineArgs, key, ctor) { + if (is.null(engineArgs)) { + return(ctor()) } - udControl <- utils::modifyList( - list( - n_unconstrained = 50L, - maxiter = 1000L, - tol = 1e-2, - tol.lik = 1e-2 - ), - udControl - ) - U.can <- mashr::cov_canonical(mashData) - fit0 <- udr::ud_init( - mashData, - n_unconstrained = udControl$n_unconstrained, - U_scaled = U.can - ) - fit <- .mashUdFit(fit0, mashData, engine, udControl) - list(U = map(fit$U, "mat"), w = fit$w, loglik = fit$loglik) + (engineArgs[[key]] %||% ctor()) } - # ============================================================================= # 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. -#' Either shape the producers return is accepted: a bare named list of -#' covariance matrices (\code{\link{mashCovarianceComponents}}) or the -#' \code{list(U, w, loglik)} a \code{\link{mashPriorCovariances}} result -#' carries, which is unwrapped to its \code{U}. -#' @param vhat Residual correlation matrix (\code{V}); \code{NULL} -> identity. -#' @param fitOn Partition to learn the mixture weights on: \code{"random"} -#' (default, the standard unbiased choice) or \code{"strong"}. -#' @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}} -#' @examples -#' data(mashInputExample) -#' mi <- mashInputExample -#' mk <- function(b, s) { -#' qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), -#' study = "mash") -#' } -#' ssl <- list(strong = mk("strong.b", "strong.s"), -#' random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) -#' conds <- colnames(mi$strong.b) -#' vhat <- diag(length(conds)) -#' dimnames(vhat) <- list(conds, conds) -#' prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, -#' components = "canonical") -#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, -#' vhat = vhat) -#' @export -mashModelFit <- function( - sumStatsList, - alpha, - priorCovariances, - vhat = NULL, - fitOn = c("random", "strong"), - outputLevel = 4L, - inputScale = c("auto", "beta", "z"), - setSeed = 999 -) { - fitOn <- arg_match(fitOn) - inputScale <- arg_match(inputScale) - if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) - } - if (methods::is(sumStatsList, "SimpleList")) { - sumStatsList <- as.list(sumStatsList) - } - priorCovariances <- .mashAsUlist(priorCovariances) - .mashValidatePriorCovList(priorCovariances) - if (is.null(sumStatsList[[fitOn]])) { - msg <- glue( - "mashModelFit: `sumStatsList` has no '{fitOn}' entry to fit on." - ) - abort(msg) - } - if (!is.null(setSeed)) { - withr::local_seed(setSeed) - } - mashData <- .mashMakeMashData( - sumStatsList[[fitOn]], - fitOn, - vhat, - alpha, - inputScale - ) - mashr::mash(mashData, Ulist = priorCovariances, outputlevel = outputLevel) -} - # `priorCovariances` must be a non-empty named list of covariance matrices. # @noRd .mashValidatePriorCovList <- function(priorCovariances) { @@ -955,89 +1169,6 @@ mashModelFit <- function( } } -#' @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}} -#' @examples -#' data(mashInputExample) -#' mi <- mashInputExample -#' mk <- function(b, s) { -#' qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), -#' study = "mash") -#' } -#' ssl <- list(strong = mk("strong.b", "strong.s"), -#' random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) -#' conds <- colnames(mi$strong.b) -#' vhat <- diag(length(conds)) -#' dimnames(vhat) <- list(conds, conds) -#' prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, -#' components = "canonical") -#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, -#' vhat = vhat) -#' mashPosterior(model, mk("strong.b", "strong.s"), alpha = 0, vhat = vhat) -#' @export -mashPosterior <- function( - model, - sumStats, - alpha, - vhat = NULL, - excludeCondition = character(0), - outputPosteriorCov = TRUE, - inputScale = c("auto", "beta", "z") -) { - inputScale <- arg_match(inputScale) - if (!requireNamespace("mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mashr: ", - "https://cran.r-project.org/web/packages/mashr/index.html" - ) - abort(msg) - } - mats <- .mashSumStatsToMatrices(sumStats, "target", inputScale = inputScale) - ex <- .mashExcludeConditions( - mats$b, - mats$s, - vhat, - model, - as.character(excludeCondition) - ) - vhat <- if (is.null(ex$vhat)) diag(rep(1, ncol(ex$b))) else ex$vhat - mashData <- mashr::mash_set_data( - ex$b, - Shat = ex$s, - V = vhat, - alpha, - zero_Bhat_Shat_reset = 1000 - ) - mashr::mash_compute_posterior_matrices( - ex$model, - mashData, - output_posterior_cov = outputPosteriorCov - ) -} - # Drop `excludeCondition` columns from the target b/s (positionally, since a # supplied vhat may have no dimnames), subsetting vhat + the model's covariances # to match. Returns list(b, s, vhat, model); a no-op when nothing is excluded. @@ -1088,11 +1219,11 @@ mashPosterior <- function( #' \code{pair[2]}. #' @examples #' makePairwiseContrastCol(c("a", "b"), "mean_contrast_") +#' @importFrom checkmate assertCharacter #' @export makePairwiseContrastCol <- function(pair, template) { - template[pair[1]] <- 1 - template[pair[2]] <- -1 - template + assertCharacter(pair, len = 2L, any.missing = FALSE) + replace(template, pair, c(1, -1)) } #' Compute pairwise contrasts from mash posterior @@ -1124,6 +1255,7 @@ makePairwiseContrastCol <- function(pair, template) { #' pv <- array(diag(3) * 0.1, dim = c(3, 3, 1)) #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' fitMashContrast(1L, om, pm, pv) +#' @importFrom checkmate assertCount assertNumeric #' @export fitMashContrast <- function( index, @@ -1132,12 +1264,15 @@ fitMashContrast <- function( posteriorVcov, grouping = NULL ) { - populationNames <- colnames(posteriorMean) - if (!is.null(populationNames)) { - populationNames <- str_remove_all(populationNames, "BETA_") + assertCount(index, positive = TRUE) + assertNumeric(grouping, null.ok = TRUE) + rawNames <- colnames(posteriorMean) + populationNames <- if (is.null(rawNames)) { + NULL + } else { + str_remove_all(rawNames, "BETA_") } - origMeanVector <- origMean[index, ] - names(origMeanVector) <- populationNames + origMeanVector <- set_names(origMean[index, ], populationNames) tested <- names(origMeanVector[origMeanVector != 0]) if (length(tested) < 2) { return(NULL) @@ -1171,10 +1306,9 @@ fitMashContrast <- function( .mashContrastDesign <- function(tested, nPop, grouping) { pairwiseVector <- set_names(rep(0, nPop), tested) if (nPop <= 2) { - pairwiseVector[tested[1]] <- 1 - pairwiseVector[tested[2]] <- -1 + contrast <- replace(pairwiseVector, tested[1:2], c(1, -1)) return(matrix( - pairwiseVector, + contrast, ncol = 1, dimnames = list(tested, str_c(tested[1], "_vs_", tested[2])) )) @@ -1188,43 +1322,82 @@ fitMashContrast <- function( # conditions sharing their deviation weight. # @noRd .mashDeviationContrast <- function(tested, nPop, grouping) { - dev <- matrix(-1, nPop, nPop, dimnames = list(tested, tested)) - diag(dev) <- nPop - 1 - uniqueGroups <- unique(grouping) - for (grp in uniqueGroups[uniqueGroups > 0]) { - grpMask <- grouping == grp - grpSize <- sum(grpMask) - diag(dev)[grpMask] <- (nPop - 1) / grpSize - dev[grpMask, grpMask] <- (nPop - 1) / grpSize - } - colnames(dev) <- str_c(tested, "_deviation") - dev + # Three cases, stated directly: conditions sharing a group split the + # deviation weight between them, the diagonal carries the full weight, + # and everything else contributes -1. + sameAll <- outer(grouping, grouping, "==") + # Group sizes are counted off `sameAll`, not looked up in + # table(grouping) by as.character(grouping): that round-tripped every + # grouping code through its string form to find its own count. + groupSize <- as.integer(colSums(sameAll)) + sameGroup <- sameAll & matrix(grouping > 0, nPop, nPop) + matrix( + ifelse( + sameGroup, + matrix((nPop - 1) / groupSize, nPop, nPop), + ifelse(diag(TRUE, nPop), nPop - 1, -1) + ), + nPop, + nPop, + dimnames = list(tested, str_c(tested, "_deviation")) + ) } # Pairwise (all-pairs) contrasts, with grouped conditions' contributions split # evenly across the group. # @noRd +# One grouped condition's share of a pairwise column: the group's matched +# contribution split evenly across its members. +# @noRd +.mashSplitGroupShare <- function(column, dg, grouping, groups, pwCol) { + rowsInGroup <- names(grouping[grouping == dg]) + matchedRow <- rowsInGroup[is_in(rowsInGroup, groups)] + if (length(matchedRow) == 0) { + return(column) + } + replace(column, rowsInGroup, pwCol[matchedRow] / length(rowsInGroup)) +} + +# One pairwise column, with each grouped condition's contribution split +# across its group. A column whose two sides share a grouping (or that +# involves no grouped condition) is left as it is. +# @noRd +.mashAdjustPairwiseColumn <- function(col, pw, grouping) { + column <- pw[, col] + groups <- str_split(col, "_vs_")[[1]] + groupValues <- grouping[is_in(names(grouping), groups)] + relevant <- names(groupValues[groupValues > 0]) + if (n_distinct(groupValues) <= 1 || length(relevant) == 0) { + return(column) + } + reduce( + unique(groupValues[groupValues > 0]), + .mashSplitGroupShare, + grouping = grouping, + groups = groups, + pwCol = column, + .init = column + ) +} + .mashPairwiseContrast <- function(tested, grouping, pairwiseVector) { twoCombn <- combn(tested, 2) pwNames <- apply(twoCombn, 2, str_flatten, collapse = "_vs_") - pw <- apply(twoCombn, 2, makePairwiseContrastCol, pairwiseVector) - colnames(pw) <- pwNames - pwAdj <- pw - for (col in colnames(pw)) { - groups <- str_split(col, "_vs_")[[1]] - groupValues <- grouping[is_in(names(grouping), groups)] - relevant <- names(groupValues[groupValues > 0]) - if (n_distinct(groupValues) > 1 && length(relevant) > 0) { - for (dg in unique(groupValues[groupValues > 0])) { - rowsInGroup <- names(grouping[grouping == dg]) - matchedRow <- rowsInGroup[is_in(rowsInGroup, groups)] - if (length(matchedRow) > 0) { - pwAdj[rowsInGroup, col] <- pw[matchedRow, col] / - length(rowsInGroup) - } - } - } - } + pw <- `colnames<-`( + apply(twoCombn, 2, makePairwiseContrastCol, pairwiseVector), + pwNames + ) + pwAdj <- matrix( + unname(list_c(map( + colnames(pw), + .mashAdjustPairwiseColumn, + pw = pw, + grouping = grouping + ))), + nrow = nrow(pw), + ncol = ncol(pw), + dimnames = dimnames(pw) + ) pwAdj } @@ -1238,19 +1411,38 @@ fitMashContrast <- function( contrastSe, contrastP ) { - fid <- rownames(posteriorMean)[index] - if (is.null(fid)) { - fid <- as.character(index) - } - df <- tibble(feature_id = fid) + fid <- rownames(posteriorMean)[index] %||% as.character(index) # unname: contrast* carry contrastDesign colnames; tibble (unlike - # data.frame) preserves a named scalar's name on the column. - for (i in seq_along(cnames)) { - df[[str_c("mean_contrast_", cnames[i])]] <- unname(contrastDiff[i]) - df[[str_c("se_contrast_", cnames[i])]] <- unname(contrastSe[i]) - df[[str_c("p_contrast_", cnames[i])]] <- unname(contrastP[i]) - } - df + # data.frame) preserves a named scalar's name on the column. Columns are + # interleaved mean/se/p per contrast, which is the order the loop built. + cols <- list_c(map( + seq_along(cnames), + .mashContrastColumns, + cnames = cnames, + contrastDiff = contrastDiff, + contrastSe = contrastSe, + contrastP = contrastP + )) + tibble(feature_id = fid, !!!cols) +} + +# One contrast's three columns, named for it. +# @noRd +.mashContrastColumns <- function( + i, + cnames, + contrastDiff, + contrastSe, + contrastP +) { + set_names( + list( + unname(contrastDiff[i]), + unname(contrastSe[i]), + unname(contrastP[i]) + ), + str_c(c("mean_contrast_", "se_contrast_", "p_contrast_"), cnames[i]) + ) } #' Posterior contrast table over an entire mash posterior @@ -1287,6 +1479,7 @@ fitMashContrast <- function( #' pv <- array(diag(3) * 0.1, dim = c(3, 3, 1)) #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' mashPosteriorContrast(pm, pv, om) +#' @importFrom checkmate assertNumeric #' @export mashPosteriorContrast <- function( posteriorMean, @@ -1294,18 +1487,18 @@ mashPosteriorContrast <- function( origMean, grouping = NULL ) { - origMean <- origMean[, colnames(posteriorMean), drop = FALSE] - origMean[is.nan(origMean)] <- 0 + assertNumeric(grouping, null.ok = TRUE) + aligned <- origMean[, colnames(posteriorMean), drop = FALSE] + origMean <- replace(aligned, is.nan(aligned), 0) - parts <- map( + parts <- compact(map( seq_len(nrow(posteriorMean)), fitMashContrast, origMean = origMean, posteriorMean = posteriorMean, posteriorVcov = posteriorVcov, grouping = grouping - ) - parts <- compact(parts) + )) if (length(parts) == 0L) { return(tibble()) } @@ -1358,51 +1551,76 @@ mashPosteriorContrast <- function( #' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, #' vhat = vhat) #' updateMashModelCov(model, allSamples = conds, samples = conds[1:3]) +#' @importFrom checkmate assertCharacter #' @export updateMashModelCov <- function(mashModel, allSamples, samples) { + assertCharacter(allSamples, any.missing = FALSE) + assertCharacter(samples, any.missing = FALSE) + unwanted <- setdiff(allSamples, samples) cov <- mashModel$fitted_g$Ulist + retained <- discard(names(cov), .mashCovIsDropped, unwanted = unwanted) + resized <- set_names( + map(retained, .mashResizeCov, cov = cov, samples = samples), + retained + ) + keptPi <- discard( + names(mashModel$fitted_g$pi), + .mashPiMentionsDropped, + unwanted = unwanted + ) + list_assign( + mashModel, + fitted_g = list_assign( + mashModel$fitted_g, + Ulist = resized, + pi = mashModel$fitted_g$pi[keptPi] + ) + ) +} - # Remove matrices for dropped conditions - unwanted <- setdiff(allSamples, samples) - for (d in names(cov)) { - if (is_in(d, unwanted) || is_in(d, str_c("ED_", unwanted))) { - cov[[d]] <- NULL - } - } +# A covariance component belongs to a dropped condition, under either its +# bare name or its ED_ prefixed one. +# @noRd +.mashCovIsDropped <- function(d, unwanted) { + is_in(d, unwanted) || is_in(d, str_c("ED_", unwanted)) +} - # Resize remaining matrices to match retained conditions - for (d in names(cov)) { - if (is_in(d, samples)) { - # Condition-specific: single 1 on diagonal - m <- matrix(0, length(samples), length(samples)) - m[which(samples == d), which(samples == d)] <- 1 - cov[[d]] <- m - } else if (d == "identity") { - m <- matrix(0, length(samples), length(samples)) - m[1, 1] <- 1 - cov[[d]] <- m - } else if (is.null(colnames(cov[[d]]))) { - cov[[d]] <- cov[[d]][ - seq_along(samples), - seq_along(samples) - ] - } else { - cov[[d]] <- cov[[d]][samples, samples] - } - cov[[d]] <- as.matrix(cov[[d]]) - } +# A mixture-weight name mentioning any dropped condition. +# @noRd +.mashPiMentionsDropped <- function(nm, unwanted) { + any(map_lgl(unwanted, .mashNameMentions, nm = nm)) +} - mashModel$fitted_g$Ulist <- cov +# @noRd +.mashNameMentions <- function(s, nm) { + str_detect(nm, fixed(s)) +} - # Prune mixture weights for removed conditions - for (s in unwanted) { - dropIdx <- which(str_detect(names(mashModel$fitted_g$pi), fixed(s))) - if (length(dropIdx) > 0) { - mashModel$fitted_g$pi <- mashModel$fitted_g$pi[-dropIdx] - } +# One covariance component resized to the retained conditions. A +# condition-specific component is a single 1 on its own diagonal entry; +# `identity` is a single 1 in the first cell; anything else is subset by +# name when it has one, else positionally. +# @noRd +.mashResizeCov <- function(d, cov, samples) { + n <- length(samples) + if (is_in(d, samples)) { + at <- which(samples == d) + return(replace(matrix(0, n, n), (at - 1L) * n + at, 1)) + } + if (d == "identity") { + return(replace(matrix(0, n, n), 1L, 1)) } + if (is.null(colnames(cov[[d]]))) { + return(as.matrix(cov[[d]][seq_along(samples), seq_along(samples)])) + } + as.matrix(cov[[d]][samples, samples]) +} - mashModel +# One matrix sliced to (snps, samples), relabelled with the retained +# condition names. `snps` / `samples` are subscripts, so NULL is meaningful. +# @noRd +.mashSliceMatrix <- function(m, rows, cols) { + `colnames<-`(as.matrix(m[rows, cols]), cols) } #' Subset mash data matrices to specific SNPs and conditions @@ -1430,17 +1648,22 @@ updateMashModelCov <- function(mashModel, allSamples, samples) { #' vhat <- diag(3) #' dimnames(vhat) <- list(cond, cond) #' sliceMashData(dat, vhat = vhat, snps = 1:4, samples = NULL) +#' @importFrom checkmate assertList assertCharacter #' @export sliceMashData <- function(data, vhat, snps, samples) { - data$bhat <- as.matrix(data$bhat[snps, samples]) - data$sbhat <- as.matrix(data$sbhat[snps, samples]) - data$Z <- as.matrix(data$Z[snps, samples]) - vhat <- as.matrix(vhat[samples, samples]) - data$snp <- data$snp[is_in(data$snp, snps)] - colnames(data$bhat) <- colnames(data$sbhat) <- colnames(data$Z) <- colnames( - vhat - ) <- samples - list(data = data, vhat = vhat) + assertList(data) + # `snps` and `samples` are SUBSCRIPTS -- `data$bhat[snps, samples]` -- so + # character names, integer indices and NULL are all valid. No type + # assertion is correct here (the @example passes snps = 1:4 and + # samples = NULL). + sliced <- list_assign( + data, + bhat = .mashSliceMatrix(data$bhat, snps, samples), + sbhat = .mashSliceMatrix(data$sbhat, snps, samples), + Z = .mashSliceMatrix(data$Z, snps, samples), + snp = data$snp[is_in(data$snp, snps)] + ) + list(data = sliced, vhat = .mashSliceMatrix(vhat, samples, samples)) } #' Sanitize NaN/Inf values in mash data @@ -1452,11 +1675,19 @@ sliceMashData <- function(data, vhat, snps, samples) { #' @return The data list with sanitized values. #' @examples #' sanitizeMashData(list(strong = list(z = matrix(rnorm(9), 3, 3)))) +#' @importFrom checkmate assertList #' @export sanitizeMashData <- function(data) { - data$bhat[is.nan(data$bhat)] <- 0 - data$sbhat[is.nan(data$sbhat) | is.infinite(data$sbhat)] <- 1e3 - data + assertList(data) + list_assign( + data, + bhat = replace(data$bhat, is.nan(data$bhat), 0), + sbhat = replace( + data$sbhat, + is.nan(data$sbhat) | is.infinite(data$sbhat), + 1e3 + ) + ) } #' Random-Effects Meta-Analysis of Mash Pairwise Contrasts, per Condition @@ -1479,6 +1710,9 @@ sanitizeMashData <- function(data) { #' meta-analysis, forwarded to \code{metafor::rma(method = )}. Default #' \code{"DL"} (DerSimonian-Laird); other options include \code{"REML"}, #' \code{"ML"}, \code{"EB"}. +#' @param metaArgs Extra arguments for \code{metafor::rma()}, built with +#' \code{\link{RmaOptions}} -- \code{test = "knha"} in particular, the +#' small-study correction. #' @return A tibble with columns: #' \describe{ #' \item{condition}{The condition (context) name.} @@ -1502,8 +1736,10 @@ metaAnalysisPerCondition <- function( effectSizes, seValues, seCutoff = 0, - metaMethod = "DL" + metaMethod = "DL", + metaArgs = RmaOptions() ) { + .assertMethodOptions(metaArgs, "RmaOptions", "metaArgs") stopifnot(identical(dim(effectSizes), dim(seValues))) stopifnot(identical(colnames(effectSizes), colnames(seValues))) contrasts <- str_remove(colnames(effectSizes), "^mean_contrast_") @@ -1518,7 +1754,8 @@ metaAnalysisPerCondition <- function( seValues = seValues, contrasts = contrasts, seCutoff = seCutoff, - metaMethod = metaMethod + metaMethod = metaMethod, + metaArgs = metaArgs )) bind_rows(rows) } @@ -1531,7 +1768,8 @@ metaAnalysisPerCondition <- function( seValues, contrasts, seCutoff, - metaMethod + metaMethod, + metaArgs = list() ) { idx <- which(str_detect(colnames(effectSizes), condition)) if (length(idx) == 0) { @@ -1548,7 +1786,8 @@ metaAnalysisPerCondition <- function( condEffects = condEffects, condSes = condSes, seCutoff = seCutoff, - metaMethod = metaMethod + metaMethod = metaMethod, + metaArgs = metaArgs ) } @@ -1562,7 +1801,8 @@ metaAnalysisPerCondition <- function( es, se, seCutoff, - metaMethod + metaMethod, + metaArgs = list() ) { keep <- se > seCutoff & is.finite(es) & is.finite(se) es <- es[keep] @@ -1582,7 +1822,7 @@ metaAnalysisPerCondition <- function( I2 = NA_real_ )) } - ma <- .rmaMeta(es, se, method = metaMethod) + ma <- .rmaMeta(es, se, method = metaMethod, metaArgs = metaArgs) tibble( condition = condition, contrast = contrast, @@ -1607,6 +1847,9 @@ metaAnalysisPerCondition <- function( #' columns. #' @param metaMethod Between-study variance estimator forwarded to #' \code{metafor::rma} (default \code{"REML"}). +#' @param metaArgs Extra arguments for \code{metafor::rma()}, built with +#' \code{\link{RmaOptions}} -- \code{test = "knha"} in particular, the +#' small-study correction. #' @return A \code{data.frame} with \code{condition} and \code{zScore}. #' @seealso \code{\link{nSignificantScore}}, \code{\link{scoreFromCs}} #' @examples @@ -1618,8 +1861,15 @@ metaAnalysisPerCondition <- function( #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' cr <- fitMashContrast(1L, om, pm, pv) #' calculateFeatureScores(cr, metaMethod = "mean") +#' @importFrom checkmate assertString #' @export -calculateFeatureScores <- function(contrastResult, metaMethod = "REML") { +calculateFeatureScores <- function( + contrastResult, + metaMethod = "REML", + metaArgs = RmaOptions() +) { + assertString(metaMethod) + .assertMethodOptions(metaArgs, "RmaOptions", "metaArgs") cr <- as_tibble(contrastResult) effCols <- names(cr)[str_detect(names(cr), "mean_contrast_.*deviation")] if (length(effCols) == 0L) { @@ -1629,7 +1879,8 @@ calculateFeatureScores <- function(contrastResult, metaMethod = "REML") { effCols, .metaContrastZScore, cr = cr, - metaMethod = metaMethod + metaMethod = metaMethod, + metaArgs = metaArgs ) tibble( condition = str_remove( @@ -1661,8 +1912,10 @@ calculateFeatureScores <- function(contrastResult, metaMethod = "REML") { #' dimnames(pv) <- list(c("a", "b", "c"), c("a", "b", "c"), NULL) #' cr <- fitMashContrast(1L, om, pm, pv) #' nSignificantScore(cr, pCutoff = 0.05) +#' @importFrom checkmate assertNumber #' @export nSignificantScore <- function(contrastResult, pCutoff = 1e-5) { + assertNumber(pCutoff, lower = 0, upper = 1) cr <- as_tibble(contrastResult) pCols <- names(cr)[str_detect(names(cr), "p_contrast_.*deviation")] if (length(pCols) == 0L) { @@ -1713,8 +1966,8 @@ scoreFromCs <- function(fineMapping, contrastResults, condition) { return(NA_real_) } leadRows <- bind_rows(map(css, .csLeadRow, fineMapping = fineMapping)) - cr <- as_tibble(contrastResults) - cr <- filter(cr, is_in(.data$feature_id, leadRows$variants)) + cr <- as_tibble(contrastResults) |> + filter(is_in(.data$feature_id, leadRows$variants)) if (nrow(cr) == 0L) { return(NA_real_) } @@ -1757,7 +2010,8 @@ scoreFromCs <- function(fineMapping, contrastResults, condition) { condEffects, condSes, seCutoff, - metaMethod + metaMethod, + metaArgs = list() ) { .metaOneContrast( condition, @@ -1765,26 +2019,27 @@ scoreFromCs <- function(fineMapping, contrastResults, condition) { abs(as.numeric(condEffects[, i])), as.numeric(condSes[, i]), seCutoff, - metaMethod + metaMethod, + metaArgs ) } # Meta-analysis z-score (mean/se) for one mean-contrast column, NA when empty. # @noRd -.metaContrastZScore <- function(ec, cr, metaMethod) { +.metaContrastZScore <- function(ec, cr, metaMethod, metaArgs = list()) { seCol <- str_replace(ec, "^mean_contrast", "se_contrast") if (!is_in(seCol, 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] + esAll <- abs(as.numeric(cr[[ec]])) + seAll <- as.numeric(cr[[seCol]]) + keep <- is.finite(esAll) & is.finite(seAll) & seAll > 0 + es <- esAll[keep] + se <- seAll[keep] if (length(es) < 1L) { return(NA_real_) } - ma <- .rmaMeta(es, se, method = metaMethod) + ma <- .rmaMeta(es, se, method = metaMethod, metaArgs = metaArgs) ma$mean / ma$se } @@ -1802,3 +2057,1591 @@ scoreFromCs <- function(fineMapping, contrastResults, condition) { tmp <- filter(fineMapping, .data$cs_order == cs) filter(tmp, .data$pip == max(.data$pip)) } + + +# ============================================================================= +# Input preparation +# ----------------------------------------------------------------------------- +# Assembling and filtering the matrices mash is fitted on. This is a +# preparatory step of the pipeline, not an engine interface -- nothing here +# calls mashr; the engine calls live in mashWrapper.R. +# ============================================================================= + +# Filter rows of a z-score matrix by significance p-value cutoff. +# Returns integer indices of rows where any |z| exceeds the threshold. +# @noRd +filterBySignificance <- function(zMatrix, sigPCutoff) { + zThreshold <- sqrt(stats::qchisq(sigPCutoff, df = 1, lower.tail = FALSE)) + which(apply(zMatrix, 1, .mashRowExceeds, zThreshold = zThreshold)) +} + +# Coerce to a numeric matrix and replace every NaN / Inf / NA cell with +# `replaceWith`. Accepts a data.frame or a matrix and always returns a matrix: +# mash operates on matrices, so the cleaning is a direct matrix op rather than a +# data.frame round-trip. +# @noRd +.mashReplaceValues <- function(x, replaceWith) { + m <- `storage.mode<-`(as.matrix(x), "double") + replace(m, is.nan(m) | is.infinite(m) | is.na(m), replaceWith) +} + +# Coerce z-scores to a matrix (NaN/Inf/NA -> 0) and, when a missing-rate +# threshold is given, drop rows falling below it. +# @noRd +.mashProcessZ <- function(zData, filterByMissingRate) { + cleaned <- .mashReplaceValues(zData, 0) + if (is.null(filterByMissingRate)) { + return(cleaned) + } + proportionNonzero <- apply(cleaned, 1, .mashRowNonzeroRate) + cleaned[proportionNonzero >= filterByMissingRate, , drop = FALSE] +} + +#' Filter invalid summary statistics for mash input +#' +#' Assemble and clean a per-condition effect-size / z-score matrix for +#' \code{mashr}, dropping variants with invalid or insufficiently-observed +#' statistics. +#' +#' @param datList A named list of summary-statistic data frames / matrices. +#' @param bhat Optional name of the effect-size element in \code{datList}. +#' @param sbhat Optional name of the standard-error element in \code{datList}. +#' @param z Optional name of the z-score element in \code{datList}. +#' @param btoz Logical. If \code{TRUE}, derive z-scores from +#' \code{bhat}/\code{sbhat}. +#' @param sigPCutoff Numeric. Significance p-value cutoff for selecting strong +#' signals. Default \code{1e-6}. +#' @param filterByMissingRate Numeric in [0, 1]. Drop variants observed in fewer +#' than this fraction of conditions. Default \code{0.2}. +#' @return A cleaned list of summary-statistic matrices suitable for mash. +#' @importFrom vroom vroom +#' @examples +#' datList <- list(strong = list(z = matrix(rnorm(9), 3, 3))) +#' filterInvalidSummaryStat(datList) +#' @export +#' @importFrom checkmate assertFlag assertList assertNumber +filterInvalidSummaryStat <- function( + datList, + bhat = NULL, + sbhat = NULL, + z = NULL, + btoz = FALSE, + sigPCutoff = 1E-6, + filterByMissingRate = 0.2 +) { + assertList(datList) + assertFlag(btoz) + # NULL is how callers disable each filter. + assertNumber(sigPCutoff, lower = 0, upper = 1, null.ok = TRUE) + assertNumber( + filterByMissingRate, + lower = 0, + upper = 1, + null.ok = TRUE + ) + reset <- if ( + !is.null(bhat) && + !is.null(sbhat) && + all(is_in(c(bhat, sbhat), names(datList))) + ) { + .mashFilterBhatSbhat(datList, bhat, sbhat, filterByMissingRate) + } else { + datList + } + withZ <- if (btoz) { + .mashFilterBtoz(reset, bhat, sbhat, sigPCutoff) + } else { + reset + } + if (is.null(z)) { + return(withZ) + } + .mashFilterZ(withZ, filterByMissingRate, sigPCutoff) +} + +# Reset invalid bhat/sbhat cells (bhat -> 0, sbhat -> 1000) and, when a +# null/random partition is present, drop variants below `filterByMissingRate` +# non-missing. +# @noRd +.mashFilterBhatSbhat <- function(datList, bhat, sbhat, filterByMissingRate) { + if (is.null(datList[[bhat]]) || is.null(datList[[sbhat]])) { + return(datList) + } + reset <- list_assign( + datList, + !!!set_names( + list( + .mashReplaceValues(datList[[bhat]], 0), + .mashReplaceValues(datList[[sbhat]], 1000) + ), + c(bhat, sbhat) + ) + ) + hasNullOrRandom <- is_in("null.b", names(reset)) || + is_in("random.b", names(reset)) + if (!hasNullOrRandom || is.null(filterByMissingRate)) { + return(reset) + } + proportionNonzero <- apply(reset[[bhat]], 1, .mashRowNonzeroRate) + keep <- proportionNonzero >= filterByMissingRate + list_assign( + reset, + !!!set_names( + # `drop = FALSE`: one surviving variant would collapse these + # to vectors, and they go back into the mash data list where + # mashr expects an N x R matrix. + list( + reset[[bhat]][keep, , drop = FALSE], + reset[[sbhat]][keep, , drop = FALSE] + ), + c(bhat, sbhat) + ) + ) +} + +# Derive z = bhat / sbhat (into a `.z` or `z` slot) and apply the +# significance cutoff to strong signals. +# @noRd +.mashFilterBtoz <- function(datList, bhat, sbhat, sigPCutoff) { + perCondition <- any(str_detect(bhat, "\\.b$")) || + any(str_detect(sbhat, "\\.s$")) + zName <- if (perCondition) { + str_c(str_remove(bhat, "\\.b$"), ".z") + } else { + "z" + } + # list(NULL) not NULL: the z slot must EXIST and be empty, where assigning + # NULL would delete it. + zValue <- if (!is.null(datList[[bhat]]) && !is.null(datList[[sbhat]])) { + list(as.matrix(datList[[bhat]] / datList[[sbhat]])) + } else { + list(NULL) + } + withZ <- list_assign(datList, !!!set_names(zValue, zName)) + if (!is_in("strong.z", names(withZ)) || is.null(sigPCutoff)) { + return(withZ) + } + keepIndex <- filterBySignificance(withZ$strong.z, sigPCutoff) + list_assign( + withZ, + # `drop = FALSE`: exactly one significant variant is a common + # outcome, and a vector here would reach mashr as the strong set. + strong.z = withZ$strong.z[keepIndex, , drop = FALSE], + strong.b = withZ$strong.b[keepIndex, , drop = FALSE], + strong.s = withZ$strong.s[keepIndex, , drop = FALSE] + ) +} + +# Process each partition's z-matrix (missing-rate filter) and apply the +# significance cutoff to strong z-scores. +# @noRd +.mashFilterZ <- function(datList, filterByMissingRate, sigPCutoff) { + # Only partitions that are present and carry a z get rewritten: + # `list_assign()` would otherwise CREATE an absent component as NULL. + components <- keep( + intersect(c("strong", "random", "null"), names(datList)), + .mashPartitionHasZ, + datList = datList + ) + processed <- if (length(components) == 0L) { + datList + } else { + list_assign( + datList, + !!!set_names( + map( + components, + .mashProcessPartition, + datList = datList, + filterByMissingRate = filterByMissingRate + ), + components + ) + ) + } + if ( + is.null(processed$strong) || + is.null(processed$strong$z) || + is.null(sigPCutoff) + ) { + return(processed) + } + keepIndex <- filterBySignificance(processed$strong$z, sigPCutoff) + list_assign( + processed, + strong = list_assign( + processed$strong, + z = processed$strong$z[keepIndex, , drop = FALSE] + ) + ) +} + +# @noRd +.mashPartitionHasZ <- function(comp, datList) { + !is.null(datList[[comp]]) && !is.null(datList[[comp]]$z) +} + +# One partition with its z-matrix missing-rate filtered. +# @noRd +.mashProcessPartition <- function(comp, datList, filterByMissingRate) { + part <- datList[[comp]] + list_assign(part, z = .mashProcessZ(part$z, filterByMissingRate)) +} + +#' Filter conditions from mash prior mixture components +#' +#' Drop the conditions not in \code{conditionsToKeep} from each prior covariance +#' matrix in \code{U}, optionally removing components whose weight is below +#' \code{wCutoff}. +#' +#' @param conditionsToKeep Character vector of condition names to retain. +#' @param U Named list of prior covariance matrices (one per mixture component). +#' @param w Optional numeric vector of mixture weights aligned to \code{U}. +#' @param wCutoff Numeric. Drop components with weight below this. Default +#' \code{1e-4}. +#' @return A list with the filtered \code{U} (and \code{w} when supplied). +#' @importFrom purrr keep +#' @examples +#' conditionsToKeep <- c("cond1", "cond2") +#' cn <- c("cond1", "cond2", "cond3") +#' U <- list(shared = diag(3), corr = matrix(0.3, 3, 3) + diag(0.7, 3)) +#' U <- lapply(U, function(m) { +#' dimnames(m) <- list(cn, cn) +#' m +#' }) +#' filterMixtureComponents(conditionsToKeep = conditionsToKeep, U = U) +#' @export +#' @importFrom checkmate assertCharacter assertNumber +filterMixtureComponents <- function( + conditionsToKeep, + U, + w = NULL, + wCutoff = 1e-04 +) { + assertCharacter(conditionsToKeep, any.missing = FALSE) + assertNumber(wCutoff, lower = 0, finite = TRUE) + conditionsToFilter <- setdiff(colnames(U[[1]]), conditionsToKeep) + sumW <- sum(w) + subsetU <- .mashSubsetU(U, conditionsToKeep) + # Drop all-zero matrices, then those below the weight cutoff. + nonzero <- names(keep(subsetU, .mashMatrixNonzero)) + keepNames <- if (is.null(w)) { + nonzero + } else { + intersect(nonzero, names(w[w >= wCutoff])) + } + # Also drop the U components driven by non-relevant contexts: the EM can + # leave tiny non-zero diagonals, so all-zero removal alone won't drop them, + # yet real diagonal signal must be kept. + keptU <- subsetU[setdiff(keepNames, conditionsToFilter)] + keptW <- w[keepNames] + survivors <- keptW[!is_in(names(keptW), conditionsToFilter)] + # Rescale the surviving weights back to the original total. + rescaled <- (survivors / sum(survivors)) * sumW + msg <- glue( + "{length(keptU)} components of matrices remained after filtering." + ) + inform(msg) + list(U = keptU, w = rescaled) +} + +# Subset every U matrix to the kept conditions (erroring if a matrix lacks one). +# @noRd +.mashSubsetU <- function(U, conditionsToKeep) { + map(U, .mashSubsetMatrix, conditionsToKeep = conditionsToKeep) +} + + +# Draw the random + null sub-samples used to estimate the null correlation. +# @noRd +.mashExtractOneData <- function(dat, nRandom, nNull) { + if (is.null(dat)) { + return(NULL) + } + if (is_in("z", names(dat))) { + absZ <- abs(dat$z) + zData <- dat$z + } else { + absZ <- abs(dat$bhat / dat$sbhat) + zData <- NULL + } + random <- .mashSampleSubset(dat, zData, seq_len(nrow(absZ)), nRandom) + null <- .mashSampleNull(dat, zData, absZ, nNull) + list(random = random, null = null) +} + +# Sample up to `n` rows from `poolIdx` and return them as a z (or bhat/sbhat) +# list, matching the source scale. +# @noRd +.mashSampleSubset <- function(dat, zData, poolIdx, n) { + idx <- sample(poolIdx, min(n, length(poolIdx)), replace = FALSE) + if (!is.null(zData)) { + list(z = zData[idx, , drop = FALSE]) + } else { + list( + bhat = dat$bhat[idx, , drop = FALSE], + sbhat = dat$sbhat[idx, , drop = FALSE] + ) + } +} + +# Null subset: variants with max|z| < 2. Empty (with a warning) when there are +# none, or too few to estimate the null correlation. +# @noRd +.mashSampleNull <- function(dat, zData, absZ, nNull) { + nullId <- which(apply(absZ, 1, max) < 2) + if (length(nullId) == 0) { + msg <- glue( + "no variants are included in the null dataset because absZ > 2 ", + "for all variants in {dat$region %||% ''}" + ) + warn(msg) + return(list()) + } + if (length(nullId) < ncol(absZ)) { + msg <- glue( + "not enough null data to estimate null correlation in ", + "{dat$region %||% ''}" + ) + warn(msg) + return(list()) + } + .mashSampleSubset(dat, zData, nullId, nNull) +} + +#' Sample random and null variant subsets for mash +#' +#' Draw a random subset and a null (non-significant) subset of rows from a mash +#' data list, used to fit the mash prior and estimate the null correlation. +#' +#' @param dat A mash data list with \code{random} and \code{null} components. +#' @param nRandom Integer. Number of random rows to sample. +#' @param nNull Integer. Number of null rows to sample. +#' @param excludeCondition Optional character vector of conditions to exclude. +#' @param seed Optional integer random seed; \code{NULL} leaves the RNG +#' unchanged. +#' @return A list with sampled \code{random} and \code{null} matrices. +#' @examples +#' cond <- c("brain", "blood", "muscle") +#' p <- 8 +#' bhat <- matrix(rnorm(p * 3), p, 3, +#' dimnames = list(sprintf("chr1:%d:A:G", 100L * (1:p)), cond)) +#' sbhat <- matrix(abs(rnorm(p * 3)) + 0.1, p, 3, +#' dimnames = list(sprintf("chr1:%d:A:G", 100L * (1:p)), cond)) +#' dat <- list(bhat = bhat, sbhat = sbhat, Z = bhat / sbhat, +#' snp = sprintf("chr1:%d:A:G", 100L * (1:p))) +#' mashRandNullSample(dat, nRandom = 2L, nNull = 2L, +#' excludeCondition = character()) +#' @export +mashRandNullSample <- function( + dat, + nRandom, + nNull, + excludeCondition, + seed = NULL +) { + if (!is.null(seed)) { + withr::local_seed(seed) + } + + if (length(excludeCondition) > 0) { + colsToCheck <- if (is_in("z", names(dat))) "z" else "bhat" + if (!all(is_in(excludeCondition, colnames(dat[[colsToCheck]])))) { + msg <- glue( + "Error: excludeCondition are not present in ", + "{dat$region %||% ''}" + ) + abort(msg) + } + keys <- intersect(names(dat), c("z", "bhat", "sbhat")) + dat <- list_assign( + dat, + !!!set_names( + map(dat[keys], .mashDropConditions, drop = excludeCondition), + keys + ) + ) + } + .mashExtractOneData(dat, nRandom, nNull) +} + +# One matrix without the excluded condition columns. +# @noRd +.mashDropConditions <- function(m, drop) { + m[, setdiff(colnames(m), drop), drop = FALSE] +} + +#' Merge two mash data lists +#' +#' Row-bind the components of two mash data lists, returning the non-empty one +#' when the other is empty. +#' +#' @param resData The accumulated mash data list (may be empty). +#' @param oneData The mash data list to merge in. +#' @return The merged mash data list. +#' @examples +#' # Each object's variants must be uniquely keyed (row names); the two +#' # objects share the same conditions (columns), which are aligned by name. +#' a <- list(strong = list(z = matrix(rnorm(9), 3, 3, +#' dimnames = list( +#' c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), +#' c("t1", "t2", "t3"))))) +#' b <- list(strong = list(z = matrix(rnorm(9), 3, 3, +#' dimnames = list( +#' c("chr1:400:A:G", "chr1:500:A:G", "chr1:600:A:G"), +#' c("t1", "t2", "t3"))))) +#' mergeMashData(a, b) +#' @importFrom checkmate assertList +#' @export +mergeMashData <- function(resData, oneData) { + assertList(resData, null.ok = TRUE) + assertList(oneData, null.ok = TRUE) + if (length(resData) == 0 || is.null(resData)) { + return(oneData) + } + if (length(oneData) == 0 || is.null(oneData)) { + return(resData) + } + + set_names( + map( + names(oneData), + .mashCombineDatum, + oneData = oneData, + resData = resData + ), + names(oneData) + ) +} + +# 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")) { + return(.mashSumStatsMatrices(obj, inputScale)) + } + if (methods::is(obj, "FineMappingResultBase")) { + return(.mashFmrMatrices(obj, coverage)) + } + msg <- glue( + "mashInput: each element of `objects` must be a QtlSumStats, ", + "GwasSumStats, or FineMappingResult; got ", + "{str_flatten(class(obj), '/')}." + ) + abort(msg) +} + +# (Bhat, Shat, strongRows) from a SumStats object; strong = the max|z| variant +# per condition column, unioned. +# @noRd +.mashSumStatsMatrices <- function(obj, inputScale) { + mats <- .mashSumStatsToMatrices(obj, "mash input", inputScale = inputScale) + z <- mats$b / mats$s + strongRows <- sort(unique(apply(abs(z), 2L, which.max))) + list(b = mats$b, s = mats$s, strongRows = strongRows) +} + +# (Bhat, Shat, strongRows) from a FineMappingResult: pivot the marginal effects +# to a variants x contexts matrix pair; strong = each credible set's lead (max +# PIP) variant. +# @noRd +.mashFmrMatrices <- function(obj, coverage) { + rawMe <- getMarginalEffects(obj) + rawCs <- getCs(obj, coverage = coverage) + if (!all(is_in(c("variant_id", "context", "beta", "se"), names(rawMe)))) { + msg <- glue( + "mashInput: getMarginalEffects() must return variant_id/context/", + "beta/se columns; a FineMappingResult with >= 2 contexts is ", + "required." + ) + abort(msg) + } + pinned <- .mashFmrMethodPin(rawMe, rawCs) + me <- pinned$me + cs <- pinned$cs + contexts <- unique(me$context) + variants <- unique(me$variant_id) + empty <- matrix( + NA_real_, + length(variants), + length(contexts), + dimnames = list(variants, contexts) + ) + # One (variant, context) cell per long-format row; the rest stay NA. + cell <- cbind(match(me$variant_id, variants), match(me$context, contexts)) + list( + b = replace(empty, cell, me$beta), + s = replace(empty, cell, me$se), + strongRows = .mashFmrStrongRows(cs, variants) + ) +} + +# A multi-method FineMappingResult would duplicate (variant, context) cells; +# pin the first method so the pivot is unambiguous. +# @noRd +.mashFmrMethodPin <- function(me, cs) { + if (!is_in("method", names(me)) || n_distinct(me$method) <= 1L) { + return(list(me = me, cs = cs)) + } + m1 <- me$method[[1L]] + msg <- glue( + "mashInput: FineMappingResult carries multiple methods; using ", + "'{m1}'." + ) + warn(msg) + me <- filter(me, .data$method == m1) + if (is_in("method", names(cs))) { + cs <- filter(cs, .data$method == m1) + } + list(me = me, cs = cs) +} + +# The max-PIP variant among one credible set's rows. +# @noRd +.mashLeadVariant <- function(rows, cs) { + cs$variant_id[[rows[[which.max(cs$pip[rows])]]]] +} + +# Row indices (into `variants`) of each credible set's lead (max PIP) variant. +# @noRd +.mashFmrStrongRows <- function(cs, variants) { + csCol <- names(cs)[str_detect(names(cs), "^cs_")] + strongVar <- if ( + nrow(cs) > 0L && length(csCol) > 0L && is_in("pip", names(cs)) + ) { + grp <- interaction(cs$context, cs[[csCol[[1L]]]], drop = TRUE) + map_chr(split(seq_len(nrow(cs)), grp), .mashLeadVariant, cs = cs) + } else { + character(0) + } + strongRows <- sort(match(unique(strongVar), variants)) + strongRows[!is.na(strongRows)] +} + +# 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) { + msg <- glue( + "mashInput: fewer than 2 conditions remain for an object (after ", + "excludeCondition); mash operates across conditions and needs >= 2." + ) + abort(msg) + } + pool <- .mashIndependentPool(mats, independentVariants) + rn <- mashRandNullSample( + list(bhat = pool$poolB, sbhat = pool$poolS), + nRandom = nRandom, + nNull = nNull, + excludeCondition = excludeCondition, + seed = seed + ) + .mashPartitionOut(mats, keepCols, rn) +} + +# Random / null candidate pool, optionally restricted to LD-independent +# variants (so the background carries no LD-correlated SNPs, which would bias +# Vhat / weights). Strong is always drawn from the full set elsewhere. +# @noRd +.mashIndependentPool <- function(mats, independentVariants) { + if (is.null(independentVariants) || length(independentVariants) == 0L) { + return(list(poolB = mats$b, poolS = mats$s)) + } + # Rownames carry a "study::trait::" block prefix; strip to the bare variant + # id before matching (proper chrom/pos/allele via matchVariants). + rawIds <- str_remove(rownames(mats$b), ".*::") + keepIdx <- matchVariants( + rawIds, + independentVariants, + allowFlip = TRUE, + removeStrandAmbiguous = FALSE + )$idxA + if (length(keepIdx) == 0L) { + msg <- glue( + "mashInput: no variants matched the independent-variant list; ", + "the random/null background is empty for this object." + ) + warn(msg) + } + list( + poolB = mats$b[keepIdx, , drop = FALSE], + poolS = mats$s[keepIdx, , drop = FALSE] + ) +} + +# Assemble the flat strong/random/null (.b/.s) partition list, omitting any +# empty partition. +# @noRd +.mashPartitionOut <- function(mats, keepCols, rn) { + hasStrong <- length(mats$strongRows) > 0L + hasRandom <- !is.null(rn$random) && length(rn$random) > 0L + hasNull <- !is.null(rn$null) && length(rn$null) > 0L + compact(list( + strong.b = if (hasStrong) { + mats$b[mats$strongRows, keepCols, drop = FALSE] + }, + strong.s = if (hasStrong) { + mats$s[mats$strongRows, keepCols, drop = FALSE] + }, + random.b = if (hasRandom) rn$random$bhat, + random.s = if (hasRandom) rn$random$sbhat, + null.b = if (hasNull) rn$null$bhat, + null.s = if (hasNull) rn$null$sbhat + )) +} + +#' 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{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}} +#' @examples +#' data(qtlSumStatsMulticontextExample) +#' ss <- qtlSumStatsMulticontextExample +#' mashInput(objects = list(strong = ss, random = ss)) +#' @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 <- arg_match(inputScale) + if (!is.null(independentVariants)) { + independentVariants <- as.character(independentVariants) + } + objects <- .mashPrepObjects(objects) + cfg <- list( + nRandom = nRandom, + nNull = nNull, + excludeCondition = excludeCondition, + coverage = coverage, + inputScale = inputScale, + seed = seed, + independentVariants = independentVariants + ) + combined <- .mashCombinePartitions(objects, cfg) + .mashFinalizeCombined(combined, sigPCutoff, zOnly) +} + +# `objects` must be a non-empty list; unnamed lists get synthetic region names. +# @noRd +.mashPrepObjects <- function(objects) { + if (!is.list(objects) || length(objects) == 0L) { + msg <- glue( + "mashInput: `objects` must be a non-empty list of QtlSumStats ", + "and/or FineMappingResult objects." + ) + abort(msg) + } + if (is.null(names(objects)) || any(str_length(names(objects)) == 0L)) { + return(set_names(objects, str_c("region", seq_along(objects)))) + } + objects +} + +# Extract + merge each object's strong/random/null partitions, disambiguating +# rownames by region before accumulating. +# @noRd +.mashCombinePartitions <- function(objects, cfg) { + reduce( + map( + names(objects), + .mashRegionPartitions, + objects = objects, + cfg = cfg + ), + mergeMashData, + .init = list() + ) +} + +# One region's partitions, with its rownames region-prefixed so the merge can +# tell same-named variants from different regions apart. +# @noRd +.mashRegionPartitions <- function(nm, objects, cfg) { + part <- .mashObjectPartitions( + objects[[nm]], + nRandom = cfg$nRandom, + nNull = cfg$nNull, + excludeCondition = cfg$excludeCondition, + coverage = cfg$coverage, + inputScale = cfg$inputScale, + seed = cfg$seed, + independentVariants = cfg$independentVariants + ) + map(part, .mashPrefixRownames, nm = nm) +} + +# Coerce to data.frame, clean each partition + derive z (random/null before +# strong so the strong significance filter runs once), restore the strong +# 1-row matrix shape, add the strong XtX, and optionally drop b/s slots. +# @noRd +.mashFinalizeCombined <- function(combined, sigPCutoff, zOnly) { + # Each condition's z derivation sees the frame the previous one produced, + # so the sweep is a fold rather than a variable rewritten three times. + withZ <- reduce( + c("random", "null", "strong"), + .mashDeriveZFor, + sigPCutoff = sigPCutoff, + .init = map(combined, .mashAsDataFrameOrNull) + ) + shaped <- .mashAddXtX(.mashRestoreStrongShape(withZ)) + if (!zOnly) { + return(shaped) + } + shaped[!str_detect(names(shaped), "\\.(b|s)$")] +} + +# Derive z for one condition, when it carries both b and s. +# @noRd +.mashDeriveZFor <- function(combined, cond, sigPCutoff) { + bKey <- str_c(cond, ".b") + sKey <- str_c(cond, ".s") + if (is.null(combined[[bKey]]) || is.null(combined[[sKey]])) { + return(combined) + } + filterInvalidSummaryStat( + combined, + bhat = bKey, + sbhat = sKey, + btoz = TRUE, + sigPCutoff = sigPCutoff + ) +} + +# filterInvalidSummaryStat subsets strong without drop = FALSE, so a single +# surviving strong variant degrades to a vector; restore the 1-row matrix. +# @noRd +.mashRestoreStrongShape <- function(combined) { + # Only keys that exist AND lost their dim are rewritten; `list_assign()` + # would otherwise create an absent key as NULL. + needs <- keep( + intersect(c("strong.b", "strong.s", "strong.z"), names(combined)), + .mashLostDim, + combined = combined + ) + if (length(needs) == 0L) { + return(combined) + } + list_assign( + combined, + !!!set_names(map(combined[needs], .mashAsOneRow), needs) + ) +} + +# @noRd +.mashLostDim <- function(k, combined) { + !is.null(combined[[k]]) && is.null(dim(combined[[k]])) +} + +# @noRd +.mashAsOneRow <- function(v) { + matrix(v, nrow = 1L, dimnames = list(NULL, names(v))) +} + +# Strong XtX cross-product (conditions x conditions), when strong.z is present. +# @noRd +.mashAddXtX <- function(combined) { + if ( + is.null(combined$strong.z) || nrow(as.matrix(combined$strong.z)) == 0L + ) { + return(combined) + } + sz <- as.matrix(combined$strong.z) + list_assign(combined, XtX = crossprod(sz) / nrow(sz)) +} + +#' @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 +#' pipeline uses when only Z is available. Each column is one condition, and +#' conditions are distinguished by \code{context}, \code{trait}, or both: the +#' columns may be different cell types / tissues (contexts), different +#' molecular phenotypes (traits), or arbitrary context x trait pairs. +#' Chromosome / position are decoded from the row (variant) identifiers via +#' \code{\link{parseVariantId}} (with a synthetic-position fallback for ids +#' that do not encode coordinates); \code{A1} / \code{A2} / \code{N} are +#' placeholders because a Z-only input carries no alleles or sample sizes +#' (mash reads only Z). A pass-through \code{qcInfo} record is set so the +#' result clears the mash QC gate. +#' @param z Numeric matrix (variants x conditions). \code{rownames(z)} are +#' variant ids (ideally \code{chr:pos:A2:A1}); \code{colnames(z)} label the +#' conditions. +#' @param study Study identifier (recycled across conditions). +#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) +#' 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. +#' @param trait Condition trait label(s): a single value recycled across every +#' column, or a length-\code{ncol(z)} vector. Default \code{"mash"}. Pass +#' \code{colnames(z)} here (with a constant \code{context}) when the columns +#' are traits rather than contexts. +#' @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). +#' @importFrom GenomicRanges GRanges +#' @importFrom IRanges IRanges +#' @examples +#' panel <- readGenotypes( +#' system.file("extdata", "toy_ref.bed", package = "pecotmr")) +#' z <- matrix(rnorm(6), 2, 3, dimnames = list( +#' c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) +#' qtlSumStatsFromZMatrix(z = z, study = "s1", ldSketch = panel, +#' context = colnames(z), trait = "g1", genome = "hg38", n = 100) +#' @export +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)) { + msg <- glue( + "qtlSumStatsFromZMatrix: `z` must be a numeric variants x ", + "conditions matrix." + ) + abort(msg) + } + vids <- rownames(z) %||% str_c("var", seq_len(nrow(z))) + .qtlSumStatsFromMatrix( + vids = vids, + nCond = ncol(z), + study = study, + ldSketch = ldSketch, + context = context, + trait = trait, + genome = genome, + role = role, + mcolFn = .mashZMcolFn, + mcolArgs = list(a1 = a1, a2 = a2, z = z, n = n) + ) +} + +#' @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 genotype panel (see \code{\link{readGenotypes}}) +#' 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 +#' @examples +#' panel <- readGenotypes( +#' system.file("extdata", "toy_ref.bed", package = "pecotmr")) +#' bhat <- matrix(rnorm(6), 2, 3, dimnames = list( +#' c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) +#' shat <- matrix(0.1, 2, 3, dimnames = dimnames(bhat)) +#' qtlSumStatsFromBetaMatrix(bhat = bhat, shat = shat, study = "s1", +#' ldSketch = panel, context = colnames(bhat), trait = "g1", +#' genome = "hg38", n = 100) +#' @export +qtlSumStatsFromBetaMatrix <- function( + bhat, + shat, + study, + ldSketch = NULL, + context = colnames(bhat), + trait = "mash", + genome = "GRCh38", + n = 1000L, + a1 = "A", + a2 = "G", + role = "mash" +) { + .mashValidateBetaMatrix(bhat, shat) + vids <- rownames(bhat) %||% str_c("var", seq_len(nrow(bhat))) + .qtlSumStatsFromMatrix( + vids = vids, + nCond = ncol(bhat), + study = study, + ldSketch = ldSketch, + context = context, + trait = trait, + genome = genome, + role = role, + mcolFn = .mashBetaMcolFn, + mcolArgs = list(a1 = a1, a2 = a2, bhat = bhat, shat = shat, n = n) + ) +} + +# `bhat` / `shat` must be numeric variants x conditions matrices of identical +# dimension. +# @noRd +.mashValidateBetaMatrix <- function(bhat, shat) { + if (!is.matrix(bhat) || !is.numeric(bhat)) { + msg <- glue( + "qtlSumStatsFromBetaMatrix: `bhat` must be a numeric ", + "variants x conditions matrix." + ) + abort(msg) + } + if (!is.matrix(shat) || !is.numeric(shat)) { + msg <- glue( + "qtlSumStatsFromBetaMatrix: `shat` must be a numeric ", + "variants x conditions matrix." + ) + abort(msg) + } + if (!identical(dim(bhat), dim(shat))) { + msg <- glue( + "qtlSumStatsFromBetaMatrix: ", + "`bhat` ({str_flatten(dim(bhat), 'x')}) and ", + "`shat` ({str_flatten(dim(shat), 'x')}) ", + "must have identical dimensions." + ) + abort(msg) + } +} + +# Decode chrom/pos from the variant ids, synthesising where they do not +# parse. An unparseable id still needs a placeable coordinate: the GRanges +# is keyed by the variant id, so the range only has to be unique and +# ordered, not correct. +# @noRd +#' @importFrom rlang try_fetch +.qszmCoords <- function(vids) { + parsed <- try_fetch( + suppressWarnings(parseVariantId(vids)), + error = function(cnd) NULL + ) + rawChrom <- if (!is.null(parsed)) { + as.character(parsed$chrom) + } else { + rep(NA_character_, length(vids)) + } + rawPos <- if (!is.null(parsed)) { + suppressWarnings(as.integer(parsed$pos)) + } else { + rep(NA_integer_, length(vids)) + } + list( + chrom = replace( + rawChrom, + is.na(rawChrom) | str_length(rawChrom) == 0L, + "chr1" + ), + pos = replace(rawPos, is.na(rawPos), seq_along(rawPos)[is.na(rawPos)]) + ) +} + +# 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 +#' @importFrom rlang try_fetch +.qtlSumStatsFromMatrix <- function( + vids, + nCond, + study, + ldSketch, + context, + trait, + genome, + role, + mcolFn, + mcolArgs = list() +) { + context <- .qszmRecycle(context, nCond, "context") + trait <- .qszmRecycle(trait, nCond, "trait") + coords <- .qszmCoords(vids) + chrom <- coords$chrom + pos <- coords$pos + entries <- map( + seq_len(nCond), + .qszmEntry, + chrom = chrom, + pos = pos, + vids = vids, + mcolFn = mcolFn, + mcolArgs = mcolArgs + ) + QtlSumStats( + study = rep(as.character(study), nCond), + context = context, + trait = trait, + entry = entries, + genome = genome, + ldSketch = ldSketch, + qcInfo = list(role = role, entryAudit = vector("list", nCond)) + ) +} + +# Internal: recycle a condition-label argument (context / trait) to one value +# 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)) { + msg <- glue( + "qtlSumStats matrix constructor: `{what}` is NULL; pass a ", + "length-1 or length-{n} value (or give the matrix column ", + "names)." + ) + abort(msg) + } + v <- as.character(v) + if (length(v) == 1L) { + return(rep(v, n)) + } + if (length(v) == n) { + return(v) + } + msg <- glue( + "qtlSumStats matrix constructor: `{what}` must be length 1 or ", + "ncol={n}, got {length(v)}." + ) + abort(msg) +} + +# Internal: convert a single SumStats object (post-QC) into a (Bhat, Shat) +# pair of matrices keyed by context. Each row of the matrix corresponds to +# one (variantId x (study, trait)) cell from the SumStats entries; each +# column corresponds to a context (from QtlSumStats $context; from +# GwasSumStats $study, which is the per-study mash column). +# +# For QtlSumStats: +# * Pivots entries on (study, trait) so each (study, trait) becomes a +# block of rows and each context becomes a column. Missing +# (study, trait, context) cells are filled with NA. +# For GwasSumStats: +# * Each row of the collection is one study; we treat each study as a +# mash "context" (single block of rows per study, columns = studies). +# This is rarely used on its own but lets a flat GwasSumStats pass +# through alongside (or instead of) a QtlSumStats without special +# casing further upstream. +# +# Variant alignment within a (study, trait) block uses the entry's +# variant order; missing variants in any one context are filled with NA. +# NA in Bhat is mapped to 0 and NA in Shat is mapped to a large value +# (1000) inside mashr::mash_set_data via its `zero_Bhat_Shat_reset` +# pathway, matching the prior pipeline's handling of incomplete cells. +# @noRd +.mashSumStatsToMatrices <- function( + x, + role, + inputScale = c("auto", "beta", "z") +) { + inputScale <- arg_match(inputScale) + .mashValidateInput(x, role) + setup <- .mashBlockSetup(x) + resolvedScale <- .mashResolveScale(x, role, inputScale) + blocks <- .mashBuildBlockMatrices(x, setup, resolvedScale) + bhat <- exec(rbind, !!!blocks$bhat) + shat <- exec(rbind, !!!blocks$shat) + # bhat NA -> 0, shat NA / <= 0 -> 1000 (the mash_set_data + # zero_Bhat_Shat_reset convention; missing-cell variants do not drive the + # fit). + list( + b = replace(bhat, is.na(bhat), 0), + s = replace(shat, is.na(shat) | shat <= 0, 1000) + ) +} + +# The SumStats input must be a QC'd, non-empty QtlSumStats / GwasSumStats. +# @noRd +.mashValidateInput <- function(x, role) { + if (!methods::is(x, "QtlSumStats") && !methods::is(x, "GwasSumStats")) { + msg <- glue( + "mashPipeline: '{role}' input must be a QtlSumStats or ", + "GwasSumStats; got {str_flatten(class(x), '/')}." + ) + abort(msg) + } + if (length(getQcInfo(x)) == 0L) { + msg <- glue( + "mashPipeline: '{role}' SumStats has no QC info ", + "(length(getQcInfo(x)) == 0L). ", + "Run summaryStatsQc() on the SumStats before passing it to ", + "mashPipeline()." + ) + abort(msg) + } + if (nrow(x) == 0L) { + msg <- glue( + "mashPipeline: '{role}' SumStats has no entries (nrow == 0)." + ) + abort(msg) + } +} + +# Block / column layout: QtlSumStats blocks by (study, trait) with context +# columns; GwasSumStats blocks by study with study columns. +# @noRd +.mashBlockSetup <- function(x) { + isQtl <- methods::is(x, "QtlSumStats") + studyCol <- as.character(x$study) + if (isQtl) { + traitCol <- as.character(x$trait) + contextCol <- as.character(x$context) + blockKeys <- str_c(studyCol, traitCol, sep = "::") + columnLabels <- unique(contextCol) + } else { + traitCol <- NULL + contextCol <- studyCol + blockKeys <- studyCol + columnLabels <- unique(studyCol) + } + list( + isQtl = isQtl, + studyCol = studyCol, + traitCol = traitCol, + contextCol = contextCol, + blockKeys = blockKeys, + columnLabels = columnLabels + ) +} + +# Resolve which (Bhat, Shat) source to pull: "beta" (BETA/SE) or "z" +# (Z, Shat=1). +# "auto" picks beta when every entry has BETA+SE, else z; mixed inputs error. +# @noRd +.mashResolveScale <- function(x, role, inputScale) { + entries <- .collectionEntries(x) + caps <- map(entries, .mashEntryCaps) + allHaveBetaSe <- all(map_lgl(caps, "hasBetaSe")) + allHaveZ <- all(map_lgl(caps, "hasZ")) + switch( + inputScale, + beta = .mashScaleBeta(allHaveBetaSe, role), + z = .mashScaleZ(allHaveZ, role), + auto = .mashScaleAuto(allHaveBetaSe, allHaveZ, role) + ) +} + +# @noRd +.mashScaleBeta <- function(allHaveBetaSe, role) { + if (!allHaveBetaSe) { + msg <- glue( + "mashPipeline: inputScale = 'beta' requires every '{role}' ", + "entry to carry both BETA and SE mcols." + ) + abort(msg) + } + "beta" +} + +# @noRd +.mashScaleZ <- function(allHaveZ, role) { + if (!allHaveZ) { + msg <- glue( + "mashPipeline: inputScale = 'z' requires every '{role}' entry ", + "to carry a Z mcol." + ) + abort(msg) + } + "z" +} + +# @noRd +.mashScaleAuto <- function(allHaveBetaSe, allHaveZ, role) { + if (allHaveBetaSe) { + return("beta") + } + if (allHaveZ) { + return("z") + } + msg <- glue( + "mashPipeline: '{role}' SumStats has no usable scale - every ", + "entry must carry (BETA, SE) or Z mcols." + ) + abort(msg) +} + +# Per (study, trait) block, a variant x context Bhat / Shat matrix pair. +# @noRd +.mashBuildBlockMatrices <- function(x, setup, resolvedScale) { + blocks <- map( + unique(setup$blockKeys), + .mashBlockMatrix, + x = x, + setup = setup, + resolvedScale = resolvedScale + ) + list(bhat = map(blocks, "b"), shat = map(blocks, "s")) +} + +# The per-context (Bhat, Shat) vectors for one block: the variant universe is +# the first-seen union of SNP ids across the block's contexts. +# @noRd +.mashBlockPerContext <- function(x, rowsInBlock, setup, resolvedScale) { + requireCols <- if (resolvedScale == "beta") { + c("SNP", "BETA", "SE") + } else { + c("SNP", "Z") + } + rows <- map( + rowsInBlock, + .mashContextRow, + x = x, + setup = setup, + requireCols = requireCols, + resolvedScale = resolvedScale + ) + contexts <- map_chr(rows, "context") + # A later row overwrites an earlier one sharing a context, as the keyed + # assignment did; the variant order is first-seen across all rows. + lastPerContext <- !duplicated(contexts, fromLast = TRUE) + list( + variantOrder = unique(.mashConcatChr(map(rows, "snps"))), + perContextB = set_names( + map(rows[lastPerContext], "b"), + contexts[lastPerContext] + ), + perContextSe = set_names( + map(rows[lastPerContext], "se"), + contexts[lastPerContext] + ) + ) +} + +# @noRd +.mashConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + as.character(list_c(pieces)) +} + +# One row's effect / standard-error vectors for its context. On the z scale +# the standard errors are unit by construction. +# @noRd +.mashContextRow <- function(rIdx, x, setup, requireCols, resolvedScale) { + df <- .mashRowDf(x, rIdx, setup, requireCols) + snps <- df$variant_id + onBeta <- resolvedScale == "beta" + list( + context = setup$contextCol[[rIdx]], + snps = snps, + b = set_names(if (onBeta) df$beta else df$z, snps), + se = set_names( + if (onBeta) df$se else rep(1, length(snps)), + snps + ) + ) +} + +# One row's sumstat data.frame (QtlSumStats keyed by study/context/trait; +# GwasSumStats by study). +# @noRd +.mashRowDf <- function(x, rIdx, setup, requireCols) { + if (setup$isQtl) { + getSumStatsDf( + x, + study = setup$studyCol[[rIdx]], + context = setup$contextCol[[rIdx]], + trait = setup$traitCol[[rIdx]], + require = requireCols + ) + } else { + getSumStatsDf(x, study = setup$studyCol[[rIdx]], require = requireCols) + } +} + +# Assemble one block's (variant x context) Bhat / Shat matrices, disambiguating +# rownames by block key to avoid silent cross-block dedup. +# @noRd +.mashBlockMatrix <- function(bkey, x, setup, resolvedScale) { + rowsInBlock <- which(setup$blockKeys == bkey) + pc <- .mashBlockPerContext(x, rowsInBlock, setup, resolvedScale) + # Every context owns one column, so each is built whole and the columns + # are laid side by side -- no scatter into a preallocated matrix, and the + # block-qualified rownames go on at construction. + dims <- list( + str_c(bkey, pc$variantOrder, sep = "::"), + setup$columnLabels + ) + list( + b = .mashContextMatrix(pc$perContextB, pc$variantOrder, dims), + s = .mashContextMatrix(pc$perContextSe, pc$variantOrder, dims) + ) +} + +# One context's column, aligned to `variantOrder`. Indexing a named vector by +# a variant it lacks yields NA, which is the unfilled cell. +# @noRd +.mashContextColumn <- function(ctx, perContext, variantOrder) { + v <- perContext[[ctx]] + if (is.null(v)) { + return(rep(NA_real_, length(variantOrder))) + } + unname(v[variantOrder]) +} + +# @noRd +.mashContextMatrix <- function(perContext, variantOrder, dims) { + cols <- map( + dims[[2L]], + .mashContextColumn, + perContext = perContext, + variantOrder = variantOrder + ) + matrix( + unname(list_c(cols)), + nrow = length(variantOrder), + ncol = length(dims[[2L]]), + dimnames = dims + ) +} + +# ---- map/apply helpers (lambda-free callbacks) --------------------------- + +# TRUE when any |z| in a matrix row reaches the significance threshold. +# @noRd +.mashRowExceeds <- function(row, zThreshold) { + any(abs(row) >= zThreshold) +} + +# The fraction of non-zero entries in a matrix row. +# @noRd +.mashRowNonzeroRate <- function(row) { + mean(row != 0) +} + +# TRUE when a covariance matrix is not identically zero. +# @noRd +.mashMatrixNonzero <- function(mat) { + !all(mat == 0) +} + +# Subset one U matrix to the kept conditions (erroring if any is absent). +# @noRd +.mashSubsetMatrix <- function(mat, conditionsToKeep) { + missingConditions <- setdiff(conditionsToKeep, colnames(mat)) + if (length(missingConditions) > 0) { + msg <- glue( + "Condition(s) {str_flatten(missingConditions, ', ')} ", + "not found in matrix" + ) + abort(msg) + } + mat[conditionsToKeep, conditionsToKeep] +} + +# Merge partition `d` of two mash data lists: a column-aligned row-bind (the two +# objects may measure different condition sets). bind_rows unions the columns, +# filling gaps with NA -> NaN. Returns a base data.frame because this backs the +# exported mergeMashData(), whose result is column-accessed (`$cond`); the +# mashInput pipeline then coerces these frames back to matrices. The variant-id +# rownames are load-bearing -- they survive (via as.matrix) as the output +# matrices' dimnames (tested, e.g. rownames(mashInput(...)$strong.z)), which a +# tibble (no rownames) would drop. Rows are APPENDED (each object's variants are +# distinct, disambiguated by the region prefix), so the row keys must be unique +# across the two sides -- a collision means the prefix invariant broke, and we +# error loudly rather than silently stack. +# @noRd +.mashCombineDatum <- function(d, oneData, resData) { + od <- oneData[[d]] + rd <- resData[[d]] + if (length(od) == 0 || is.null(od)) { + return(rd) + } + if (is.null(rd) || length(rd) == 0) { + return(od) + } + rnRes <- rownames(as.data.frame(rd)) + rnOne <- rownames(as.data.frame(od)) + if (anyDuplicated(c(rnRes, rnOne)) > 0L) { + abort(glue( + "mergeMashData: duplicate variant ids across the merged ", + "partitions -- each object's variants must be uniquely keyed ", + "(the mashInput region prefix guarantees this). A collision ", + "means two objects share a name or the prefix invariant broke." + )) + } + joined <- bind_rows(as.data.frame(rd), as.data.frame(od)) + # NaN, not NA: mash reads a missing cell as NaN. + combined <- replace(joined, is.na(joined), NaN) + `rownames<-`(combined, c(rnRes, rnOne)) +} + +# Region-prefix one partition matrix's rownames (no-op for empty/NULL). +# @noRd +.mashPrefixRownames <- function(m, nm) { + if (is.null(m) || nrow(m) == 0L) { + return(m) + } + `rownames<-`(m, str_c(rownames(m), nm, sep = "_")) +} + +# Coerce one partition to a data.frame (NULL passes through). Kept as a base +# data.frame (not a tibble) so the variant-id rownames survive to the output +# matrices -- see .mashCombineDatum. +# @noRd +.mashAsDataFrameOrNull <- function(m) { + if (is.null(m)) { + return(NULL) + } + as.data.frame(m) +} + +# One condition's GRanges entry, mcols from `mcolFn(j, vids, )`. +# @noRd +.qszmEntry <- function(j, chrom, pos, vids, mcolFn, mcolArgs) { + gr <- GenomicRanges::GRanges( + seqnames = chrom, + ranges = IRanges::IRanges(start = pos, width = 1L) + ) + mcolCallArgs <- c(list(j, vids), mcolArgs) + S4Vectors::`mcols<-`(gr, value = exec(mcolFn, !!!mcolCallArgs)) +} + +# mcols for condition `j` of a z-scale matrix (Z + placeholder N/alleles). +# @noRd +.mashZMcolFn <- function(j, vids, a1, a2, z, n) { + 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)) + ) +} + +# mcols for condition `j` of a beta-scale pair (BETA/SE + derived Z). +# @noRd +.mashBetaMcolFn <- function(j, vids, a1, a2, bhat, shat, n) { + 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)) + ) +} + +# The (hasBetaSe, hasZ) scale capabilities of one sumstats entry. +# @noRd +.mashEntryCaps <- function(e) { + mc <- S4Vectors::mcols(e) + list( + hasBetaSe = all(is_in(c("BETA", "SE"), colnames(mc))), + hasZ = is_in("Z", colnames(mc)) + ) +} diff --git a/R/mashWrapper.R b/R/mashWrapper.R index 9fe94e81d..663f15857 100644 --- a/R/mashWrapper.R +++ b/R/mashWrapper.R @@ -1,1400 +1,929 @@ -# Filter rows of a z-score matrix by significance p-value cutoff. -# Returns integer indices of rows where any |z| exceeds the threshold. -# @noRd -filterBySignificance <- function(zMatrix, sigPCutoff) { - zThreshold <- sqrt(stats::qchisq(sigPCutoff, df = 1, lower.tail = FALSE)) - which(apply(zMatrix, 1, .mashRowExceeds, zThreshold = zThreshold)) -} - -# Coerce to a numeric matrix and replace every NaN / Inf / NA cell with -# `replaceWith`. Accepts a data.frame or a matrix and always returns a matrix: -# mash operates on matrices, so the cleaning is a direct matrix op rather than a -# data.frame round-trip. -# @noRd -.mashReplaceValues <- function(x, replaceWith) { - m <- as.matrix(x) - storage.mode(m) <- "double" - m[is.nan(m) | is.infinite(m) | is.na(m)] <- replaceWith - m -} +# ============================================================================= +# mash / udr engine interface +# ----------------------------------------------------------------------------- +# Every call into mashr, udr, CorShrink and flashier lives here; +# mashPipeline.R orchestrates the stages, holds the Param bundles and +# prepares the input. The split is mechanical, so a reader can check it: a +# block belongs here if it calls one of those packages, or is the Options bag +# that forwards arguments to such a call. +# +# `mashResidualCorrelation()`, `mashCovarianceComponents()` and +# `mashPriorCovariances()` deliberately stay in mashPipeline.R: they name +# pipeline stages and dispatch among the helpers below without calling an +# engine themselves. +# ============================================================================= -# Coerce z-scores to a matrix (NaN/Inf/NA -> 0) and, when a missing-rate -# threshold is given, drop rows falling below it. +# method 'simple': mashr's estimate_null_correlation_simple on the null set. # @noRd -.mashProcessZ <- function(zData, filterByMissingRate) { - zData <- .mashReplaceValues(zData, 0) - - if (!is.null(filterByMissingRate)) { - proportionNonzero <- apply(zData, 1, .mashRowNonzeroRate) - zData <- zData[proportionNonzero >= filterByMissingRate, , drop = FALSE] - } - - return(zData) -} - -#' Filter invalid summary statistics for mash input -#' -#' Assemble and clean a per-condition effect-size / z-score matrix for -#' \code{mashr}, dropping variants with invalid or insufficiently-observed -#' statistics. -#' -#' @param datList A named list of summary-statistic data frames / matrices. -#' @param bhat Optional name of the effect-size element in \code{datList}. -#' @param sbhat Optional name of the standard-error element in \code{datList}. -#' @param z Optional name of the z-score element in \code{datList}. -#' @param btoz Logical. If \code{TRUE}, derive z-scores from -#' \code{bhat}/\code{sbhat}. -#' @param sigPCutoff Numeric. Significance p-value cutoff for selecting strong -#' signals. Default \code{1e-6}. -#' @param filterByMissingRate Numeric in [0, 1]. Drop variants observed in fewer -#' than this fraction of conditions. Default \code{0.2}. -#' @return A cleaned list of summary-statistic matrices suitable for mash. -#' @importFrom vroom vroom -#' @examples -#' datList <- list(strong = list(z = matrix(rnorm(9), 3, 3))) -#' filterInvalidSummaryStat(datList) -#' @export -filterInvalidSummaryStat <- function( - datList, - bhat = NULL, - sbhat = NULL, - z = NULL, - btoz = FALSE, - sigPCutoff = 1E-6, - filterByMissingRate = 0.2 +.mashResidCorSimple <- function( + sumStatsList, + alpha, + inputScale, + mashDataArgs, + corArgs ) { - if ( - !is.null(bhat) && - !is.null(sbhat) && - all(is_in(c(bhat, sbhat), names(datList))) - ) { - datList <- .mashFilterBhatSbhat( - datList, - bhat, - sbhat, - filterByMissingRate + if (is.null(sumStatsList$null)) { + msg <- glue( + "mashResidualCorrelation: method 'simple' requires a 'null' entry ", + "in `sumStatsList`." ) + abort(msg) } - if (btoz) { - datList <- .mashFilterBtoz(datList, bhat, sbhat, sigPCutoff) - } - if (!is.null(z)) { - datList <- .mashFilterZ(datList, filterByMissingRate, sigPCutoff) - } - datList -} - -# Reset invalid bhat/sbhat cells (bhat -> 0, sbhat -> 1000) and, when a -# null/random partition is present, drop variants below `filterByMissingRate` -# non-missing. -# @noRd -.mashFilterBhatSbhat <- function(datList, bhat, sbhat, filterByMissingRate) { - if (is.null(datList[[bhat]]) || is.null(datList[[sbhat]])) { - return(datList) - } - datList[[bhat]] <- .mashReplaceValues(datList[[bhat]], 0) - datList[[sbhat]] <- .mashReplaceValues(datList[[sbhat]], 1000) - hasNullOrRandom <- is_in("null.b", names(datList)) || - is_in("random.b", names(datList)) - if (!hasNullOrRandom || is.null(filterByMissingRate)) { - return(datList) - } - proportionNonzero <- apply(datList[[bhat]], 1, .mashRowNonzeroRate) - keep <- proportionNonzero >= filterByMissingRate - datList[[bhat]] <- datList[[bhat]][keep, ] - datList[[sbhat]] <- datList[[sbhat]][keep, ] - datList + nullMats <- .mashSumStatsToMatrices( + sumStatsList$null, + "null", + inputScale = inputScale + ) + exec( + mashr::estimate_null_correlation_simple, + .mashSetData(nullMats$b, nullMats$s, alpha, NULL, mashDataArgs), + !!!as.list(corArgs) + ) } -# Derive z = bhat / sbhat (into a `.z` or `z` slot) and apply the -# significance cutoff to strong signals. +# mash_set_data with the caller's own settings spliced in. V is passed only +# when supplied: mash_set_data's own default differs from an explicit NULL. # @noRd -.mashFilterBtoz <- function(datList, bhat, sbhat, sigPCutoff) { - if (any(str_detect(bhat, "\\.b$")) || any(str_detect(sbhat, "\\.s$"))) { - zName <- str_c(str_remove(bhat, "\\.b$"), ".z") - if (!is.null(datList[[bhat]]) && !is.null(datList[[sbhat]])) { - datList[[zName]] <- as.matrix(datList[[bhat]] / datList[[sbhat]]) - } else { - datList[zName] <- list(NULL) - } - } else if (!is.null(datList[[bhat]]) && !is.null(datList[[sbhat]])) { - datList[["z"]] <- as.matrix(datList[[bhat]] / datList[[sbhat]]) - } else { - datList["z"] <- list(NULL) - } - if (is_in("strong.z", names(datList)) && !is.null(sigPCutoff)) { - keepIndex <- filterBySignificance(datList$strong.z, sigPCutoff) - datList[["strong.z"]] <- datList$strong.z[keepIndex, ] - datList[["strong.b"]] <- datList$strong.b[keepIndex, ] - datList[["strong.s"]] <- datList$strong.s[keepIndex, ] - } - datList +.mashSetData <- function(b, s, alpha, vhat, mashDataArgs) { + args <- c( + list(Bhat = b, Shat = s, alpha = alpha), + if (!is.null(vhat)) list(V = vhat), + as.list(mashDataArgs) + ) + exec(mashr::mash_set_data, !!!args) } -# Process each partition's z-matrix (missing-rate filter) and apply the -# significance cutoff to strong z-scores. +# method 'mle': EM refinement of V against the prior U over a random subset. # @noRd -.mashFilterZ <- function(datList, filterByMissingRate, sigPCutoff) { - for (comp in c("strong", "random", "null")) { - if (!is.null(datList[[comp]]) && !is.null(datList[[comp]]$z)) { - datList[[comp]]$z <- .mashProcessZ( - datList[[comp]]$z, - filterByMissingRate - ) - } - } - if ( - !is.null(datList$strong) && - !is.null(datList$strong$z) && - !is.null(sigPCutoff) - ) { - keepIndex <- filterBySignificance(datList$strong$z, sigPCutoff) - datList$strong$z <- datList$strong$z[keepIndex, , drop = FALSE] - } - datList -} - -#' Filter conditions from mash prior mixture components -#' -#' Drop the conditions not in \code{conditionsToKeep} from each prior covariance -#' matrix in \code{U}, optionally removing components whose weight is below -#' \code{wCutoff}. -#' -#' @param conditionsToKeep Character vector of condition names to retain. -#' @param U Named list of prior covariance matrices (one per mixture component). -#' @param w Optional numeric vector of mixture weights aligned to \code{U}. -#' @param wCutoff Numeric. Drop components with weight below this. Default -#' \code{1e-4}. -#' @return A list with the filtered \code{U} (and \code{w} when supplied). -#' @importFrom purrr keep -#' @examples -#' conditionsToKeep <- c("cond1", "cond2") -#' cn <- c("cond1", "cond2", "cond3") -#' U <- list(shared = diag(3), corr = matrix(0.3, 3, 3) + diag(0.7, 3)) -#' U <- lapply(U, function(m) { -#' dimnames(m) <- list(cn, cn) -#' m -#' }) -#' filterMixtureComponents(conditionsToKeep = conditionsToKeep, U = U) -#' @export -filterMixtureComponents <- function( - conditionsToKeep, - U, - w = NULL, - wCutoff = 1e-04 +.mashResidCorMle <- function( + sumStatsList, + alpha, + inputScale, + priorCovariances, + nSubset, + maxIter, + mashDataArgs, + corArgs ) { - conditionsToFilter <- setdiff(colnames(U[[1]]), conditionsToKeep) - sumW <- sum(w) - U <- .mashSubsetU(U, conditionsToKeep) - # Drop all-zero matrices, then those below the weight cutoff. - keepNames <- names(keep(U, .mashMatrixNonzero)) - if (!is.null(w)) { - keepNames <- intersect(keepNames, names(w[w >= wCutoff])) - } - U <- U[keepNames] - if (!is.null(w)) { - w <- w[keepNames] - } - # Manually remove the U components driven by non-relevant contexts: the EM - # can leave tiny non-zero diagonals, so all-zero removal alone won't drop - # them, yet real diagonal signal must be kept. - U[conditionsToFilter] <- NULL - w <- w[!is_in(names(w), conditionsToFilter)] - # Rescale the surviving weights back to the original total. - w <- (w / sum(w)) * sumW - msg <- glue("{length(U)} components of matrices remained after filtering.") - inform(msg) - list(U = U, w = w) -} - -# Subset every U matrix to the kept conditions (erroring if a matrix lacks one). -# @noRd -.mashSubsetU <- function(U, conditionsToKeep) { - map(U, .mashSubsetMatrix, conditionsToKeep = conditionsToKeep) -} - - -# Draw the random + null sub-samples used to estimate the null correlation. -# @noRd -.mashExtractOneData <- function(dat, nRandom, nNull) { - if (is.null(dat)) { - return(NULL) - } - if (is_in("z", names(dat))) { - absZ <- abs(dat$z) - zData <- dat$z - } else { - absZ <- abs(dat$bhat / dat$sbhat) - zData <- NULL - } - random <- .mashSampleSubset(dat, zData, seq_len(nrow(absZ)), nRandom) - null <- .mashSampleNull(dat, zData, absZ, nNull) - list(random = random, null = null) -} - -# Sample up to `n` rows from `poolIdx` and return them as a z (or bhat/sbhat) -# list, matching the source scale. -# @noRd -.mashSampleSubset <- function(dat, zData, poolIdx, n) { - idx <- sample(poolIdx, min(n, length(poolIdx)), replace = FALSE) - if (!is.null(zData)) { - list(z = zData[idx, , drop = FALSE]) - } else { - list( - bhat = dat$bhat[idx, , drop = FALSE], - sbhat = dat$sbhat[idx, , drop = FALSE] - ) - } -} - -# Null subset: variants with max|z| < 2. Empty (with a warning) when there are -# none, or too few to estimate the null correlation. -# @noRd -.mashSampleNull <- function(dat, zData, absZ, nNull) { - nullId <- which(apply(absZ, 1, max) < 2) - if (length(nullId) == 0) { + if (is.null(sumStatsList$random)) { msg <- glue( - "no variants are included in the null dataset because absZ > 2 ", - "for all variants in {dat$region %||% ''}" + "mashResidualCorrelation: method 'mle' requires a 'random' entry ", + "in `sumStatsList`." ) - warn(msg) - return(list()) - } - if (length(nullId) < ncol(absZ)) { - msg <- glue( - "not enough null data to estimate null correlation in ", - "{dat$region %||% ''}" - ) - warn(msg) - return(list()) - } - .mashSampleSubset(dat, zData, nullId, nNull) -} - -#' Sample random and null variant subsets for mash -#' -#' Draw a random subset and a null (non-significant) subset of rows from a mash -#' data list, used to fit the mash prior and estimate the null correlation. -#' -#' @param dat A mash data list with \code{random} and \code{null} components. -#' @param nRandom Integer. Number of random rows to sample. -#' @param nNull Integer. Number of null rows to sample. -#' @param excludeCondition Optional character vector of conditions to exclude. -#' @param seed Optional integer random seed; \code{NULL} leaves the RNG -#' unchanged. -#' @return A list with sampled \code{random} and \code{null} matrices. -#' @examples -#' cond <- c("brain", "blood", "muscle") -#' p <- 8 -#' bhat <- matrix(rnorm(p * 3), p, 3, -#' dimnames = list(sprintf("chr1:%d:A:G", 100L * (1:p)), cond)) -#' sbhat <- matrix(abs(rnorm(p * 3)) + 0.1, p, 3, -#' dimnames = list(sprintf("chr1:%d:A:G", 100L * (1:p)), cond)) -#' dat <- list(bhat = bhat, sbhat = sbhat, Z = bhat / sbhat, -#' snp = sprintf("chr1:%d:A:G", 100L * (1:p))) -#' mashRandNullSample(dat, nRandom = 2L, nNull = 2L, -#' excludeCondition = character()) -#' @export -mashRandNullSample <- function( - dat, - nRandom, - nNull, - excludeCondition, - seed = NULL -) { - if (!is.null(seed)) { - withr::local_seed(seed) - } - - if (length(excludeCondition) > 0) { - colsToCheck <- if (is_in("z", names(dat))) "z" else "bhat" - if (!all(is_in(excludeCondition, colnames(dat[[colsToCheck]])))) { - msg <- glue( - "Error: excludeCondition are not present in ", - "{dat$region %||% ''}" - ) - abort(msg) - } - for (key in intersect(names(dat), c("z", "bhat", "sbhat"))) { - keep <- setdiff(colnames(dat[[key]]), excludeCondition) - dat[[key]] <- dat[[key]][, keep, drop = FALSE] - } - } - - result <- .mashExtractOneData(dat, nRandom, nNull) - return(result) -} - -#' Merge two mash data lists -#' -#' Row-bind the components of two mash data lists, returning the non-empty one -#' when the other is empty. -#' -#' @param resData The accumulated mash data list (may be empty). -#' @param oneData The mash data list to merge in. -#' @return The merged mash data list. -#' @examples -#' # Each object's variants must be uniquely keyed (row names); the two -#' # objects share the same conditions (columns), which are aligned by name. -#' a <- list(strong = list(z = matrix(rnorm(9), 3, 3, -#' dimnames = list( -#' c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), -#' c("t1", "t2", "t3"))))) -#' b <- list(strong = list(z = matrix(rnorm(9), 3, 3, -#' dimnames = list( -#' c("chr1:400:A:G", "chr1:500:A:G", "chr1:600:A:G"), -#' c("t1", "t2", "t3"))))) -#' mergeMashData(a, b) -#' @export -mergeMashData <- function(resData, oneData) { - if (length(resData) == 0 || is.null(resData)) { - return(oneData) - } - if (length(oneData) == 0 || is.null(oneData)) { - return(resData) - } - - combinedData <- map( - names(oneData), - .mashCombineDatum, - oneData = oneData, - resData = resData - ) - names(combinedData) <- names(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")) { - return(.mashSumStatsMatrices(obj, inputScale)) - } - if (methods::is(obj, "FineMappingResultBase")) { - return(.mashFmrMatrices(obj, coverage)) + abort(msg) } - msg <- glue( - "mashInput: each element of `objects` must be a QtlSumStats, ", - "GwasSumStats, or FineMappingResult; got ", - "{str_flatten(class(obj), '/')}." - ) - abort(msg) -} - -# (Bhat, Shat, strongRows) from a SumStats object; strong = the max|z| variant -# per condition column, unioned. -# @noRd -.mashSumStatsMatrices <- function(obj, inputScale) { - mats <- .mashSumStatsToMatrices(obj, "mash input", inputScale = inputScale) - z <- mats$b / mats$s - strongRows <- sort(unique(apply(abs(z), 2L, which.max))) - list(b = mats$b, s = mats$s, strongRows = strongRows) -} - -# (Bhat, Shat, strongRows) from a FineMappingResult: pivot the marginal effects -# to a variants x contexts matrix pair; strong = each credible set's lead (max -# PIP) variant. -# @noRd -.mashFmrMatrices <- function(obj, coverage) { - me <- getMarginalEffects(obj) - cs <- getCs(obj, coverage = coverage) - if (!all(is_in(c("variant_id", "context", "beta", "se"), names(me)))) { + if (is.null(priorCovariances)) { msg <- glue( - "mashInput: getMarginalEffects() must return variant_id/context/", - "beta/se columns; a FineMappingResult with >= 2 contexts is ", - "required." + "mashResidualCorrelation: method 'mle' requires ", + "`priorCovariances` ", + "(the prior U the EM refines V against)." ) abort(msg) } - pinned <- .mashFmrMethodPin(me, cs) - me <- pinned$me - cs <- pinned$cs - contexts <- unique(me$context) - variants <- unique(me$variant_id) - b <- matrix( - NA_real_, - length(variants), - length(contexts), - dimnames = list(variants, contexts) + priorCovariances <- .mashAsUlist(priorCovariances) + randomMats <- .mashSumStatsToMatrices( + sumStatsList$random, + "random", + inputScale = inputScale ) - s <- b - cell <- cbind(match(me$variant_id, variants), match(me$context, contexts)) - b[cell] <- me$beta - s[cell] <- me$se - list(b = b, s = s, strongRows = .mashFmrStrongRows(cs, variants)) -} - -# A multi-method FineMappingResult would duplicate (variant, context) cells; -# pin the first method so the pivot is unambiguous. -# @noRd -.mashFmrMethodPin <- function(me, cs) { - if (!is_in("method", names(me)) || n_distinct(me$method) <= 1L) { - return(list(me = me, cs = cs)) - } - m1 <- me$method[[1L]] - msg <- glue( - "mashInput: FineMappingResult carries multiple methods; using ", - "'{m1}'." + n <- nrow(randomMats$b) + idx <- sample(seq_len(n), min(nSubset, n)) + dsub <- .mashSetData( + randomMats$b[idx, , drop = FALSE], + randomMats$s[idx, , drop = FALSE], + alpha, + NULL, + mashDataArgs ) - warn(msg) - me <- filter(me, .data$method == m1) - if (is_in("method", names(cs))) { - cs <- filter(cs, .data$method == m1) - } - list(me = me, cs = cs) -} - -# Row indices (into `variants`) of each credible set's lead (max PIP) variant. -# @noRd -.mashFmrStrongRows <- function(cs, variants) { - strongVar <- character(0) - csCol <- names(cs)[str_detect(names(cs), "^cs_")] - if (nrow(cs) > 0L && length(csCol) > 0L && is_in("pip", 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)) - strongRows[!is.na(strongRows)] + fit <- exec( + mashr::mash_estimate_corr_em, + dsub, + priorCovariances, + max_iter = maxIter, + details = TRUE, + !!!as.list(corArgs) + ) + fit$V } -# 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(). +# methods 'corshrink' / 'simpleSpecific': estimate V on the null z-matrix. The +# `null` partition is already the null variants (max|z| < 2), so no +# re-thresholding is needed. # @noRd -.mashObjectPartitions <- function( - obj, - nRandom, - nNull, - excludeCondition, - coverage, +.mashResidCorNullBased <- function( + sumStatsList, inputScale, - seed, - independentVariants = NULL + method, + corArgs ) { - mats <- .mashObjectMatrices( - obj, - inputScale = inputScale, - coverage = coverage - ) - keepCols <- setdiff(colnames(mats$b), excludeCondition) - if (length(keepCols) < 2L) { + if (is.null(sumStatsList$null)) { msg <- glue( - "mashInput: fewer than 2 conditions remain for an object (after ", - "excludeCondition); mash operates across conditions and needs >= 2." + "mashResidualCorrelation: method '{method}' requires a 'null' ", + "entry in `sumStatsList` (the null variants V is estimated on)." ) abort(msg) } - pool <- .mashIndependentPool(mats, independentVariants) - rn <- mashRandNullSample( - list(bhat = pool$poolB, sbhat = pool$poolS), - nRandom = nRandom, - nNull = nNull, - excludeCondition = excludeCondition, - seed = seed + nullMats <- .mashSumStatsToMatrices( + sumStatsList$null, + "null", + inputScale = inputScale ) - .mashPartitionOut(mats, keepCols, rn) -} - -# Random / null candidate pool, optionally restricted to LD-independent -# variants (so the background carries no LD-correlated SNPs, which would bias -# Vhat / weights). Strong is always drawn from the full set elsewhere. -# @noRd -.mashIndependentPool <- function(mats, independentVariants) { - if (is.null(independentVariants) || length(independentVariants) == 0L) { - return(list(poolB = mats$b, poolS = mats$s)) + nullZ <- nullMats$b / nullMats$s + if (method == "simpleSpecific") { + return(as.matrix( + Matrix::nearPD( + stats::cov(nullZ), + conv.tol = 1e-06, + doSym = TRUE, + corr = TRUE + )$mat + )) } - # Rownames carry a "study::trait::" block prefix; strip to the bare variant - # id before matching (proper chrom/pos/allele via matchVariants). - rawIds <- str_remove(rownames(mats$b), ".*::") - keepIdx <- matchVariants( - rawIds, - independentVariants, - allowFlip = TRUE, - removeStrandAmbiguous = FALSE - )$idxA - if (length(keepIdx) == 0L) { + if (!requireNamespace("CorShrink", quietly = TRUE)) { msg <- glue( - "mashInput: no variants matched the independent-variant list; ", - "the random/null background is empty for this object." + "mashResidualCorrelation: method 'corshrink' needs the CorShrink ", + "package. Install it, or use 'simple' / 'simpleSpecific'." ) - warn(msg) + abort(msg) } - list( - poolB = mats$b[keepIdx, , drop = FALSE], - poolS = mats$s[keepIdx, , drop = FALSE] + as.matrix( + exec(CorShrink::CorShrinkData, nullZ, !!!as.list(corArgs))$cor ) } -# Assemble the flat strong/random/null (.b/.s) partition list, omitting any -# empty partition. +# Internal: build the requested data-driven covariance components off a prepared +# mashr data object, in a fixed order (canonical, pca, flash, flashNonneg) so a +# given `components` set reproduces the same ordering everywhere. RNG is +# consumed only by cov_flash / cov_flash(nonneg). Shared by mashPriorCovariances +# and the exported mashCovarianceComponents. # @noRd -.mashPartitionOut <- function(mats, keepCols, rn) { - 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{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}} -#' @examples -#' data(qtlSumStatsMulticontextExample) -#' ss <- qtlSumStatsMulticontextExample -#' mashInput(objects = list(strong = ss, random = ss)) -#' @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 <- arg_match(inputScale) - if (!is.null(independentVariants)) { - independentVariants <- as.character(independentVariants) - } - objects <- .mashPrepObjects(objects) - cfg <- list( - nRandom = nRandom, - nNull = nNull, - excludeCondition = excludeCondition, - coverage = coverage, - inputScale = inputScale, - seed = seed, - independentVariants = independentVariants - ) - combined <- .mashCombinePartitions(objects, cfg) - .mashFinalizeCombined(combined, sigPCutoff, zOnly) -} - -# `objects` must be a non-empty list; unnamed lists get synthetic region names. +# Build the requested components, keeping the two roles apart: `canonical` +# are fixed structural hypotheses that go to the mash fit unrefined, while +# `dataDriven` are the generator output the engine refines. mashr's own eQTL +# vignette draws exactly this line -- cov_ed sees only the data-driven set. # @noRd -.mashPrepObjects <- function(objects) { - if (!is.list(objects) || length(objects) == 0L) { - msg <- glue( - "mashInput: `objects` must be a non-empty list of QtlSumStats ", - "and/or FineMappingResult objects." +.mashBuildComponents <- function( + mashData, + components, + nPcs = NULL, + componentArgs = NULL +) { + npc <- nPcs %||% (ncol(mashData$Bhat) - 1) + argsFor <- function(key) as.list(componentArgs[[key]] %||% list()) + canonical <- if (is_in("canonical", components)) { + exec( + mashr::cov_canonical, + mashData, + !!!compact(argsFor("canonical")) ) - abort(msg) } - if (is.null(names(objects)) || any(str_length(names(objects)) == 0L)) { - names(objects) <- str_c("region", seq_along(objects)) + pca <- if (is_in("pca", components)) { + exec(mashr::cov_pca, mashData, npc = npc, !!!compact(argsFor("pca"))) } - objects -} - -# Extract + merge each object's strong/random/null partitions, disambiguating -# rownames by region before accumulating. -# @noRd -.mashCombinePartitions <- function(objects, cfg) { - combined <- list() - for (nm in names(objects)) { - part <- .mashObjectPartitions( - objects[[nm]], - nRandom = cfg$nRandom, - nNull = cfg$nNull, - excludeCondition = cfg$excludeCondition, - coverage = cfg$coverage, - inputScale = cfg$inputScale, - seed = cfg$seed, - independentVariants = cfg$independentVariants - ) - part <- map(part, .mashPrefixRownames, nm = nm) - combined <- mergeMashData(combined, part) + flash <- if (is_in("flash", components)) { + exec(mashr::cov_flash, mashData, !!!compact(argsFor("flash"))) } - combined -} - -# Coerce to data.frame, clean each partition + derive z (random/null before -# strong so the strong significance filter runs once), restore the strong -# 1-row matrix shape, add the strong XtX, and optionally drop b/s slots. -# @noRd -.mashFinalizeCombined <- function(combined, sigPCutoff, zOnly) { - combined <- map(combined, .mashAsDataFrameOrNull) - for (cond in c("random", "null", "strong")) { - bKey <- str_c(cond, ".b") - sKey <- str_c(cond, ".s") - if (!is.null(combined[[bKey]]) && !is.null(combined[[sKey]])) { - combined <- filterInvalidSummaryStat( - combined, - bhat = bKey, - sbhat = sKey, - btoz = TRUE, - sigPCutoff = sigPCutoff - ) - } - } - combined <- .mashRestoreStrongShape(combined) - combined <- .mashAddXtX(combined) - if (zOnly) { - combined[str_detect(names(combined), "\\.(b|s)$")] <- NULL + flashNonneg <- if (is_in("flashNonneg", components)) { + exec( + mashr::cov_flash, + mashData, + factors = "nonneg", + !!!compact(argsFor("flashNonneg")) + ) } - combined + list( + canonical = canonical, + dataDriven = c(pca, flash, flashNonneg) + ) } -# filterInvalidSummaryStat subsets strong without drop = FALSE, so a single -# surviving strong variant degrades to a vector; restore the 1-row matrix. -# @noRd -.mashRestoreStrongShape <- function(combined) { - 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)) - ) - } +# The covariance list and its mixture weights. A supplied `priorCovariances` +# short-circuits the cov_* chain; either way the weights come from a +# weights-only mash() fit unless the covariance step already produced them +# (the ED/UDR engines return their own). +# @noRd +.mashPriorFit <- function( + mashData, + priorCovariances, + priorComponents, + components, + nPcs, + engine, + engineArgs, + componentArgs, + mashArgs +) { + result <- if (!is.null(priorCovariances)) { + .mashUserPriorCovariances(priorCovariances, mashData) + } else { + .mashDataDrivenCovariances( + mashData, + priorComponents, + components, + nPcs, + engine, + engineArgs = engineArgs, + componentArgs = componentArgs + ) } - combined + w <- result$w %||% + mashr::get_estimated_pi(exec( + mashr::mash, + mashData, + Ulist = result$U, + outputlevel = 1, + !!!as.list(mashArgs) + )) + list(U = result$U, w = w, loglik = result$loglik) +} + +#' @title Arguments For mashr's Canonical Covariance Components +#' @description Options for \code{mashr::cov_canonical}, which builds the +#' fixed structural hypotheses (identity, singletons, equal effects, simple +#' heterogeneity) from the condition count. These are hypotheses about +#' shape, so they go to the mash fit unrefined. +#' @param cov_methods Which canonical components to build. \code{NULL} +#' (default) leaves mashr's own selection in place. +#' @param ... Any other \code{mashr::cov_canonical} argument. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CovCanonicalOptions(cov_methods = c("identity", "equal_effects")) +#' @export +CovCanonicalOptions <- function(cov_methods = NULL, ...) { + .newMethodOptions( + "mashr::cov_canonical", + defaults = list(cov_methods = cov_methods), + extra = list(...), + label = "CovCanonicalOptions", + engine = "canonical" + ) } -# Strong XtX cross-product (conditions x conditions), when strong.z is present. -# @noRd -.mashAddXtX <- function(combined) { - 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) - } - combined +#' @title Arguments For mashr's PCA Covariance Components +#' @description Options for \code{mashr::cov_pca}, a data-driven generator. +#' The number of components is not settable here: it comes from +#' \code{mashPriorCovariances(nPcs = )}, which the caller also reports on. +#' @param subset Rows of the data to use. \code{NULL} (default) uses all. +#' @param ... Any other \code{mashr::cov_pca} argument. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CovPcaOptions(subset = 1:50) +#' @export +CovPcaOptions <- function(subset = NULL, ...) { + .newMethodOptions( + "mashr::cov_pca", + defaults = list(subset = subset), + extra = list(...), + label = "CovPcaOptions", + engine = "pca" + ) } -#' @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 -#' pipeline uses when only Z is available. Each column is one condition, and -#' conditions are distinguished by \code{context}, \code{trait}, or both: the -#' columns may be different cell types / tissues (contexts), different -#' molecular phenotypes (traits), or arbitrary context x trait pairs. -#' Chromosome / position are decoded from the row (variant) identifiers via -#' \code{\link{parseVariantId}} (with a synthetic-position fallback for ids -#' that do not encode coordinates); \code{A1} / \code{A2} / \code{N} are -#' placeholders because a Z-only input carries no alleles or sample sizes -#' (mash reads only Z). A pass-through \code{qcInfo} record is set so the -#' result clears the mash QC gate. -#' @param z Numeric matrix (variants x conditions). \code{rownames(z)} are -#' variant ids (ideally \code{chr:pos:A2:A1}); \code{colnames(z)} label the -#' conditions. -#' @param study Study identifier (recycled across conditions). -#' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) -#' 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. -#' @param trait Condition trait label(s): a single value recycled across every -#' column, or a length-\code{ncol(z)} vector. Default \code{"mash"}. Pass -#' \code{colnames(z)} here (with a constant \code{context}) when the columns -#' are traits rather than contexts. -#' @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). -#' @importFrom GenomicRanges GRanges -#' @importFrom IRanges IRanges +#' @title Arguments For mashr's FLASH Covariance Components +#' @description Options for \code{mashr::cov_flash}, a data-driven generator. +#' \code{factors} is not settable here: pecotmr sets it to distinguish the +#' \code{"flash"} and \code{"flashNonneg"} components. +#' @param subset Rows of the data to use. \code{NULL} (default) uses all. +#' @param remove_singleton Drop singleton effect vectors. Default +#' \code{FALSE}. +#' @param tag,output_model Passed through to \code{mashr::cov_flash}. +#' @param greedy_args,backfit_args Option lists forwarded to flashier's greedy +#' and backfit stages; mashr nests these itself. +#' @param ... Any other \code{mashr::cov_flash} argument. +#' @return A \code{\link{MethodOptions}} object. #' @examples -#' panel <- readGenotypes( -#' system.file("extdata", "toy_ref.bed", package = "pecotmr")) -#' z <- matrix(rnorm(6), 2, 3, dimnames = list( -#' c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) -#' qtlSumStatsFromZMatrix(z = z, study = "s1", ldSketch = panel, -#' context = colnames(z), trait = "g1", genome = "hg38", n = 100) +#' CovFlashOptions(remove_singleton = TRUE) #' @export -qtlSumStatsFromZMatrix <- function( - z, - study, - ldSketch = NULL, - context = colnames(z), - trait = "mash", - genome = "GRCh38", - n = 1000L, - a1 = "A", - a2 = "G", - role = "mash" +CovFlashOptions <- function( + subset = NULL, + remove_singleton = FALSE, + tag = NULL, + output_model = NULL, + greedy_args = list(), + backfit_args = list(), + ... ) { - if (!is.matrix(z) || !is.numeric(z)) { - msg <- glue( - "qtlSumStatsFromZMatrix: `z` must be a numeric variants x ", - "conditions matrix." - ) - abort(msg) - } - vids <- rownames(z) - if (is.null(vids)) { - vids <- str_c("var", seq_len(nrow(z))) - } - .qtlSumStatsFromMatrix( - vids = vids, - nCond = ncol(z), - study = study, - ldSketch = ldSketch, - context = context, - trait = trait, - genome = genome, - role = role, - mcolFn = .mashZMcolFn, - a1 = a1, - a2 = a2, - z = z, - n = n + .newMethodOptions( + "mashr::cov_flash", + defaults = list( + subset = subset, + remove_singleton = remove_singleton, + tag = tag, + output_model = output_model, + greedy_args = greedy_args, + backfit_args = backfit_args + ), + extra = list(...), + label = "CovFlashOptions", + engine = "flash" ) } -#' @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 genotype panel (see \code{\link{readGenotypes}}) -#' 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 +#' @title Arguments For Extreme Deconvolution Refinement +#' @description Options for \code{mashr::cov_ed}, which refines the +#' data-driven components by Extreme Deconvolution. The components to refine +#' are not settable here -- they are whatever \code{components} produced. +#' +#' \code{mashr::cov_ed} takes \code{...}, so argument names \strong{cannot +#' be checked} against it; see \code{\link{MethodOptions}}. +#' @param subset Rows of the data to use. \code{NULL} (default) uses all. +#' @param algorithm Deconvolution algorithm, \code{"bovy"} (default) or +#' \code{"teem"}. +#' @param ... Any other argument \code{mashr::cov_ed} forwards. +#' @return A \code{\link{MethodOptions}} object. #' @examples -#' panel <- readGenotypes( -#' system.file("extdata", "toy_ref.bed", package = "pecotmr")) -#' bhat <- matrix(rnorm(6), 2, 3, dimnames = list( -#' c("chr22:1:A:G", "chr22:2:A:G"), c("brain", "blood", "muscle"))) -#' shat <- matrix(0.1, 2, 3, dimnames = dimnames(bhat)) -#' qtlSumStatsFromBetaMatrix(bhat = bhat, shat = shat, study = "s1", -#' ldSketch = panel, context = colnames(bhat), trait = "g1", -#' genome = "hg38", n = 100) +#' CovEdOptions(algorithm = "teem") #' @export -qtlSumStatsFromBetaMatrix <- function( - bhat, - shat, - study, - ldSketch = NULL, - context = colnames(bhat), - trait = "mash", - genome = "GRCh38", - n = 1000L, - a1 = "A", - a2 = "G", - role = "mash" -) { - .mashValidateBetaMatrix(bhat, shat) - vids <- rownames(bhat) - if (is.null(vids)) { - vids <- str_c("var", seq_len(nrow(bhat))) - } - .qtlSumStatsFromMatrix( - vids = vids, - nCond = ncol(bhat), - study = study, - ldSketch = ldSketch, - context = context, - trait = trait, - genome = genome, - role = role, - mcolFn = .mashBetaMcolFn, - a1 = a1, - a2 = a2, - bhat = bhat, - shat = shat, - n = n +CovEdOptions <- function(subset = NULL, algorithm = "bovy", ...) { + .newMethodOptions( + "mashr::cov_ed", + defaults = list(subset = subset, algorithm = algorithm), + extra = list(...), + label = "CovEdOptions", + engine = "covEd" ) } -# `bhat` / `shat` must be numeric variants x conditions matrices of identical -# dimension. +# udr's tunables live in a `control` list rather than in ud_fit's formals, so +# the valid names come from udr::ud_fit_control_default(). Still read live, so +# the check cannot drift from the installed udr. # @noRd -.mashValidateBetaMatrix <- function(bhat, shat) { - if (!is.matrix(bhat) || !is.numeric(bhat)) { - msg <- glue( - "qtlSumStatsFromBetaMatrix: `bhat` must be a numeric ", - "variants x conditions matrix." - ) - abort(msg) - } - if (!is.matrix(shat) || !is.numeric(shat)) { - msg <- glue( - "qtlSumStatsFromBetaMatrix: `shat` must be a numeric ", - "variants x conditions matrix." - ) - abort(msg) - } - if (!identical(dim(bhat), dim(shat))) { - msg <- glue( - "qtlSumStatsFromBetaMatrix: ", - "`bhat` ({str_flatten(dim(bhat), 'x')}) and ", - "`shat` ({str_flatten(dim(shat), 'x')}) ", - "must have identical dimensions." - ) - abort(msg) +.udrControlNames <- function() { + if (!requireNamespace("udr", quietly = TRUE)) { + return(NULL) } + names(udr::ud_fit_control_default()) } -# 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 - ) - chrom <- if (!is.null(parsed)) { - as.character(parsed$chrom) - } else { - rep(NA_character_, length(vids)) - } - pos <- if (!is.null(parsed)) { - suppressWarnings(as.integer(parsed$pos)) - } else { - rep(NA_integer_, length(vids)) - } - chrom[is.na(chrom) | str_length(chrom) == 0L] <- "chr1" - pos[is.na(pos)] <- seq_along(pos)[is.na(pos)] - entries <- map( - seq_len(nCond), - .qszmEntry, - chrom = chrom, - pos = pos, - vids = vids, - mcolFn = mcolFn, - mcolArgs = list(...) +#' @title Arguments For udr's Initialisation Step +#' @description Arguments for \code{udr::ud_init()}, which sets up the +#' mixture before \code{udr::ud_fit()} refines it. The data and the +#' component matrices are pecotmr's to supply and are refused here; the +#' remaining names --- \code{n_unconstrained}, \code{n_rank1} --- are +#' checked against that function's live formals. +#' +#' udr's own spellings, not pecotmr's: this is somebody else's signature, +#' so \code{n_unconstrained} is written the way udr writes it. +#' @param ... Arguments for \code{udr::ud_init()}. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' UdInitOptions(n_unconstrained = 20L) +#' @export +UdInitOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + dat = "the mash data being refined", + V = "the mash data's residual covariance", + U_scaled = "the canonical components", + U_unconstrained = "the data-driven components", + control = "UdFitOptions()" + ), + "UdInitOptions" ) - QtlSumStats( - study = rep(as.character(study), nCond), - context = context, - trait = trait, - entry = entries, - genome = genome, - ldSketch = ldSketch, - qcInfo = list(role = role, entryAudit = vector("list", nCond)) + .newMethodOptions( + "udr::ud_init", + defaults = list(), + extra = extra, + label = "UdInitOptions", + engine = "udInit" ) } -# Internal: recycle a condition-label argument (context / trait) to one value -# 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)) { - msg <- glue( - "qtlSumStats matrix constructor: `{what}` is NULL; pass a ", - "length-1 or length-{n} value (or give the matrix column ", - "names)." - ) - abort(msg) - } - v <- as.character(v) - if (length(v) == 1L) { - return(rep(v, n)) - } - if (length(v) == n) { - return(v) - } - msg <- glue( - "qtlSumStats matrix constructor: `{what}` must be length 1 or ", - "ncol={n}, got {length(v)}." +#' @title Arguments For udr's Fitting Step +#' @description Arguments for \code{udr::ud_fit()}'s \code{control} list. +#' udr's tunables do not live in \code{ud_fit}'s formals --- it takes an +#' opaque \code{control} --- so the valid names come from +#' \code{udr::ud_fit_control_default()} instead. Still a live source, not +#' a transcription. +#' @param ... Any \code{udr} control field: \code{unconstrained.update}, +#' \code{maxiter}, \code{tol}, \code{tol.lik}, \code{penalty.type}, and +#' the rest of \code{udr::ud_fit_control_default()}. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' UdFitOptions(unconstrained.update = "ted", maxiter = 500) +#' @export +UdFitOptions <- function(...) { + extra <- list(...) + .udAssertUnconstrainedUpdate(extra) + .newMethodOptions( + NULL, + defaults = list(), + extra = extra, + label = "UdFitOptions", + engine = "udFit", + accepted = .udrControlNames() ) - abort(msg) } -# Internal: convert a single SumStats object (post-QC) into a (Bhat, Shat) -# pair of matrices keyed by context. Each row of the matrix corresponds to -# one (variantId x (study, trait)) cell from the SumStats entries; each -# column corresponds to a context (from QtlSumStats $context; from -# GwasSumStats $study, which is the per-study mash column). -# -# For QtlSumStats: -# * Pivots entries on (study, trait) so each (study, trait) becomes a -# block of rows and each context becomes a column. Missing -# (study, trait, context) cells are filled with NA. -# For GwasSumStats: -# * Each row of the collection is one study; we treat each study as a -# mash "context" (single block of rows per study, columns = studies). -# This is rarely used on its own but lets a flat GwasSumStats pass -# through alongside (or instead of) a QtlSumStats without special -# casing further upstream. -# -# Variant alignment within a (study, trait) block uses the entry's -# variant order; missing variants in any one context are filled with NA. -# NA in Bhat is mapped to 0 and NA in Shat is mapped to a large value -# (1000) inside mashr::mash_set_data via its `zero_Bhat_Shat_reset` -# pathway, matching the prior pipeline's handling of incomplete cells. -# @noRd -.mashSumStatsToMatrices <- function( - x, - role, - inputScale = c("auto", "beta", "z") +#' @title Arguments For Unconstrained Deconvolution Refinement +#' @description Refining the data-driven components with \code{udr}. +#' +#' The engine is two functions, so each one's arguments travel in their +#' own bundle and are checked against their own live source: +#' \code{init} against \code{udr::ud_init()}'s formals, \code{fit} +#' against \code{udr::ud_fit_control_default()}'s names. Splitting them +#' also retired two pecotmr spellings --- \code{unconstrainedUpdate} and +#' \code{nUnconstrained} --- that had to be translated back to +#' \code{unconstrained.update} and \code{n_unconstrained} on the way out. +#' @param init Arguments for \code{udr::ud_init()}, built with +#' \code{\link{UdInitOptions}}. +#' @param fit Arguments for \code{udr::ud_fit()}'s control list, built with +#' \code{\link{UdFitOptions}}. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CovUdrOptions( +#' fit = UdFitOptions(unconstrained.update = "ted", maxiter = 500) +#' ) +#' @export +CovUdrOptions <- function( + init = UdInitOptions(), + fit = UdFitOptions() ) { - inputScale <- arg_match(inputScale) - .mashValidateInput(x, role) - setup <- .mashBlockSetup(x) - resolvedScale <- .mashResolveScale(x, role, inputScale) - blocks <- .mashBuildBlockMatrices(x, setup, resolvedScale) - bhatBlocks <- blocks$bhat - shatBlocks <- blocks$shat - bhat <- exec(rbind, !!!bhatBlocks) - shat <- exec(rbind, !!!shatBlocks) - # bhat NA -> 0, shat NA / <= 0 -> 1000 (the mash_set_data - # zero_Bhat_Shat_reset convention; missing-cell variants do not drive the - # fit). - bhat[is.na(bhat)] <- 0 - shat[is.na(shat) | shat <= 0] <- 1000 - list(b = bhat, s = shat) -} - -# The SumStats input must be a QC'd, non-empty QtlSumStats / GwasSumStats. -# @noRd -.mashValidateInput <- function(x, role) { - if (!methods::is(x, "QtlSumStats") && !methods::is(x, "GwasSumStats")) { - msg <- glue( - "mashPipeline: '{role}' input must be a QtlSumStats or ", - "GwasSumStats; got {str_flatten(class(x), '/')}." - ) - abort(msg) - } - if (length(getQcInfo(x)) == 0L) { - msg <- glue( - "mashPipeline: '{role}' SumStats has no QC info ", - "(length(getQcInfo(x)) == 0L). ", - "Run summaryStatsQc() on the SumStats before passing it to ", - "mashPipeline()." - ) - abort(msg) - } - if (nrow(x) == 0L) { - msg <- glue( - "mashPipeline: '{role}' SumStats has no entries (nrow == 0)." - ) - abort(msg) - } + .assertMethodOptions(init, "UdInitOptions", "init") + .assertMethodOptions(fit, "UdFitOptions", "fit") + .newMethodOptions( + NULL, + defaults = list(init = init, fit = fit), + extra = list(), + label = "CovUdrOptions", + engine = "covUdr" + ) } -# Block / column layout: QtlSumStats blocks by (study, trait) with context -# columns; GwasSumStats blocks by study with study columns. -# @noRd -.mashBlockSetup <- function(x) { - isQtl <- methods::is(x, "QtlSumStats") - studyCol <- as.character(x$study) - if (isQtl) { - traitCol <- as.character(x$trait) - contextCol <- as.character(x$context) - blockKeys <- str_c(studyCol, traitCol, sep = "::") - columnLabels <- unique(contextCol) - } else { - traitCol <- NULL - contextCol <- studyCol - blockKeys <- studyCol - columnLabels <- unique(studyCol) - } - list( - isQtl = isQtl, - studyCol = studyCol, - traitCol = traitCol, - contextCol = contextCol, - blockKeys = blockKeys, - columnLabels = columnLabels +#' @title Settings For The mash Mixture-Weight Fit +#' @description Options forwarded to \code{mashr::mash}, the fit that +#' estimates the mixture weights over the prior covariances. Checked +#' against that function's live formals. +#' +#' \code{data}, \code{Ulist} and \code{outputlevel} are refused: they are +#' the inputs pecotmr assembles and the output level it needs. +#' \code{seed} is refused too --- use the caller's \code{setSeed}, so one +#' setting governs the whole run. +#' @param ... Arguments for \code{mashr::mash}, under its own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' MashOptions(nullweight = 10, optmethod = "mixSQP") +#' @export +MashOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + data = "the sumstats pecotmr assembles", + Ulist = "the prior covariances", + outputlevel = "fixed by the calling entry point", + seed = "the caller's `setSeed`" + ), + "MashOptions" + ) + .newMethodOptions( + "mashr::mash", + defaults = list(), + extra = extra, + label = "MashOptions", + engine = "mash" ) } -# Resolve which (Bhat, Shat) source to pull: "beta" (BETA/SE) or "z" -# (Z, Shat=1). -# "auto" picks beta when every entry has BETA+SE, else z; mixed inputs error. -# @noRd -.mashResolveScale <- function(x, role, inputScale) { - entries <- .collectionEntries(x) - caps <- map(entries, .mashEntryCaps) - allHaveBetaSe <- all(map_lgl(caps, "hasBetaSe")) - allHaveZ <- all(map_lgl(caps, "hasZ")) - switch( - inputScale, - beta = .mashScaleBeta(allHaveBetaSe, role), - z = .mashScaleZ(allHaveZ, role), - auto = .mashScaleAuto(allHaveBetaSe, allHaveZ, role) +#' @title Settings For mashr Data Assembly +#' @description Options forwarded to \code{mashr::mash_set_data}, which turns +#' the effect-size and standard-error matrices into mashr's data object. +#' +#' \code{Bhat}, \code{Shat}, \code{alpha} and \code{V} are refused: the +#' first two are the matrices pecotmr builds, and the last two are the +#' caller's own \code{alpha} / \code{vhat} arguments. +#' +#' \code{zero_Bhat_Shat_reset} defaults to \code{1000} here because that +#' is the value pecotmr has always passed; it is now a setting rather than +#' a literal. +#' @param ... Arguments for \code{mashr::mash_set_data}, under its own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' MashDataOptions(zero_Bhat_Shat_reset = 500) +#' @export +MashDataOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + Bhat = "the effect-size matrix pecotmr builds", + Shat = "the standard-error matrix pecotmr builds", + alpha = "the caller's `alpha`", + V = "the caller's `vhat`" + ), + "MashDataOptions" + ) + .newMethodOptions( + "mashr::mash_set_data", + defaults = list(zero_Bhat_Shat_reset = 1000), + extra = extra, + label = "MashDataOptions", + engine = "mashData" ) } -# @noRd -.mashScaleBeta <- function(allHaveBetaSe, role) { - if (!allHaveBetaSe) { - msg <- glue( - "mashPipeline: inputScale = 'beta' requires every '{role}' ", - "entry to carry both BETA and SE mcols." - ) - abort(msg) - } - "beta" +#' @title Settings For mashr Posterior Computation +#' @description Options forwarded to +#' \code{mashr::mash_compute_posterior_matrices}. +#' +#' \code{g}, \code{data} and \code{output_posterior_cov} are refused: the +#' first two are the fitted model and the data pecotmr assembles, and the +#' third is the caller's \code{outputPosteriorCov}. \code{A} is refused as +#' well --- the contrast matrix follows from \code{excludeCondition}. +#' \code{seed} is refused; use \code{setSeed}. +#' @param ... Arguments for the posterior computation, under its own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' MashPosteriorOptions(pi_thresh = 1e-8) +#' @export +MashPosteriorOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + g = "the fitted mash model", + data = "the sumstats pecotmr assembles", + A = "derived from `excludeCondition`", + output_posterior_cov = "the caller's `outputPosteriorCov`", + seed = "the caller's `setSeed`" + ), + "MashPosteriorOptions" + ) + .newMethodOptions( + "mashr::mash_compute_posterior_matrices", + defaults = list(), + extra = extra, + label = "MashPosteriorOptions", + engine = "mashPosterior" + ) } -# @noRd -.mashScaleZ <- function(allHaveZ, role) { - if (!allHaveZ) { - msg <- glue( - "mashPipeline: inputScale = 'z' requires every '{role}' entry ", - "to carry a Z mcol." - ) - abort(msg) - } - "z" +#' @title Settings For The Simple Null-Correlation Estimator +#' @description Options forwarded to +#' \code{mashr::estimate_null_correlation_simple}. \code{data} is refused: +#' it is the null-partition data object pecotmr assembles. +#' @param ... Arguments for the estimator, under its own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' MashCorSimpleOptions(z_thresh = 3) +#' @export +MashCorSimpleOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c(data = "the null-partition data pecotmr assembles"), + "MashCorSimpleOptions" + ) + .newMethodOptions( + "mashr::estimate_null_correlation_simple", + defaults = list(), + extra = extra, + label = "MashCorSimpleOptions", + engine = "simple" + ) } -# @noRd -.mashScaleAuto <- function(allHaveBetaSe, allHaveZ, role) { - if (allHaveBetaSe) { - return("beta") - } - if (allHaveZ) { - return("z") - } - msg <- glue( - "mashPipeline: '{role}' SumStats has no usable scale - every ", - "entry must carry (BETA, SE) or Z mcols." +#' @title Settings For The EM Null-Correlation Estimator +#' @description Options forwarded to \code{mashr::mash_estimate_corr_em}, the +#' \code{method = "mle"} estimator. +#' +#' \code{data}, \code{Ulist} and \code{max_iter} are refused: the first +#' two are what pecotmr assembles, and \code{max_iter} is the caller's +#' \code{maxIter}. +#' +#' Not checkable: \code{mash_estimate_corr_em} ends in \code{...}, so any +#' name is legal there and nothing can be rejected. +#' @param ... Arguments for the estimator, under its own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' MashCorEmOptions(tol = 1e-5) +#' @export +MashCorEmOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + data = "the random-subset data pecotmr assembles", + Ulist = "the prior covariances", + max_iter = "the caller's `maxIter`" + ), + "MashCorEmOptions" + ) + .newMethodOptions( + "mashr::mash_estimate_corr_em", + defaults = list(), + extra = extra, + label = "MashCorEmOptions", + engine = "mle" ) - abort(msg) } -# Per (study, trait) block, a variant x context Bhat / Shat matrix pair. -# @noRd -.mashBuildBlockMatrices <- function(x, setup, resolvedScale) { - blocks <- map( - unique(setup$blockKeys), - .mashBlockMatrix, - x = x, - setup = setup, - resolvedScale = resolvedScale +#' @title Settings For The CorShrink Null-Correlation Estimator +#' @description Options forwarded to \code{CorShrink::CorShrinkData}, the +#' \code{method = "corshrink"} estimator. \code{data} is refused: it is +#' the null z-matrix pecotmr assembles. +#' +#' \code{ash.control} and \code{image} default to what pecotmr has always +#' passed, so they are settings now rather than literals. +#' @param ... Arguments for \code{CorShrinkData}, under its own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CorShrinkOptions(nboot = 100) +#' @export +CorShrinkOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c(data = "the null z-matrix pecotmr assembles"), + "CorShrinkOptions" + ) + .newMethodOptions( + "CorShrink::CorShrinkData", + defaults = list( + ash.control = list(mixcompdist = "halfuniform"), + image = "null" + ), + extra = extra, + label = "CorShrinkOptions", + engine = "corshrink" ) - list(bhat = map(blocks, "b"), shat = map(blocks, "s")) } -# The per-context (Bhat, Shat) vectors for one block: the variant universe is -# the first-seen union of SNP ids across the block's contexts. +# cov_ed engine: mashr's exported extreme-deconvolution wrapper (default +# algorithm = bovy) refines the components; mash() (upstream) learns the +# mixture weights. Returns list(U, w = NULL, loglik = NULL). # @noRd -.mashBlockPerContext <- function(x, rowsInBlock, setup, resolvedScale) { - requireCols <- if (resolvedScale == "beta") { - c("SNP", "BETA", "SE") - } else { - c("SNP", "Z") - } - variantOrder <- character() - perContextB <- list() - perContextSe <- list() - for (rIdx in rowsInBlock) { - df <- .mashRowDf(x, rIdx, setup, requireCols) - snps <- df$variant_id - variantOrder <- c(variantOrder, setdiff(snps, variantOrder)) - ctx <- setup$contextCol[[rIdx]] - if (resolvedScale == "beta") { - perContextB[[ctx]] <- set_names(df$beta, snps) - perContextSe[[ctx]] <- set_names(df$se, snps) - } else { - perContextB[[ctx]] <- set_names(df$z, snps) - perContextSe[[ctx]] <- set_names(rep(1, length(snps)), snps) +.mashEngineCovEd <- function(mashData, dataDriven, engineArgs = NULL) { + U.ed <- exec( + mashr::cov_ed, + mashData, + Ulist_init = dataDriven, + !!!compact(as.list(engineArgs %||% list())) + ) + list(U = U.ed, w = NULL, loglik = NULL) +} + +# ud_fit with a directed error for the ud_ted / non-i.i.d. (per-variant SE) +# incompatibility. +# @noRd +#' @importFrom rlang try_fetch +.mashUdFit <- function(fit0, fitOpts, nCond) { + # is.matrix(fit$V) is the same test udr itself applies, and it reads the + # POST-init fit: ud_init() is what expands a shared V per variant. + control <- .mashUdControl(fitOpts, nCond, iid = is.matrix(fit0$V)) + try_fetch( + udr::ud_fit(fit0, control = control, verbose = FALSE), + error = function(cnd) { + if ( + identical(control$unconstrained.update, "ted") && + str_detect(conditionMessage(cnd), "i.i.d") + ) { + msg <- glue( + "mashPriorCovariances: the udr TED update needs ", + "i.i.d. data (a single shared V), which the beta scale ", + "does not provide (per-variant SE). Use ", + "CovUdrOptions(fit = UdFitOptions(unconstrained.update ", + "= 'ed')), or a z-scale input." + ) + abort(msg, parent = cnd) + } + # Not the TED i.i.d. case rewrapped above -- re-raise the + # original condition unchanged so unrelated udr failures surface + # (and aren't swallowed as a NULL fit). + cnd_signal(cnd) } - } - list( - variantOrder = variantOrder, - perContextB = perContextB, - perContextSe = perContextSe ) } -# One row's sumstat data.frame (QtlSumStats keyed by study/context/trait; -# GwasSumStats by study). -# @noRd -.mashRowDf <- function(x, rIdx, setup, requireCols) { - if (setup$isQtl) { - getSumStatsDf( - x, - study = setup$studyCol[[rIdx]], - context = setup$contextCol[[rIdx]], - trait = setup$traitCol[[rIdx]], - require = requireCols - ) - } else { - getSumStatsDf(x, study = setup$studyCol[[rIdx]], require = requireCols) - } -} - -# Assemble one block's (variant x context) Bhat / Shat matrices, disambiguating -# rownames by block key to avoid silent cross-block dedup. -# @noRd -.mashBlockMatrix <- function(bkey, x, setup, resolvedScale) { - rowsInBlock <- which(setup$blockKeys == bkey) - pc <- .mashBlockPerContext(x, rowsInBlock, setup, resolvedScale) - dims <- list(pc$variantOrder, setup$columnLabels) - nVar <- length(pc$variantOrder) - nCol <- length(setup$columnLabels) - bMat <- matrix(NA_real_, nrow = nVar, ncol = nCol, dimnames = dims) - sMat <- matrix(NA_real_, nrow = nVar, ncol = nCol, dimnames = dims) - for (ctx in names(pc$perContextB)) { - bMat[names(pc$perContextB[[ctx]]), ctx] <- pc$perContextB[[ctx]] - sMat[names(pc$perContextSe[[ctx]]), ctx] <- pc$perContextSe[[ctx]] - } - rn <- str_c(bkey, pc$variantOrder, sep = "::") - rownames(bMat) <- rn - rownames(sMat) <- rn - list(b = bMat, s = sMat) -} - -# ---- map/apply helpers (lambda-free callbacks) --------------------------- - -# TRUE when any |z| in a matrix row reaches the significance threshold. -# @noRd -.mashRowExceeds <- function(row, zThreshold) { - any(abs(row) >= zThreshold) -} - -# The fraction of non-zero entries in a matrix row. -# @noRd -.mashRowNonzeroRate <- function(row) { - mean(row != 0) -} - -# TRUE when a covariance matrix is not identically zero. -# @noRd -.mashMatrixNonzero <- function(mat) { - !all(mat == 0) -} - -# Subset one U matrix to the kept conditions (erroring if any is absent). +# ud / ud_ted engine (OPT-IN; udr with known numerical issues). Seeds canonical +# as the scaled prior and generates n_unconstrained data-driven matrices, +# returning U + weights + loglik directly. Returns list(U, w, loglik). # @noRd -.mashSubsetMatrix <- function(mat, conditionsToKeep) { - missingConditions <- setdiff(conditionsToKeep, colnames(mat)) - if (length(missingConditions) > 0) { +.mashEngineUd <- function(mashData, dataDriven, canonical, engineArgs) { + if (!requireNamespace("udr", quietly = TRUE)) { msg <- glue( - "Condition(s) {str_flatten(missingConditions, ', ')} ", - "not found in matrix" + "mashPriorCovariances: engine 'covUdr' needs the udr package. ", + "Install it, or use the default 'covEd'." ) abort(msg) } - mat[conditionsToKeep, conditionsToKeep] -} - -# Merge partition `d` of two mash data lists: a column-aligned row-bind (the two -# objects may measure different condition sets). bind_rows unions the columns, -# filling gaps with NA -> NaN. Returns a base data.frame because this backs the -# exported mergeMashData(), whose result is column-accessed (`$cond`); the -# mashInput pipeline then coerces these frames back to matrices. The variant-id -# rownames are load-bearing -- they survive (via as.matrix) as the output -# matrices' dimnames (tested, e.g. rownames(mashInput(...)$strong.z)), which a -# tibble (no rownames) would drop. Rows are APPENDED (each object's variants are -# distinct, disambiguated by the region prefix), so the row keys must be unique -# across the two sides -- a collision means the prefix invariant broke, and we -# error loudly rather than silently stack. -# @noRd -.mashCombineDatum <- function(d, oneData, resData) { - od <- oneData[[d]] - rd <- resData[[d]] - if (length(od) == 0 || is.null(od)) { - return(rd) + initOpts <- .mashUdHalf(engineArgs, "init", UdInitOptions) + fitOpts <- .mashUdHalf(engineArgs, "fit", UdFitOptions) + # udr distinguishes scaled components from unconstrained ones, which is + # the same line mashr draws: the fixed hypotheses initialise `U_scaled`, + # the data-driven components `U_unconstrained`. Previously the + # data-driven set was discarded here and udr always started from + # canonical alone. + scaled <- canonical %||% mashr::cov_canonical(mashData) + # n_unconstrained only applies when udr has to invent the unconstrained + # components, so it is dropped outright when data-driven ones exist -- + # including one the caller set, which would otherwise be refused by udr. + initArgs <- compact(list( + U_scaled = scaled, + U_unconstrained = if (length(dataDriven) > 0L) dataDriven, + n_unconstrained = if (length(dataDriven) == 0L) { + initOpts$n_unconstrained %||% 50L + } + )) + userInit <- as.list(initOpts)[setdiff(names(initOpts), "n_unconstrained")] + fit0 <- exec(udr::ud_init, mashData, !!!initArgs, !!!userInit) + fit <- .mashUdFit(fit0, fitOpts, ncol(mashData$Bhat)) + list(U = map(fit$U, "mat"), w = fit$w, loglik = fit$loglik) +} + +#' @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. +#' Either shape the producers return is accepted: a bare named list of +#' covariance matrices (\code{\link{mashCovarianceComponents}}) or the +#' \code{list(U, w, loglik)} a \code{\link{mashPriorCovariances}} result +#' carries, which is unwrapped to its \code{U}. +#' @param vhat Residual correlation matrix (\code{V}); \code{NULL} -> identity. +#' @param fitOn Partition to learn the mixture weights on: \code{"random"} +#' (default, the standard unbiased choice) or \code{"strong"}. +#' @param outputLevel \code{mashr::mash()} \code{outputlevel} (default 4 -- the +#' full model \code{\link{mashPosterior}} consumes). +#' @param inputScale SumStats -> matrix conversion scale. +#' @param mashDataArgs Extra arguments for +#' \code{mashr::mash_set_data()}, built with +#' \code{\link{MashDataOptions}} -- for example +#' \code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +#' \code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +#' are refused by the constructor. +#' @param mashArgs Extra arguments for \code{mashr::mash()}, built with +#' \code{\link{MashOptions}} -- for example \code{nullweight}, +#' \code{optmethod} or \code{verbose}. \code{data}, \code{Ulist}, +#' \code{outputlevel} and \code{seed} are owned by pecotmr and are +#' refused by the constructor. +#' @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}} +#' @examples +#' data(mashInputExample) +#' mi <- mashInputExample +#' mk <- function(b, s) { +#' qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), +#' study = "mash") +#' } +#' ssl <- list(strong = mk("strong.b", "strong.s"), +#' random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) +#' conds <- colnames(mi$strong.b) +#' vhat <- diag(length(conds)) +#' dimnames(vhat) <- list(conds, conds) +#' prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, +#' components = "canonical") +#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, +#' vhat = vhat) +#' @export +mashModelFit <- function( + sumStatsList, + alpha, + priorCovariances, + vhat = NULL, + fitOn = c("random", "strong"), + outputLevel = 4L, + inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + mashArgs = MashOptions(), + setSeed = 999 +) { + .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") + .assertMethodOptions(mashArgs, "MashOptions", "mashArgs") + fitOn <- arg_match(fitOn) + inputScale <- arg_match(inputScale) + if (!requireNamespace("mashr", quietly = TRUE)) { + abort("Package 'mashr' is required for this function.") } - if (is.null(rd) || length(rd) == 0) { - return(od) + if (methods::is(sumStatsList, "SimpleList")) { + sumStatsList <- as.list(sumStatsList) } - rnRes <- rownames(as.data.frame(rd)) - rnOne <- rownames(as.data.frame(od)) - if (anyDuplicated(c(rnRes, rnOne)) > 0L) { - abort(glue( - "mergeMashData: duplicate variant ids across the merged ", - "partitions -- each object's variants must be uniquely keyed ", - "(the mashInput region prefix guarantees this). A collision ", - "means two objects share a name or the prefix invariant broke." - )) + priorCovariances <- .mashAsUlist(priorCovariances) + .mashValidatePriorCovList(priorCovariances) + if (is.null(sumStatsList[[fitOn]])) { + msg <- glue( + "mashModelFit: `sumStatsList` has no '{fitOn}' entry to fit on." + ) + abort(msg) } - combined <- bind_rows(as.data.frame(rd), as.data.frame(od)) - combined[is.na(combined)] <- NaN - rownames(combined) <- c(rnRes, rnOne) - combined -} - -# Region-prefix one partition matrix's rownames (no-op for empty/NULL). -# @noRd -.mashPrefixRownames <- function(m, nm) { - if (!is.null(m) && nrow(m) > 0L) { - rownames(m) <- str_c(rownames(m), nm, sep = "_") + if (!is.null(setSeed)) { + withr::local_seed(setSeed) } - m -} - -# Coerce one partition to a data.frame (NULL passes through). Kept as a base -# data.frame (not a tibble) so the variant-id rownames survive to the output -# matrices -- see .mashCombineDatum. -# @noRd -.mashAsDataFrameOrNull <- function(m) { - if (is.null(m)) { - return(NULL) - } - as.data.frame(m) -} - -# One condition's GRanges entry, mcols from `mcolFn(j, vids, )`. -# @noRd -.qszmEntry <- function(j, chrom, pos, vids, mcolFn, mcolArgs) { - gr <- GenomicRanges::GRanges( - seqnames = chrom, - ranges = IRanges::IRanges(start = pos, width = 1L) + mashData <- .mashMakeMashData( + sumStatsList[[fitOn]], + fitOn, + vhat, + alpha, + inputScale, + mashDataArgs ) - mcolCallArgs <- c(list(j, vids), mcolArgs) - S4Vectors::mcols(gr) <- exec(mcolFn, !!!mcolCallArgs) - gr -} - -# mcols for condition `j` of a z-scale matrix (Z + placeholder N/alleles). -# @noRd -.mashZMcolFn <- function(j, vids, a1, a2, z, n) { - 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)) + exec( + mashr::mash, + mashData, + Ulist = priorCovariances, + outputlevel = outputLevel, + !!!as.list(mashArgs) ) } -# mcols for condition `j` of a beta-scale pair (BETA/SE + derived Z). -# @noRd -.mashBetaMcolFn <- function(j, vids, a1, a2, bhat, shat, n) { - 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)) +#' @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. +#' @param mashDataArgs Extra arguments for +#' \code{mashr::mash_set_data()}, built with +#' \code{\link{MashDataOptions}} -- for example +#' \code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +#' \code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +#' are refused by the constructor. +#' @param posteriorArgs Extra arguments for +#' \code{mashr::mash_compute_posterior_matrices()}, built with +#' \code{\link{MashPosteriorOptions}} -- for example +#' \code{algorithm.version}. \code{g}, \code{data}, \code{A}, +#' \code{output_posterior_cov} and \code{seed} are owned by pecotmr +#' and are refused by the constructor. +#' @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}} +#' @examples +#' data(mashInputExample) +#' mi <- mashInputExample +#' mk <- function(b, s) { +#' qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), +#' study = "mash") +#' } +#' ssl <- list(strong = mk("strong.b", "strong.s"), +#' random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) +#' conds <- colnames(mi$strong.b) +#' vhat <- diag(length(conds)) +#' dimnames(vhat) <- list(conds, conds) +#' prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, +#' components = "canonical") +#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, +#' vhat = vhat) +#' mashPosterior(model, mk("strong.b", "strong.s"), alpha = 0, vhat = vhat) +#' @export +mashPosterior <- function( + model, + sumStats, + alpha, + vhat = NULL, + excludeCondition = character(0), + outputPosteriorCov = TRUE, + inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + posteriorArgs = MashPosteriorOptions() +) { + .assertMethodOptions(mashDataArgs, "MashDataOptions", "mashDataArgs") + .assertMethodOptions(posteriorArgs, "MashPosteriorOptions", "posteriorArgs") + inputScale <- arg_match(inputScale) + if (!requireNamespace("mashr", quietly = TRUE)) { + abort("Package 'mashr' is required for this function.") + } + mats <- .mashSumStatsToMatrices(sumStats, "target", inputScale = inputScale) + ex <- .mashExcludeConditions( + mats$b, + mats$s, + vhat, + model, + as.character(excludeCondition) ) -} - -# The (hasBetaSe, hasZ) scale capabilities of one sumstats entry. -# @noRd -.mashEntryCaps <- function(e) { - mc <- S4Vectors::mcols(e) - list( - hasBetaSe = all(is_in(c("BETA", "SE"), colnames(mc))), - hasZ = is_in("Z", colnames(mc)) + vhat <- if (is.null(ex$vhat)) diag(rep(1, ncol(ex$b))) else ex$vhat + mashData <- .mashSetData(ex$b, ex$s, alpha, vhat, mashDataArgs) + exec( + mashr::mash_compute_posterior_matrices, + ex$model, + mashData, + output_posterior_cov = outputPosteriorCov, + !!!as.list(posteriorArgs) ) } diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R index 247fffb28..3934cebd4 100644 --- a/R/overlapTopLoci.R +++ b/R/overlapTopLoci.R @@ -30,13 +30,21 @@ # getTopLoci frame (study/context/trait/method) that carries no # variant_id; restore the join key so the empty join still resolves # instead of erroring in inner_join()'s `by` check. - if (!is_in("variant_id", names(qp))) { - qp$variant_id <- character(0) - } - if (!is_in("variant_id", names(gp))) { - gp$variant_id <- character(0) + inner_join( + .overlapWithJoinKey(qp), + .overlapWithJoinKey(gp), + by = "variant_id" + ) +} + +# The join key, restored as an empty column when the frame carries no signal +# and so never got one. +# @noRd +.overlapWithJoinKey <- function(tl) { + if (is_in("variant_id", names(tl))) { + return(tl) } - inner_join(qp, gp, by = "variant_id") + mutate(tl, variant_id = character(0)) } # Convert the merged frame to the requested output type. @@ -90,8 +98,7 @@ setMethod( qtl, gwas, signalCutoff = 0.025, - type = c("data.frame", "GRanges"), - ... + type = c("data.frame", "GRanges") ) { type <- arg_match(type) keyCols <- c("variant_id", "chrom", "pos", "A1", "A2") @@ -158,20 +165,32 @@ setMethod( # helper columns. # @noRd .overlapRelabelGwas <- function(gwasTl, vmap, coordCols) { - g <- inner_join(gwasTl, vmap, by = c("variant_id" = "gwas_vid")) + joined <- inner_join(gwasTl, vmap, by = c("variant_id" = "gwas_vid")) signedCols <- c("beta", "z", "conditional_effect") # Bound with partial() rather than across()'s deprecated `...`; the local # matters because partial() resolves it lazily (see .negateWhere et al). - rowSign <- g$.sign - g <- mutate( - g, + rowSign <- joined$.sign + signed <- mutate( + joined, across(any_of(signedCols), partial(.overlapApplySign, sign = rowSign)) ) - if (is_in("af", names(g))) { - g$af <- if_else(g$.sign < 0 & !is.na(g$af), 1 - g$af, g$af) - } - g$variant_id <- g$canon_vid - select(g, all_of(setdiff(names(g), c(coordCols, "canon_vid", ".sign")))) + relabelled <- mutate( + signed, + !!!compact(list( + af = if (is_in("af", names(signed))) { + if_else( + signed$.sign < 0 & !is.na(signed$af), + 1 - signed$af, + signed$af + ) + } + )), + variant_id = .data$canon_vid + ) + select( + relabelled, + all_of(setdiff(names(relabelled), c(coordCols, "canon_vid", ".sign"))) + ) } # Build a GRanges from an overlap table: variants as width-1 ranges, all other @@ -186,6 +205,8 @@ setMethod( seqnames = str_c("chr", p$chrom), ranges = IRanges::IRanges(start = p$pos, width = 1L) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(df, check.names = FALSE) - gr + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(df, check.names = FALSE) + ) } diff --git a/R/pvalCombine.R b/R/pvalCombineWrappers.R similarity index 51% rename from R/pvalCombine.R rename to R/pvalCombineWrappers.R index 14fc0df09..2fe643076 100644 --- a/R/pvalCombine.R +++ b/R/pvalCombineWrappers.R @@ -1,3 +1,6 @@ +#' @include MethodParam.R +NULL + #' @title P-value Combination Methods #' @description Functions for combining p-values across multiple tests or #' methods: Cauchy combination (ACAT), harmonic mean p-value (HMP), poolr, @@ -38,8 +41,12 @@ NULL #' @return Numeric vector of two-sided p-values. #' @examples #' waldTestPval(beta = 0.3, se = 0.1, n = 1000) +#' @importFrom checkmate assertNumeric #' @export waldTestPval <- function(beta, se, n) { + assertNumeric(beta) + assertNumeric(se) + assertNumeric(n) # Calculate the t statistic tValue <- beta / se # Degrees of freedom @@ -61,20 +68,20 @@ pvalAcat <- function(pvals, naRm = TRUE) { # avoid Inf from floating-point precision loss in pi*0.5 # - large-stat asymptotic: when the mean Cauchy variate is > 1e15 the # CDF tail collapses to (1/T) / pi (Cauchy survival expansion) - if (naRm) { - pvals <- pvals[!is.na(pvals)] - } - if (length(pvals) == 0L) { + present <- if (naRm) pvals[!is.na(pvals)] else pvals + if (length(present) == 0L) { return(NA_real_) } - if (length(pvals) == 1L) { - return(pvals[[1]]) + if (length(present) == 1L) { + return(present[[1]]) } - pvals <- pmin(pvals, 0.99) + # Capped below 1: tan(pi * (0.5 - 1)) is -Inf, which would sink the + # combined statistic regardless of the other p-values. + capped <- pmin(present, 0.99) cauchyVals <- if_else( - pvals < 1e-15, - 1 / (pvals * pi), - tan(pi * (0.5 - pvals)) + capped < 1e-15, + 1 / (capped * pi), + tan(pi * (0.5 - capped)) ) stat <- mean(cauchyVals) if (!is.finite(stat)) { @@ -89,11 +96,7 @@ pvalAcat <- function(pvals, naRm = TRUE) { pvalHmp <- function(pvals) { # Make sure harmonicmeanp is installed if (!requireNamespace("harmonicmeanp", quietly = TRUE)) { - msg <- glue( - "To use this function, please install harmonicmeanp: ", - "https://cran.r-project.org/web/packages/harmonicmeanp/index.html" - ) - abort(msg) + abort("Package 'harmonicmeanp' is required for this function.") } # https://search.r-project.org/CRAN/refmans/harmonicmeanp/html/pLandau.html L <- length(pvals) @@ -118,13 +121,9 @@ pvalHmp <- function(pvals) { abort(msg) } -pvalPoolr <- function(pvals, method, R) { +pvalPoolr <- function(pvals, method, R, methodArgs = PoolrOptions()) { if (!requireNamespace("poolr", quietly = TRUE)) { - msg <- glue( - "To use this method, please install poolr: ", - "install.packages('poolr')" - ) - abort(msg) + abort("Package 'poolr' is required for this method.") } fn <- switch( method, @@ -133,23 +132,29 @@ pvalPoolr <- function(pvals, method, R) { invchisq = poolr::invchisq, .abortUnknownMethod("poolr", method) ) - fn(pvals, adjust = "generalized", R = R)$p + exec(fn, pvals, R = R, !!!as.list(methodArgs))$p } -pvalGbj <- function(zScores, R, method) { +pvalGbj <- function(zScores, R, method, methodArgs = GbjOptions()) { if (!requireNamespace("GBJ", quietly = TRUE)) { - abort("To use this method, please install GBJ: install.packages('GBJ')") + abort("Package 'GBJ' is required for this method.") } - result <- switch( + fn <- switch( method, - gbj = GBJ::GBJ(test_stats = zScores, cor_mat = R), - bj = GBJ::BJ(test_stats = zScores, cor_mat = R), - hc = GBJ::HC(test_stats = zScores, cor_mat = R), - ghc = GBJ::GHC(test_stats = zScores, cor_mat = R), - minp = GBJ::minP(test_stats = zScores, cor_mat = R), - gbj_omni = GBJ::OMNI_ss(test_stats = zScores, cor_mat = R), + gbj = GBJ::GBJ, + bj = GBJ::BJ, + hc = GBJ::HC, + ghc = GBJ::GHC, + minp = GBJ::minP, + gbj_omni = GBJ::OMNI_ss, .abortUnknownMethod("GBJ", method) ) + result <- exec( + fn, + test_stats = zScores, + cor_mat = R, + !!!as.list(methodArgs) + ) pvalName <- switch( method, gbj = "GBJ_pvalue", @@ -162,22 +167,29 @@ pvalGbj <- function(zScores, R, method) { result[[pvalName]] } -pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { +pvalAspu <- function( + zScores = NULL, + pvals = NULL, + R, + method, + methodArgs = AspuOptions() +) { if (!requireNamespace("aSPU", quietly = TRUE)) { abort( - "To use this method, please install aSPU: install.packages('aSPU')" + "Package 'aSPU' is required for this method." ) } switch( method, - aspu = { - result <- aSPU::aSPUs(Zs = zScores, corSNP = R) - result$pvs["aSPUs"] - }, - gates = { - result <- aSPU::GATES2(ldmatrix = R, p = pvals) - result[["Pg"]] - }, + aspu = exec( + aSPU::aSPUs, + Zs = zScores, + corSNP = R, + !!!as.list(methodArgs) + )$pvs["aSPUs"], + # GATES2's only formals are the two pecotmr supplies, so there is + # nothing for a caller to configure here. + gates = aSPU::GATES2(ldmatrix = R, p = pvals)[["Pg"]], .abortUnknownMethod("aSPU", method) ) } @@ -233,13 +245,12 @@ pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { # Internal: align an R correlation matrix to a target order. If R has # rownames/colnames, reorder to match `targetNames`; require every target # name to be present. If R is unnamed, only length check. +#' @importFrom checkmate assertMatrix .combinePvalAlignR <- function(R, targetNames) { if (is.null(R)) { return(NULL) } - if (!is.matrix(R)) { - abort("`R` must be a matrix.") - } + assertMatrix(R) if (nrow(R) != ncol(R)) { abort("`R` must be square.") } @@ -279,7 +290,8 @@ pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { # Internal: compute one method's combined p-value. Assumes inputs have # already been validity-filtered (positive, finite, < 1) and aligned with R. -.combinePvalSingle <- function(method, pvals, zScores, R) { +.combinePvalSingle <- function(method, pvals, zScores, R, methodArgs = list()) { + args <- .combinePvalMethodArgs(methodArgs, method) switch( method, acat = pvalAcat(pvals), @@ -287,19 +299,54 @@ pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { bonferroni = min(length(pvals) * min(pvals), 1.0), fisher = , stouffer = , - invchisq = pvalPoolr(pvals, method = method, R = R), + invchisq = pvalPoolr(pvals, method = method, R = R, methodArgs = args), gbj = , bj = , hc = , ghc = , minp = , - gbj_omni = pvalGbj(zScores, R = R, method = method), - aspu = pvalAspu(zScores = zScores, R = R, method = "aspu"), + gbj_omni = pvalGbj( + zScores, + R = R, + method = method, + methodArgs = args + ), + aspu = pvalAspu( + zScores = zScores, + R = R, + method = "aspu", + methodArgs = args + ), gates = pvalAspu(pvals = pvals, R = R, method = "gates"), .abortUnknownMethod("combination", method) ) } +# One method's entry out of the PvalMethodsParam() record, or that method's +# own empty record when the caller configured nothing for it. Returning the +# constructor's result rather than list() keeps each engine's pecotmr +# defaults -- poolr's `adjust = "generalized"` -- in force either way. +# @noRd +.combinePvalMethodArgs <- function(methodArgs, method) { + entries <- .pvalMethodEntriesOf(methodArgs) + i <- match(method, names(entries)) + if (!is.na(i)) { + return(entries[[i]]) + } + ctors <- .pvalMethodCtors() + if (is_in(method, names(ctors))) ctors[[method]]() else list() +} + +# The per-method entries, whether they arrived in a PvalMethodsParam or as +# the bare list() that still means "no settings". +# @noRd +.pvalMethodEntriesOf <- function(methodArgs) { + if (is(methodArgs, "PvalMethodsParam")) { + return(slot(methodArgs, "methods") %||% list()) + } + methodArgs %||% list() +} + #' Combine P-values via Any of a Menu of Methods #' #' Unified dispatcher for combining a vector of p-values (and/or z-scores) into @@ -336,6 +383,12 @@ pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { #' \code{zScores}. Required for the correlation-adjusted methods. #' @param naRm Logical; if \code{TRUE} (default), drop NA p-values before #' combination. +#' @param methodArgs Per-method engine options, built with +#' \code{\link{PvalMethodsParam}} -- for example +#' \code{PvalMethodsParam(aspu = AspuOptions(n.perm = 5000))}. Configuring +#' a method that \code{methods} does not request is an error rather than a +#' silent no-op. \code{acat}, \code{hmp}, \code{bonferroni} and +#' \code{gates} take no options. #' @return A list with two elements: #' \describe{ #' \item{input}{Summary of the call: \code{nPvalsIn}, @@ -347,14 +400,19 @@ pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { #' @examples #' combinePValues(pvals = c(0.01, 0.2, 0.5), methods = "fisher", R = diag(3)) #' @export +#' @importFrom checkmate assertFlag combinePValues <- function( pvals = NULL, zScores = NULL, methods, R = NULL, - naRm = TRUE + naRm = TRUE, + methodArgs = PvalMethodsParam() ) { + assertFlag(naRm) + .assertMethodParam(methodArgs, "PvalMethodsParam", "methodArgs") methods <- .combinePvalCheckMethods(methods) + .combinePvalCheckMethodArgs(methodArgs, methods) nPvalsIn <- if (is.null(pvals)) 0L else length(pvals) nZScoresIn <- if (is.null(zScores)) 0L else length(zScores) .combinePvalCheckPrereqs(methods, zScores, R) @@ -376,7 +434,8 @@ combinePValues <- function( methods, filt$pvalsK, filt$zScoresK, - Raligned + Raligned, + methodArgs ) .combinePvalResult(perMethod, input) } @@ -400,6 +459,23 @@ combinePValues <- function( methods } +# Options for a method that was not requested would be dropped in silence -- +# exactly the failure the constructors exist to prevent -- so say so instead. +# @noRd +.combinePvalCheckMethodArgs <- function(methodArgs, methods) { + configured <- names(.pvalMethodEntriesOf(methodArgs)) + unused <- setdiff(configured, methods) + if (length(unused) == 0L) { + return(invisible(NULL)) + } + msg <- glue( + "combinePValues: `methodArgs` configures ", + "{str_flatten(unused, ', ')}, which `methods` does not request ", + "({str_flatten(methods, ', ')}), so those options would be ignored." + ) + abort(msg) +} + # Method-level prerequisites: z-score-requiring + R-requiring methods. # @noRd .combinePvalCheckPrereqs <- function(methods, zScores, R) { @@ -503,27 +579,40 @@ combinePValues <- function( # Run each method, warning + NA on per-method failure. # @noRd -.combinePvalRunMethods <- function(methods, pvalsK, zScoresK, Raligned) { +.combinePvalRunMethods <- function( + methods, + pvalsK, + zScoresK, + Raligned, + methodArgs +) { set_names( map( methods, .combinePvalRunOne, pvalsK = pvalsK, zScoresK = zScoresK, - Raligned = Raligned + Raligned = Raligned, + methodArgs = methodArgs ), methods ) } # @noRd -.combinePvalRunOne <- function(m, pvalsK, zScoresK, Raligned) { - p <- tryCatch( - .combinePvalSingle(m, pvals = pvalsK, zScores = zScoresK, R = Raligned), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("combinePValues: method '{m}' failed: {eMsg}") - warn(msg) +#' @importFrom rlang try_fetch +.combinePvalRunOne <- function(m, pvalsK, zScoresK, Raligned, methodArgs) { + p <- try_fetch( + .combinePvalSingle( + m, + pvals = pvalsK, + zScores = zScoresK, + R = Raligned, + methodArgs = methodArgs + ), + error = function(cnd) { + msg <- glue("combinePValues: method '{m}' failed") + warn(msg, parent = cnd) NA_real_ } ) @@ -534,3 +623,256 @@ combinePValues <- function( .combinePvalResult <- function(perMethod, input) { list(input = input, results = perMethod) } + +# ============================================================================= +# Engine option records +# ============================================================================= + +#' @title Options for the GBJ Family of Combination Tests +#' @description Build a checked record of extra arguments for the \pkg{GBJ} +#' set-based tests behind \code{\link{combinePValues}} methods +#' \code{"gbj"}, \code{"bj"}, \code{"hc"}, \code{"ghc"} and \code{"minp"}. +#' All five share one signature, so one constructor covers them. +#' @param ... Arguments for \code{GBJ::GBJ()} and its siblings -- in practice +#' \code{pairwise_cors}, the vector of pairwise correlations the test would +#' otherwise derive from \code{cor_mat}. Names are checked against the +#' engine's formals, so a misspelling is an error rather than a silent drop. +#' \code{test_stats} and \code{cor_mat} are supplied by pecotmr and refused. +#' @return A \code{MethodOptions} record for +#' \code{\link{PvalMethodsParam}}. +#' @seealso \code{\link{combinePValues}}, \code{\link{GbjOmniOptions}} +#' @examples +#' GbjOptions(pairwise_cors = rep(0.1, 3)) +#' @export +GbjOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + test_stats = "the caller's `zScores`", + cor_mat = "the caller's `R`" + ), + "GbjOptions" + ) + .newMethodOptions( + c("GBJ::GBJ", "GBJ::BJ", "GBJ::HC", "GBJ::GHC", "GBJ::minP"), + defaults = list(), + extra = extra, + label = "GbjOptions", + engine = "gbj" + ) +} + +#' @title Options for the GBJ Omnibus Combination Test +#' @description Build a checked record of extra arguments for +#' \code{GBJ::OMNI_ss()}, the engine behind \code{\link{combinePValues}} +#' method \code{"gbj_omni"}. It takes a different option from its siblings +#' (\code{num_boots} rather than \code{pairwise_cors}), so it has its own +#' constructor. +#' @param ... Arguments for \code{GBJ::OMNI_ss()} -- in practice +#' \code{num_boots}, the bootstrap count the omnibus null is built from. +#' \code{test_stats} and \code{cor_mat} are supplied by pecotmr and refused. +#' @return A \code{MethodOptions} record for +#' \code{\link{PvalMethodsParam}}. +#' @seealso \code{\link{combinePValues}}, \code{\link{GbjOptions}} +#' @examples +#' GbjOmniOptions(num_boots = 200) +#' @export +GbjOmniOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + test_stats = "the caller's `zScores`", + cor_mat = "the caller's `R`" + ), + "GbjOmniOptions" + ) + .newMethodOptions( + "GBJ::OMNI_ss", + defaults = list(), + extra = extra, + label = "GbjOmniOptions", + engine = "gbjOmni" + ) +} + +#' @title Options for the aSPU Combination Test +#' @description Build a checked record of extra arguments for +#' \code{aSPU::aSPUs()}, the engine behind \code{\link{combinePValues}} +#' method \code{"aspu"}. +#' @param ... Arguments for \code{aSPU::aSPUs()}: \code{pow} (the SPU powers +#' the omnibus minimises over), \code{n.perm} (permutation count -- aSPU's +#' p-value resolution is bounded by it), \code{Ps} and \code{prune}. +#' \code{Zs} and \code{corSNP} are supplied by pecotmr and refused. +#' @return A \code{MethodOptions} record for +#' \code{\link{PvalMethodsParam}}. +#' @seealso \code{\link{combinePValues}} +#' @examples +#' AspuOptions(n.perm = 5000) +#' @export +AspuOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + Zs = "the caller's `zScores`", + corSNP = "the caller's `R`" + ), + "AspuOptions" + ) + .newMethodOptions( + "aSPU::aSPUs", + defaults = list(), + extra = extra, + label = "AspuOptions", + engine = "aspu" + ) +} + +#' @title Options for the poolr Combination Tests +#' @description Build a record of extra arguments for \code{poolr::fisher()}, +#' \code{poolr::stouffer()} and \code{poolr::invchisq()} -- the engines +#' behind \code{\link{combinePValues}} methods \code{"fisher"}, +#' \code{"stouffer"} and \code{"invchisq"}. All three share one signature. +#' @param ... Arguments for the chosen \pkg{poolr} test: \code{adjust} (the +#' correlation adjustment; pecotmr defaults it to \code{"generalized"}), +#' \code{m}, \code{size}, \code{threshold}, \code{side}, \code{batchsize} +#' and \code{nearpd}. The \pkg{poolr} signatures end in \code{...}, so +#' names cannot be checked here and a misspelling is passed through. +#' \code{p} and \code{R} are supplied by pecotmr and refused. +#' @return A \code{MethodOptions} record for +#' \code{\link{PvalMethodsParam}}. +#' @seealso \code{\link{combinePValues}} +#' @examples +#' PoolrOptions(adjust = "empirical", side = 1) +#' @export +PoolrOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + p = "the caller's `pvals`", + R = "the caller's `R`" + ), + "PoolrOptions" + ) + .newMethodOptions( + c("poolr::fisher", "poolr::stouffer", "poolr::invchisq"), + defaults = list(adjust = "generalized"), + extra = extra, + label = "PoolrOptions", + engine = "poolr" + ) +} + +# Which constructor configures each combinePValues() method. Keys that share +# an engine share a constructor: the five GBJ set tests have one signature, +# and so do the three poolr tests. A method absent from this map takes no +# options -- acat, hmp and bonferroni are pecotmr's own arithmetic, and +# gates's aSPU::GATES2() has no formal beyond the two pecotmr supplies. +# @noRd +.pvalMethodCtors <- function() { + list( + fisher = PoolrOptions, + stouffer = PoolrOptions, + invchisq = PoolrOptions, + gbj = GbjOptions, + bj = GbjOptions, + hc = GbjOptions, + ghc = GbjOptions, + minp = GbjOptions, + gbj_omni = GbjOmniOptions, + aspu = AspuOptions + ) +} + +#' @rdname PvalMethodsParam +#' @aliases PvalMethodsParam-class +#' @exportClass PvalMethodsParam +setClass( + "PvalMethodsParam", + contains = "MethodParam", + slots = c(methods = "list_OR_NULL") +) + +#' @title Per-Method Options for combinePValues +#' @description Bundle per-method engine options for +#' \code{\link{combinePValues}}. Each entry is named for the method it +#' configures and built with that method's constructor, so an option meant +#' for one engine cannot silently reach another. +#' @param fisher,stouffer,invchisq Options for those poolr tests, built with +#' \code{\link{PoolrOptions}}. +#' @param gbj,bj,hc,ghc,minp Options for those GBJ tests, built with +#' \code{\link{GbjOptions}}. +#' @param gbj_omni Options for the GBJ omnibus test, built with +#' \code{\link{GbjOmniOptions}}. +#' @param aspu Options for aSPU, built with \code{\link{AspuOptions}}. +#' @details Each entry may be given as a plain named list instead, which is +#' spliced into that method's constructor and so gets the same defaults and +#' the same checking. +#' +#' \code{acat}, \code{hmp}, \code{bonferroni} and \code{gates} are valid +#' \code{combinePValues} methods but take no options, so they are not +#' arguments here --- naming one is an unused-argument error. +#' @return A \code{PvalMethodsParam} object, a \code{\link{MethodParam}}, +#' for \code{combinePValues(methodArgs =)}. \code{names()} lists the +#' methods that were configured. +#' @seealso \code{\link{combinePValues}} +#' @examples +#' PvalMethodsParam(aspu = AspuOptions(n.perm = 5000)) +#' @export +PvalMethodsParam <- function( + fisher = NULL, + stouffer = NULL, + invchisq = NULL, + gbj = NULL, + bj = NULL, + hc = NULL, + ghc = NULL, + minp = NULL, + gbj_omni = NULL, + aspu = NULL +) { + # discard(is.null), not compact(): naming a method with default options + # must still configure it, and compact() would drop an empty record. + given <- discard( + list( + fisher = fisher, + stouffer = stouffer, + invchisq = invchisq, + gbj = gbj, + bj = bj, + hc = hc, + ghc = ghc, + minp = minp, + gbj_omni = gbj_omni, + aspu = aspu + ), + is.null + ) + # One named-list slot rather than one nullable slot per method: a + # record configuring aspu showed eight NULL slots and one set, which + # tells a reader nothing. The formals stay named, so R still rejects a + # misspelled method before the body runs. + entries <- .pvalMethodEntries(given) + new( + "PvalMethodsParam", + methods = if (length(entries) == 0L) NULL else entries + ) +} + +# Each entry validated and built the same way: a plain list is spliced into +# that method's constructor, a built record passes through, and one built by +# the WRONG constructor is refused -- several methods share an engine (poolr +# covers three, GBJ five), so the check is on the engine the key's own +# constructor produces, not on the key. +# @noRd +.pvalMethodEntries <- function(given) { + if (length(given) == 0L) { + return(list()) + } + ctors <- .pvalMethodCtors() + .nestedAssertEngines(given, ctors, NULL, "PvalMethodsParam") + imap(given, .nestedElement, ctors = ctors, label = "PvalMethodsParam") +} diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index 21bd39d41..2fa8abe2d 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -19,39 +19,91 @@ # perm thresh-> stats::qbeta (empirical bracketing feeds the beta quantile) # ============================================================================= +#' @title Options for Storey q-value Estimation +#' @description Build a record of extra arguments for +#' \code{qvalue::qvalue()}, the Storey q-value engine behind +#' \code{\link{qtlAssociationPostprocess}}. +#' @param ... Arguments for \code{qvalue::qvalue()}: \code{pi0}, the +#' \code{pi0.method} / \code{lambda} pair that sets how the null +#' proportion is estimated, \code{pfdr}, \code{fdr.level} and +#' \code{lfdr.out}. \code{qvalue()}'s signature ends in \code{...}, so +#' names cannot be checked here and a misspelling is passed through. +#' \code{p} is the p-value vector pecotmr assembles and is refused. +#' +#' pecotmr retries \code{qvalue()} on its two documented degenerate cases +#' ("missing or infinite" with \code{lambda = 0}, "pi0 <= 0" with a +#' bootstrap \code{pi0}); setting \code{lambda} or \code{pi0.method} +#' here replaces the first attempt, and the retries still override them +#' when that attempt fails. +#' @return A \code{MethodOptions} record for +#' \code{qtlAssociationPostprocess(qvalueArgs =)}. +#' @seealso \code{\link{qtlAssociationPostprocess}} +#' @examples +#' QvalueOptions(pi0.method = "bootstrap") +#' @export +QvalueOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c(p = "the p-value vector pecotmr assembles"), + "QvalueOptions" + ) + .newMethodOptions( + "qvalue::qvalue", + defaults = list(), + extra = extra, + label = "QvalueOptions", + engine = "qvalue" + ) +} + # 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) { +#' @importFrom rlang try_fetch +.qapSafeQvalue <- function(p, qvalueArgs = list()) { + # Engine-call exception: qvalue estimates FDR for this module's own + # output. qtlAssociationPostprocess.R is a topical module rather than a + # pipeline, and is the only consumer of the call. if (!requireNamespace("qvalue", quietly = TRUE)) { # Optional-package guard; qvalue is Suggests-only. msg <- glue( "qtlAssociationPostprocess: the 'qvalue' package is required for ", - "Storey q-values. Install Bioconductor 'qvalue'." + "Storey q-values." ) abort(msg) } - tryCatch( - qvalue::qvalue(p)$qvalues, - error = function(e) { - if (str_detect(conditionMessage(e), "missing or infinite")) { - qvalue::qvalue(p, lambda = 0)$qvalues - } else if (str_detect(conditionMessage(e), "pi0 <= 0")) { + extra <- as.list(qvalueArgs) + try_fetch( + exec(qvalue::qvalue, p, !!!extra)$qvalues, + error = function(cnd) { + if (str_detect(conditionMessage(cnd), "missing or infinite")) { + exec( + qvalue::qvalue, + p, + !!!list_assign(extra, lambda = 0) + )$qvalues + } else if (str_detect(conditionMessage(cnd), "pi0 <= 0")) { maxP <- max(p, na.rm = TRUE) lambdaSeq <- seq(0, min(0.9, maxP * 0.95), length.out = 10) - qvalue::qvalue( + exec( + qvalue::qvalue, p, - lambda = lambdaSeq, - pi0.method = "bootstrap" + !!!list_assign( + extra, + lambda = lambdaSeq, + pi0.method = "bootstrap" + ) )$qvalues } else { + # The cause is chained via `parent`, so it is no longer + # interpolated into the message. msg <- glue( - "qtlAssociationPostprocess: qvalue::qvalue failed ", - "({conditionMessage(e)}). Not substituting a ", - "hand-rolled q-value." + "qtlAssociationPostprocess: qvalue::qvalue failed. ", + "Not substituting a hand-rolled q-value." ) - abort(msg) + abort(msg, parent = cnd) } } ) @@ -59,10 +111,10 @@ # 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) { +.qapGlobalAdjust <- function(eventP, qvalueArgs = list()) { list( fdr = stats::p.adjust(eventP, method = "fdr"), - q = .qapSafeQvalue(eventP) + q = .qapSafeQvalue(eventP, qvalueArgs) ) } @@ -94,18 +146,18 @@ # 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) + byMaf <- if (mafCutoff > 0 && !is.null(mc[[afCol]])) { + pmin(mc[[afCol]], 1 - mc[[afCol]]) > mafCutoff + } else { + rep(TRUE, nVar) } - if ( - cisWindow > 0 && !is.null(mc$tss_distance) && !is.null(mc$tes_distance) - ) { - keep <- keep & - (mc$tss_distance >= -cisWindow & mc$tes_distance <= cisWindow) + inCis <- cisWindow > 0 && + !is.null(mc$tss_distance) && + !is.null(mc$tes_distance) + if (!inCis) { + return(byMaf) } - keep + byMaf & (mc$tss_distance >= -cisWindow & mc$tes_distance <= cisWindow) } # Per-gene logical masks of significant variants under a correction method (the @@ -151,15 +203,25 @@ ) abort(msg) } - thr <- as.numeric(x$p_nominal_threshold) - for (i in seq_len(nrow(x))) { - if (is.na(thr[i])) { - next - } - pv <- S4Vectors::mcols(x[[i]])[[pcol]] - masks[[i]] <- !is.na(pv) & pv < thr[i] + map( + seq_len(nrow(x)), + .qapPermutationMaskAt, + x = x, + masks = masks, + thr = as.numeric(x$p_nominal_threshold), + pcol = pcol + ) +} + +# Entry `i`'s permutation mask, or the incoming mask when the gene has no +# threshold to apply. +# @noRd +.qapPermutationMaskAt <- function(i, x, masks, thr, pcol) { + if (is.na(thr[i])) { + return(masks[[i]]) } - masks + pv <- S4Vectors::mcols(x[[i]])[[pcol]] + !is.na(pv) & pv < thr[i] } # Bonferroni significance (original / filtered flavour): a global variant-level @@ -183,17 +245,20 @@ } # global scalar varThr <- max(as.numeric(.tupleColumn(x, pMinCol))[sig], na.rm = TRUE) - nVar <- as.numeric(.tupleColumn(x, nCol)) - for (i in seq_len(nrow(x))) { - masks[[i]] <- .qapBonferroniRowMask( - x[[i]], - recipe, - flav, - nVar[i], - varThr - ) - } - masks + map( + seq_len(nrow(x)), + .qapBonferroniMaskAt, + x = x, + recipe = recipe, + flav = flav, + nVar = as.numeric(.tupleColumn(x, nCol)), + varThr = varThr + ) +} + +# @noRd +.qapBonferroniMaskAt <- function(i, x, recipe, flav, nVar, varThr) { + .qapBonferroniRowMask(x[[i]], recipe, flav, nVar[i], varThr) } # One entry's Bonferroni keep-mask: Bonferroni-adjusted p <= the global @@ -202,9 +267,11 @@ .qapBonferroniRowMask <- function(entry, recipe, flav, nVarI, varThr) { mc <- S4Vectors::mcols(entry) pv <- mc[[recipe$pvalueCol]] - keep <- pmin(1, pv * nVarI) <= varThr - if (flav == "filtered") { - keep <- keep & + bySignificance <- pmin(1, pv * nVarI) <= varThr + keep <- if (flav != "filtered") { + bySignificance + } else { + bySignificance & .qapFilterKeep( mc, recipe$mafCutoff, @@ -219,6 +286,17 @@ # Q-value significance: per-entry mask of variant q-values below the threshold # for the FDR-significant genes. # @noRd +# Entry `i`'s q-value mask, or the incoming mask when the gene is not +# FDR-significant or carries no per-variant q-values. +# @noRd +.qapQvalueMaskAt <- function(i, x, masks, sig, threshold) { + mc <- S4Vectors::mcols(x[[i]]) + if (!isTRUE(sig[i]) || is.null(mc$qvalue)) { + return(masks[[i]]) + } + !is.na(mc$qvalue) & mc$qvalue < threshold +} + .qapMaskQvalue <- function(x, masks, threshold) { qCol <- if (!is.null(x$q_beta)) "q_beta" else "q_bonferroni_min_original" if (is.null(.tupleColumn(x, qCol))) { @@ -228,14 +306,14 @@ ) abort(msg) } - sig <- replace_na(as.numeric(.tupleColumn(x, qCol)) < threshold, FALSE) - for (i in seq_len(nrow(x))) { - mc <- S4Vectors::mcols(x[[i]]) - if (isTRUE(sig[i]) && !is.null(mc$qvalue)) { - masks[[i]] <- !is.na(mc$qvalue) & mc$qvalue < threshold - } - } - masks + map( + seq_len(nrow(x)), + .qapQvalueMaskAt, + x = x, + masks = masks, + sig = replace_na(as.numeric(.tupleColumn(x, qCol)) < threshold, FALSE), + threshold = threshold + ) } #' @rdname getSignificantQtls @@ -260,8 +338,9 @@ setMethod( ) { method <- arg_match(method) masks <- .qapSignificanceMask(x, method, threshold) - pieces <- map(seq_len(nrow(x)), .qapMaskedEntry, x = x, masks = masks) - pieces <- pieces[!map_lgl(pieces, is.null)] + pieces <- compact( + map(seq_len(nrow(x)), .qapMaskedEntry, x = x, masks = masks) + ) if (length(pieces) == 0L) { return(x[[1L]][0L]) } @@ -277,16 +356,28 @@ setMethod( # The collection is a GRangesList now, not a DFrame: the per-variant # GRanges are the elements and `newCols` are per-tuple metadata, so the # rebuild keeps the elements as-is and only rewrites mcols. - md <- mcols(x, use.names = FALSE) - for (nm in names(newCols)) { - md[[nm]] <- newCols[[nm]] + existing <- mcols(x, use.names = FALSE) + # A NULL entry in `newCols` removed that column, which is what dropping + # every named column and re-adding only the non-NULL ones reproduces. + kept <- existing[, + setdiff(colnames(existing), names(newCols)), + drop = FALSE + ] + added <- compact(newCols) + md <- if (length(added) == 0L) { + kept + } else { + cbind(kept, S4Vectors::DataFrame(added, check.names = FALSE)) } - grl <- GenomicRanges::GRangesList(as.list(x)) # Rebuilding from as.list() starts from the elements' own seqinfo, so the # build is written back explicitly -- it is collection-level state, and # there is no genome slot to carry it any more. - GenomeInfoDb::genome(grl) <- getGenome(x) - mcols(grl) <- md + built <- .withGenomeBuild( + GenomicRanges::GRangesList(as.list(x)), + TRUE, + getGenome(x) + ) + grl <- S4Vectors::`mcols<-`(built, value = md) methods::new( "QtlSumStats", grl, @@ -312,6 +403,9 @@ setMethod( #' \code{getSignificantQtls}). #' @param pvalueCol,afCol Entry mcol names for the per-variant p-value / allele #' frequency (defaults \code{"P"} / \code{"af"}). +#' @param qvalueArgs Extra arguments for \code{qvalue::qvalue()}, built with +#' \code{\link{QvalueOptions}} -- the \code{pi0.method} / \code{lambda} +#' pair in particular, which sets how the null proportion is estimated. #' @export setMethod( "qtlAssociationPostprocess", @@ -323,47 +417,79 @@ setMethod( cisWindow = 0, methods = c("permutation", "bonferroni"), pvalueCol = "P", - afCol = "af" + afCol = "af", + qvalueArgs = QvalueOptions() ) { + .assertMethodOptions(qvalueArgs, "QvalueOptions", "qvalueArgs") methods <- arg_match( methods, c("permutation", "bonferroni"), multiple = TRUE ) filtering <- (mafCutoff > 0 || cisWindow > 0) - newCols <- list() - if (is_in("bonferroni", methods)) { - newCols <- c( - newCols, - .qapBonferroniCols( - x, - mafCutoff, - cisWindow, - pvalueCol, - afCol, - filtering - ) - ) - } - if (is_in("permutation", methods) && !is.null(x$p_beta)) { - newCols <- c(newCols, .qapPermutationCols(x, fdrThreshold)) - } + newCols <- .qapNewCols( + x, + methods = methods, + mafCutoff = mafCutoff, + cisWindow = cisWindow, + pvalueCol = pvalueCol, + afCol = afCol, + filtering = filtering, + fdrThreshold = fdrThreshold, + qvalueArgs = qvalueArgs + ) # Stash the correction recipe so getSignificantQtls / # annotateSignificance can reproduce significance cheaply (thresholds, # not flags). - qc <- getQcInfo(x) - qc$associationPostprocess <- .qapRecipe( - fdrThreshold, - mafCutoff, - cisWindow, - methods, - pvalueCol, - afCol + qc <- list_assign( + getQcInfo(x), + associationPostprocess = list( + fdrThreshold = fdrThreshold, + mafCutoff = mafCutoff, + cisWindow = cisWindow, + methods = methods, + pvalueCol = pvalueCol, + afCol = afCol + ) ) .qapRebuild(x, newCols, qc) } ) +# The corrected-statistic columns for the requested methods. Permutation +# columns need `p_beta`, which only a permutation run carries, so that half +# is skipped rather than refused when it is absent. +# @noRd +.qapNewCols <- function( + x, + methods, + mafCutoff, + cisWindow, + pvalueCol, + afCol, + filtering, + fdrThreshold, + qvalueArgs +) { + c( + if (is_in("bonferroni", methods)) { + .qapBonferroniCols( + x, + mafCutoff, + cisWindow, + pvalueCol, + afCol, + filtering, + qvalueArgs + ) + }, + if (is_in("permutation", methods) && !is.null(x$p_beta)) { + .qapPermutationCols(x, fdrThreshold, qvalueArgs) + } + ) %||% + list() +} + # Local Bonferroni correction columns: per-gene min adjusted p (original and, # when filtering, filtered) plus their global FDR / q-value adjustments. # @noRd @@ -373,7 +499,8 @@ setMethod( cisWindow, pvalueCol, afCol, - filtering + filtering, + qvalueArgs = list() ) { nVar <- .qapBonferroniNVar(x) nVarFilt <- if (!is.null(x$n_variants_filtered)) { @@ -398,17 +525,31 @@ setMethod( cisWindow, filtering ) - cols <- list(p_bonferroni_min_original = perGene$orig) - gaO <- .qapGlobalAdjust(perGene$orig) - cols$fdr_bonferroni_min_original <- gaO$fdr - cols$q_bonferroni_min_original <- gaO$q - if (filtering) { - cols$p_bonferroni_min_filtered <- perGene$filt - gaF <- .qapGlobalAdjust(perGene$filt) - cols$fdr_bonferroni_min_filtered <- gaF$fdr - cols$q_bonferroni_min_filtered <- gaF$q + gaO <- .qapGlobalAdjust(perGene$orig, qvalueArgs) + gaF <- if (filtering) { + .qapGlobalAdjust(perGene$filt, qvalueArgs) + } else { + NULL } - cols + .qapBonferroniResultCols(perGene, gaO, gaF, filtering) +} + +# The Bonferroni column set: always the original-scale trio, plus the +# filtered trio when a MAF / cis-window filter was applied. +# @noRd +.qapBonferroniResultCols <- function(perGene, gaO, gaF, filtering) { + c( + list( + p_bonferroni_min_original = perGene$orig, + fdr_bonferroni_min_original = gaO$fdr, + q_bonferroni_min_original = gaO$q + ), + compact(list( + p_bonferroni_min_filtered = if (filtering) perGene$filt, + fdr_bonferroni_min_filtered = gaF$fdr, + q_bonferroni_min_filtered = gaF$q + )) + ) } # The n_variants row column is mandatory for the Bonferroni correction. @@ -428,88 +569,97 @@ setMethod( # pre-filter always retains the global-min variant, so the min over the entry is # the exact per-gene min. Returns list(orig, filt). # @noRd -.qapBonferroniPerGene <- function( +# One gene's Bonferroni-adjusted minimum p-value, before and after the +# variant filter. NA on either side means the gene had nothing to adjust. +# @noRd +.qapBonferroniForGene <- function( + i, x, + pvalueCol, nVar, nVarFilt, - pvalueCol, afCol, mafCutoff, cisWindow, filtering ) { - n <- nrow(x) - pBonfOrig <- rep(NA_real_, n) - pBonfFilt <- rep(NA_real_, n) - for (i in seq_len(n)) { - mc <- S4Vectors::mcols(x[[i]]) - pv <- mc[[pvalueCol]] - if (is.null(pv) || length(pv) == 0L) { - next - } - pBonfOrig[i] <- min(stats::p.adjust( - pv, + mc <- S4Vectors::mcols(x[[i]]) + pv <- mc[[pvalueCol]] + if (is.null(pv) || length(pv) == 0L) { + return(list(orig = NA_real_, filt = NA_real_)) + } + orig <- min(stats::p.adjust(pv, method = "bonferroni", n = nVar[i])) + if (!filtering) { + return(list(orig = orig, filt = NA_real_)) + } + keep <- .qapFilterKeep(mc, mafCutoff, cisWindow, afCol, length(pv)) + if (!any(keep)) { + return(list(orig = orig, filt = NA_real_)) + } + list( + orig = orig, + filt = min(stats::p.adjust( + pv[keep], method = "bonferroni", - n = nVar[i] + n = nVarFilt[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] - )) - } - } - } - list(orig = pBonfOrig, filt = pBonfFilt) + ) +} + +.qapBonferroniPerGene <- function( + x, + nVar, + nVarFilt, + pvalueCol, + afCol, + mafCutoff, + cisWindow, + filtering +) { + perGene <- map( + seq_len(nrow(x)), + .qapBonferroniForGene, + x = x, + pvalueCol = pvalueCol, + nVar = nVar, + nVarFilt = nVarFilt, + afCol = afCol, + mafCutoff = mafCutoff, + cisWindow = cisWindow, + filtering = filtering + ) + list( + orig = map_dbl(perGene, "orig"), + filt = map_dbl(perGene, "filt") + ) } # Permutation columns: BH-FDR of p_beta, the Storey q-value (q_beta, when # absent), and the per-gene nominal p threshold from the beta shape params. # @noRd -.qapPermutationCols <- function(x, fdrThreshold) { +.qapPermutationCols <- function(x, fdrThreshold, qvalueArgs = list()) { pBeta <- as.numeric(x$p_beta) qBeta <- if (!is.null(x$q_beta)) { as.numeric(x$q_beta) } else { - .qapSafeQvalue(pBeta) + .qapSafeQvalue(pBeta, qvalueArgs) } - cols <- list() - if (is.null(x$q_beta)) { - cols$q_beta <- qBeta - } - cols$fdr_beta <- stats::p.adjust(pBeta, method = "fdr") - if (!is.null(x$beta_shape1) && !is.null(x$beta_shape2)) { - cols$p_nominal_threshold <- .qapPermutationNominalThreshold( - pBeta, - qBeta, - as.numeric(x$beta_shape1), - as.numeric(x$beta_shape2), - fdrThreshold - ) - } - cols -} - -# The significance recipe stashed for cheap downstream re-derivation. -# @noRd -.qapRecipe <- function( - fdrThreshold, - mafCutoff, - cisWindow, - methods, - pvalueCol, - afCol -) { - list( - fdrThreshold = fdrThreshold, - mafCutoff = mafCutoff, - cisWindow = cisWindow, - methods = methods, - pvalueCol = pvalueCol, - afCol = afCol + c( + compact(list(q_beta = if (is.null(x$q_beta)) qBeta)), + list(fdr_beta = stats::p.adjust(pBeta, method = "fdr")), + compact(list( + p_nominal_threshold = if ( + !is.null(x$beta_shape1) && !is.null(x$beta_shape2) + ) { + .qapPermutationNominalThreshold( + pBeta, + qBeta, + as.numeric(x$beta_shape1), + as.numeric(x$beta_shape2), + fdrThreshold + ) + } + )) ) } @@ -529,8 +679,15 @@ setMethod( 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 + S4Vectors::`mcols<-`( + gr, + value = cbind( + mcols(gr, use.names = FALSE), + S4Vectors::DataFrame( + study = as.character(x$study)[i], + context = as.character(x$context)[i], + trait = as.character(x$trait)[i] + ) + ) + ) } diff --git a/R/qtlEnrichmentPipeline.R b/R/qtlEnrichmentPipeline.R index 9519f616c..2c79287bf 100644 --- a/R/qtlEnrichmentPipeline.R +++ b/R/qtlEnrichmentPipeline.R @@ -1,3 +1,65 @@ +#' @include MethodParam.R +NULL + +#' @rdname QtlEnrichmentParam +#' @aliases QtlEnrichmentParam-class +#' @exportClass QtlEnrichmentParam +setClass( + "QtlEnrichmentParam", + contains = "MethodParam", + slots = c( + numGwas = "numeric_OR_NULL", + piQtl = "numeric_OR_NULL", + lambda = "numeric", + impN = "numeric", + doubleShrinkage = "logical", + besselCorrection = "logical" + ) +) + +#' @title Arguments For The QTL Enrichment Estimator +#' @description The algorithmic settings \code{\link{qtlEnrichment}} takes, +#' as one checked bundle. Everything else that function accepts --- the two +#' data arguments, \code{numThreads}, \code{seed}, \code{verbose}, and the +#' \code{alignNames} switch --- is the pipeline's own business and is not +#' settable here. +#' @param numGwas Number of GWAS variants used to estimate \code{piGwas}. +#' \code{NULL} (default) estimates it from the data, which is biased unless +#' the outcome PIP vector really is genome-wide. +#' @param piQtl Per-variant prior of being a causal QTL variant. \code{NULL} +#' (default) estimates it from the data. +#' @param lambda Shrinkage parameter, shrinking the enrichment estimate +#' towards zero as in ridge regression. \code{0} applies no shrinkage. +#' Default \code{1.0}. +#' @param impN Rounds of multiple imputation to draw QTL from. Default +#' \code{25}. +#' @param doubleShrinkage Logical. Apply the double-shrinkage correction to +#' the enrichment estimate. Default \code{FALSE}. +#' @param besselCorrection Logical. Apply Bessel's correction when estimating +#' the sampling variance. Default \code{TRUE}. +#' @return A \code{QtlEnrichmentParam} object, a \code{\link{MethodParam}}. +#' @examples +#' QtlEnrichmentParam(lambda = 0, impN = 50) +#' @export +QtlEnrichmentParam <- function( + numGwas = NULL, + piQtl = NULL, + lambda = 1.0, + impN = 25, + doubleShrinkage = FALSE, + besselCorrection = TRUE +) { + new( + "QtlEnrichmentParam", + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + doubleShrinkage = doubleShrinkage, + besselCorrection = besselCorrection + ) +} + #' @title QTL Enrichment Pipeline (Genome-Wide) #' @description Genome-wide pipeline that computes per-pair enrichment #' estimates by passing an outcome PIP vector and a set of annotation @@ -41,21 +103,17 @@ #' #' @param gwasFineMappingResult The outcome side; see above. #' @param qtlFineMappingResult The annotation side; see above. -#' @param numGwas Number of GWAS variants used to estimate \code{piGwas}. When -#' \code{NULL} (default) it is estimated from the data -- bias warning applies -#' if the input PIP vector is not genome-wide. -#' @param piQtl Per-variant prior of being a QTL causal variant. \code{NULL} -#' (default) estimates from the data. -#' @param lambda Shrinkage parameter for the enrichment estimator. Default -#' \code{1.0}. -#' @param impN Number of imputed samples used by the estimator. Default -#' \code{25}. +#' @param methodArgs The estimator's algorithmic settings, built with +#' \code{\link{QtlEnrichmentParam}}: \code{numGwas}, \code{piQtl}, +#' \code{lambda}, \code{impN}, \code{doubleShrinkage} and +#' \code{besselCorrection}. A bare list is refused, since it cannot be +#' checked. #' @param numThreads Number of threads used by \code{qtlEnrichment}. Default #' \code{1}. #' @param seed Integer or \code{NULL}. Base random seed forwarded to #' \code{\link{qtlEnrichment}} for reproducible multiple imputation. #' \code{NULL} (default) draws a nondeterministic seed. -#' @param ... Additional arguments forwarded to \code{\link{qtlEnrichment}}. +#' @param verbose Logical. Print progress messages. Default \code{TRUE}. #' @return A tibble with one row per (outcome trait, annotation unit) pair. #' The identity columns are \code{gwasStudy}, \code{gwasContext}, #' \code{gwasTrait}, \code{qtlStudy}, \code{qtlContext}; the axes a side does @@ -67,15 +125,17 @@ #' The estimates are \code{enrichmentLogOdds}, the enrichment parameter #' \eqn{a_1} on the log-odds scale, with its standard error #' \code{enrichmentSe}; \code{enrichment} is the same quantity as a -#' multiplicative factor, \eqn{e^{a_1} - 1}, which is what -#' \code{colocPipeline} scales \code{p12} by (so \eqn{a_1 = 0} leaves the -#' prior untouched). \code{enrichmentLogOddsNoShrinkage} and +#' multiplicative factor, \eqn{e^{a_1} - 1}, reported for interpretation +#' (so \eqn{a_1 = 0} means no enrichment). +#' \code{enrichmentLogOddsNoShrinkage} and #' \code{enrichmentSeNoShrinkage} are the same estimate before shrinkage, #' \code{intercept} / \code{interceptSe} are \eqn{a_0}, and \code{colocP1}, -#' \code{colocP2}, \code{colocP12} are the enrichment-informed coloc priors -#' the estimator derives from \eqn{(a_0, a_1)} -- an alternative to scaling -#' a baseline \code{p12}. \code{effectiveMiRounds} is how many -#' multiple-imputation rounds survived outlier filtering. +#' \code{colocP2}, \code{colocP12} are the enrichment-informed priors the +#' estimator derives from \eqn{(a_0, a_1)} exactly as fastenloc's +#' \code{set_enrich_params} does; those three are what +#' \code{\link{colocPipeline}} scores with when given this table. +#' \code{effectiveMiRounds} is how many multiple-imputation rounds survived +#' outlier filtering. #' @examples #' data(gwasFineMappingExample) #' data(qtlFineMappingExample) @@ -87,45 +147,45 @@ qtlEnrichmentPipeline <- function( gwasFineMappingResult, qtlFineMappingResult, - numGwas = NULL, - piQtl = NULL, - lambda = 1.0, - impN = 25, + methodArgs = QtlEnrichmentParam(), numThreads = 1L, seed = NULL, - ... + verbose = TRUE ) { + .assertMethodParam(methodArgs, "QtlEnrichmentParam", "methodArgs") .enrValidateInputs(gwasFineMappingResult, qtlFineMappingResult) - p <- as.list(environment()) - p$dots <- list(...) - p <- .enrPrepare(p) + prep <- .enrPrepare(gwasFineMappingResult, qtlFineMappingResult) + gwasTuples <- prep$gwasTuples + qtlTuples <- prep$qtlTuples + alignedByTuple <- prep$alignedByTuple results <- list_flatten(map( - seq_len(nrow(p$gwasTuples)), + seq_len(nrow(gwasTuples)), .enrScoreOutcomeTuple, - p = p + gwasPipByTuple = prep$gwasPipByTuple, + qtlRegionsByTuple = prep$qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + methodArgs = methodArgs, + numThreads = numThreads, + seed = seed, + verbose = verbose, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples )) .enrAssemble(results) } # Validate the input classes + LD-sketch presence / identity. # @noRd +#' @importFrom checkmate assertMultiClass .enrValidateInputs <- function(gwasFineMappingResult, qtlFineMappingResult) { - if (!methods::is(gwasFineMappingResult, "FineMappingResultBase")) { - msg <- glue( - "`gwasFineMappingResult` must be a GwasFineMappingResult or a ", - "QtlFineMappingResult ", - "(got class '{class(gwasFineMappingResult)[[1L]]}')." - ) - abort(msg) - } - if (!methods::is(qtlFineMappingResult, "FineMappingResultBase")) { - msg <- glue( - "`qtlFineMappingResult` must be a QtlFineMappingResult or a ", - "GwasFineMappingResult ", - "(got class '{class(qtlFineMappingResult)[[1L]]}')." - ) - abort(msg) - } + # assertMultiClass rather than assertClass on the virtual parent: naming + # both concrete subclasses is more use to a caller than + # "FineMappingResultBase", and these two are its only subclasses. + fmrClasses <- c("GwasFineMappingResult", "QtlFineMappingResult") + assertMultiClass(gwasFineMappingResult, fmrClasses) + assertMultiClass(qtlFineMappingResult, fmrClasses) outcomeLd <- getLdSketch(gwasFineMappingResult) if ( is.null(outcomeLd) && @@ -154,38 +214,41 @@ qtlEnrichmentPipeline <- function( # each tuple's one-time alignment to the union panel (errors captured as # values). # @noRd -.enrPrepare <- function(p) { - p$gwasTuples <- .enrOutcomeTuples(p$gwasFineMappingResult) - p$qtlTuples <- .enrAnnotationTuples(p$qtlFineMappingResult) - if (nrow(p$gwasTuples) == 0L || nrow(p$qtlTuples) == 0L) { +.enrPrepare <- function(gwasFineMappingResult, qtlFineMappingResult) { + gwasTuples <- .enrOutcomeTuples(gwasFineMappingResult) + qtlTuples <- .enrAnnotationTuples(qtlFineMappingResult) + if (nrow(gwasTuples) == 0L || nrow(qtlTuples) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no (outcome, annotation) pairs to ", "compute (one of the inputs has zero rows)." ) abort(msg) } - p$gwasPipByTuple <- map( - seq_len(nrow(p$gwasTuples)), + gwasPipByTuple <- map( + seq_len(nrow(gwasTuples)), .enrGwasPipForRow, - gwasTuples = p$gwasTuples, - fmr = p$gwasFineMappingResult + gwasTuples = gwasTuples, + fmr = gwasFineMappingResult ) - unionGwasNames <- unique(unlist( - map(p$gwasPipByTuple, names), - use.names = FALSE - )) - p$qtlRegionsByTuple <- map( - seq_len(nrow(p$qtlTuples)), + unionGwasNames <- unique(unname(list_c(map(gwasPipByTuple, names)))) + qtlRegionsByTuple <- map( + seq_len(nrow(qtlTuples)), .enrQtlRegionsForRow, - qtlTuples = p$qtlTuples, - fmr = p$qtlFineMappingResult + qtlTuples = qtlTuples, + fmr = qtlFineMappingResult ) - p$alignedByTuple <- map( - p$qtlRegionsByTuple, + alignedByTuple <- map( + qtlRegionsByTuple, .enrAlignRegionsSafe, unionGwasNames = unionGwasNames ) - p + list( + gwasTuples = gwasTuples, + qtlTuples = qtlTuples, + gwasPipByTuple = gwasPipByTuple, + qtlRegionsByTuple = qtlRegionsByTuple, + alignedByTuple = alignedByTuple + ) } # The outcome side's per-trait keys: one PIP vector is built per key. A GWAS @@ -264,108 +327,172 @@ qtlEnrichmentPipeline <- function( # Align one tuple's regions to the union GWAS panel, capturing any error as a # value (re-raised + skipped per (gwas, tuple) below, never aborting). # @noRd +#' @importFrom rlang try_fetch .enrAlignRegionsSafe <- function(regions, unionGwasNames) { - tryCatch( + try_fetch( .enrAlignRegions(regions, unionGwasNames), - error = function(e) e + error = function(cnd) cnd ) } # Score one outcome trait against every annotation tuple -> enrichment records # (empty when the outcome has no usable PIPs). # @noRd -.enrScoreOutcomeTuple <- function(gi, p) { - gwasPip <- p$gwasPipByTuple[[gi]] +.enrScoreOutcomeTuple <- function( + gi, + gwasPipByTuple, + qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + methodArgs, + numThreads, + seed, + verbose, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples +) { + gwasPip <- gwasPipByTuple[[gi]] if (length(gwasPip) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no usable PIPs for ", - "{.enrOutcomeLabel(p, gi)}; skipping." + "{.enrOutcomeLabel(gwasFineMappingResult, gwasTuples, gi)}; ", + "skipping." ) warn(msg) return(list()) } compact(map( - seq_len(nrow(p$qtlTuples)), + seq_len(nrow(qtlTuples)), .enrScoreTuple, gi = gi, gwasPip = gwasPip, - p = p + qtlRegionsByTuple = qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + methodArgs = methodArgs, + numThreads = numThreads, + seed = seed, + verbose = verbose, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples )) } # Score one (outcome trait, annotation tuple) pair -> an enrichment record, or # NULL when the tuple has no regions or qtlEnrichment fails. # @noRd -.enrScoreTuple <- function(k, gi, gwasPip, p) { - if (length(p$qtlRegionsByTuple[[k]]) == 0L) { +.enrScoreTuple <- function( + k, + gi, + gwasPip, + qtlRegionsByTuple, + alignedByTuple = alignedByTuple, + methodArgs, + numThreads, + seed, + verbose, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples +) { + if (length(qtlRegionsByTuple[[k]]) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no usable regions for ", - "{.enrAnnotationLabel(p, k)}; skipping." + "{.enrAnnotationLabel(qtlFineMappingResult, qtlTuples, k)}; ", + "skipping." ) warn(msg) return(NULL) } - enr <- .enrRunEnrichment(gi, gwasPip, k, p) + enr <- .enrRunEnrichment( + gi, + gwasPip, + k, + alignedByTuple = alignedByTuple, + methodArgs = methodArgs, + numThreads = numThreads, + seed = seed, + verbose = verbose, + gwasFineMappingResult = gwasFineMappingResult, + gwasTuples = gwasTuples, + qtlFineMappingResult = qtlFineMappingResult, + qtlTuples = qtlTuples + ) if (is.null(enr)) { return(NULL) } c( .enrFlattenEnrichment(enr), - as.list(p$gwasTuples[gi, , drop = FALSE]), - as.list(p$qtlTuples[k, , drop = FALSE]) + as.list(gwasTuples[gi, , drop = FALSE]), + as.list(qtlTuples[k, , drop = FALSE]) ) } # Human-readable identities for the warnings above, naming each side by its own # flavour and only the axes it has. # @noRd -.enrOutcomeLabel <- function(p, gi) { +.enrOutcomeLabel <- function(gwasFineMappingResult, gwasTuples, gi) { .fmrTupleLabel( - .fmrSideName(p$gwasFineMappingResult), - .enrOutcomeIdent(p$gwasTuples, gi) + .fmrSideName(gwasFineMappingResult), + .enrOutcomeIdent(gwasTuples, gi) ) } # @noRd -.enrAnnotationLabel <- function(p, k) { +.enrAnnotationLabel <- function(qtlFineMappingResult, qtlTuples, k) { .fmrTupleLabel( - .fmrSideName(p$qtlFineMappingResult), - .enrAnnotationIdent(p$qtlTuples, k) + .fmrSideName(qtlFineMappingResult), + .enrAnnotationIdent(qtlTuples, k) ) } # Run qtlEnrichment for a pair (with the pre-aligned regions), warning + NULL on -# failure. alignNames = FALSE reuses the shared per-tuple alignment. +# failure. # @noRd -.enrRunEnrichment <- function(gi, gwasPip, k, p) { - aligned <- p$alignedByTuple[[k]] - tryCatch( +.enrRunEnrichment <- function( + gi, + gwasPip, + k, + alignedByTuple, + methodArgs, + numThreads, + seed, + verbose, + gwasFineMappingResult, + gwasTuples, + qtlFineMappingResult, + qtlTuples +) { + aligned <- alignedByTuple[[k]] + try_fetch( { if (inherits(aligned, "condition")) { cnd_signal(aligned) } - enrichArgs <- c( - list( - gwasPip = gwasPip, - susieQtlRegions = aligned, - numGwas = p$numGwas, - piQtl = p$piQtl, - lambda = p$lambda, - impN = p$impN, - numThreads = p$numThreads, - seed = p$seed, - alignNames = FALSE - ), - p$dots + # alignNames = FALSE reuses the per-tuple alignment; it is the + # pipeline's own invariant, which is why `methodArgs` cannot + # carry it -- QtlEnrichmentParam() has no such formal. + exec( + qtlEnrichment, + gwasPip = gwasPip, + susieQtlRegions = aligned, + numThreads = numThreads, + seed = seed, + verbose = verbose, + alignNames = FALSE, + !!!methodArgs ) - exec(qtlEnrichment, !!!enrichArgs) }, - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { + eMsg <- conditionMessage(cnd) msg <- glue( "qtlEnrichmentPipeline: qtlEnrichment failed for ", - "{.enrOutcomeLabel(p, gi)} x ", - "{.enrAnnotationLabel(p, k)}: {eMsg}" + "{.enrOutcomeLabel(gwasFineMappingResult, gwasTuples, gi)} x ", + "{.enrAnnotationLabel(qtlFineMappingResult, qtlTuples, k)}: ", + "{eMsg}" ) warn(msg) NULL @@ -426,38 +553,37 @@ qtlEnrichmentPipeline <- function( # would collide on every variant they share. #' @importFrom dplyr add_count #' @noRd +# One row's PIP vector keyed by variant id, or NULL when the row carries no +# fit, no PIPs, or ids that do not line up with them. +# @noRd +.enrRowPipVector <- function(i, gwasFmr) { + parts <- .fmrRowParts(gwasFmr, i) + fit <- getSusieFit(parts) + if (is.null(fit) || is.null(fit$pip)) { + return(NULL) + } + pip <- as.numeric(fit$pip) + ids <- names(fit$pip) %||% .fmrPartsVariantIds(parts) + if (length(ids) != length(pip)) { + return(NULL) + } + set_names(pip, as.character(ids)) +} + .enrBuildGwasPipVector <- function(gwasFmr, ident) { idx <- .enrMatchRows(gwasFmr, ident) if (length(idx) == 0L) { return(numeric(0)) } - pieces <- list() - for (i in idx) { - parts <- .fmrRowParts(gwasFmr, i) - fit <- getSusieFit(parts) - if (is.null(fit) || is.null(fit$pip)) { - next - } - pip <- as.numeric(fit$pip) - ids <- if (!is.null(names(fit$pip))) { - names(fit$pip) - } else { - .fmrPartsVariantIds(parts) - } - if (length(ids) != length(pip)) { - next - } - pieces[[length(pieces) + 1L]] <- - set_names(pip, as.character(ids)) - } + pieces <- compact(map(idx, .enrRowPipVector, gwasFmr = gwasFmr)) if (length(pieces) == 0L) { return(numeric(0)) } - all <- unlist(pieces) - if (n_distinct(names(all)) < length(all)) { - all <- .enrCollapseDuplicatePips(all) + combined <- list_c(pieces) + if (n_distinct(names(combined)) == length(combined)) { + return(combined) } - all + .enrCollapseDuplicatePips(combined) } # Collapse duplicate variant ids across GWAS blocks: agreeing PIPs (rounded to @@ -465,8 +591,8 @@ qtlEnrichmentPipeline <- function( # row per (id, rounded-pip), so a conflicting variant survives with >1 row for # add_count() to flag. # @noRd -.enrCollapseDuplicatePips <- function(all) { - byId <- tibble(id = names(all), pip = as.numeric(all)) |> +.enrCollapseDuplicatePips <- function(pips) { + byId <- tibble(id = names(pips), pip = as.numeric(pips)) |> mutate(pipR = round(.data$pip, 12)) |> distinct(.data$id, .data$pipR, .keep_all = TRUE) |> add_count(.data$id) @@ -494,33 +620,31 @@ qtlEnrichmentPipeline <- function( if (length(idx) == 0L) { return(list()) } - out <- list() - for (i in idx) { - parts <- .fmrRowParts(qtlFmr, i) - fit <- getSusieFit(parts) - if (is.null(fit) || is.null(fit$alpha) || is.null(fit$pip)) { - next - } - pV <- if (!is.null(fit$V)) { - fit$V - } else if (!is.null(fit$prior_variance)) { - fit$prior_variance - } else { - NULL - } - if (is.null(pV)) { - next - } - if (is.null(names(fit$pip))) { - names(fit$pip) <- .fmrPartsVariantIds(parts) - } - out[[length(out) + 1L]] <- list( - alpha = fit$alpha, - pip = fit$pip, - prior_variance = pV - ) + compact(map(idx, .enrRowRegion, qtlFmr = qtlFmr)) +} + +# One row's region payload for qtlEnrichment, or NULL when the row lacks a +# fit, an alpha, PIPs, or a prior variance. The PIP names fall back to the +# row's own variant ids when the fit did not carry any. +# @noRd +.enrRowRegion <- function(i, qtlFmr) { + parts <- .fmrRowParts(qtlFmr, i) + fit <- getSusieFit(parts) + if (is.null(fit) || is.null(fit$alpha) || is.null(fit$pip)) { + return(NULL) } - out + priorVariance <- fit$V %||% fit$prior_variance + if (is.null(priorVariance)) { + return(NULL) + } + list( + alpha = fit$alpha, + pip = set_names( + fit$pip, + names(fit$pip) %||% .fmrPartsVariantIds(parts) + ), + prior_variance = priorVariance + ) } # Pull one enrichment field from qtlEnrichment's list output as a scalar numeric @@ -736,8 +860,7 @@ qtlEnrichment <- function( numThreads = as.integer(numThreads), seed = if (is.null(seed)) NULL else as.integer(seed) ) - en$unused_xqtl_variants <- unmatchedVariants - en + list_assign(en, unused_xqtl_variants = unmatchedVariants) } # piGwas = sum(gwasPip) / numGwas (estimated from the data, with a warning, when @@ -747,17 +870,15 @@ qtlEnrichment <- function( if (!is.null(numGwas)) { return(sum(gwasPip) / numGwas) } - msg <- glue( + warn(glue( "numGwas is not provided. Estimating piGwas from the data. Note ", "that this estimate may be biased if the input gwasPip does not ", "contain genome-wide variants." - ) - warn(msg) + )) piGwas <- sum(gwasPip) / length(gwasPip) if (verbose) { piGwasR <- round(piGwas, 5) - msg <- glue("Estimated piGwas: {piGwasR}\n", .trim = FALSE) - inform(msg) + inform(glue("Estimated piGwas: {piGwasR}\n", .trim = FALSE)) } piGwas } @@ -776,12 +897,11 @@ qtlEnrichment <- function( "variables inside of credible sets or signal clusters." ) warn(msg) - allPips <- unlist(map(susieQtlRegions, "pip")) + allPips <- list_c(map(susieQtlRegions, "pip")) piQtl <- sum(allPips) / length(allPips) if (verbose) { piQtlR <- round(piQtl, 5) - msg <- glue("Estimated piQtl: {piQtlR}\n", .trim = FALSE) - inform(msg) + inform(glue("Estimated piQtl: {piQtlR}\n", .trim = FALSE)) } piQtl } @@ -848,14 +968,17 @@ qtlEnrichment <- function( # @noRd .enrAlignRegionByMatch <- function(x, gwasPip) { mm <- matchVariants(names(x$pip), names(gwasPip)) - nm <- names(x$pip) - nm[mm$idxA] <- names(gwasPip)[mm$idxB] - names(x$pip) <- nm - unmatchedIdx <- setdiff(seq_along(x$pip), mm$idxA) - if (length(unmatchedIdx) > 0) { - x$unmatched_variants <- names(x$pip)[unmatchedIdx] - } - x + nm <- replace(names(x$pip), mm$idxA, names(gwasPip)[mm$idxB]) + aligned <- list_assign(x, pip = set_names(x$pip, nm)) + unmatchedIdx <- setdiff(seq_along(aligned$pip), mm$idxA) + list_assign( + aligned, + !!!compact(list( + unmatched_variants = if (length(unmatchedIdx) > 0) { + names(aligned$pip)[unmatchedIdx] + } + )) + ) } # Record the region's variants absent from the GWAS name set (cheap membership @@ -863,17 +986,20 @@ qtlEnrichment <- function( # @noRd .enrMarkUnmatched <- function(x, gwasNameSet) { unmatchedIdx <- which(!is_in(names(x$pip), gwasNameSet)) - if (length(unmatchedIdx) > 0) { - x$unmatched_variants <- names(x$pip)[unmatchedIdx] - } - x + list_assign( + x, + !!!compact(list( + unmatched_variants = if (length(unmatchedIdx) > 0) { + names(x$pip)[unmatchedIdx] + } + )) + ) } # Drop the transient unmatched_variants field from a region. # @noRd .enrStripUnmatched <- function(x) { - x$unmatched_variants <- NULL - x + list_modify(x, unmatched_variants = zap()) } # Relabel one region's matched pip names to the union GWAS panel (unmatched @@ -882,9 +1008,8 @@ qtlEnrichment <- function( .enrAlignRegion <- function(x, unionGwasNames) { if (!is.null(names(x$pip)) && length(unionGwasNames) > 0L) { mm <- matchVariants(names(x$pip), unionGwasNames) - nm <- names(x$pip) - nm[mm$idxA] <- unionGwasNames[mm$idxB] - names(x$pip) <- nm + nm <- replace(names(x$pip), mm$idxA, unionGwasNames[mm$idxB]) + return(list_assign(x, pip = set_names(x$pip, nm))) } x } diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index a962b5f06..289cc5345 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -36,39 +36,25 @@ setClass( # Collect all contract violations (empty vector = valid). The per-entry checks # run only once the basic slot/column checks pass (they assume those columns). # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateQtlSumStats <- function(object) { - errors <- c( - .qssCheckLdSketch(object), - .qssCheckRequiredCols(object), - .qssCheckGenome(object), - .qssCheckQcInfo(object), - .validateTraitPosColumn(object) + coll <- makeAssertCollection() + # `names(object)` is element names on a RangedTupleList, so the required + # metadata columns are read from mcols directly. + assertNames( + colnames(mcols(object)) %||% character(0), + must.include = c("study", "context", "trait"), + what = "colnames", + .var.name = "mcols", + add = coll ) - if (length(errors) == 0L) { - errors <- .qssCheckEntries(object) + coll$push(.qssCheckGenome(object)) + coll$push(.validateTraitPosColumn(object)) + if (!coll$isEmpty()) { + return(coll$getMessages()) } - if (length(errors) == 0L) TRUE else errors -} - -# ldSketch must be a GenotypeHandle or NULL. -# @noRd -.qssCheckLdSketch <- function(object) { - # The slot's class union enforces the type; nothing to check. - NULL -} - -# The study/context/trait metadata columns must be present. `names(object)` is -# element names on a RangedTupleList, so the check reads mcols directly. -# @noRd -.qssCheckRequiredCols <- function(object) { - missingCols <- setdiff( - c("study", "context", "trait"), - colnames(mcols(object)) - ) - if (length(missingCols) > 0L) { - return(str_c("missing columns: ", str_flatten(missingCols, ", "))) - } - NULL + coll$push(.qssCheckEntries(object)) + coll$getMessages() } # The genome build, read from seqinfo (there is no genome slot). @@ -77,13 +63,6 @@ setClass( .sumStatsCheckGenome(object) } -# qcInfo slot must be a list. -# @noRd -.qssCheckQcInfo <- function(object) { - # The slot's declared type enforces this; nothing to check. - NULL -} - # Element contract. The elements ARE GRanges by construction now -- the # container is a GRangesList -- and RangedTupleList's validity enforces the # one-seqname/one-strand invariant, so only tuple uniqueness is left to check. @@ -142,7 +121,11 @@ NULL #' \code{getNSamples()} (the LD-panel sample size). Unlike GWAS, QTL #' collections carry no case/control counts (molecular traits are #' quantitative), so only this total-N fallback is exposed. -#' @param ... Additional per-tuple columns to attach to the collection. +#' @param extraCols Optional named list of additional per-tuple columns to +#' attach to the collection's \code{mcols}. Named rather than variadic +#' because the base class's own constructor, \code{GRangesList(...)}, uses +#' \code{...} for its \emph{elements}: a bare \code{...} here would read +#' as adding an entry rather than a metadata column. #' @param qcInfo A \code{list} recording which QC steps ran. Empty \code{list()} #' on construction; populated by \code{summaryStatsQc()} with a per-step audit #' record. Fine-mapping / TWAS pipelines reject inputs where @@ -171,7 +154,7 @@ QtlSumStats <- function( nSample = NULL, qcInfo = list(), traitPos = NULL, - ... + extraCols = list() ) { if ( missing(study) || @@ -189,10 +172,10 @@ QtlSumStats <- function( n <- length(study) varY <- .qssValidateArgs(context, trait, entry, genome, varY, n) entry <- .qssAddTraitDistances(entry, traitPos, n) - cols <- .qssBaseCols(study, context, trait, varY) - cols <- .qssAppendNSample(cols, nSample, n) - cols <- .appendTraitPosCol(cols, traitPos, n) - cols <- .qssAppendExtras(cols, list(...)) + cols <- .qssBaseCols(study, context, trait, varY) |> + .qssAppendNSample(nSample, n) |> + .appendTraitPosCol(traitPos, n) |> + .qssAppendExtras(extraCols) dfArgs <- c(cols, list(check.names = FALSE)) # The per-tuple GRanges become the collection's ELEMENTS; the tuple keys # and per-tuple scalars go in mcols. There is no `entry` column. @@ -202,9 +185,11 @@ QtlSumStats <- function( # A multi-seqname entry (e.g. a genome-wide GWAS) is split into one # element per chromosome, with its metadata row replicated alongside. split <- .rtlSplitBySeqname(entry) - grl <- GenomicRanges::GRangesList(split$entry) md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] + grl <- S4Vectors::`mcols<-`( + GenomicRanges::GRangesList(split$entry), + value = md[split$fromIdx, , drop = FALSE] + ) .sumStatsNewValidated("QtlSumStats", grl, ldSketch, genome, qcInfo) } @@ -283,17 +268,16 @@ QtlSumStats <- function( if (is.null(nSample)) { return(cols) } - cols$nSample <- as.numeric(.qssRecycleTo(nSample, n, "nSample")) - cols + c( + cols, + list(nSample = as.numeric(.qssRecycleTo(nSample, n, "nSample"))) + ) } # Append any user-supplied extra columns (from `...`). # @noRd .qssAppendExtras <- function(cols, extras) { - for (nm in names(extras)) { - cols[[nm]] <- extras[[nm]] - } - cols + c(cols, extras) } # Annotate each entry's variants with tss_distance / tes_distance from the @@ -321,6 +305,7 @@ QtlSumStats <- function( # Internal: resolve a (study, context, trait) tuple to its element indices. # Returns a VECTOR: a tuple whose entry spanned several chromosomes was split # into one element per seqname at construction. +#' @importFrom checkmate assertVector .qtlSumStatsSelectRow <- function(x, study, context, trait) { if (nrow(x) == 0L) { abort("QtlSumStats has no rows.") @@ -341,9 +326,9 @@ QtlSumStats <- function( ) abort(msg) } - if (length(study) != 1L || length(context) != 1L || length(trait) != 1L) { - abort("`study`, `context`, and `trait` must each be length 1.") - } + assertVector(study, len = 1L) + assertVector(context, len = 1L) + assertVector(trait, len = 1L) .qssMatchTuple(x, study, context, trait) } @@ -401,12 +386,13 @@ setMethod( context = NULL, trait = NULL, annotateSignificance = NULL, - ranges = NULL, - ... + ranges = NULL ) { idx <- .qtlSumStatsSelectRow(x, study, context, trait) - gr <- .ssStitchElements(x, idx, ranges) - if (!is.null(annotateSignificance)) { + stitched <- .ssStitchElements(x, idx, ranges) + gr <- if (is.null(annotateSignificance)) { + stitched + } else { m <- arg_match( annotateSignificance, c( @@ -416,10 +402,14 @@ setMethod( "qvalue" ) ) - S4Vectors::mcols(gr)[["significant"]] <- .qapSignificanceMask( - x, - m - )[[idx]] + S4Vectors::`mcols<-`( + stitched, + value = `[[<-`( + S4Vectors::mcols(stitched, use.names = FALSE), + "significant", + value = .qapSignificanceMask(x, m)[[idx]] + ) + ) } gr } @@ -487,7 +477,7 @@ setMethod("getTraits", "QtlSumStats", function(x) unique(as.character(x$trait))) # or a scalar NA when no trait position was supplied. #' @rdname getTraitPosition #' @export -setMethod("getTraitPosition", "QtlSumStats", function(x, traitId = NULL, ...) { +setMethod("getTraitPosition", "QtlSumStats", function(x, traitId = NULL) { tp <- .getTraitPosColumn(x) if (!methods::is(tp, "GRanges") || is.null(traitId)) { return(tp) @@ -559,14 +549,17 @@ setMethod("show", "QtlSumStats", function(object) { # that row count away, so the assignment below died with "n elements in # value to replace 0 elements" for any entry without mcols. mc <- S4Vectors::mcols(gr) - if (is.null(mc[["tss_distance"]])) { - mc[["tss_distance"]] <- pos - tssPos - } - if (is.null(mc[["tes_distance"]])) { - mc[["tes_distance"]] <- pos - tesPos + added <- compact(list( + tss_distance = if (is.null(mc[["tss_distance"]])) pos - tssPos, + tes_distance = if (is.null(mc[["tes_distance"]])) pos - tesPos + )) + if (length(added) == 0L) { + return(gr) } - S4Vectors::mcols(gr) <- mc - gr + S4Vectors::`mcols<-`( + gr, + value = cbind(mc, exec(S4Vectors::DataFrame, !!!added)) + ) } # Entry `i` of a SumStats collection restricted to chromosome `chrName`. Shared diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 39dbdd039..bcee90d49 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -1,3 +1,6 @@ +#' @include MethodParam.R +NULL + #' Extract weights from mr.ash.rss (susieR) #' @param stat A list of summary statistics with elements \code{b} (effect #' sizes), \code{seb} (standard errors) and \code{n} (per-variant sample @@ -11,7 +14,10 @@ #' @param w0 Numeric vector of prior mixture weights (summing to 1). #' @param z Optional numeric vector of z-scores; defaults to \code{numeric(0)} #' (derived from \code{stat}). -#' @param ... Additional arguments forwarded to \code{mr.ash.rss}. +#' @param methodArgs Options forwarded to \code{susieR::mr.ash.rss}, built +#' with \code{\link{MrashOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of the posterior mean of the coefficients. #' @importFrom susieR mr.ash.rss #' @examples @@ -25,6 +31,7 @@ #' seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X))) #' mrashRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), #' s0 = c(0, 0.1, 0.5), w0 = c(0.8, 0.1, 0.1)) +#' @importFrom checkmate assertList assertNumeric #' @export mrashRssWeights <- function( stat, @@ -34,20 +41,26 @@ mrashRssWeights <- function( s0, w0, z = numeric(0), - ... + methodArgs = MrashRssOptions() ) { - model <- mr.ash.rss( - bhat = stat$b, - shat = stat$seb, - z = z, - R = LD, - var_y = varY, - n = median(stat$n), - sigma2_e = sigma2E, - s0 = s0, - w0 = w0, - ... + .assertMethodOptions(methodArgs, "MrashRssOptions", "methodArgs") + assertList(stat) + assertNumeric(z) + callArgs <- list_modify( + list( + bhat = stat$b, + shat = stat$seb, + z = z, + R = LD, + var_y = varY, + n = median(stat$n), + sigma2_e = sigma2E, + s0 = s0, + w0 = w0 + ), + !!!methodArgs ) + model <- exec(mr.ash.rss, !!!callArgs) return(model$mu1) } @@ -174,7 +187,10 @@ prsCs <- function( #' sizes) and \code{n} (per-variant sample sizes). #' @param LD Numeric LD (correlation) matrix aligned to the variants in #' \code{stat}. -#' @param ... Additional arguments forwarded to \code{prsCs}. +#' @param methodArgs Options forwarded to \code{prsCs}, built +#' with \code{\link{PrsCsOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of the posterior SNP coefficients. #' @examples #' data(eqtlRegionExample) @@ -188,10 +204,15 @@ prsCs <- function( #' n = rep(nrow(X), ncol(X)) #' ) #' LD <- cor(X) -#' prsCsWeights(stat, LD, maf = rep(0.3, ncol(X))) +#' prsCsWeights(stat, LD, methodArgs = PrsCsOptions(maf = rep(0.3, ncol(X)))) #' @export -prsCsWeights <- function(stat, LD, ...) { - model <- prsCs(bhat = stat$b, R = LD, n = median(stat$n), ...) +prsCsWeights <- function(stat, LD, methodArgs = PrsCsOptions()) { + .assertMethodOptions(methodArgs, "PrsCsOptions", "methodArgs") + callArgs <- list_modify( + list(bhat = stat$b, R = LD, n = median(stat$n)), + !!!methodArgs + ) + model <- exec(prsCs, !!!callArgs) return(model$betaEst) } @@ -221,7 +242,7 @@ prsCsWeights <- function(stat, LD, ...) { #' @param iter Number of iterations for MCMC. Default is 1000. #' @param burn Number of burn-in iterations for MCMC. Default is 200. #' @param thin Thinning interval for MCMC. Default is 5. -#' @param nThreads Number of threads to use. Default is 1. +#' @param numThreads Number of threads to use. Default is 1. #' @param optLlk Which likelihood to evaluate. 1 for equation 6 (slightly shrink #' the correlation of SNPs) and 2 for equation 5 (SNPs genotyped on different #' arrays in a separate cohort). Default is 1. @@ -294,7 +315,7 @@ sdpr <- function( iter = 1000, burn = 200, thin = 5, - nThreads = 1, + numThreads = 1, optLlk = 1, verbose = TRUE, seed = NULL @@ -316,7 +337,7 @@ sdpr <- function( iter = as.integer(iter), burn = as.integer(burn), thin = as.integer(thin), - nThreads = as.integer(nThreads), + numThreads = as.integer(numThreads), optLlk = as.integer(optLlk), verbose = verbose, seed = seed @@ -349,7 +370,10 @@ sdpr <- function( #' sizes) and \code{n} (per-variant sample sizes). #' @param LD Numeric LD (correlation) matrix aligned to the variants in #' \code{stat}. -#' @param ... Additional arguments forwarded to \code{sdpr}. +#' @param methodArgs Options forwarded to \code{sdpr}, built +#' with \code{\link{SdprOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of the posterior SNP coefficients. #' @examples #' data(eqtlRegionExample) @@ -365,8 +389,13 @@ sdpr <- function( #' LD <- cor(X) #' sdprWeights(stat, LD) #' @export -sdprWeights <- function(stat, LD, ...) { - model <- sdpr(bhat = stat$b, R = LD, n = median(stat$n), ...) +sdprWeights <- function(stat, LD, methodArgs = SdprOptions()) { + .assertMethodOptions(methodArgs, "SdprOptions", "methodArgs") + callArgs <- list_modify( + list(bhat = stat$b, R = LD, n = median(stat$n)), + !!!methodArgs + ) + model <- exec(sdpr, !!!callArgs) return(model$betaEst) } @@ -380,18 +409,19 @@ sdprWeights <- function(stat, LD, ...) { #' @param mrmashFit Optional fitted mr.mash object. #' @param X Genotype matrix. Required when `mrmashFit` is NULL. #' @param Y Phenotype matrix. Required when `mrmashFit` is NULL. -#' @param retainFit If TRUE, attach (as the `"fit"` attribute of the returned -#' weights) the parts of the mr.mash fit that `fineMappingPipeline` needs to -#' rebuild the mvSuSiE reweighted mixture prior + residual variance: the -#' original data-driven prior matrices (`dataDrivenPriorMatrices`), the fitted -#' mixture weights (`w0`) and the residual covariance (`V`). Default FALSE. -#' @param fitDetail How much of the fit to retain when `retainFit = TRUE`. -#' `"slim"` (default) keeps only the three reconstruction inputs above; the -#' heavy coefficient matrix (`mu1`) is already returned as the weights, so it -#' is not duplicated. `"full"` additionally retains the complete mr.mash fit -#' under `$fit` (consistent with how susie fits are kept), at the cost of a -#' larger payload. -#' @param ... Additional arguments passed to `mrmashWrapper()` when fitting. +#' @param fitRetention How much of the mr.mash fit is kept as the +#' \code{"fit"} attribute of the returned weights. \code{"none"} (default) +#' attaches nothing. \code{"slim"} keeps what \code{fineMappingPipeline} +#' needs to rebuild the mvSuSiE reweighted mixture prior and residual +#' variance --- the original \code{dataDrivenPriorMatrices}, the fitted +#' \code{w0} and \code{V}; the heavy coefficient matrix \code{mu1} is +#' already returned as the weights, so it is not duplicated. \code{"full"} +#' additionally retains the complete fit under \code{$fit}, at the cost of +#' a larger payload. +#' @param methodArgs Options forwarded to \code{mr.mashr::mr.mash}, built +#' with \code{\link{MrmashOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return Matrix of variant weights. #' @examples #' data(multiTraitData) @@ -399,73 +429,93 @@ sdprWeights <- function(stat, LD, ...) { #' Y <- multiTraitData$Y #' ddpm <- multiTraitData$priorMatrices #' fit <- mrmashWrapper(X = X, Y = Y, dataDrivenPriorMatrices = ddpm, -#' canonicalPriorMatrices = TRUE) +#' prior = MrmashPriorParam(canonicalPriorMatrices = TRUE)) #' mrmashWeights(mrmashFit = fit, X = X, Y = Y) +#' @param dataDrivenPriorMatrices Optional list of data-driven prior +#' covariance matrices; forwarded to \code{mrmashWrapper} when it has to fit, +#' and retained in the payload for mvSuSiE prior reconstruction. #' @export mrmashWeights <- function( mrmashFit = NULL, X = NULL, Y = NULL, - retainFit = FALSE, - fitDetail = c("slim", "full"), - ... + fitRetention = c("none", "slim", "full"), + dataDrivenPriorMatrices = NULL, + methodArgs = MrmashOptions() ) { + fitRetention <- arg_match(fitRetention) + .assertMethodOptions(methodArgs, "MrmashOptions", "methodArgs") if (!requireNamespace("mr.mashr", quietly = TRUE)) { - msg <- glue( - "Package 'mr.mashr' is required. Install with: ", - "devtools::install_github('stephenslab/mr.mashr')" - ) - abort(msg) + abort("Package 'mr.mashr' is required.") } - dotArgs <- list(...) if (is.null(mrmashFit)) { inform("mrmashFit is not provided; fitting mr.mash now ...") if (is.null(X) || is.null(Y)) { abort("Both X and Y must be provided if mrmashFit is NULL.") } - mrmashFit <- mrmashWrapper(X, Y, ...) + # methodArgs is one flat bag; the prior-construction names belong to + # mrmashWrapper's `prior` group, so they are routed there rather + # than passed as top-level arguments it no longer has. + split <- .mrmashSplitPriorArgs(as.list(methodArgs)) + mrmashFit <- exec( + mrmashWrapper, + X, + Y, + dataDrivenPriorMatrices = dataDrivenPriorMatrices, + prior = exec(MrmashPriorParam, !!!split$prior), + !!!split$rest + ) } - out <- mr.mashr::coef.mr.mash(mrmashFit)[-1, ] + out <- mr.mashr::coef.mr.mash(mrmashFit)[-1, , drop = FALSE] # mu1 (= out) is already the returned weights; the payload carries only the # mvSuSiE data-driven-prior reconstruction inputs (w0, V, and the raw prior - # matrices), plus the whole fit when fitDetail = "full". + # matrices), plus the whole fit at fitRetention = "full". .mrmashAttachFit( out, mrmashFit, - dotArgs$dataDrivenPriorMatrices, - retainFit, - fitDetail + dataDrivenPriorMatrices, + fitRetention ) } # Attach the mvSuSiE-prior reconstruction payload as the "fit" attribute, # shared by mrmashWeights (individual) and mrmashRssWeights (summary stats): -# the data-driven prior matrices + fitted w0 + V, and -- when fitDetail = -# "full" -- the whole fit. The coefficients are already the returned `weights`, -# so mu1 is not duplicated. Returns `weights` unchanged unless retainFit is -# TRUE. +# the data-driven prior matrices + fitted w0 + V, and -- at +# fitRetention = "full" -- the whole fit. The coefficients are already the +# returned `weights`, so mu1 is not duplicated. Returns `weights` unchanged +# at fitRetention = "none". .mrmashAttachFit <- function( weights, fit, dataDrivenPriorMatrices, - retainFit, - fitDetail = c("slim", "full") + fitRetention ) { - if (!isTRUE(retainFit)) { + if (identical(fitRetention, "none")) { return(weights) } - fitDetail <- arg_match(fitDetail) - fitList <- list( - dataDrivenPriorMatrices = dataDrivenPriorMatrices, - w0 = fit$w0, - V = fit$V + fitList <- c( + list( + dataDrivenPriorMatrices = dataDrivenPriorMatrices, + w0 = fit$w0, + V = fit$V + ), + compact(list(fit = if (fitRetention == "full") fit)) ) - if (fitDetail == "full") { - fitList$fit <- fit + `attr<-`(weights, "fit", fitList) +} + +# The `beta.init` override for mr.ash: lasso weights when the caller supplied +# none, or the caller's own initialisation restricted to the retained columns. +# @noRd +.mrashBetaInit <- function(methodArgs, XKeep, y, X, keep) { + if (!is_in("beta.init", names(methodArgs))) { + return(list(beta.init = lassoWeights(XKeep, y))) } - attr(weights, "fit") <- fitList - weights + if (length(methodArgs$beta.init) != ncol(X)) { + return(list()) + } + list(beta.init = methodArgs$beta.init[keep]) } #' Compute mr.mash-RSS TWAS weights from summary statistics @@ -483,9 +533,9 @@ mrmashWeights <- function( #' \code{\link{mrmashWrapper}}: \code{computeGrid} + #' \code{mr.mashr::compute_canonical_covs()} + \code{mr.mashr::expand_covs()} #' for \code{S0}, and \code{computeW0} for the mixture weights. Supply -#' \code{dataDrivenPriorMatrices} (e.g. from \code{\link{computeCovFlash}} / -#' \code{\link{computeCovDiag}}) to add data-driven covariance components -#' alongside the canonical mixture. +#' \code{dataDrivenPriorMatrices} (e.g. from +#' \code{\link{computeCovDiag}}, or \code{mashr::cov_flash}) to add +#' data-driven covariance components alongside the canonical mixture. #' #' @param stat A list with \code{z} (variants x conditions matrix) and \code{n} #' (per-context numeric vector or scalar). May also include \code{Bhat}, @@ -507,17 +557,19 @@ mrmashWeights <- function( #' the identity matrix of size K. #' @param covY Optional response covariance matrix (K x K). When NULL, defaults #' to the identity matrix of size K. -#' @param retainFit If TRUE, attaches (as the \code{"fit"} attribute on the -#' returned weights) the inputs \code{fineMappingPipeline} needs to rebuild -#' the mvSuSiE reweighted prior: \code{dataDrivenPriorMatrices}, the fitted -#' \code{w0}, and the fitted \code{V}. Default FALSE. -#' @param fitDetail How much to retain when \code{retainFit = TRUE}. -#' \code{"slim"} (default) keeps only those reconstruction inputs (the -#' coefficients are already the returned weights); \code{"full"} additionally -#' keeps the complete \code{mr.mash.rss} fit under \code{$fit}. Mirrors -#' \code{\link{mrmashWeights}}. -#' @param ... Additional arguments forwarded to \code{mr.mashr::mr.mash.rss}. -#' +#' @param fitRetention How much of the mr.mash fit is kept as the +#' \code{"fit"} attribute of the returned weights. \code{"none"} (default) +#' attaches nothing. \code{"slim"} keeps what \code{fineMappingPipeline} +#' needs to rebuild the mvSuSiE reweighted mixture prior and residual +#' variance --- the original \code{dataDrivenPriorMatrices}, the fitted +#' \code{w0} and \code{V}; the heavy coefficient matrix \code{mu1} is +#' already returned as the weights, so it is not duplicated. \code{"full"} +#' additionally retains the complete fit under \code{$fit}, at the cost of +#' a larger payload. +#' @param methodArgs Options forwarded to \code{mr.mashr::mr.mash.rss}, built +#' with \code{\link{MrmashOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric matrix of per-variant per-context weights (variants x #' conditions). #' @examples @@ -532,6 +584,7 @@ mrmashWeights <- function( #' dataDrivenPriorMatrices = multiTraitData$priorMatrices, #' canonicalPriorMatrices = TRUE) #' @export +#' @importFrom checkmate assertFlag assertList mrmashRssWeights <- function( stat, LD, @@ -542,10 +595,13 @@ mrmashRssWeights <- function( w0 = NULL, V = NULL, covY = NULL, - retainFit = FALSE, - fitDetail = c("slim", "full"), - ... + fitRetention = c("none", "slim", "full"), + methodArgs = MrmashRssOptions() ) { + fitRetention <- arg_match(fitRetention) + .assertMethodOptions(methodArgs, "MrmashRssOptions", "methodArgs") + assertList(stat) + assertFlag(canonicalPriorMatrices) .mrmashRssRequirePackage() if (is.null(mrmashRssFit)) { mrmashRssFit <- .mrmashRssComputeFit( @@ -557,7 +613,7 @@ mrmashRssWeights <- function( w0, V, covY, - list(...) + methodArgs ) } # coef.mr.mash.rss returns nrow(Bhat) rows (no intercept). Do not strip. @@ -566,8 +622,7 @@ mrmashRssWeights <- function( weights, mrmashRssFit, dataDrivenPriorMatrices, - retainFit, - fitDetail + fitRetention ) } @@ -577,8 +632,7 @@ mrmashRssWeights <- function( if (!requireNamespace("mr.mashr", quietly = TRUE)) { msg <- glue( "Package 'mr.mashr' is required. ", - "Install with: ", - "devtools::install_github('stephenslab/mr.mash.alpha')" + "is required." ) abort(msg) } @@ -651,7 +705,9 @@ mrmashRssWeights <- function( S0 = S0, w0 = w0 ), - dots + # `dots` is the caller's MrmashOptions() record; c() would append it as + # one opaque element instead of splicing its entries. + as.list(dots) ) exec(mr.mashr::mr.mash.rss, !!!rssArgs) } @@ -691,6 +747,234 @@ initPriorSd <- function(X, y, n = 30) { keep } +# --- TWAS weight-method argument constructors ------------------------------- +# +# One constructor per fitting engine, not per method token: several tokens +# share an engine (lasso and enet both fit with glmnet; bayesA/C/N/R all use +# qgg), and it is the engine that defines what the options are. + +#' @title Arguments For A TWAS Weight-Fitting Engine +#' @description Options forwarded to the engine behind a TWAS weight method, +#' checked against that engine's live formals where it enumerates them. Pass +#' the result as an element of \code{\link{TwasWeightsMethodsParam}}, or +#' directly to the matching weights function. +#' +#' A method's individual-level and summary-statistic paths often run +#' DIFFERENT engines, and then each takes its own constructor: +#' \code{lassoWeights} fits with glmnet (\code{GlmnetOptions}) while +#' \code{lassosumRssWeights} runs pecotmr's lassosum solver +#' (\code{LassosumOptions}); \code{scadWeights} / \code{mcpWeights} / +#' \code{l0learnWeights} use ncvreg and L0Learn while their \code{*Rss} +#' counterparts use \code{PenalizedRssOptions}; \code{dprGibbsWeights} uses +#' RcppDPR and \code{sdprWeights} uses \code{SdprOptions}. Splitting them is +#' what lets each be checked exactly, rather than against a union in which +#' an option meant for the other path would pass and then be dropped. +#' +#' \code{GlmnetOptions}, \code{NcvregOptions} and \code{DprOptions} cannot be +#' checked: \code{cv.glmnet}, \code{cv.ncvreg} and \code{fit_model} each +#' take \code{...}, so they accept any name and there is nothing to check +#' against. Every other constructor here rejects an unknown option. See +#' \code{\link{MethodOptions}}. +#' @param ... Arguments for the engine, under its own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' GlmnetOptions(nfold = 10) +#' QggOptions(nit = 1000) +#' LassosumOptions(thr = 1e-4) +#' @name twasEngineOptions +NULL + +#' @rdname twasEngineOptions +#' @export +GlmnetOptions <- function(...) { + .newMethodOptions( + "glmnet::cv.glmnet", + defaults = list(), + extra = list(...), + label = "GlmnetOptions", + engine = "glmnet" + ) +} + +#' @rdname twasEngineOptions +#' @export +QggOptions <- function(...) { + .newMethodOptions( + "qgg::gbayes", + defaults = list(), + extra = list(...), + label = "QggOptions", + engine = "qgg" + ) +} + +#' @rdname twasEngineOptions +#' @export +BglrOptions <- function(...) { + .newMethodOptions( + "BGLR::BGLR", + defaults = list(), + extra = list(...), + label = "BglrOptions", + engine = "bglr" + ) +} + +#' @rdname twasEngineOptions +#' @export +DprOptions <- function(...) { + .newMethodOptions( + "RcppDPR::fit_model", + defaults = list(), + extra = list(...), + label = "DprOptions", + engine = "dpr" + ) +} + +#' @rdname twasEngineOptions +#' @export +NcvregOptions <- function(...) { + .newMethodOptions( + "ncvreg::cv.ncvreg", + defaults = list(), + extra = list(...), + label = "NcvregOptions", + engine = "ncvreg" + ) +} + +#' @rdname twasEngineOptions +#' @export +L0learnOptions <- function(...) { + .newMethodOptions( + "L0Learn::L0Learn.cvfit", + defaults = list(), + extra = list(...), + label = "L0learnOptions", + engine = "l0learn" + ) +} + +#' @rdname twasEngineOptions +#' @export +MrashOptions <- function(...) { + .newMethodOptions( + "susieR::mr.ash", + defaults = list(), + extra = list(...), + label = "MrashOptions", + engine = "mrash" + ) +} + +#' @rdname twasEngineOptions +#' @export +MrashRssOptions <- function(...) { + # The summary-statistics twin of MrashOptions(). Separate because the two + # engines take different arguments entirely -- mr.ash takes (X, y, ...), + # mr.ash.rss takes (bhat, shat, R, ...) -- so one record validating + # against the union of both would accept an individual-level name on a + # summary-statistics run, and the reverse. + .newMethodOptions( + "susieR::mr.ash.rss", + defaults = list(), + extra = list(...), + label = "MrashRssOptions", + engine = "mrashRss" + ) +} + +#' @rdname twasEngineOptions +#' @export +PrsCsOptions <- function(...) { + .newMethodOptions( + "pecotmr::prsCs", + defaults = list(), + extra = list(...), + label = "PrsCsOptions", + engine = "prsCs" + ) +} + +#' @rdname twasEngineOptions +#' @export +LassosumOptions <- function(...) { + .newMethodOptions( + "pecotmr::lassosumRss", + defaults = list(), + extra = list(...), + label = "LassosumOptions", + engine = "lassosum" + ) +} + +#' @rdname twasEngineOptions +#' @export +PenalizedRssOptions <- function(...) { + .newMethodOptions( + "pecotmr::penalizedRss", + defaults = list(), + extra = list(...), + label = "PenalizedRssOptions", + engine = "penalizedRss" + ) +} + +#' @rdname twasEngineOptions +#' @export +SdprOptions <- function(...) { + .newMethodOptions( + "pecotmr::sdpr", + defaults = list(), + extra = list(...), + label = "SdprOptions", + engine = "sdpr" + ) +} + +#' @rdname twasEngineOptions +#' @export +MrmashOptions <- function(...) { + .newMethodOptions( + "mr.mashr::mr.mash", + defaults = list(), + extra = list(...), + label = "MrmashOptions", + engine = "mrmash", + # The bag is split before the engine sees it: .mrmashSplitPriorArgs + # routes the prior-covariance names to MrmashPriorParam() and the rest + # to mr.mash. So the accepted set is both, read from the live + # formals of each rather than transcribed. + accepted = unique(c( + .engineAcceptedNames("mr.mashr::mr.mash"), + names(formals(MrmashPriorParam)) + )) + ) +} + +#' @rdname twasEngineOptions +#' @export +MrmashRssOptions <- function(...) { + # The summary-statistics twin of MrmashOptions(). mr.mash takes + # (X, Y, S0, w0, V, mu1_init, ...) and mr.mash.rss takes + # (Bhat, Shat, Z, R, covY, n, ...), so the two cannot share one + # validated record without each accepting the other's names. + .newMethodOptions( + "mr.mashr::mr.mash.rss", + defaults = list(), + extra = list(...), + label = "MrmashRssOptions", + engine = "mrmashRss", + # Same prior-name passthrough as the individual path: + # .mrmashSplitPriorArgs routes those to MrmashPriorParam(). + accepted = unique(c( + .engineAcceptedNames("mr.mashr::mr.mash.rss"), + names(formals(MrmashPriorParam)) + )) + ) +} + #' Compute TWAS weights via penalized regression (glmnet) #' #' Fit a cross-validated elastic-net / lasso model with \code{glmnet::cv.glmnet} @@ -700,6 +984,9 @@ initPriorSd <- function(X, y, n = 30) { #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param alpha Elastic-net mixing parameter in \code{[0, 1]}: \code{1} = lasso, #' \code{0} = ridge, \code{0.5} = elastic net. +#' @param methodArgs Additional arguments forwarded to +#' \code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare +#' list is refused, since it cannot be checked against the engine's formals. #' @return Numeric vector of length \code{ncol(X)} of per-variant weights. #' @importFrom stats coef #' @examples @@ -708,27 +995,38 @@ initPriorSd <- function(X, y, n = 30) { #' y <- eqtlRegionExample$yRes #' glmnetWeights(X, y, alpha = 0.5) #' @export -glmnetWeights <- function(X, y, alpha) { +glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { # Check if glmnet is installed if (!requireNamespace("glmnet", quietly = TRUE)) { - msg <- glue( - "To use this function, please install glmnet: ", - "https://cran.r-project.org/web/packages/glmnet/index.html" - ) - abort(msg) + abort("Package 'glmnet' is required for this function.") } + .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "glmnetWeights") - enet <- glmnet::cv.glmnet( - x = X[, keep, drop = FALSE], - y = y, - alpha = alpha, - nfold = 5, - intercept = TRUE, - standardize = FALSE + # `alpha` is the wrapper's own dial -- it is what distinguishes lasso from + # enet from ridge -- so it is supplied here rather than settable in + # methodArgs. Everything else pecotmr fixed is now overridable. + userArgs <- as.list(methodArgs) + if (is_in("alpha", names(userArgs))) { + abort(glue( + "glmnetWeights: `alpha` selects the penalty family and is set by ", + "the calling wrapper (lassoWeights = 1, enetWeights = 0.5), so ", + "it cannot also be given in `methodArgs`." + )) + } + callArgs <- list_modify( + list( + x = X[, keep, drop = FALSE], + y = y, + alpha = alpha, + nfold = 5, + intercept = TRUE, + standardize = FALSE + ), + !!!userArgs ) - eff.wgt[keep] <- coef(enet, s = "lambda.min")[2:(sum(keep) + 1)] - return(eff.wgt) + enet <- exec(glmnet::cv.glmnet, !!!callArgs) + replace(eff.wgt, keep, coef(enet, s = "lambda.min")[2:(sum(keep) + 1)]) } #' Compute TWAS weights via elastic net (glmnet, alpha = 0.5) @@ -742,7 +1040,10 @@ glmnetWeights <- function(X, y, alpha) { #' y <- eqtlRegionExample$yRes #' enetWeights(X, y) #' @export -enetWeights <- function(X, y) glmnetWeights(X, y, 0.5) +enetWeights <- function(X, y, methodArgs = GlmnetOptions()) { + .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") + glmnetWeights(X, y, 0.5, methodArgs = methodArgs) +} #' Compute TWAS weights via lasso (glmnet, alpha = 1) #' @@ -755,7 +1056,10 @@ enetWeights <- function(X, y) glmnetWeights(X, y, 0.5) #' y <- eqtlRegionExample$yRes #' lassoWeights(X, y) #' @export -lassoWeights <- function(X, y) glmnetWeights(X, y, 1) +lassoWeights <- function(X, y, methodArgs = GlmnetOptions()) { + .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") + glmnetWeights(X, y, 1, methodArgs = methodArgs) +} #' Compute Weights Using mr.ash Shrinkage #' @@ -775,24 +1079,41 @@ lassoWeights <- function(X, y) glmnetWeights(X, y, 1) #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param initPriorSd Logical. Initialize the prior standard-deviation grid #' from the data. Default \code{TRUE}. -#' @param retainFit Logical. Attach the full fitted-model object to the result. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} attach the fitted model. This +#' engine keeps no trimmable intermediates, so the two retaining levels +#' behave alike here. #' Default \code{FALSE}. -#' @param ... Additional arguments forwarded to \code{mr.ash}. +#' @param methodArgs Options forwarded to \code{susieR::mr.ash}, built +#' with \code{\link{MrashOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of weights, one per variant (column of \code{X}); -#' zero-variance columns receive weight 0. When \code{retainFit = TRUE} the -#' fitted \code{mr.ash} object is attached as attribute \code{"fit"}. +#' zero-variance columns receive weight 0. Unless +#' \code{fitRetention = "none"} the fitted \code{mr.ash} object is +#' attached as attribute \code{"fit"}. +#' @importFrom checkmate assertFlag #' @export -mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { - eff.wgt <- rep(0, ncol(X)) +mrashWeights <- function( + X, + y, + initPriorSd = TRUE, + fitRetention = c("none", "slim", "full"), + methodArgs = MrashOptions() +) { + .assertMethodOptions(methodArgs, "MrashOptions", "methodArgs") + assertFlag(initPriorSd) + fitRetention <- arg_match(fitRetention) keep <- .dropZeroVariance(X, "mrashWeights") XKeep <- X[, keep, drop = FALSE] - argsList <- list(...) - if (!is_in("beta.init", names(argsList))) { - argsList$beta.init <- lassoWeights(XKeep, y) - } else if (length(argsList$beta.init) == ncol(X)) { - argsList$beta.init <- argsList$beta.init[keep] - } - mrashArgs <- c( + # as.list(): list_assign() rejects a MethodOptions outright as `.x`, the + # same S4-SimpleList seam that makes c() append it instead of splicing. + argsList <- list_assign( + as.list(methodArgs), + !!!.mrashBetaInit(methodArgs, XKeep, y, X, keep) + ) + MrashOptions <- c( list( X = XKeep, y = y, @@ -800,12 +1121,17 @@ mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { ), argsList ) - fit.mr.ash <- exec(mr.ash, !!!mrashArgs) - eff.wgt[keep] <- predict(fit.mr.ash, type = "coefficients")[-1] - if (retainFit) { - attr(eff.wgt, "fit") <- fit.mr.ash + fit.mr.ash <- exec(mr.ash, !!!MrashOptions) + # Zero-variance columns were never fitted and keep a zero weight. + eff.wgt <- replace( + rep(0, ncol(X)), + keep, + predict(fit.mr.ash, type = "coefficients")[-1] + ) + if (identical(fitRetention, "none")) { + return(eff.wgt) } - return(eff.wgt) + `attr<-`(eff.wgt, "fit", fit.mr.ash) } #' Extract Coefficients From Bayesian Linear Regression #' @@ -824,7 +1150,10 @@ mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { #' \code{1000}. #' @param nthin Integer. Thinning interval for retained MCMC samples. Default #' \code{5}. -#' @param ... Additional arguments forwarded to \code{qgg::gbayes}. +#' @param methodArgs Options forwarded to \code{qgg::gbayes}, built +#' with \code{\link{QggOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A vector containing the weights to be applied to each genotype in #' predicting the phenotype. #' @details This function fits a Bayesian linear regression model with a range @@ -850,47 +1179,41 @@ bayesAlphabetWeights <- function( nit = 5000, nburn = 1000, nthin = 5, - ... + methodArgs = QggOptions() ) { + .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") .bayesAlphabetValidate(X, y, Z) eff.wgt <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "bayesAlphabetWeights") - model <- qgg::gbayes( - y = y, - W = X[, keep, drop = FALSE], - X = Z, - method = method, - h2 = h2, - nit = nit, - nburn = nburn, - ... + callArgs <- list_modify( + list( + y = y, + W = X[, keep, drop = FALSE], + X = Z, + method = method, + h2 = h2, + nit = nit, + nburn = nburn, + nthin = nthin + ), + !!!methodArgs ) - - eff.wgt[keep] <- model$bm - return(eff.wgt) + model <- exec(qgg::gbayes, !!!callArgs) + replace(eff.wgt, keep, model$bm) } # Shared input validation for the gbayes-backed weight fitters: qgg present, # and matching row counts for response / genotype / covariates. # @noRd +#' @importFrom checkmate assertMatrix assertVector .bayesAlphabetValidate <- function(X, y, Z) { if (!requireNamespace("qgg", quietly = TRUE)) { - msg <- glue( - "To use this function, please install qgg: ", - "https://cran.r-project.org/web/packages/qgg/index.html" - ) - abort(msg) - } - if (!(length(y) == nrow(X))) { - abort("All objects must have the same number of rows") - } - if (!is.null(Z) && nrow(X) != nrow(Z)) { - abort( - "Genotype and covariate matrices must have same number of rows" - ) + abort("Package 'qgg' is required for this function.") } + assertVector(y, len = nrow(X)) + assertMatrix(Z, nrows = nrow(X), null.ok = TRUE) } #' @title BayesN TWAS weights (Gaussian prior, ridge-equivalent) #' @description Use Gaussian distribution as prior. Posterior means will be @@ -898,8 +1221,10 @@ bayesAlphabetWeights <- function( #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / -#' \code{qgg}. +#' @param methodArgs Options forwarded to \code{qgg::gbayes}, built +#' with \code{\link{QggOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. #' @examples @@ -908,8 +1233,9 @@ bayesAlphabetWeights <- function( #' y <- eqtlRegionExample$yRes #' bayesNWeights(X, y) #' @export -bayesNWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesN", Z, ...)) +bayesNWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { + .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") + bayesAlphabetWeights(X, y, method = "bayesN", Z, methodArgs = methodArgs) } #' @title BayesL TWAS weights (Laplace prior, LASSO-equivalent) #' @description Use laplace/double exponential distribution as prior. This is @@ -917,8 +1243,10 @@ bayesNWeights <- function(X, y, Z = NULL, ...) { #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / -#' \code{qgg}. +#' @param methodArgs Options forwarded to \code{qgg::gbayes}, built +#' with \code{\link{QggOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. #' @examples @@ -927,16 +1255,19 @@ bayesNWeights <- function(X, y, Z = NULL, ...) { #' y <- eqtlRegionExample$yRes #' bayesLWeights(X, y) #' @export -bayesLWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesL", Z, ...)) +bayesLWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { + .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") + bayesAlphabetWeights(X, y, method = "bayesL", Z, methodArgs = methodArgs) } #' @title BayesA TWAS weights (t-distribution prior) #' @description Use t-distribution as prior. #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / -#' \code{qgg}. +#' @param methodArgs Options forwarded to \code{qgg::gbayes}, built +#' with \code{\link{QggOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. #' @examples @@ -945,8 +1276,9 @@ bayesLWeights <- function(X, y, Z = NULL, ...) { #' y <- eqtlRegionExample$yRes #' bayesAWeights(X, y) #' @export -bayesAWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesA", Z, ...)) +bayesAWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { + .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") + bayesAlphabetWeights(X, y, method = "bayesA", Z, methodArgs = methodArgs) } #' @title BayesC TWAS weights (rounded-spike prior) #' @description Use a rounded spike prior (low-variance Gaussian). @@ -955,8 +1287,10 @@ bayesAWeights <- function(X, y, Z = NULL, ...) { #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. #' @param pi Numeric in (0, 1). Prior proportion of non-null effects for the #' BayesC mixture. Default \code{0.1}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / -#' \code{qgg}. +#' @param methodArgs Options forwarded to \code{qgg::gbayes}, built +#' with \code{\link{QggOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. #' @examples @@ -965,8 +1299,17 @@ bayesAWeights <- function(X, y, Z = NULL, ...) { #' y <- eqtlRegionExample$yRes #' bayesCWeights(X, y) #' @export -bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesC", Z, pi = pi, ...)) +bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) { + .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") + # `pi` is a qgg option, not a formal of bayesAlphabetWeights, so it joins + # the option list rather than the argument list. + bayesAlphabetWeights( + X, + y, + method = "bayesC", + Z, + methodArgs = .methodOptionsWith(methodArgs, "QggOptions", pi = pi) + ) } #' @title BayesR TWAS weights (hierarchical mixture prior) #' @description Use a hierarchical Bayesian mixture model with four Gaussian @@ -974,8 +1317,10 @@ bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, ...) { #' @param X Numeric genotype / design matrix (samples x variants). #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param Z Optional numeric matrix of fixed-effect covariates, or \code{NULL}. -#' @param ... Additional arguments forwarded to \code{bayesAlphabetWeights} / -#' \code{qgg}. +#' @param methodArgs Options forwarded to \code{qgg::gbayes}, built +#' with \code{\link{QggOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of effect-size weights, one per variant (column of #' \code{X}); columns dropped for zero variance receive weight 0. #' @examples @@ -984,8 +1329,9 @@ bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, ...) { #' y <- eqtlRegionExample$yRes #' bayesRWeights(X, y) #' @export -bayesRWeights <- function(X, y, Z = NULL, ...) { - return(bayesAlphabetWeights(X, y, method = "bayesR", Z, ...)) +bayesRWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { + .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") + bayesAlphabetWeights(X, y, method = "bayesR", Z, methodArgs = methodArgs) } @@ -1126,7 +1472,7 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { # stop( # paste0( # "To use this function, please install qgg: ", -# "https://cran.r-project.org/web/packages/qgg/index.html" +# # ) # ) # } @@ -1376,30 +1722,30 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { # #' Use Gaussian distribution as prior. Posterior means will be BLUP, # #' equivalent to Ridge Regression. # #' @export -# bayes_n_rss_weights <- function(sumstats, LD, ...) { +# bayes_n_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesN", ...)) # } # #' Use laplace/double exponential distribution as prior. This is equivalent # #' to Bayesian LASSO. # #' @export -# bayes_l_rss_weights <- function(sumstats, LD, ...) { +# bayes_l_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesL", ...)) # } # #' Use t-distribution as prior. # #' @export -# bayes_a_rss_weights <- function(sumstats, LD, ...) { +# bayes_a_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesA", ...)) # } # #' Use a rounded spike prior (low-variance Gaussian). # #' @export -# bayes_c_rss_weights <- function(sumstats, LD, ...) { +# bayes_c_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesC", ...)) # } # #' Use a hierarchical Bayesian mixture model with four Gaussian components. # #' Variances are scaled # #' by 0, 0.0001 , 0.001 , and 0.01 . # #' @export -# bayes_r_rss_weights <- function(sumstats, LD, ...) { +# bayes_r_rss_weights <- function(sumstats, LD, methodArgs = list()) { # return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesR", ...)) # } @@ -1444,6 +1790,7 @@ bayesRWeights <- function(X, y, Z = NULL, ...) { #' } #' out <- lassosumRss(bhat, R, n) #' @export +#' @importFrom checkmate assertCount assertNumber assertNumeric lassosumRss <- function( bhat, R, @@ -1452,6 +1799,9 @@ lassosumRss <- function( thr = 1e-4, maxiter = 10000 ) { + assertNumeric(lambda, lower = 0, any.missing = FALSE) + assertNumber(thr, lower = 0, finite = TRUE) + assertCount(maxiter, positive = TRUE) # cpp11 requires exact integer types; the C++ backend takes a block list, so # the single-window matrix R is wrapped as one block here. .rssSolvePath( @@ -1460,8 +1810,7 @@ lassosumRss <- function( n, lambda, .rssLassosumSolve, - thr = thr, - maxiter = maxiter + solveArgs = list(thr = thr, maxiter = maxiter) ) } @@ -1515,9 +1864,12 @@ lassosumRss <- function( ldBeta <- LD %*% candidateBeta bxy <- as.numeric(crossprod(corInput, candidateBeta)) bxxb <- colSums(candidateBeta * ldBeta) - scores <- rep(-Inf, length(bxy)) positive <- is.finite(bxxb) & bxxb > 0 - scores[positive] <- bxy[positive] / sqrt(bxxb[positive]) + scores <- replace( + rep(-Inf, length(bxy)), + positive, + bxy[positive] / sqrt(bxxb[positive]) + ) idx <- .lassosumFirstMax(scores) list( beta = candidateBeta[, idx], @@ -1533,6 +1885,7 @@ lassosumRss <- function( # of an "argument is missing" error, and propagate through the public wrappers # (verified two levels deep). Method-specific checks -- prsCs's maf length, # sdpr's M / perVariantSampleSize / array -- stay in the caller. +#' @importFrom checkmate assertVector .rssValidateInputs <- function(bhat, R, n) { if (missing(R) || !is.matrix(R)) { abort("Please provide the LD correlation matrix 'R' as a matrix.") @@ -1540,9 +1893,7 @@ lassosumRss <- function( if (missing(n) || n <= 0) { abort("Please provide a valid sample size using 'n'.") } - if (length(bhat) != nrow(R)) { - abort("The length of 'bhat' must equal the number of rows of 'R'.") - } + assertVector(bhat, len = nrow(R)) invisible(NULL) } @@ -1551,21 +1902,28 @@ lassosumRss <- function( # lambda order via the inverse permutation and assemble the standard result # list. Shared by lassosumRss and penalizedRss, which differ only in which Rcpp # solver they pass as `solveFn` (and penalizedRss's per-penalty gamma default). -.rssSolvePath <- function(bhat, R, n, lambda, solveFn, ...) { +.rssSolvePath <- function(bhat, R, n, lambda, solveFn, solveArgs = list()) { .rssValidateInputs(bhat, R, n) z <- bhat / sqrt(n) order <- order(lambda, decreasing = TRUE) - result <- solveFn(z, lambda[order], R, ...) + # `solveArgs` rather than `...`: the two solvers take different fixed + # argument sets, and both callers know theirs statically, so an unknown + # solver argument should be an error here rather than reaching the solver. + solved <- exec(solveFn, z, lambda[order], R, !!!solveArgs) # Reorder back to original lambda order via the inverse permutation. invOrder <- order(order) - result$beta <- result$beta[, invOrder, drop = FALSE] - result$conv <- result$conv[invOrder] - result$loss <- result$loss[invOrder] - result$fbeta <- result$fbeta[invOrder] - result$lambda <- lambda - result$nparams <- as.integer(colSums(result$beta != 0)) - result$betaEst <- as.numeric(result$beta[, which.min(result$fbeta)]) - result + beta <- solved$beta[, invOrder, drop = FALSE] + fbeta <- solved$fbeta[invOrder] + list_assign( + solved, + beta = beta, + conv = solved$conv[invOrder], + loss = solved$loss[invOrder], + fbeta = fbeta, + lambda = lambda, + nparams = as.integer(colSums(beta != 0)), + betaEst = as.numeric(beta[, which.min(fbeta)]) + ) } # Per-`s` fit for one RSS method (`method` selects the solver + which `config` @@ -1594,7 +1952,10 @@ lassosumRss <- function( # lassosum shrinkage path for one s. # @noRd .rssFitLassosum <- function(solverInput, LDs, n, sVal, config) { - lsArgs <- c(list(bhat = solverInput, R = LDs, n = n), config$dotArgs) + lsArgs <- c( + list(bhat = solverInput, R = LDs, n = n), + as.list(config$dotArgs) + ) model <- exec(lassosumRss, !!!lsArgs) list(beta = model$beta, meta = .rssPathMeta(sVal, model)) } @@ -1613,7 +1974,7 @@ lassosumRss <- function( lambda0 = config$lambda0, lambda2 = config$lambda2 ), - config$dotArgs + as.list(config$dotArgs) ) model <- exec(penalizedRss, !!!penArgs) list(beta = model$beta, meta = .rssPathMeta(sVal, model)) @@ -1644,14 +2005,7 @@ lassosumRss <- function( # @noRd .rssFinalize <- function(method, bestBeta, sel, meta, config) { base <- c(mode = sel$mode, index = sel$index) - attr( - bestBeta, - if (method == "lassosum") { - "lassosum_selection" - } else { - "penalized_rss_selection" - } - ) <- switch( + selection <- switch( method, lassosum = c( base, @@ -1672,7 +2026,12 @@ lassosumRss <- function( lambda = meta$lambda[sel$index] ) ) - bestBeta + attrName <- if (method == "lassosum") { + "lassosum_selection" + } else { + "penalized_rss_selection" + } + `attr<-`(bestBeta, attrName, selection) } # Shared scaffold for the RSS shrinkage-grid weight functions @@ -1681,6 +2040,19 @@ lassosumRss <- function( # candidate accumulation, and the ldQuadratic / minFbeta selection. `method` + # `config` pick the per-`s` solver (.rssFitOne) and the finalizer # (.rssFinalize). +# One shrinkage level's fit against the correspondingly shrunk LD. +# @noRd +.rssFitAtS <- function(sVal, method, solverInput, LD, n, p, config) { + .rssFitOne( + method, + solverInput, + (1 - sVal) * LD + sVal * diag(p), + n, + sVal, + config + ) +} + .rssShrinkGridWeights <- function( stat, LD, @@ -1694,15 +2066,18 @@ lassosumRss <- function( p <- nrow(LD) corInput <- .lassosumClampCor(.lassosumCorFromStat(stat, n = n, p = p)) solverInput <- corInput * sqrt(n) - candidateBeta <- NULL - candidateMeta <- list() - for (sVal in s) { - LDs <- (1 - sVal) * LD + sVal * diag(p) - one <- .rssFitOne(method, solverInput, LDs, n, sVal, config) - candidateBeta <- cbind(candidateBeta, one$beta) - candidateMeta[[length(candidateMeta) + 1L]] <- one$meta - } - candidateMeta <- bind_rows(candidateMeta) + fits <- map( + s, + .rssFitAtS, + method = method, + solverInput = solverInput, + LD = LD, + n = n, + p = p, + config = config + ) + candidateBeta <- exec(cbind, !!!map(fits, "beta")) + candidateMeta <- bind_rows(map(fits, "meta")) selectorResult <- if (selection == "ldQuadratic") { .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) } else { @@ -1740,8 +2115,10 @@ lassosumRss <- function( #' @param selection Selection strategy. Default \code{"ldQuadratic"} uses #' \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. #' \code{"minFbeta"} is retained as an explicit alternative for debugging. -#' @param ... Additional arguments passed to \code{lassosumRss()}. -#' +#' @param methodArgs Options forwarded to \code{lassosumRss}, built +#' with \code{\link{LassosumOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of the posterior SNP coefficients at the best (s, #' lambda). #' @examples @@ -1763,15 +2140,16 @@ lassosumRssWeights <- function( LD, s = c(0.2, 0.5, 0.9, 1.0), selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = LassosumOptions() ) { + .assertMethodOptions(methodArgs, "LassosumOptions", "methodArgs") selection <- arg_match(selection) .rssShrinkGridWeights( stat, LD, s, "lassosum", - list(dotArgs = list(...)), + list(dotArgs = methodArgs), selection ) } @@ -1858,14 +2236,16 @@ penalizedRss <- function( n, lambda, .rssPenalizedSolve, - penalty = penalty, - gamma = gamma, - alpha = alpha, - lambda0 = lambda0, - lambda2 = lambda2, - thr = thr, - maxiter = maxiter, - maxSwaps = maxSwaps + solveArgs = list( + penalty = penalty, + gamma = gamma, + alpha = alpha, + lambda0 = lambda0, + lambda2 = lambda2, + thr = thr, + maxiter = maxiter, + maxSwaps = maxSwaps + ) ) } @@ -1878,8 +2258,10 @@ penalizedRss <- function( #' sI}) and selects the best candidate via LD-quadratic pseudovalidation or #' minimum penalized objective. #' -#' @param stat,LD,s,selection,penalty,gamma,alpha,lambda0,lambda2,... See the +#' @param stat,LD,s,selection,penalty,gamma,alpha,lambda0,lambda2 See the #' public wrappers for details. +#' @param methodArgs Options forwarded to \code{penalizedRss}, built with +#' \code{\link{PenalizedRssOptions}}. #' @return Numeric weight vector of length \code{nrow(LD)}. #' @keywords internal .penalizedRssWeights <- function( @@ -1892,8 +2274,9 @@ penalizedRss <- function( lambda0 = 0, lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = PenalizedRssOptions() ) { + .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") selection <- arg_match(selection) .rssShrinkGridWeights( stat, @@ -1906,7 +2289,7 @@ penalizedRss <- function( alpha = alpha, lambda0 = lambda0, lambda2 = lambda2, - dotArgs = list(...) + dotArgs = methodArgs ), selection ) @@ -1927,7 +2310,10 @@ penalizedRss <- function( #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. -#' @param ... Additional arguments passed to \code{penalizedRss()}. +#' @param methodArgs Options forwarded to \code{penalizedRss}, built +#' with \code{\link{PenalizedRssOptions}}. A bare list is refused: it +#' cannot be checked against the engine, so a misspelled option would +#' be silently ignored. #' @return A numeric vector of SNP coefficient weights. #' @examples #' data(eqtlRegionExample) @@ -1942,6 +2328,7 @@ penalizedRss <- function( #' ) #' LD <- cor(X) #' scadRssWeights(stat, LD) +#' @importFrom checkmate assertList assertNumeric assertNumber #' @export scadRssWeights <- function( stat, @@ -1950,8 +2337,13 @@ scadRssWeights <- function( gamma = 3.7, alpha = 1.0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = PenalizedRssOptions() ) { + .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") + assertList(stat) + assertNumeric(s, lower = 0, any.missing = FALSE) + assertNumber(gamma, finite = TRUE) + assertNumber(alpha, finite = TRUE) .penalizedRssWeights( stat = stat, LD = LD, @@ -1960,7 +2352,7 @@ scadRssWeights <- function( gamma = gamma, alpha = alpha, selection = selection, - ... + methodArgs = methodArgs ) } @@ -1979,7 +2371,10 @@ scadRssWeights <- function( #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. -#' @param ... Additional arguments passed to \code{penalizedRss()}. +#' @param methodArgs Options forwarded to \code{penalizedRss}, built +#' with \code{\link{PenalizedRssOptions}}. A bare list is refused: it +#' cannot be checked against the engine, so a misspelled option would +#' be silently ignored. #' @return A numeric vector of SNP coefficient weights. #' @examples #' data(eqtlRegionExample) @@ -1994,6 +2389,7 @@ scadRssWeights <- function( #' ) #' LD <- cor(X) #' mcpRssWeights(stat, LD) +#' @importFrom checkmate assertList assertNumeric assertNumber #' @export mcpRssWeights <- function( stat, @@ -2002,8 +2398,13 @@ mcpRssWeights <- function( gamma = 3.0, alpha = 1.0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = PenalizedRssOptions() ) { + .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") + assertList(stat) + assertNumeric(s, lower = 0, any.missing = FALSE) + assertNumber(gamma, finite = TRUE) + assertNumber(alpha, finite = TRUE) .penalizedRssWeights( stat = stat, LD = LD, @@ -2012,7 +2413,7 @@ mcpRssWeights <- function( gamma = gamma, alpha = alpha, selection = selection, - ... + methodArgs = methodArgs ) } @@ -2041,7 +2442,10 @@ mcpRssWeights <- function( #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. #' @param maxSwaps Maximum swap rounds per lambda. Default 100. -#' @param ... Additional arguments passed to \code{penalizedRss()}. +#' @param methodArgs Options forwarded to \code{penalizedRss}, built +#' with \code{\link{PenalizedRssOptions}}. A bare list is refused: it +#' cannot be checked against the engine, so a misspelled option would +#' be silently ignored. #' @return A numeric vector of SNP coefficient weights. #' @examples #' data(eqtlRegionExample) @@ -2067,8 +2471,9 @@ l0learnRssWeights <- function( lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, - ... + methodArgs = PenalizedRssOptions() ) { + .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") penalty <- arg_match(penalty) selection <- arg_match(selection) @@ -2092,7 +2497,7 @@ l0learnRssWeights <- function( lambda0 = lambda0, lambda2 = lambda2, maxSwaps = maxSwaps, - dotArgs = list(...) + dotArgs = methodArgs ), selection ) @@ -2111,29 +2516,39 @@ l0learnRssWeights <- function( #' @param y A numeric response vector. #' @param penalty Either "SCAD" or "MCP". #' @param nfolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `ncvreg::cv.ncvreg`. +#' @param methodArgs Options forwarded to \code{ncvreg::cv.ncvreg}, built +#' with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @importFrom stats coef #' @keywords internal -ncvregWeights <- function(X, y, penalty, nfolds = 5, ...) { +#' @importFrom checkmate assertCount +ncvregWeights <- function( + X, + y, + penalty, + nfolds = 5, + methodArgs = NcvregOptions() +) { + .assertMethodOptions(methodArgs, "NcvregOptions", "methodArgs") + assertCount(nfolds, positive = TRUE) if (!requireNamespace("ncvreg", quietly = TRUE)) { - msg <- glue( - "To use this function, please install ncvreg: ", - "https://cran.r-project.org/package=ncvreg" - ) - abort(msg) + abort("Package 'ncvreg' is required for this function.") } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "ncvregWeights") - fit <- ncvreg::cv.ncvreg( - X = X[, keep, drop = FALSE], - y = y, - penalty = penalty, - nfolds = nfolds, - ... + callArgs <- list_modify( + list( + X = X[, keep, drop = FALSE], + y = y, + penalty = penalty, + nfolds = nfolds + ), + !!!methodArgs ) - eff.wgt[keep] <- coef(fit, lambda = fit$lambda.min)[-1] - return(eff.wgt) + fit <- exec(ncvreg::cv.ncvreg, !!!callArgs) + replace(eff.wgt, keep, coef(fit, lambda = fit$lambda.min)[-1]) } #' Compute Weights Using SCAD-Penalized Regression @@ -2144,7 +2559,10 @@ ncvregWeights <- function(X, y, penalty, nfolds = 5, ...) { #' @param X A numeric matrix of predictors. #' @param y A numeric response vector. #' @param nfolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `ncvreg::cv.ncvreg`. +#' @param methodArgs Options forwarded to \code{ncvreg::cv.ncvreg}, built +#' with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) @@ -2152,8 +2570,15 @@ ncvregWeights <- function(X, y, penalty, nfolds = 5, ...) { #' y <- eqtlRegionExample$yRes #' scadWeights(X, y) #' @export -scadWeights <- function(X, y, nfolds = 5, ...) { - ncvregWeights(X, y, penalty = "SCAD", nfolds = nfolds, ...) +scadWeights <- function(X, y, nfolds = 5, methodArgs = NcvregOptions()) { + .assertMethodOptions(methodArgs, "NcvregOptions", "methodArgs") + ncvregWeights( + X, + y, + penalty = "SCAD", + nfolds = nfolds, + methodArgs = methodArgs + ) } #' Compute Weights Using MCP-Penalized Regression @@ -2164,7 +2589,10 @@ scadWeights <- function(X, y, nfolds = 5, ...) { #' @param X A numeric matrix of predictors. #' @param y A numeric response vector. #' @param nfolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `ncvreg::cv.ncvreg`. +#' @param methodArgs Options forwarded to \code{ncvreg::cv.ncvreg}, built +#' with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) @@ -2172,8 +2600,15 @@ scadWeights <- function(X, y, nfolds = 5, ...) { #' y <- eqtlRegionExample$yRes #' mcpWeights(X, y) #' @export -mcpWeights <- function(X, y, nfolds = 5, ...) { - ncvregWeights(X, y, penalty = "MCP", nfolds = nfolds, ...) +mcpWeights <- function(X, y, nfolds = 5, methodArgs = NcvregOptions()) { + .assertMethodOptions(methodArgs, "NcvregOptions", "methodArgs") + ncvregWeights( + X, + y, + penalty = "MCP", + nfolds = nfolds, + methodArgs = methodArgs + ) } #' Compute Weights Using L0Learn @@ -2189,8 +2624,10 @@ mcpWeights <- function(X, y, nfolds = 5, ...) { #' @param penalty Type of regularization: "L0", "L0L1", or "L0L2". Default is #' "L0". #' @param nFolds Number of cross-validation folds. Default is 5. -#' @param ... Additional arguments passed through to `L0Learn::L0Learn.cvfit` -#' (e.g. `nGamma`, `gammaMin`, `gammaMax`, `algorithm`, `maxSuppSize`). +#' @param methodArgs Options forwarded to \code{L0Learn::L0Learn.cvfit}, built +#' with \code{\link{L0learnOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) @@ -2198,36 +2635,39 @@ mcpWeights <- function(X, y, nfolds = 5, ...) { #' y <- eqtlRegionExample$yRes #' l0learnWeights(X, y) #' @export -l0learnWeights <- function(X, y, penalty = "L0", nFolds = 5, ...) { +l0learnWeights <- function( + X, + y, + penalty = "L0", + nFolds = 5, + methodArgs = L0learnOptions() +) { + .assertMethodOptions(methodArgs, "L0learnOptions", "methodArgs") if (!requireNamespace("L0Learn", quietly = TRUE)) { - msg <- glue( - "To use this function, please install L0Learn: ", - "https://cran.r-project.org/package=L0Learn" - ) - abort(msg) + abort("Package 'L0Learn' is required for this function.") } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "l0learnWeights") - fit <- L0Learn::L0Learn.cvfit( - x = X[, keep, drop = FALSE], - y = y, - penalty = penalty, - nFolds = nFolds, - ... + callArgs <- list_modify( + list( + x = X[, keep, drop = FALSE], + y = y, + penalty = penalty, + nFolds = nFolds + ), + !!!methodArgs ) + fit <- exec(L0Learn::L0Learn.cvfit, !!!callArgs) # Find (gamma, lambda) minimizing CV error across the entire path. cvMins <- map_dbl(fit$cvMeans, .rssMinNumeric) gammaIdx <- which.min(cvMins) lambdaIdx <- which.min(as.numeric(fit$cvMeans[[gammaIdx]])) bestGamma <- fit$fit$gamma[gammaIdx] bestLambda <- fit$fit$lambda[[gammaIdx]][lambdaIdx] - coefs <- as.numeric(coef(fit, lambda = bestLambda, gamma = bestGamma)) + raw <- as.numeric(coef(fit, lambda = bestLambda, gamma = bestGamma)) # If intercept was included, drop it (first row). - if (length(coefs) == sum(keep) + 1L) { - coefs <- coefs[-1L] - } - eff.wgt[keep] <- coefs - return(eff.wgt) + coefs <- if (length(raw) == sum(keep) + 1L) raw[-1L] else raw + replace(eff.wgt, keep, coefs) } #' Compute Weights Using a BGLR Linear Regression Model @@ -2246,7 +2686,10 @@ l0learnWeights <- function(X, y, penalty = "L0", nFolds = 5, ...) { #' @param thin Thinning interval. #' @param etaArgs Optional named list of additional arguments included in the #' `ETA` linear-term specification (e.g. `list(probIn = 0.05)` for BayesB). -#' @param ... Additional arguments passed through to `BGLR::BGLR`. +#' @param methodArgs Options forwarded to \code{BGLR::BGLR}, built +#' with \code{\link{BglrOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @keywords internal bglrWeights <- function( @@ -2257,14 +2700,11 @@ bglrWeights <- function( burnIn, thin, etaArgs = list(), - ... + methodArgs = BglrOptions() ) { + .assertMethodOptions(methodArgs, "BglrOptions", "methodArgs") if (!requireNamespace("BGLR", quietly = TRUE)) { - msg <- glue( - "To use this function, please install BGLR: ", - "https://cran.r-project.org/package=BGLR" - ) - abort(msg) + abort("Package 'BGLR' is required for this function.") } eff.wgt <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "bglrWeights") @@ -2275,18 +2715,20 @@ bglrWeights <- function( saveAt <- str_c(tmpdir, .Platform$file.sep) eta <- list(c(list(X = X[, keep, drop = FALSE], model = model), etaArgs)) - fit <- BGLR::BGLR( - y = y, - ETA = eta, - nIter = nIter, - burnIn = burnIn, - thin = thin, - saveAt = saveAt, - verbose = FALSE, - ... + callArgs <- list_modify( + list( + y = y, + ETA = eta, + nIter = nIter, + burnIn = burnIn, + thin = thin, + saveAt = saveAt, + verbose = FALSE + ), + !!!methodArgs ) - eff.wgt[keep] <- as.numeric(fit$ETA[[1]]$b) - return(eff.wgt) + fit <- exec(BGLR::BGLR, !!!callArgs) + replace(eff.wgt, keep, as.numeric(fit$ETA[[1]]$b)) } #' Compute Weights Using BayesB @@ -2307,13 +2749,17 @@ bglrWeights <- function( #' @param burnIn Number of burn-in iterations. Default is 2000. #' @param thin Thinning interval. Default is 5. #' @param probIn Prior inclusion probability for each marker. Default is 0.2. -#' @param ... Additional arguments passed through to `BGLR::BGLR`. +#' @param methodArgs Options forwarded to \code{BGLR::BGLR}, built +#' with \code{\link{BglrOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' bayesBWeights(X, y) +#' @importFrom checkmate assertCount assertNumber #' @export bayesBWeights <- function( X, @@ -2322,8 +2768,13 @@ bayesBWeights <- function( burnIn = 2000, thin = 5, probIn = 0.2, - ... + methodArgs = BglrOptions() ) { + .assertMethodOptions(methodArgs, "BglrOptions", "methodArgs") + assertCount(nIter, positive = TRUE) + assertCount(burnIn) + assertCount(thin, positive = TRUE) + assertNumber(probIn, lower = 0, upper = 1) bglrWeights( X, y, @@ -2332,7 +2783,7 @@ bayesBWeights <- function( burnIn = burnIn, thin = thin, etaArgs = list(probIn = probIn), - ... + methodArgs = methodArgs ) } @@ -2353,15 +2804,30 @@ bayesBWeights <- function( #' @param nIter Number of MCMC iterations. Default is 10000. #' @param burnIn Number of burn-in iterations. Default is 2000. #' @param thin Thinning interval. Default is 5. -#' @param ... Additional arguments passed through to `BGLR::BGLR`. +#' @param methodArgs Options forwarded to \code{BGLR::BGLR}, built +#' with \code{\link{BglrOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. #' @return A numeric vector of length `ncol(X)` of variant weights. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' bLassoWeights(X, y) +#' @importFrom checkmate assertCount #' @export -bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { +bLassoWeights <- function( + X, + y, + nIter = 10000, + burnIn = 2000, + thin = 5, + methodArgs = BglrOptions() +) { + .assertMethodOptions(methodArgs, "BglrOptions", "methodArgs") + assertCount(nIter, positive = TRUE) + assertCount(burnIn) + assertCount(thin, positive = TRUE) bglrWeights( X, y, @@ -2369,7 +2835,7 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { nIter = nIter, burnIn = burnIn, thin = thin, - ... + methodArgs = methodArgs ) } @@ -2390,8 +2856,15 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { #' @param y A numeric response vector. #' @param fittingMethod One of "VB", "Gibbs", or "Adaptive_Gibbs". Default is #' "VB". -#' @param ... Additional arguments passed through to `RcppDPR::fit_model`. -#' @param retainFit Logical. Attach the full fitted-model object to the result. +#' @param methodArgs Options forwarded to \code{RcppDPR::fit_model}, built +#' with \code{\link{DprOptions}}. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be +#' silently ignored. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} attach the fitted model. This +#' engine keeps no trimmable intermediates, so the two retaining levels +#' behave alike here. #' Default \code{FALSE}. #' @param nK Integer. Number of variational mixture components for the VB fit #' (\code{dprVbWeights}). Default \code{8}. @@ -2404,30 +2877,37 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { #' y <- eqtlRegionExample$yRes #' dprWeights(X, y) #' @export -dprWeights <- function(X, y, fittingMethod = "VB", retainFit = FALSE, ...) { +dprWeights <- function( + X, + y, + fittingMethod = "VB", + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) { + fitRetention <- arg_match(fitRetention) + .assertMethodOptions(methodArgs, "DprOptions", "methodArgs") if (!requireNamespace("RcppDPR", quietly = TRUE)) { - msg <- glue( - "To use this function, please install RcppDPR: ", - "https://cran.r-project.org/package=RcppDPR" - ) - abort(msg) + abort("Package 'RcppDPR' is required for this function.") } - eff.wgt <- rep(0, ncol(X)) + zeros <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "dprWeights") w <- matrix(1, nrow = nrow(X), ncol = 1) - fit <- RcppDPR::fit_model( - y = y, - w = w, - x = X[, keep, drop = FALSE], - rotate_variables = FALSE, - fitting_method = fittingMethod, - ... - ) - eff.wgt[keep] <- as.numeric(fit$beta + fit$alpha) - if (retainFit) { - attr(eff.wgt, "fit") <- fit + callArgs <- list_modify( + list( + y = y, + w = w, + x = X[, keep, drop = FALSE], + rotate_variables = FALSE, + fitting_method = fittingMethod + ), + !!!methodArgs + ) + fit <- exec(RcppDPR::fit_model, !!!callArgs) + eff.wgt <- replace(zeros, keep, as.numeric(fit$beta + fit$alpha)) + if (identical(fitRetention, "none")) { + return(eff.wgt) } - return(eff.wgt) + `attr<-`(eff.wgt, "fit", fit) } #' @rdname dprWeights @@ -2437,8 +2917,22 @@ dprWeights <- function(X, y, fittingMethod = "VB", retainFit = FALSE, ...) { #' y <- eqtlRegionExample$yRes #' dprVbWeights(X, y) #' @export -dprVbWeights <- function(X, y, nK = 8, retainFit = FALSE, ...) { - dprWeights(X, y, fittingMethod = "VB", n_k = nK, retainFit = retainFit, ...) +dprVbWeights <- function( + X, + y, + nK = 8, + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) { + fitRetention <- arg_match(fitRetention) + .assertMethodOptions(methodArgs, "DprOptions", "methodArgs") + dprWeights( + X, + y, + fittingMethod = "VB", + fitRetention = fitRetention, + methodArgs = .methodOptionsWith(methodArgs, "DprOptions", n_k = nK) + ) } #' @rdname dprWeights @@ -2450,15 +2944,28 @@ dprVbWeights <- function(X, y, nK = 8, retainFit = FALSE, ...) { #' colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) #' y <- X[, 1] * 0.5 + rnorm(n) #' dprGibbsWeights(X, y, sStep = 500) +#' @importFrom checkmate assertCount assertFlag #' @export -dprGibbsWeights <- function(X, y, sStep = 5000, retainFit = FALSE, ...) { +dprGibbsWeights <- function( + X, + y, + sStep = 5000, + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) { + .assertMethodOptions(methodArgs, "DprOptions", "methodArgs") + assertCount(sStep, positive = TRUE) + fitRetention <- arg_match(fitRetention) dprWeights( X, y, fittingMethod = "Gibbs", - s_step = sStep, - retainFit = retainFit, - ... + fitRetention = fitRetention, + methodArgs = .methodOptionsWith( + methodArgs, + "DprOptions", + s_step = sStep + ) ) } @@ -2471,16 +2978,82 @@ dprGibbsWeights <- function(X, y, sStep = 5000, retainFit = FALSE, ...) { #' colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) #' y <- X[, 1] * 0.5 + rnorm(n) #' dprAdaptiveGibbsWeights(X, y) +#' @importFrom checkmate assertFlag #' @export -dprAdaptiveGibbsWeights <- function(X, y, retainFit = FALSE, ...) { +dprAdaptiveGibbsWeights <- function( + X, + y, + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) { + .assertMethodOptions(methodArgs, "DprOptions", "methodArgs") + fitRetention <- arg_match(fitRetention) dprWeights( X, y, fittingMethod = "Adaptive_Gibbs", - retainFit = retainFit, - ... + fitRetention = fitRetention, + methodArgs = methodArgs ) } +# Starting coefficients as a plain matrix: .mrmashInitCoefficients() +# returns the fit it used, and only its Bhat is wanted here. +# @noRd +.mrmashInitB <- function(X, Y, bInitMethod, standardize, numThreads) { + as.matrix( + .mrmashInitCoefficients( + X, + Y, + bInitMethod, + standardize, + numThreads + )$Bhat + ) +} + +# Everything mrmashWrapper needs in hand before the fit: the package and +# bundle checks, the resolved coefficient-initialisation method, the +# summary statistics the prior grid is built from (computed here when the +# caller did not supply them), and the prior covariance matrices. +# @noRd +.mrmashWrapperSetup <- function( + X, + Y, + prior, + methodArgs, + dataDrivenPriorMatrices, + bInitMethod, + sumstats, + standardize, + numThreads +) { + .mrmashRequirePackages() + .assertMethodParam(prior, "MrmashPriorParam", "prior") + .assertMethodOptions(methodArgs, "MrmashOptions", "methodArgs") + priorOpts <- as.list(prior) + .mrmashValidateWrapper( + X = X, + Y = Y, + dataDrivenPriorMatrices = dataDrivenPriorMatrices, + canonicalPriorMatrices = priorOpts$canonicalPriorMatrices %||% FALSE + ) + if (is.null(sumstats)) { + sumstats <- .mrmashComputeSumstats(X, Y, standardize, numThreads) + } + list( + bInitMethod = .mrmashResolveBInit(Y, bInitMethod), + # Shared prior-covariance builder (also used by mrmashRssWeights). + priorBuilt = exec( + buildMrmashPriorMatrices, + Bhat = sumstats$Bhat, + Shat = sumstats$Shat, + K = ncol(Y), + dataDrivenPriorMatrices = dataDrivenPriorMatrices, + !!!priorOpts + ) + ) +} + #' @title Mr.Mash Wrapper #' #' @description Compute weights with mr.mash using a precomputed prior grid and @@ -2493,29 +3066,26 @@ dprAdaptiveGibbsWeights <- function(X, y, retainFit = FALSE, ...) { #' (tissue/cell-types). #' @param dataDrivenPriorMatrices A list of data-driven covariance matrices. #' Default is NULL. -#' @param priorGrid A vector of scaling factors to be used in fitting the -#' mr.mash model. Default is NULL. -#' @param nthreads The number of threads to use for parallel computation. -#' Default is 2. -#' @param canonicalPriorMatrices A logical indicating whether to use canonical -#' matrices as priors. Default is FALSE. -#' @param standardize A logical indicating whether to standardize the input -#' data. Default is FALSE. -#' @param updateW0 A logical indicating whether to update the prior mixture -#' weights. Default is TRUE. -#' @param w0Threshold The threshold for updating prior mixture weights. Default -#' is 1e-8. +#' @param prior Prior-covariance construction options, built with +#' \code{\link{MrmashPriorParam}}. +#' @param bInitMethod The method for initializing the coefficient matrix. +#' Default is "enet". #' @param updateV A logical indicating whether to update the residual covariance #' matrix. Default is TRUE. #' @param updateVMethod The method for updating the residual covariance matrix. #' Default is "full". -#' @param bInitMethod The method for initializing the coefficient matrix. -#' Default is "enet". -#' @param maxIter The maximum number of iterations. Default is 5000. -#' @param tol The tolerance for convergence. Default is 0.01. -#' @param verbose A logical indicating whether to print verbose output. Default -#' is FALSE. -#' @param ... Additional arguments to be passed to mr.mash. +#' @param standardize A logical indicating whether to standardize the input +#' data. Default is FALSE. Used by the summary-statistic and initialisation +#' steps as well as the fit, so it is set here rather than in +#' \code{methodArgs}. +#' @param numThreads The number of threads to use for parallel computation. +#' Default is 1. Used by the same three steps as \code{standardize}. +#' @param methodArgs Options forwarded to \code{mr.mashr::mr.mash} under its +#' own names, built with \code{\link{MrmashOptions}} +#' (\code{update_w0}, \code{max_iter}, \code{tol}, \code{w0_threshold}, +#' \code{verbose}, ...). Arguments the wrapper derives --- the prior, the +#' residual covariance, the coefficient initialisation --- cannot be set +#' here. #' #' @param V Optional residual covariance matrix (conditions x conditions), or #' \code{NULL} to estimate it. @@ -2555,7 +3125,7 @@ dprAdaptiveGibbsWeights <- function(X, y, retainFit = FALSE, ...) { #' res <- mrmashWrapper( #' X = multiTraitData$X[, 1:60], Y = multiTraitData$Y, #' dataDrivenPriorMatrices = multiTraitData$priorMatrices, -#' canonicalPriorMatrices = TRUE +#' prior = MrmashPriorParam(canonicalPriorMatrices = TRUE) #' ) #' #' @export @@ -2565,83 +3135,77 @@ mrmashWrapper <- function( V = NULL, sumstats = NULL, dataDrivenPriorMatrices = NULL, - priorGrid = NULL, - nthreads = 1, - canonicalPriorMatrices = FALSE, - standardize = FALSE, - updateW0 = TRUE, - w0Threshold = 1e-8, + prior = MrmashPriorParam(), + bInitMethod = "enet", updateV = TRUE, updateVMethod = "full", - bInitMethod = "enet", - maxIter = 5000, - tol = 0.01, - verbose = FALSE, - ... + standardize = FALSE, + numThreads = 1, + methodArgs = MrmashOptions() ) { - .mrmashRequirePackages() - p <- as.list(environment()) - .mrmashValidateWrapper(p) - p$bInitMethod <- .mrmashResolveBInit(Y, bInitMethod) - if (is.null(sumstats)) { - p$sumstats <- .mrmashComputeSumstats(p) - } - # Shared prior-covariance builder (also used by mrmashRssWeights). - priorBuilt <- buildMrmashPriorMatrices( - Bhat = p$sumstats$Bhat, - Shat = p$sumstats$Shat, - K = ncol(Y), + setup <- .mrmashWrapperSetup( + X = X, + Y = Y, + prior = prior, + methodArgs = methodArgs, dataDrivenPriorMatrices = dataDrivenPriorMatrices, - canonicalPriorMatrices = canonicalPriorMatrices, - priorGrid = priorGrid + bInitMethod = bInitMethod, + sumstats = sumstats, + standardize = standardize, + numThreads = numThreads ) + bInitMethod <- setup$bInitMethod + priorBuilt <- setup$priorBuilt time1 <- proc.time() - bInit <- as.matrix(.mrmashInitCoefficients(p)$Bhat) - vInit <- .mrmashInitV(p) - fitMrmash <- .mrmashFit(p, priorBuilt$S0, bInit, vInit) - fitMrmash$analysis_time <- proc.time()["elapsed"] - time1["elapsed"] - fitMrmash + bInit <- .mrmashInitB(X, Y, bInitMethod, standardize, numThreads) + vInit <- .mrmashInitV(X, Y, V, updateV, updateVMethod) + fitMrmash <- .mrmashFit( + priorBuilt$S0, + bInit, + vInit, + X = X, + Y = Y, + standardize = standardize, + numThreads = numThreads, + updateVMethod = updateVMethod, + methodArgs = methodArgs + ) + list_assign( + fitMrmash, + analysis_time = proc.time()["elapsed"] - time1["elapsed"] + ) } # Require glmnet + mr.mashr; also emit the no-seed reproducibility message. # @noRd .mrmashRequirePackages <- function() { if (!requireNamespace("glmnet", quietly = TRUE)) { - msg <- glue( - "To use this function, please install glmnet: ", - "https://cran.r-project.org/web/packages/glmnet/index.html" - ) - abort(msg) + abort("Package 'glmnet' is required for this function.") } if (!requireNamespace("mr.mashr", quietly = TRUE)) { - msg <- glue( - "To use this function, please install mr.mashr: ", - "https://github.com/stephenslab/mr.mashr" - ) - abort(msg) + abort("Package 'mr.mashr' is required for this function.") } } # Input validation for the individual-level mr.mash wrapper. # @noRd -.mrmashValidateWrapper <- function(p) { +#' @importFrom checkmate assertMatrix +.mrmashValidateWrapper <- function( + X, + Y, + dataDrivenPriorMatrices, + canonicalPriorMatrices +) { if (!exists(".Random.seed")) { inform( "! No seed has been set. Please set seed for reproducable result. " ) } - if (!is.matrix(p$X) || !is.matrix(p$Y)) { + if (!is.matrix(X) || !is.matrix(Y)) { abort("X and Y must be matrices.") } - if (nrow(p$X) != nrow(p$Y)) { - abort("X and Y must have the same number of rows.") - } - if (!is.null(p$priorGrid) && !is.vector(p$priorGrid)) { - abort("priorGrid must be a vector.") - } - if ( - is.null(p$dataDrivenPriorMatrices) && !isTRUE(p$canonicalPriorMatrices) - ) { + assertMatrix(Y, nrows = nrow(X)) + if (is.null(dataDrivenPriorMatrices) && !isTRUE(canonicalPriorMatrices)) { msg <- glue( "Please provide dataDrivenPriorMatrices or set ", "canonicalPriorMatrices = TRUE." @@ -2667,34 +3231,39 @@ mrmashWrapper <- function( # Univariate summary statistics (Bhat/Shat) for the prior + init. # @noRd -.mrmashComputeSumstats <- function(p) { +.mrmashComputeSumstats <- function(X, Y, standardize, numThreads) { mr.mashr::compute_univariate_sumstats( - p$X, - p$Y, - standardize = p$standardize, + X, + Y, + standardize = standardize, standardize.response = FALSE, - mc.cores = p$nthreads + mc.cores = numThreads ) } # Initial coefficient matrix via graphical-lasso or univariate glmnet. # @noRd -.mrmashInitCoefficients <- function(p) { - if (p$bInitMethod == "glasso") { +.mrmashInitCoefficients <- function( + X, + Y, + bInitMethod, + standardize, + numThreads +) { + if (bInitMethod == "glasso") { return(computeCoefficientsGlasso( - p$X, - p$Y, - standardize = p$standardize, - nthreads = p$nthreads, + X, + Y, + standardize = standardize, + numThreads = numThreads, Xnew = NULL )) } computeCoefficientsUnivGlmnet( - p$X, - p$Y, + X, + Y, alpha = 0.5, - standardize = p$standardize, - nthreads = p$nthreads, + standardize = standardize, Xnew = NULL ) } @@ -2702,18 +3271,18 @@ mrmashWrapper <- function( # Robust residual-covariance init. Returns list(V, updateV); a rank-deficient V # is ridge-regularized and its update disabled. # @noRd -.mrmashInitV <- function(p) { - if (!is.null(p$V)) { - return(list(V = p$V, updateV = p$updateV)) +.mrmashInitV <- function(X, Y, V, updateV, updateVMethod) { + if (!is.null(V)) { + return(list(V = V, updateV = updateV)) } - V <- .mrmashComputeVInit(p$X, p$Y, any(is.na(p$Y))) - if (p$updateVMethod == "diagonal") { - return(list(V = diag(diag(V)), updateV = p$updateV)) + V <- .mrmashComputeVInit(X, Y, any(is.na(Y))) + if (updateVMethod == "diagonal") { + return(list(V = diag(diag(V)), updateV = updateV)) } if (any(eigen(V)$values < 1e-8)) { return(list(V = V + diag(1e-8, nrow(V)), updateV = FALSE)) } - list(V = V, updateV = p$updateV) + list(V = V, updateV = updateV) } # Compute V_init via mr.mashr (cov for complete Y, flash when Y has missing). @@ -2740,26 +3309,60 @@ mrmashWrapper <- function( # Run mr.mash with the resolved prior / init / V. # @noRd -.mrmashFit <- function(p, S0, bInit, vInit) { - mr.mashr::mr.mash( - X = p$X, - Y = p$Y, +# The mr.mash call. Everything pecotmr derives -- the prior, the residual +# covariance, the coefficient initialisation -- is supplied here and cannot be +# overridden; the rest of mr.mash's arguments come from `methodArgs` under +# mr.mash's own names, with pecotmr's defaults underneath. +# @noRd +.mrmashFit <- function( + S0, + bInit, + vInit, + X, + Y, + standardize, + numThreads, + updateVMethod, + methodArgs +) { + derived <- list( + X = X, + Y = Y, V = vInit$V, S0 = S0, w0 = computeW0(bInit, length(S0)), - update_w0 = p$updateW0, - tol = p$tol, - max_iter = p$maxIter, + update_V = vInit$updateV, + update_V_method = updateVMethod, + mu1_init = bInit, + standardize = standardize, + nthreads = numThreads + ) + user <- as.list(methodArgs) + clash <- intersect(names(user), names(derived)) + if (length(clash) > 0L) { + abort(glue( + "mrmashWrapper: {str_flatten(clash, ', ')} ", + "{if (length(clash) == 1L) 'is' else 'are'} derived by the ", + "wrapper (from the data, the prior and the initialisation), so ", + "{if (length(clash) == 1L) 'it' else 'they'} cannot be set in ", + "`methodArgs`." + )) + } + defaults <- list( + update_w0 = TRUE, + tol = 0.01, + max_iter = 5000, convergence_criterion = "ELBO", compute_ELBO = TRUE, - standardize = p$standardize, - verbose = p$verbose, - update_V = vInit$updateV, - update_V_method = p$updateVMethod, - w0_threshold = p$w0Threshold, - nthreads = p$nthreads, - mu1_init = bInit + verbose = FALSE, + w0_threshold = 1e-8 ) + exec(mr.mashr::mr.mash, !!!c(derived, list_modify(defaults, !!!user))) +} + +# @noRd +.rrDropIntercept <- function(coefs) { + as.vector(coefs)[-1] } #' Compute initial mr.mash coefficients via group-lasso @@ -2771,7 +3374,7 @@ mrmashWrapper <- function( #' @param Y Numeric response matrix (samples x conditions). #' @param standardize Logical; standardize the columns of \code{X} before #' fitting. -#' @param nthreads Integer; number of threads for the group-lasso fit. +#' @param numThreads Integer; number of threads for the group-lasso fit. #' @param Xnew Optional new design matrix for prediction; \code{NULL} returns #' in-sample coefficients. #' @return A numeric matrix of initial coefficient estimates (variants x @@ -2781,15 +3384,18 @@ mrmashWrapper <- function( #' X <- eqtlRegionExample$X[, 1:30] #' Y <- matrix(rnorm(nrow(X) * 3), nrow(X), 3) #' computeCoefficientsGlasso(X = X, Y = Y, standardize = TRUE, -#' nthreads = 1L, Xnew = NULL) +#' numThreads = 1L, Xnew = NULL) +#' @importFrom checkmate assertFlag assertInt #' @export computeCoefficientsGlasso <- function( X, Y, standardize, - nthreads, + numThreads, Xnew = NULL ) { + assertFlag(standardize) + assertInt(numThreads) n <- nrow(X) p <- ncol(X) r <- ncol(Y) @@ -2806,17 +3412,20 @@ computeCoefficientsGlasso <- function( ) coeffGlmnet <- coef(cvfitGlmnet, s = "lambda.min") - # Build matrix of initial estimates for mr.mash - B <- matrix(as.numeric(NA), nrow = p, ncol = r) - - for (i in seq_along(coeffGlmnet)) { - B[, i] <- as.vector(coeffGlmnet[[i]])[-1] - } + # Build matrix of initial estimates for mr.mash: one column per outcome, + # each the glmnet coefficients with the intercept dropped. + B <- matrix( + unname(list_c(map(coeffGlmnet, .rrDropIntercept))), + nrow = p, + ncol = r + ) # Make predictions if requested. if (!is.null(Xnew)) { - YhatGlmnet <- drop(predict(cvfitGlmnet, newx = Xnew, s = "lambda.min")) - colnames(YhatGlmnet) <- conditionNames + YhatGlmnet <- `colnames<-`( + drop(predict(cvfitGlmnet, newx = Xnew, s = "lambda.min")), + conditionNames + ) res <- list(Bhat = B, Ytrain = Y, Yhat_new = YhatGlmnet) } else { res <- list(Bhat = B, Ytrain = Y) @@ -2828,7 +3437,7 @@ computeCoefficientsGlasso <- function( # Fit a cv.glmnet for outcome column `i` on its non-missing rows and return the # lambda.min coefficients (plus predictions on `Xnew` when supplied). # @noRd -.linreg <- function(i, X, Y, alpha, standardize, nthreads, Xnew) { +.linreg <- function(i, X, Y, alpha, standardize, Xnew) { samplesKept <- which(!is.na(Y[, i])) Ynomiss <- Y[samplesKept, i, drop = FALSE] Xnomiss <- X[samplesKept, , drop = FALSE] @@ -2865,27 +3474,25 @@ computeCoefficientsUnivGlmnet <- function( Y, alpha, standardize, - nthreads, Xnew = NULL ) { r <- ncol(Y) - out <- map(seq_len(r), .linreg, X, Y, alpha, standardize, nthreads, Xnew) + out <- map(seq_len(r), .linreg, X, Y, alpha, standardize, Xnew) bhatList <- map(out, "bhat") Bhat <- exec(cbind, !!!bhatList) if (!is.null(Xnew)) { yhatList <- map(out, "yhat_new") - YhatNew <- exec(cbind, !!!yhatList) - colnames(YhatNew) <- colnames(Y) + YhatNew <- `colnames<-`(exec(cbind, !!!yhatList), colnames(Y)) results <- list( - Bhat = Bhat[-1, ], + Bhat = Bhat[-1, , drop = FALSE], intercept = Bhat[1, ], Yhat_new = YhatNew ) } else { - results <- list(Bhat = Bhat[-1, ], intercept = Bhat[1, ]) + results <- list(Bhat = Bhat[-1, , drop = FALSE], intercept = Bhat[1, ]) } return(results) } @@ -2895,20 +3502,17 @@ computeCoefficientsUnivGlmnet <- function( computeW0 <- function(Bhat, ncomps) { propNonzero <- sum(rowSums(abs(Bhat)) > 0) / nrow(Bhat) - if (ncomps > 1) { - w0 <- c( - (1 - propNonzero), - rep(propNonzero / (ncomps - 1), (ncomps - 1)) - ) + fromData <- if (ncomps > 1) { + c((1 - propNonzero), rep(propNonzero / (ncomps - 1), (ncomps - 1))) } else { - w0 <- 1 + 1 } - - if (sum(w0 != 0) < 2) { - w0 <- rep(1 / ncomps, ncomps) + # Fewer than two non-zero components leaves nothing to mix: fall back to + # a flat prior over all of them. + if (sum(fromData != 0) < 2) { + return(rep(1 / ncomps, ncomps)) } - - return(w0) + fromData } @@ -2920,133 +3524,55 @@ computeW0 <- function(Bhat, ncomps) { #' @keywords internal rescaleCovW0 <- function(w0) { # remove null component - w0 <- w0[names(w0) != "null"] + nonNull <- w0[names(w0) != "null"] # split by prior group - groups <- str_remove(names(w0), "_[^_]+$") - groupList <- split(w0, groups) - - # get per group sum - groupWeight <- map(groupList, sum) - - # Renormalize values within each group - weightsList <- unlist(groupWeight) - sumWeights <- sum(weightsList) - if (sumWeights > 0) { - weightsList <- weightsList / sumWeights + groups <- str_remove(names(nonNull), "_[^_]+$") + groupList <- split(nonNull, groups) + + # get per group sum -- one scalar per group + groupSums <- map_dbl(groupList, sum) + sumWeights <- sum(groupSums) + weightsList <- if (sumWeights > 0) { + groupSums / sumWeights } else { # Use equal weights if all non null weights are zeros - weightsList <- set_names( - rep(1 / length(weightsList), length(weightsList)), - names(weightsList) + set_names( + rep(1 / length(groupSums), length(groupSums)), + names(groupSums) ) } - # vector to store updated group w0 - updatedW0 <- rep(NA, length(unique(groups))) - names(updatedW0) <- unique(groups) - - # replace with updated values - updatedW0[names(weightsList)] <- weightsList - return(updatedW0) + # One w0 slot per group, filled from the supplied weights. + groupKeys <- unique(groups) + replace( + set_names(rep(NA, length(groupKeys)), groupKeys), + names(weightsList), + weightsList + ) } -### Function to compute grids +# The prior scaling grid, from mr.mash's own exported grid builder rather +# than a copy of it. The three helpers this replaces -- gridMin, gridMax, +# autoselectMixsd -- were ports, and the first had DRIFTED: upstream +# grid_min() is `min(Shat)/10`, the port was `min(Shat)`. Every grid built +# here therefore started ten times too high and, since the point count is +# ceiling(log2(gmax/gmin)/log2(mult)), carried fewer points than mr.mash +# would have used. +# +# `mult = sqrt(2)` (finer than upstream's default 2) and the square are +# pecotmr's own choices: this grid scales variances, not standard +# deviations. autoselect.mixsd() drops Shat that is zero or non-finite, +# which covers NA, so the port's extra is.na() term was redundant. +# @noRd computeGrid <- function(bhat, sbhat) { - gridMins <- c() - gridMaxs <- c() - - include <- !(sbhat == 0 | !is.finite(sbhat) | is.na(sbhat) | is.na(bhat)) - gmax <- gridMax(bhat[include], sbhat[include]) - gmin <- gridMin(bhat[include], sbhat[include]) - gridMins <- c(gridMins, gmin) - gridMaxs <- c(gridMaxs, gmax) - - gminTot <- min(gridMins) - gmaxTot <- max(gridMaxs) - grid <- autoselectMixsd(gminTot, gmaxTot, mult = sqrt(2))^2 - - return(grid) -} - - -### Compute the minimum value for the grid -gridMin <- function(bhat, sbhat) { - min(sbhat) -} - - -### Compute the maximum value for the grid -gridMax <- function(bhat, sbhat) { - if (all(bhat^2 <= sbhat^2)) { - # the unusual case where we don't need much grid - 8 * gridMin(bhat, sbhat) - } else { - 2 * sqrt(max(bhat^2 - sbhat^2)) - } -} - - -### Function to compute the grid -autoselectMixsd <- function(gmin, gmax, mult = 2) { - if (mult == 0) { - return(c(0, gmax / 2)) - } else { - npoint <- ceiling(log2(gmax / gmin) / log2(mult)) - return(mult^((-npoint):0) * gmax) - } + mr.mashr::autoselect.mixsd( + list(Bhat = bhat, Shat = sbhat), + mult = sqrt(2) + )^2 } -#' Compute covariance matrix using FLASH -#' -#' Estimates a covariance matrix from a data matrix Y using empirical Bayes -#' matrix factorization (\code{flashier::flash}). When the FLASH fit finds no -#' shared factors, the returned covariance is diagonal with entries -#' \code{residuals_sd^2}; otherwise the factor contribution is added. FLASH -#' errors are not caught; callers should handle them explicitly or supply a -#' pre-computed prior covariance instead. -#' -#' @param Y Numeric matrix (samples x conditions). -#' @return A covariance matrix of dimension ncol(Y) x ncol(Y), rescaled by the -#' column standard deviations of Y. -#' @importFrom stats cov2cor -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' Y <- matrix(rnorm(nrow(X) * 3), nrow(X), 3) -#' computeCovFlash(Y = Y) -#' @export -computeCovFlash <- function(Y) { - # flashier >= 1.0 API: var_type / ebnm_fn / verbose (renamed from var.type - # / prior.family / verbose.lvl). Prior families now come from `ebnm`. - fl <- flashier::flash( - Y, - var_type = 2, - ebnm_fn = c(ebnm::ebnm_normal, ebnm::ebnm_normal_scale_mixture), - backfit = TRUE, - verbose = 0 - ) - if (fl$n_factors == 0) { - covar <- diag(fl$residuals_sd^2) - } else { - # For each factor's right-side prior, marginal variance for a - # mean-zero scale-mixture-of-normals is sum(pi * sd^2). - fsd <- map_dbl(fl$F_ghat, .flashFactorSd) - covar <- diag(fl$residuals_sd^2) + crossprod(t(fl$F_pm) * fsd) - } - if (nrow(covar) == 0) { - abort("computeCovFlash: FLASH produced an empty covariance matrix.") - } - s <- apply(Y, 2, sd, na.rm = TRUE) - if (length(s) > 1) { - s <- diag(s) - } else { - s <- matrix(s, 1, 1) - } - s %*% cov2cor(covar) %*% s -} - #' Compute diagonal covariance matrix #' #' Returns a diagonal covariance matrix from the column-wise variances of Y. @@ -3063,6 +3589,146 @@ computeCovDiag <- function(Y) { diag(apply(Y, 2, var, na.rm = TRUE)) } +# Split a flat mr.mash argument bag into the prior-construction names and +# everything else. mrmashWrapper takes the former as a `prior` record, so a +# caller who spells them flat -- as the pipeline's per-token kwargs do -- is +# routed rather than rejected. +# @noRd +.mrmashSplitPriorArgs <- function(args) { + priorNames <- names(formals(MrmashPriorParam)) + isPrior <- is_in(names(args), priorNames) + list(prior = args[isPrior], rest = args[!isPrior]) +} + +#' @title Arguments For mr.mashr's Canonical-Covariance Builder +#' @description Arguments for \code{mr.mashr::compute_canonical_covs()}, the +#' function that builds the canonical prior mixture. \code{r} (the number +#' of conditions) is pecotmr's to supply, so it is refused here; every +#' other name is checked against that function's live formals. +#' +#' No defaults: pecotmr used to carry \code{singletons = TRUE} and +#' \code{hetgrid = c(0, 0.25, 0.5, 0.75, 1)}, which are character for +#' character the engine's own defaults. Transcribing them bought nothing +#' and would silently go stale if mr.mashr changed them. +#' @param ... Arguments for \code{mr.mashr::compute_canonical_covs()}, such +#' as \code{singletons} and \code{hetgrid}. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' MrmashCanonicalCovsOptions(singletons = FALSE) +#' @export +MrmashCanonicalCovsOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c(r = "the condition count, taken from the data"), + "MrmashCanonicalCovsOptions" + ) + .newMethodOptions( + "mr.mashr::compute_canonical_covs", + defaults = list(), + extra = extra, + label = "MrmashCanonicalCovsOptions", + engine = "mrmashCanonicalCovs" + ) +} + +#' @title Arguments For mr.mashr's Covariance Expansion +#' @description Arguments for \code{mr.mashr::expand_covs()}, which expands +#' the prior covariances over the scaling grid. The covariance list and the +#' grid are both pecotmr's to supply, so they are refused here; every other +#' name is checked against that function's live formals. +#' @param ... Arguments for \code{mr.mashr::expand_covs()}, such as +#' \code{zeromat}. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' MrmashExpandCovsOptions(zeromat = FALSE) +#' @export +MrmashExpandCovsOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + mats = "the covariances assembled from the canonical and ", + grid = "`priorGrid` on MrmashPriorParam()" + ), + "MrmashExpandCovsOptions" + ) + .newMethodOptions( + "mr.mashr::expand_covs", + defaults = list(), + extra = extra, + label = "MrmashExpandCovsOptions", + engine = "mrmashExpandCovs" + ) +} + +#' @rdname MrmashPriorParam +#' @aliases MrmashPriorParam-class +#' @exportClass MrmashPriorParam +setClass( + "MrmashPriorParam", + contains = "MethodParam", + slots = c( + canonicalPriorMatrices = "logical", + priorGrid = "numeric_OR_NULL", + canonicalCovs = "MethodOptions", + expandCovs = "MethodOptions" + ) +) + +#' @title Prior-Covariance Arguments For mr.mash +#' @description Settings for \code{\link{buildMrmashPriorMatrices}}, the +#' shared prior-covariance builder behind \code{\link{mrmashWrapper}} and +#' \code{\link{mrmashRssWeights}}. +#' +#' The builder reaches two mr.mashr functions, so the arguments bound for +#' each travel in their own nested bundle --- \code{canonicalCovs} for +#' \code{compute_canonical_covs()} and \code{expandCovs} for +#' \code{expand_covs()} --- and each is checked against that function's +#' live formals. The two fields pecotmr itself reads stay flat. +#' +#' \code{dataDrivenPriorMatrices} is \emph{not} set here: it is an input +#' computed upstream (typically by \code{\link{mashPriorCovariances}}), +#' not a tuning choice, so it stays a parameter of the caller. +#' @param canonicalPriorMatrices Logical. Include the canonical mixture from +#' \code{mr.mashr::compute_canonical_covs()}. Default \code{FALSE}. +#' @param priorGrid Optional pre-computed scaling grid (numeric vector). +#' \code{NULL} (default) derives one from the summary statistics via +#' \code{computeGrid()}. +#' @param canonicalCovs Arguments for +#' \code{mr.mashr::compute_canonical_covs()}, built with +#' \code{\link{MrmashCanonicalCovsOptions}}. Only consulted when +#' \code{canonicalPriorMatrices} is \code{TRUE}. +#' @param expandCovs Arguments for \code{mr.mashr::expand_covs()}, built +#' with \code{\link{MrmashExpandCovsOptions}}. +#' @return A \code{MrmashPriorParam} object, a \code{\link{MethodParam}}. +#' @examples +#' MrmashPriorParam(canonicalPriorMatrices = TRUE) +#' MrmashPriorParam( +#' canonicalCovs = MrmashCanonicalCovsOptions(singletons = FALSE) +#' ) +#' @export +MrmashPriorParam <- function( + canonicalPriorMatrices = FALSE, + priorGrid = NULL, + canonicalCovs = MrmashCanonicalCovsOptions(), + expandCovs = MrmashExpandCovsOptions() +) { + .assertMethodOptions( + canonicalCovs, + "MrmashCanonicalCovsOptions", + "canonicalCovs" + ) + .assertMethodOptions(expandCovs, "MrmashExpandCovsOptions", "expandCovs") + new( + "MrmashPriorParam", + canonicalPriorMatrices = canonicalPriorMatrices, + priorGrid = priorGrid, + canonicalCovs = canonicalCovs, + expandCovs = expandCovs + ) +} + #' Build mr.mash prior covariance matrices #' #' Shared helper used by both \code{\link{mrmashWrapper}} (individual-level) and @@ -3077,19 +3743,23 @@ computeCovDiag <- function(Y) { #' @param Shat Numeric matrix of standard errors (variants x conditions). #' @param K Number of conditions. When NULL, inferred from \code{ncol(Bhat)}. #' @param dataDrivenPriorMatrices Optional list with element \code{U} (list of -#' raw covariance matrices) computed e.g. by \code{\link{computeCovFlash}} / -#' \code{\link{computeCovDiag}}. +#' raw covariance matrices) computed e.g. by +#' \code{\link{computeCovDiag}}, or by \code{mashr::cov_flash}, which +#' returns such a list directly. #' @param canonicalPriorMatrices Logical. When TRUE (default for RSS), include #' the standard canonical mixture from #' \code{mr.mashr::compute_canonical_covs()}. When FALSE, #' \code{dataDrivenPriorMatrices} must be supplied. #' @param priorGrid Optional pre-computed scaling grid (numeric vector). When #' NULL, derived from \code{Bhat}, \code{Shat} via \code{computeGrid()}. -#' @param hetgrid Heterogeneity grid passed to -#' \code{mr.mashr::compute_canonical_covs()}. Default \code{c(0, 0.25, 0.5, -#' 0.75, 1)}, matching the individual-level wrapper. -#' @param singletons Whether to include single-condition prior components. -#' Default TRUE. +#' @param canonicalCovs Arguments for +#' \code{mr.mashr::compute_canonical_covs()} --- \code{singletons}, +#' \code{hetgrid} --- built with +#' \code{\link{MrmashCanonicalCovsOptions}}. Empty by default, which +#' leaves that function's own defaults in place. +#' @param expandCovs Arguments for \code{mr.mashr::expand_covs()} --- +#' \code{zeromat} --- built with \code{\link{MrmashExpandCovsOptions}}. +#' Empty by default, which leaves that function's own defaults in place. #' @return A list with components \code{S0} (the expanded list of prior #' covariance matrices) and \code{prior_grid} (the scaling grid that was #' used). @@ -3105,12 +3775,18 @@ buildMrmashPriorMatrices <- function( dataDrivenPriorMatrices = NULL, canonicalPriorMatrices = TRUE, priorGrid = NULL, - hetgrid = c(0, 0.25, 0.5, 0.75, 1), - singletons = TRUE + canonicalCovs = MrmashCanonicalCovsOptions(), + expandCovs = MrmashExpandCovsOptions() ) { if (!requireNamespace("mr.mashr", quietly = TRUE)) { abort("Package 'mr.mashr' is required.") } + .assertMethodOptions( + canonicalCovs, + "MrmashCanonicalCovsOptions", + "canonicalCovs" + ) + .assertMethodOptions(expandCovs, "MrmashExpandCovsOptions", "expandCovs") if (is.null(dataDrivenPriorMatrices) && !isTRUE(canonicalPriorMatrices)) { msg <- glue( "Supply dataDrivenPriorMatrices or set ", @@ -3126,10 +3802,10 @@ buildMrmashPriorMatrices <- function( } if (isTRUE(canonicalPriorMatrices)) { - canonical <- mr.mashr::compute_canonical_covs( + canonical <- exec( + mr.mashr::compute_canonical_covs, K, - singletons = singletons, - hetgrid = hetgrid + !!!as.list(canonicalCovs) ) S0_raw <- if (!is.null(dataDrivenPriorMatrices)) { c(canonical, dataDrivenPriorMatrices$U) @@ -3140,7 +3816,12 @@ buildMrmashPriorMatrices <- function( S0_raw <- dataDrivenPriorMatrices$U } - S0 <- mr.mashr::expand_covs(S0_raw, priorGrid, zeromat = TRUE) + S0 <- exec( + mr.mashr::expand_covs, + S0_raw, + priorGrid, + !!!as.list(expandCovs) + ) list(S0 = S0, priorGrid = priorGrid) } @@ -3202,7 +3883,7 @@ buildMrmashPriorMatrices <- function( lambda2 = config$lambda2, maxSwaps = config$maxSwaps ), - config$dotArgs + as.list(config$dotArgs) ) model <- exec(penalizedRss, !!!penArgs) list( @@ -3221,9 +3902,3 @@ buildMrmashPriorMatrices <- function( .rssMinNumeric <- function(v) { min(as.numeric(v)) } - -# The marginal SD sqrt(sum(pi * sd^2)) of one FLASH factor's right prior. -# @noRd -.flashFactorSd <- function(g) { - sqrt(sum(g$pi * g$sd^2)) -} diff --git a/R/relatednessQc.R b/R/relatednessQc.R index 8246e8961..e60664575 100644 --- a/R/relatednessQc.R +++ b/R/relatednessQc.R @@ -1,3 +1,184 @@ +#' @include MethodParam.R +NULL + +#' @rdname RelatednessColumnsParam +#' @aliases RelatednessColumnsParam-class +#' @exportClass RelatednessColumnsParam +setClass( + "RelatednessColumnsParam", + contains = "MethodParam", + slots = c( + iid1 = "character", + iid2 = "character", + fid1 = "character_OR_NULL", + fid2 = "character_OR_NULL", + value = "character" + ) +) + +#' @title Column Names In A Relatedness Table +#' @description Which columns of the \code{relatedness} data frame hold the +#' pair identifiers and the relatedness measure. Built by this constructor +#' rather than passed as a bare list so a misspelled field fails at the call +#' site instead of silently leaving the default in place. +#' @param iid1,iid2 Column names for the first and second individual ID. +#' Defaults \code{"IID1"} and \code{"IID2"}. +#' @param fid1,fid2 Column names for the first and second family ID, or +#' \code{NULL} (default) when the table has none. +#' @param value Column name for the relatedness measure. Default +#' \code{"PI_HAT"}. +#' @return A \code{RelatednessColumnsParam} object, a \code{\link{MethodParam}}. +#' @examples +#' RelatednessColumnsParam(value = "KINSHIP") +#' @export +RelatednessColumnsParam <- function( + iid1 = "IID1", + iid2 = "IID2", + fid1 = NULL, + fid2 = NULL, + value = "PI_HAT" +) { + # No `...`: every field is pecotmr's own, so R's argument matching is the + # check and an unknown name is an "unused argument" error. + new( + "RelatednessColumnsParam", + iid1 = iid1, + iid2 = iid2, + fid1 = fid1, + fid2 = fid2, + value = value + ) +} + +#' @rdname RelatednessPruningParam +#' @aliases RelatednessPruningParam-class +#' @exportClass RelatednessPruningParam +setClass( + "RelatednessPruningParam", + contains = "MethodParam", + slots = c( + maxComponentSize = "numeric", + reduceFraction = "numeric", + maxIterations = "numeric" + ) +) + +#' @title Graph Pre-Pruning Controls For filterRelatedness +#' @description Bounds on the graph-based pre-pruning that runs before +#' plinkQC, and on the iterative cleanup that runs after it. +#' @param maxComponentSize Largest connected component left untouched by +#' pre-pruning. Default \code{20}. +#' @param reduceFraction Fraction of highest-degree nodes removed per +#' pre-pruning iteration. Default \code{0.05}. +#' @param maxIterations Maximum plinkQC iterations used to resolve any +#' remaining related pairs. Default \code{20}. +#' @return A \code{RelatednessPruningParam} object, a \code{\link{MethodParam}}. +#' @examples +#' RelatednessPruningParam(maxComponentSize = 50L) +#' @export +RelatednessPruningParam <- function( + maxComponentSize = 20L, + reduceFraction = 0.05, + maxIterations = 20L +) { + new( + "RelatednessPruningParam", + maxComponentSize = maxComponentSize, + reduceFraction = reduceFraction, + maxIterations = maxIterations + ) +} + +#' @title Additional Arguments For plinkQC::relatednessFilter +#' @description The secondary-criterion settings \code{filterRelatedness} +#' forwards to \code{plinkQC::relatednessFilter}, plus anything else that +#' function accepts. Names are plinkQC's own and \strong{are checked} +#' against \code{plinkQC::relatednessFilter}'s live formals, so the check +#' cannot drift from the upstream signature. See +#' \code{\link{MethodOptions}} for when checking is not possible. +#' +#' The pair identifiers, the relatedness column and the threshold are +#' \emph{not} settable here: \code{filterRelatedness} derives those from +#' its own \code{columns} and \code{relatednessThreshold} arguments, which +#' its graph pre-pruning uses as well, and injects them. +#' @param otherCriterion Optional data frame of additional filtering criteria. +#' @param otherCriterionTh Threshold for the additional criterion. +#' @param otherCriterionThDirection Direction of the threshold comparison. +#' Default \code{"ge"}. +#' @param otherCriterionIID Column name for the individual ID in +#' \code{otherCriterion}. Default \code{"IID"}. +#' @param otherCriterionMeasure Column name for the criterion measure. +#' @param ... Any other \code{plinkQC::relatednessFilter} argument. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' PlinkQcOptions(otherCriterionThDirection = "le") +#' @export +PlinkQcOptions <- function( + otherCriterion = NULL, + otherCriterionTh = NULL, + otherCriterionThDirection = "ge", + otherCriterionIID = "IID", + otherCriterionMeasure = NULL, + ... +) { + .newMethodOptions( + "plinkQC::relatednessFilter", + defaults = list( + otherCriterion = otherCriterion, + otherCriterionTh = otherCriterionTh, + otherCriterionThDirection = otherCriterionThDirection, + otherCriterionIID = otherCriterionIID, + otherCriterionMeasure = otherCriterionMeasure + ), + extra = list(...), + label = "PlinkQcOptions", + engine = "plinkQC::relatednessFilter" + ) +} + +# Phases 2 and 3 of filterRelatedness: plinkQC-based filtering (which +# depends on the analysis type) followed by iterative cleanup. They share +# the injected plinkQC arguments, which is why they sit together -- the +# pair columns and the threshold are pecotmr's own, since the graph pruning +# in phase 1 reads the same values, so they are injected rather than left +# settable in `plinkQc`. +# @noRd +.relatednessFilterAndClean <- function( + kin, + plinkQcArgs, + relatednessThreshold, + columns, + verbose, + analysisType, + phenoData, + phenoCol, + pruning +) { + pqArgs <- .relatednessBuildPlinkQcArgs( + plinkQcArgs, + relatednessThreshold, + columns, + verbose + ) + filtered <- .relatednessPhase2( + kin, + pqArgs, + analysisType, + phenoData, + phenoCol, + columns + ) + .relatednessIterativeCleanup( + filtered$kin, + filtered$allExclude, + pqArgs, + pruning, + verbose, + columns, + relatednessThreshold + ) +} + #' Filter related individuals from a study #' #' Iterative greedy algorithm that removes related individuals exceeding a @@ -12,95 +193,89 @@ #' @param analysisType One of \code{"maximizeUnrelated"} (default) or #' \code{"maximizeCases"}. The latter preserves cases in case-control #' studies. -#' @param relatednessIid1 Column name for first individual ID (default "IID1"). -#' @param relatednessIid2 Column name for second individual ID (default "IID2"). -#' @param relatednessFid1 Column name for first family ID (default NULL). -#' @param relatednessFid2 Column name for second family ID (default NULL). -#' @param relatednessValue Column name for the relatedness measure (default -#' "PI_HAT"). +#' @param columns Which columns of \code{relatedness} hold the pair +#' identifiers and the relatedness measure. Build with +#' \code{\link{RelatednessColumnsParam}}. #' @param phenoData A data.frame with columns \code{IID} and the column named by #' \code{phenoCol}. Required when \code{analysisType = "maximizeCases"}. #' @param phenoCol Column name for the phenotype (default "pheno"). Expected to #' be binary (1 = case, 0 = control). -#' @param otherCriterion Optional data.frame with additional filtering criteria -#' (passed to \code{plinkQC::relatednessFilter}). -#' @param otherCriterionThreshold Threshold for additional criterion. -#' @param otherCriterionDirection Direction for threshold comparison (default -#' "ge"). -#' @param otherCriterionIid Column name for individual ID in criterion data -#' (default "IID"). -#' @param otherCriterionMeasure Column name for the criterion measure. -#' @param maxComponentSize Maximum component size before graph-based pre-pruning -#' (default 20). -#' @param reduceFraction Fraction of highest-degree nodes to remove per -#' iteration during pre-pruning (default 0.05). -#' @param maxIterations Maximum plinkQC iterations for resolving remaining -#' related pairs (default 20). +#' @param pruning Bounds on the graph pre-pruning and the iterative cleanup. +#' Build with \code{\link{RelatednessPruningParam}}. +#' @param plinkQcArgs Additional arguments forwarded to +#' \code{plinkQC::relatednessFilter}. Build with +#' \code{\link{PlinkQcOptions}}. #' @param verbose Logical, print progress messages (default FALSE). #' @return A character vector of individual IDs to exclude. #' @examples #' rel <- data.frame(IID1 = c("s1", "s2"), IID2 = c("s2", "s3"), #' value = c(0.5, 0.1)) -#' filterRelatedness(rel, relatednessIid1 = "IID1", relatednessIid2 = "IID2", -#' relatednessValue = "value", relatednessThreshold = 0.2) +#' filterRelatedness(rel, relatednessThreshold = 0.2, +#' columns = RelatednessColumnsParam(value = "value")) #' @export filterRelatedness <- function( relatedness, relatednessThreshold = 0.0625, analysisType = c("maximizeUnrelated", "maximizeCases"), - relatednessIid1 = "IID1", - relatednessIid2 = "IID2", - relatednessFid1 = NULL, - relatednessFid2 = NULL, - relatednessValue = "PI_HAT", + columns = RelatednessColumnsParam(), phenoData = NULL, phenoCol = "pheno", - otherCriterion = NULL, - otherCriterionThreshold = NULL, - otherCriterionDirection = "ge", - otherCriterionIid = "IID", - otherCriterionMeasure = NULL, - maxComponentSize = 20L, - reduceFraction = 0.05, - maxIterations = 20L, + pruning = RelatednessPruningParam(), + plinkQcArgs = PlinkQcOptions(), verbose = FALSE ) { .relatednessRequirePackages() + .assertMethodParam(columns, "RelatednessColumnsParam", "columns") + .assertMethodParam(pruning, "RelatednessPruningParam", "pruning") + .assertMethodOptions(plinkQcArgs, "PlinkQcOptions", "plinkQc") analysisType <- arg_match(analysisType) - p <- as.list(environment()) - p$relatedness <- as_tibble(relatedness) + relatedness <- as_tibble(relatedness) if (analysisType == "maximizeCases" && is.null(phenoData)) { abort("Must provide phenoData when analysisType is 'maximizeCases'") } # Phase 1: graph-based pre-pruning of large components. - highRelatedIndiv <- .relatednessPrune(p) - kin <- .relatednessRemovePruned(p$relatedness, highRelatedIndiv, p) - # Phase 2: plinkQC-based filtering (analysis-type dependent). - plinkqcArgs <- .relatednessBuildPlinkqcArgs(p) - filtered <- .relatednessPhase2(kin, plinkqcArgs, analysisType, p) - # Phase 3: iterative cleanup + combine with the graph-pruned individuals. - allExclude <- .relatednessIterativeCleanup( - filtered$kin, - filtered$allExclude, - plinkqcArgs, - p + highRelatedIndiv <- .relatednessPrune( + relatedness, + columns, + relatednessThreshold, + pruning, + verbose + ) + kin <- .relatednessRemovePruned(relatedness, highRelatedIndiv, columns) + cleaned <- .relatednessFilterAndClean( + kin, + plinkQcArgs = plinkQcArgs, + relatednessThreshold = relatednessThreshold, + columns = columns, + verbose = verbose, + analysisType = analysisType, + phenoData = phenoData, + phenoCol = phenoCol, + pruning = pruning ) - allExclude <- unique(c(allExclude, highRelatedIndiv)) - .relatednessReport(allExclude, p) + allExclude <- unique(c(cleaned, highRelatedIndiv)) + .relatednessReport(allExclude, verbose, relatednessThreshold) allExclude } # Phase-2 dispatch: maximizeUnrelated runs plinkQC directly; maximizeCases # preserves cases. Returns list(allExclude, kin). # @noRd -.relatednessPhase2 <- function(kin, plinkqcArgs, analysisType, p) { +.relatednessPhase2 <- function( + kin, + pqArgs, + analysisType, + phenoData, + phenoCol, + columns +) { if (analysisType == "maximizeUnrelated") { return(list( - allExclude = .relatednessRunPlinkqc(kin, plinkqcArgs)$IID, + allExclude = .relatednessRunPlinkQc(kin, pqArgs)$IID, kin = kin )) } - .relatednessMaximizeCases(kin, plinkqcArgs, p) + .relatednessMaximizeCases(kin, pqArgs, phenoData, phenoCol, columns) } # @noRd @@ -113,42 +288,71 @@ filterRelatedness <- function( } } +# Size of the largest component, or 0 when the graph has none. Guards +# max(integer(0)), which warns and returns -Inf -- with no related pairs the +# loop below must simply not run. +# @noRd +.relatednessLargestComponent <- function(workingComp) { + if (length(workingComp$csize) == 0L) 0L else max(workingComp$csize) +} + # Graph pre-pruning: iteratively remove the highest-degree nodes of any # component larger than maxComponentSize. Returns the pruned individuals. # @noRd -.relatednessPrune <- function(p) { +.relatednessPrune <- function( + relatedness, + columns, + relatednessThreshold, + pruning, + verbose +) { relatedPairs <- filter( - p$relatedness, - .data[[p$relatednessValue]] >= p$relatednessThreshold + relatedness, + .data[[columns$value]] >= relatednessThreshold ) edges <- select( relatedPairs, - all_of(c(p$relatednessIid1, p$relatednessIid2)) + all_of(c(columns$iid1, columns$iid2)) ) # igraph requires a base data.frame (it sets row names on the input). workingGraph <- igraph::graph_from_data_frame( as.data.frame(edges), directed = FALSE ) - workingComp <- igraph::components(workingGraph) - highRelatedIndiv <- character(0) - while (max(workingComp$csize) > p$maxComponentSize) { - .relatednessPruneMessage(workingComp, p) - nodesToRemove <- .relatednessNodesToRemove(workingGraph, workingComp, p) - highRelatedIndiv <- c(highRelatedIndiv, nodesToRemove) - workingGraph <- igraph::delete_vertices(workingGraph, nodesToRemove) - workingComp <- igraph::components(workingGraph) + .relatednessPruneStep( + workingGraph, + character(0), + pruning, + verbose + ) +} + +# One pruning round: stop once the largest component fits, otherwise drop the +# chosen nodes and recurse on the smaller graph. Each round removes a +# fraction of the largest component, so the recursion is shallow. +# @noRd +.relatednessPruneStep <- function(graph, removed, pruning, verbose) { + comp <- igraph::components(graph) + if (.relatednessLargestComponent(comp) <= pruning$maxComponentSize) { + return(removed) } - highRelatedIndiv + .relatednessPruneMessage(comp, verbose, pruning) + nodesToRemove <- .relatednessNodesToRemove(graph, comp, pruning) + .relatednessPruneStep( + igraph::delete_vertices(graph, nodesToRemove), + c(removed, nodesToRemove), + pruning, + verbose + ) } # @noRd -.relatednessPruneMessage <- function(workingComp, p) { - if (p$verbose) { +.relatednessPruneMessage <- function(workingComp, verbose, pruning) { + if (verbose) { + pct <- round(pruning$reduceFraction * 100) msg <- glue( "Largest component has {max(workingComp$csize)} individuals. ", - "Removing top {round(p$reduceFraction * 100)}% ", - "highest-degree nodes." + "Removing top {pct}% highest-degree nodes." ) inform(msg) } @@ -157,14 +361,14 @@ filterRelatedness <- function( # The highest-degree nodes to remove across all over-sized components. # @noRd -.relatednessNodesToRemove <- function(workingGraph, workingComp, p) { - largeCompIds <- which(workingComp$csize > p$maxComponentSize) - unlist(map( +.relatednessNodesToRemove <- function(workingGraph, workingComp, pruning) { + largeCompIds <- which(workingComp$csize > pruning$maxComponentSize) + list_c(map( largeCompIds, .relatednessCompNodesToRemove, workingGraph = workingGraph, membership = workingComp$membership, - reduceFraction = p$reduceFraction + pruning = pruning )) } @@ -173,87 +377,110 @@ filterRelatedness <- function( compId, workingGraph, membership, - reduceFraction + pruning ) { compNodes <- igraph::V(workingGraph)[membership == compId] compDegrees <- igraph::degree(workingGraph, v = compNodes) - numToRemove <- ceiling(length(compNodes) * reduceFraction) + numToRemove <- ceiling(length(compNodes) * pruning$reduceFraction) names(sort(compDegrees, decreasing = TRUE))[seq_len(numToRemove)] } # Drop the pre-pruned individuals from the relatedness data. # @noRd -.relatednessRemovePruned <- function(relatedness, highRelatedIndiv, p) { +.relatednessRemovePruned <- function(relatedness, highRelatedIndiv, columns) { filter( relatedness, - !is_in(.data[[p$relatednessIid1]], highRelatedIndiv) & - !is_in(.data[[p$relatednessIid2]], highRelatedIndiv) + !is_in(.data[[columns$iid1]], highRelatedIndiv) & + !is_in(.data[[columns$iid2]], highRelatedIndiv) ) } # @noRd -.relatednessBuildPlinkqcArgs <- function(p) { - list( - otherCriterion = p$otherCriterion, - relatednessTh = p$relatednessThreshold, - relatednessIID1 = p$relatednessIid1, - relatednessIID2 = p$relatednessIid2, - otherCriterionTh = p$otherCriterionThreshold, - otherCriterionThDirection = p$otherCriterionDirection, - relatednessFID1 = p$relatednessFid1, - relatednessFID2 = p$relatednessFid2, - relatednessRelatedness = p$relatednessValue, - otherCriterionIID = p$otherCriterionIid, - otherCriterionMeasure = p$otherCriterionMeasure, - verbose = p$verbose +.relatednessBuildPlinkQcArgs <- function( + plinkQcArgs, + relatednessThreshold, + columns, + verbose +) { + # pecotmr's own settings translated into plinkQC's spelling, then the + # user's own plinkQC arguments on top. The user cannot reach the derived + # names: PlinkQcOptions() would have rejected a duplicate anyway, and these + # must agree with what the graph pruning used. + derived <- list( + relatednessTh = relatednessThreshold, + relatednessIID1 = columns$iid1, + relatednessIID2 = columns$iid2, + relatednessFID1 = columns$fid1, + relatednessFID2 = columns$fid2, + relatednessRelatedness = columns$value, + verbose = verbose + ) + user <- as.list(plinkQcArgs) + clash <- intersect(names(user), names(derived)) + if (length(clash) > 0L) { + # Without this the duplicate surfaces as R's bare "matched by multiple + # actual arguments" from inside exec(), which says nothing about where + # the other value came from. + abort(glue( + "filterRelatedness: {str_flatten(clash, ', ')} ", + "{if (length(clash) == 1L) 'is' else 'are'} derived from ", + "`relatednessThreshold` and `columns`, which the graph pruning ", + "reads as well, so {if (length(clash) == 1L) 'it' else 'they'} ", + "cannot also be set in `plinkQc`." + )) + } + c(derived, user) +} + +# The kinship pairs whose BOTH members are in `ids` -- the repeated +# "restrict the relatedness graph to this set" step. +# @noRd +.relatednessKinWithin <- function(kin, ids, columns) { + filter( + kin, + is_in(.data[[columns$iid1]], ids) & + is_in(.data[[columns$iid2]], ids) ) } # maximizeCases: preserve cases, preferentially remove controls. Returns # list(allExclude, kin) (kin is restricted to phenotyped individuals). # @noRd -.relatednessMaximizeCases <- function(kin, plinkqcArgs, p) { - phenoData <- as_tibble(p$phenoData) - phenoData <- filter(phenoData, !is.na(.data[[p$phenoCol]])) - relatedIndividuals <- unique(c( - kin[[p$relatednessIid1]], - kin[[p$relatednessIid2]] - )) - phenoData <- filter(phenoData, is_in(.data$IID, relatedIndividuals)) - relatedCases <- phenoData |> - filter(.data[[p$phenoCol]] == 1) |> +.relatednessMaximizeCases <- function( + kin, + pqArgs, + phenoData, + phenoCol, + columns +) { + iid1Col <- columns$iid1 + iid2Col <- columns$iid2 + relatedIndividuals <- unique(c(kin[[iid1Col]], kin[[iid2Col]])) + related <- as_tibble(phenoData) |> + filter(!is.na(.data[[phenoCol]])) |> + filter(is_in(.data$IID, relatedIndividuals)) + relatedCases <- related |> + filter(.data[[phenoCol]] == 1) |> pull("IID") - relatedControls <- phenoData |> - filter(.data[[p$phenoCol]] == 0) |> + relatedControls <- related |> + filter(.data[[phenoCol]] == 0) |> pull("IID") - kin <- filter( - kin, - is_in(.data[[p$relatednessIid1]], phenoData$IID) & - is_in(.data[[p$relatednessIid2]], phenoData$IID) - ) + kin <- .relatednessKinWithin(kin, related$IID, columns) # Step 1: filter among cases. - caseKin <- filter( - kin, - is_in(.data[[p$relatednessIid1]], relatedCases) & - is_in(.data[[p$relatednessIid2]], relatedCases) - ) - relCases <- .relatednessRunPlinkqc(caseKin, plinkqcArgs) + caseKin <- .relatednessKinWithin(kin, relatedCases, columns) + relCases <- .relatednessRunPlinkQc(caseKin, pqArgs) casesKeep <- setdiff(relatedCases, relCases$IID) # Step 2: remove controls related to retained cases. controlsExclude <- .relatednessControlsToExclude( kin, casesKeep, relatedControls, - p + columns ) # Step 3: filter among the remaining controls. controlsKeep <- setdiff(relatedControls, controlsExclude) - controlKin <- filter( - kin, - is_in(.data[[p$relatednessIid1]], controlsKeep) & - is_in(.data[[p$relatednessIid2]], controlsKeep) - ) - relControls <- .relatednessRunPlinkqc(controlKin, plinkqcArgs) + controlKin <- .relatednessKinWithin(kin, controlsKeep, columns) + relControls <- .relatednessRunPlinkQc(controlKin, pqArgs) list( allExclude = c(relCases$IID, controlsExclude, relControls$IID), kin = kin @@ -263,9 +490,14 @@ filterRelatedness <- function( # Controls related to a retained case (row order preserved; a case--control # edge excludes the control, mirroring the original per-row if / else-if). # @noRd -.relatednessControlsToExclude <- function(kin, casesKeep, relatedControls, p) { - iid1 <- kin[[p$relatednessIid1]] - iid2 <- kin[[p$relatednessIid2]] +.relatednessControlsToExclude <- function( + kin, + casesKeep, + relatedControls, + columns +) { + iid1 <- kin[[columns$iid1]] + iid2 <- kin[[columns$iid2]] mask1 <- is_in(iid1, casesKeep) & is_in(iid2, relatedControls) mask2 <- is_in(iid2, casesKeep) & is_in(iid1, relatedControls) contrib <- case_when( @@ -279,49 +511,101 @@ filterRelatedness <- function( # Iteratively re-run plinkQC on the still-related pairs until none remain or # maxIterations is hit. Returns the accumulated exclusion set. # @noRd -.relatednessIterativeCleanup <- function(kin, allExclude, plinkqcArgs, p) { - remaining <- .relatednessRemaining(kin, allExclude, p) - iter <- 0L - while (nrow(remaining) > 0 && iter < p$maxIterations) { - if (p$verbose) { - msg <- glue( - "Iteration {iter + 1L}: {nrow(remaining)} related pairs ", - "remaining." - ) - inform(msg) - } - additional <- .relatednessRunPlinkqc(remaining, plinkqcArgs) - allExclude <- c(allExclude, additional$IID) - remaining <- .relatednessRemaining(kin, allExclude, p) - iter <- iter + 1L - } - if (nrow(remaining) > 0) { +.relatednessIterativeCleanup <- function( + kin, + allExclude, + pqArgs, + pruning, + verbose, + columns, + relatednessThreshold +) { + final <- .relatednessCleanupStep( + kin = kin, + allExclude = allExclude, + iter = 0L, + pruning = pruning, + pqArgs = pqArgs, + columns = columns, + relatednessThreshold = relatednessThreshold, + verbose = verbose + ) + if (nrow(final$remaining) > 0) { + iters <- pruning$maxIterations msg <- glue( - "After {p$maxIterations} iterations, {nrow(remaining)} related ", - "pairs remain." + "After {iters} iterations, {nrow(final$remaining)} ", + "related pairs remain." ) warn(msg) } - allExclude + final$allExclude +} + +# One cleanup round: re-run plinkQC on whatever is still related, add its +# exclusions, and recurse until nothing is related or the iteration cap is +# reached. Returns the accumulated exclusions and what is still related. +# @noRd +.relatednessCleanupStep <- function( + kin, + allExclude, + iter, + pruning, + pqArgs, + columns, + relatednessThreshold, + verbose +) { + remaining <- .relatednessRemaining( + kin, + allExclude, + columns, + relatednessThreshold + ) + if (nrow(remaining) == 0 || iter >= pruning$maxIterations) { + return(list(allExclude = allExclude, remaining = remaining)) + } + if (verbose) { + msg <- glue( + "Iteration {iter + 1L}: {nrow(remaining)} related pairs ", + "remaining." + ) + inform(msg) + } + additional <- .relatednessRunPlinkQc(remaining, pqArgs) + .relatednessCleanupStep( + kin = kin, + allExclude = c(allExclude, additional$IID), + iter = iter + 1L, + pruning = pruning, + pqArgs = pqArgs, + columns = columns, + relatednessThreshold = relatednessThreshold, + verbose = verbose + ) } # The still-related pairs above threshold after excluding `allExclude`. # @noRd -.relatednessRemaining <- function(kin, allExclude, p) { +.relatednessRemaining <- function( + kin, + allExclude, + columns, + relatednessThreshold +) { remaining <- filter( kin, - !is_in(.data[[p$relatednessIid1]], allExclude) & - !is_in(.data[[p$relatednessIid2]], allExclude) + !is_in(.data[[columns$iid1]], allExclude) & + !is_in(.data[[columns$iid2]], allExclude) ) - filter(remaining, .data[[p$relatednessValue]] > p$relatednessThreshold) + filter(remaining, .data[[columns$value]] > relatednessThreshold) } # @noRd -.relatednessReport <- function(allExclude, p) { - if (p$verbose) { +.relatednessReport <- function(allExclude, verbose, relatednessThreshold) { + if (verbose) { msg <- glue( "{length(allExclude)} individuals excluded at kinship ", - "threshold {p$relatednessThreshold}" + "threshold {relatednessThreshold}" ) inform(msg) } @@ -331,8 +615,11 @@ filterRelatedness <- function( # Run plinkQC::relatednessFilter with the pre-bound column names + thresholds # (`args`), returning its $failIDs. # @noRd -.relatednessRunPlinkqc <- function(relDf, args) { +.relatednessRunPlinkQc <- function(relDf, args) { + # Engine-call exception: plinkQC::relatednessFilter is the external tool + # this module exists to drive. relatednessQc.R is a topical module rather + # than a pipeline, and nothing else calls it. # plinkQC requires a base data.frame (it sets row names on the input). - rfArgs <- c(list(relatedness = as.data.frame(relDf)), args) + rfArgs <- c(list(relatedness = as.data.frame(relDf)), as.list(args)) exec(plinkQC::relatednessFilter, !!!rfArgs)$failIDs } diff --git a/R/sldscPostprocessingPipeline.R b/R/sldscPostprocessingPipeline.R index 1b6cf5730..1653147bc 100644 --- a/R/sldscPostprocessingPipeline.R +++ b/R/sldscPostprocessingPipeline.R @@ -123,18 +123,18 @@ sldscPostprocessingPipeline <- function( .sldscComputeRefStats <- function(sldscData, mafCutoff) { inform("[sldsc] Computing M_ref...") MRef <- computeSldscMRef(sldscData, mafCutoff = mafCutoff) - msg <- glue("[sldsc] M_ref = {MRef} (MAF cutoff {mafCutoff})") - inform(msg) + inform(glue("[sldsc] M_ref = {MRef} (MAF cutoff {mafCutoff})")) inform("[sldsc] Computing per-annotation sd...") sdAnnotFull <- computeSldscAnnotSd(sldscData, mafCutoff = mafCutoff) nSd <- length(sdAnnotFull) - msg <- glue("[sldsc] sd computed for {nSd} annotation columns") - inform(msg) + inform(glue("[sldsc] sd computed for {nSd} annotation columns")) inform("[sldsc] Detecting binary vs continuous annotations...") isBinaryFull <- isBinarySldscAnnot(sldscData) - names(sdAnnotFull) <- str_c(names(sdAnnotFull), "_0") - names(isBinaryFull) <- str_c(names(isBinaryFull), "_0") - list(MRef = MRef, sdAnnotFull = sdAnnotFull, isBinaryFull = isBinaryFull) + list( + MRef = MRef, + sdAnnotFull = .sldscSuffixNames(sdAnnotFull), + isBinaryFull = .sldscSuffixNames(isBinaryFull) + ) } # Resolve the target categories: keep the user's set, else auto-detect from a @@ -176,26 +176,27 @@ sldscPostprocessingPipeline <- function( # first single run. # @noRd .sldscPivotRun <- function(sldscData, trait1) { - pivotRun <- getTraitRun(sldscData, trait1, "joint") - if (is.null(pivotRun)) { - pivotRun <- getTraitRun(sldscData, trait1, "single", 1L) - } + pivotRun <- getTraitRun(sldscData, trait1, "joint") %||% + getTraitRun(sldscData, trait1, "single", 1L) pivotRun } +# polyfun appends "_0" to every annotation name in its .results table, so the +# per-annotation vectors have to carry the same suffix to join against it. +# @noRd +.sldscSuffixNames <- function(x) set_names(x, str_c(names(x), "_0")) + # Positional-rename fallback: trust polyfun's invariant that target categories # occupy the first length(sdAnnotFull) rows of .results. Returns the renamed # list(targetCategories, sdAnnotFull, isBinaryFull). # @noRd .sldscFallbackRename <- function(pivotRun, ref) { - sdAnnotFull <- ref$sdAnnotFull - isBinaryFull <- ref$isBinaryFull - nTarget <- length(sdAnnotFull) + nTarget <- length(ref$sdAnnotFull) nBaseline <- length(pivotRun$categories) - nTarget - oldNames <- names(sdAnnotFull) + oldNames <- names(ref$sdAnnotFull) targetCategories <- pivotRun$categories[seq_len(nTarget)] - names(sdAnnotFull) <- targetCategories - names(isBinaryFull) <- targetCategories + sdAnnotFull <- set_names(ref$sdAnnotFull, targetCategories) + isBinaryFull <- set_names(ref$isBinaryFull, targetCategories) .sldscFallbackMessage( pivotRun, oldNames, @@ -318,10 +319,7 @@ sldscPostprocessingPipeline <- function( # list(singleDf, blocksSingle, singleH2gs). # @noRd .sldscTraitSingle <- function(trait, ctx) { - singleRuns <- getTraitRun(ctx$sldscData, trait, "single") - if (is.null(singleRuns)) { - singleRuns <- list() - } + singleRuns <- getTraitRun(ctx$sldscData, trait, "single") %||% list() nRun <- min(length(ctx$targetCategories), length(singleRuns)) stds <- compact(map( seq_len(nRun), @@ -334,9 +332,10 @@ sldscPostprocessingPipeline <- function( # Standardize the i-th single run (NULL + warning on failure). # @noRd +#' @importFrom rlang try_fetch .sldscStandardizeSingle <- function(i, trait, ctx) { catName <- ctx$targetCategories[i] - std <- tryCatch( + std <- try_fetch( standardizeSldscTrait( ctx$sldscData, trait, @@ -346,13 +345,11 @@ sldscPostprocessingPipeline <- function( MRef = ctx$MRef, targetCategories = catName ), - error = function(e) { - eMsg <- e$message + error = function(cnd) { msg <- glue( - "[sldsc] Failed to standardize single {catName} for ", - "{trait}: {eMsg}" + "[sldsc] Failed to standardize single {catName} for {trait}" ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -401,7 +398,7 @@ sldscPostprocessingPipeline <- function( if (is.null(getTraitRun(ctx$sldscData, trait, "joint"))) { return(empty) } - std <- tryCatch( + std <- try_fetch( standardizeSldscTrait( ctx$sldscData, trait, @@ -410,12 +407,9 @@ sldscPostprocessingPipeline <- function( MRef = ctx$MRef, targetCategories = ctx$targetCategories ), - error = function(e) { - eMsg <- e$message - msg <- glue( - "[sldsc] Failed to standardize joint for {trait}: {eMsg}" - ) - warn(msg) + error = function(cnd) { + msg <- glue("[sldsc] Failed to standardize joint for {trait}") + warn(msg, parent = cnd) NULL } ) @@ -474,23 +468,25 @@ sldscPostprocessingPipeline <- function( # Combine tauStar single + joint into one wide frame (joint aligned by target). # @noRd .sldscCombineTauStar <- function(metaTauStarSingle, metaTauStarJoint) { - metaTauStar <- metaTauStarSingle - ord <- match(metaTauStar$target, metaTauStarJoint$target) - metaTauStar$jointMean <- metaTauStarJoint$jointMean[ord] - metaTauStar$jointSe <- metaTauStarJoint$jointSe[ord] - metaTauStar$jointP <- metaTauStarJoint$jointP[ord] - metaTauStar + ord <- match(metaTauStarSingle$target, metaTauStarJoint$target) + mutate( + metaTauStarSingle, + jointMean = metaTauStarJoint$jointMean[ord], + jointSe = metaTauStarJoint$jointSe[ord], + jointP = metaTauStarJoint$jointP[ord] + ) } # Two-channel enrichment meta: effect/SE from E, p-value from EnrichStat. # @noRd .sldscCombineEnrichment <- function(metaESingle, metaEsSingle) { - metaEnrichment <- metaESingle - metaEnrichment$singleP <- metaEsSingle$singleP[match( - metaEnrichment$target, - metaEsSingle$target - )] - metaEnrichment + mutate( + metaESingle, + singleP = metaEsSingle$singleP[match( + metaESingle$target, + metaEsSingle$target + )] + ) } # Assemble the pipeline result (per_trait + meta + params). @@ -538,44 +534,74 @@ sldscPostprocessingPipeline <- function( abort(msg) } relab <- set_names(targetLabels, targetCategories) - res$per_trait <- .sldscRelabelPerTrait(res$per_trait, relab) - res$meta <- .sldscRelabelMeta(res$meta, relab) - res$params$target_categories_orig <- res$params$target_categories - res$params$target_categories <- unname(relab[targetCategories]) + relabelled <- list_assign( + res, + per_trait = .sldscRelabelPerTrait(res$per_trait, relab), + meta = .sldscRelabelMeta(res$meta, relab), + params = list_assign( + res$params, + target_categories_orig = res$params$target_categories, + target_categories = unname(relab[targetCategories]) + ) + ) .sldscRelabelMessage(targetCategories, relab) - res + relabelled } # @noRd .sldscRelabelPerTrait <- function(perTrait, relab) { - for (t in names(perTrait)) { - perTrait[[t]] <- .sldscRelabelOneTrait(perTrait[[t]], relab) - } - perTrait + map(perTrait, .sldscRelabelOneTrait, relab = relab) } # @noRd .sldscRelabelOneTrait <- function(pt, relab) { - if (!is.null(pt$summary) && is_in("target", names(pt$summary))) { - pt$summary$target <- .sldscRelabVec(pt$summary$target, relab) - } - for (bn in c("tau_star_blocks_single", "tau_star_blocks_joint")) { - b <- pt[[bn]] - if (!is.null(b) && !is.null(colnames(b))) { - colnames(pt[[bn]]) <- .sldscRelabVec(colnames(b), relab) - } + relabelled <- if ( + !is.null(pt$summary) && is_in("target", names(pt$summary)) + ) { + list( + summary = mutate( + pt$summary, + target = .sldscRelabVec(pt$summary$target, relab) + ) + ) + } else { + list() } - pt + blockNames <- keep( + c("tau_star_blocks_single", "tau_star_blocks_joint"), + .sldscBlockHasColnames, + pt = pt + ) + blocks <- set_names( + map(pt[blockNames], .sldscRelabColnames, relab = relab), + blockNames + ) + list_assign(pt, !!!relabelled, !!!blocks) +} + +# @noRd +.sldscBlockHasColnames <- function(bn, pt) { + !is.null(pt[[bn]]) && !is.null(colnames(pt[[bn]])) +} + +# @noRd +.sldscRelabColnames <- function(b, relab) { + `colnames<-`(b, .sldscRelabVec(colnames(b), relab)) } # @noRd .sldscRelabelMeta <- function(meta, relab) { - for (mn in names(meta)) { - if (!is.null(meta[[mn]]) && is_in("target", names(meta[[mn]]))) { - meta[[mn]]$target <- .sldscRelabVec(meta[[mn]]$target, relab) - } + map(meta, .sldscRelabelMetaEntry, relab = relab) +} + +# One meta table with its target column relabelled, or passed through when it +# has no target column to relabel. +# @noRd +.sldscRelabelMetaEntry <- function(entry, relab) { + if (is.null(entry) || !is_in("target", names(entry))) { + return(entry) } - meta + mutate(entry, target = .sldscRelabVec(entry$target, relab)) } # @noRd @@ -597,23 +623,30 @@ sldscPostprocessingPipeline <- function( isBinary, targetCategories ) { - rows <- list() - for (category in targetCategories) { - m <- metaSldscRandom(view, category, quantity) - rows[[category]] <- tibble( - target = category, - isBinary = unname(isBinary[category]), - mean = m$mean, - se = m$se, - p = m$p, - nTraits = m$nTraits - ) - } - df <- bind_rows(rows) + df <- bind_rows(map( + targetCategories, + .sldscCategoryRow, + view = view, + quantity = quantity, + isBinary = isBinary + )) nmOld <- c("mean", "se", "p") nmNew <- str_c(label, str_to_upper(str_sub(nmOld, 1, 1)), str_sub(nmOld, 2)) - names(df)[is_in(names(df), nmOld)] <- nmNew - df + rename(df, !!!set_names(nmOld, nmNew)) +} + +# One category's meta row. +# @noRd +.sldscCategoryRow <- function(category, view, quantity, isBinary) { + m <- metaSldscRandom(view, category, quantity) + tibble( + target = category, + isBinary = unname(isBinary[category]), + mean = m$mean, + se = m$se, + p = m$p, + nTraits = m$nTraits + ) } # Relabel a target-category vector via the `relab` map, leaving unmapped values @@ -621,6 +654,5 @@ sldscPostprocessingPipeline <- function( # @noRd .sldscRelabVec <- function(x, relab) { y <- unname(relab[x]) - y[is.na(y)] <- x[is.na(y)] - y + replace(y, is.na(y), x[is.na(y)]) } diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index 9757b2f9a..130080052 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -29,6 +29,7 @@ } +#' @importFrom checkmate assertFileExists #' @title Read S-LDSC outputs from polyfun for one trait/run #' #' @description Reads the regression outputs produced by `polyfun/ldsc.py` for a @@ -56,12 +57,7 @@ #' @export readSldscTrait <- function(prefix) { files <- str_c(prefix, c(".results", ".log", ".part_delete")) - for (f in files) { - if (!file.exists(f)) { - msg <- glue("readSldscTrait: missing file: {f}") - abort(msg) - } - } + assertFileExists(files, access = "r", .var.name = "readSldscTrait input") results <- vroom(files[1], show_col_types = FALSE) cats <- as.character(results$Category) h2g <- .readSldscH2g(files[2]) @@ -123,11 +119,11 @@ readSldscTrait <- function(prefix) { ) abort(msg) } - colnames(deleteValues) <- cats - deleteValues + `colnames<-`(deleteValues, cats) } +#' @importFrom checkmate assertDirectoryExists #' @title Read target annotation files (.annot.gz) into one table #' #' @description Reads the per-chromosome polyfun `.annot.gz` files in a @@ -148,12 +144,11 @@ readSldscTrait <- function(prefix) { #' readSldscAnnot(sldsc) #' @export readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { - if (!dir.exists(targetAnnoDir)) { - msg <- glue( - "readSldscAnnot: targetAnnoDir does not exist: {targetAnnoDir}" - ) - abort(msg) - } + assertDirectoryExists( + targetAnnoDir, + access = "r", + .var.name = "targetAnnoDir" + ) annoFiles <- list.files( targetAnnoDir, pattern = "\\.annot\\.gz$", @@ -181,6 +176,7 @@ readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { } +#' @importFrom checkmate assertDirectoryExists #' @title Read PLINK allele-frequency files (.frq) into one table #' #' @description Reads the per-chromosome PLINK `.frq` files for the reference @@ -200,22 +196,19 @@ readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { #' head(readSldscFrq(sldsc, plinkName = "reference.")) #' @export readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { - if (!dir.exists(frqfileDir)) { - msg <- glue("readSldscFrq: frqfileDir does not exist: {frqfileDir}") - abort(msg) - } + assertDirectoryExists(frqfileDir, access = "r", .var.name = "frqfileDir") pat <- str_c( "^", str_replace_all(plinkName, "([.])", "\\\\\\1"), "[0-9]+\\.frq$" ) - frqFiles <- list.files(frqfileDir, pattern = pat, full.names = TRUE) - if (length(frqFiles) == 0L) { - frqFiles <- list.files( - frqfileDir, - pattern = "\\.frq$", - full.names = TRUE - ) + # The per-chromosome pattern first; a directory holding a single + # unnumbered .frq falls back to the bare extension. + matched <- list.files(frqfileDir, pattern = pat, full.names = TRUE) + frqFiles <- if (length(matched) > 0L) { + matched + } else { + list.files(frqfileDir, pattern = "\\.frq$", full.names = TRUE) } if (length(frqFiles) == 0L) { msg <- glue("readSldscFrq: no .frq files in: {frqfileDir}") @@ -227,6 +220,7 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { } +#' @importFrom checkmate assertClass #' @title Compute per-annotation standard deviation, MAF-restricted #' #' @description Computes the standard deviation of each annotation column in the @@ -272,9 +266,7 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { #' @importFrom purrr map map_dbl compact reduce #' @export computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { - if (!is(sldscData, "SldscData")) { - abort("computeSldscAnnotSd: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") annot <- getAnnotData(sldscData) frq <- getFrqData(sldscData) if (mafCutoff > 0 && nrow(frq) == 0L) { @@ -329,14 +321,13 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { # the chromosome has <= 1 usable variant after MAF filtering. # @noRd .sldscChromVar <- function(chrom, annot, frq, mafCutoff, colsUse) { - dat <- filter(annot, .data$CHR == chrom) - if (mafCutoff > 0) { - dat <- inner_join( - dat, - select(frq, all_of(c("SNP", "MAF"))), - by = "SNP" - ) - dat <- filter(dat, !is.na(.data$MAF) & .data$MAF > mafCutoff) + onChrom <- filter(annot, .data$CHR == chrom) + dat <- if (mafCutoff > 0) { + onChrom |> + inner_join(select(frq, all_of(c("SNP", "MAF"))), by = "SNP") |> + filter(!is.na(.data$MAF) & .data$MAF > mafCutoff) + } else { + onChrom } if (nrow(dat) <= 1L) { return(NULL) @@ -347,6 +338,7 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { } +#' @importFrom checkmate assertClass #' @title Reference-panel SNP count (the M_ref used to standardise tau*) #' #' @description `M_ref` is the number of SNPs in the REFERENCE PANEL over which @@ -398,9 +390,7 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { #' computeSldscMRef(sldscData = sd) #' @export computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { - if (!is(sldscData, "SldscData")) { - abort("computeSldscMRef: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") frq <- getFrqData(sldscData) if (nrow(frq) > 0L) { return(as.integer( @@ -422,6 +412,7 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { } +#' @importFrom checkmate assertClass #' @title Detect whether each annotation is binary or continuous #' #' @description Inspects each annotation column and returns whether its values @@ -461,9 +452,7 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { #' isBinarySldscAnnot(sd) #' @export isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { - if (!is(sldscData, "SldscData")) { - abort("isBinarySldscAnnot: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") annot <- getAnnotData(sldscData) colsUse <- if (is.null(annotCols)) { getAnnotCols(sldscData) @@ -473,15 +462,18 @@ isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { annotCols } - isBinary <- set_names(rep(TRUE, length(colsUse)), colsUse) - for (col in colsUse) { - vals <- unique(na.omit(as.numeric(annot[[col]]))) - if (any(!is_in(vals, c(0, 1)))) isBinary[[col]] <- FALSE - } - isBinary + set_names(map_lgl(colsUse, .sldscColIsBinary, annot = annot), colsUse) +} + +# An annotation is binary when every non-missing value is 0 or 1. +# @noRd +.sldscColIsBinary <- function(col, annot) { + vals <- unique(na.omit(as.numeric(annot[[col]]))) + all(is_in(vals, c(0, 1))) } +#' @importFrom checkmate assertClass #' @title Standardize tau and compute EnrichStat for one polyfun run #' #' @description Applies the Gazal standardization \eqn{\tau^*_C = \tau_C \cdot @@ -544,9 +536,7 @@ standardizeSldscTrait <- function( MRef, targetCategories = NULL ) { - if (!is(sldscData, "SldscData")) { - abort("standardizeSldscTrait: `sldscData` must be an SldscData object.") - } + assertClass(sldscData, "SldscData") mode <- arg_match(mode) traitData <- .stdTraitRun(sldscData, trait, mode, idx) targetCategories <- .stdTargetCategories( @@ -561,15 +551,11 @@ standardizeSldscTrait <- function( tauSe <- as.numeric(traitData$tauSe[targetCategories]) blocksTarget <- traitData$tauBlocks[, targetIdx, drop = FALSE] ts <- standardizeTauStar(tau, blocksTarget, sdTarget, MRef, h2g) - summaryDf <- .stdSummaryDf(targetCategories, tau, tauSe, ts) - if (mode == "single") { - summaryDf <- .stdEnrichmentCols( - summaryDf, - traitData, - targetCategories, - h2g, - MRef - ) + base <- .stdSummaryDf(targetCategories, tau, tauSe, ts) + summaryDf <- if (mode != "single") { + base + } else { + .stdEnrichmentCols(base, traitData, targetCategories, h2g, MRef) } tauStarBlocks <- sweep(blocksTarget, 2L, sdTarget * MRef / h2g, FUN = "*") list( @@ -664,16 +650,20 @@ standardizeSldscTrait <- function( enrichstat <- (h2g / MRef) * ((pH2 / pM) - (1 - pH2) / (1 - pM)) enrichP <- as.numeric(traitData$enrichmentP[targetCategories]) absZ <- qnorm(1 - enrichP / 2) - enrichstatSe <- abs(enrichstat) / absZ - enrichstatSe[!is.finite(absZ) | absZ <= 0] <- NA_real_ - summaryDf$enrichment <- as.numeric(traitData$enrichment[targetCategories]) - summaryDf$enrichmentSe <- as.numeric( - traitData$enrichmentSe[targetCategories] + # A non-finite or non-positive |Z| carries no scale for the SE. + enrichstatSe <- replace( + abs(enrichstat) / absZ, + !is.finite(absZ) | absZ <= 0, + NA_real_ + ) + mutate( + summaryDf, + enrichment = as.numeric(traitData$enrichment[targetCategories]), + enrichmentSe = as.numeric(traitData$enrichmentSe[targetCategories]), + enrichmentP = enrichP, + enrichstat = enrichstat, + enrichstatSe = enrichstatSe ) - summaryDf$enrichmentP <- enrichP - summaryDf$enrichstat <- enrichstat - summaryDf$enrichstatSe <- enrichstatSe - summaryDf } @@ -723,13 +713,18 @@ standardizeSldscTrait <- function( #' pp <- sldscPostprocessingPipeline(sd) #' metaSldscRandom(pp$per_trait, category = "annot_A_0", #' quantity = "enrichment") +#' @param metaArgs Extra arguments for \code{metafor::rma()}, built with +#' \code{\link{RmaOptions}} -- \code{test = "knha"} in particular, the +#' small-study correction. #' @export metaSldscRandom <- function( perTraitEstimates, category, - quantity = c("tauStar", "enrichment", "enrichstat") + quantity = c("tauStar", "enrichment", "enrichstat"), + metaArgs = RmaOptions() ) { quantity <- arg_match(quantity) + .assertMethodOptions(metaArgs, "RmaOptions", "metaArgs") cols <- .metaColPair(quantity) traitNames <- names(perTraitEstimates) %||% as.character(seq_along(perTraitEstimates)) @@ -747,7 +742,7 @@ metaSldscRandom <- function( if (length(means) < 2L) { return(.metaEmptyResult(length(means), used)) } - meta <- .rmaMeta(means, ses) + meta <- .rmaMeta(means, ses, metaArgs = metaArgs) list( mean = meta$mean, se = meta$se, @@ -817,15 +812,21 @@ metaSldscRandom <- function( "enrichstatSe" ) suffixCap <- str_c(str_to_upper(str_sub(suffix, 1, 1)), str_sub(suffix, 2)) - for (c in colsToAdd) { - newcol <- str_c(c, suffixCap) - if (!is.null(src) && is_in(c, names(src))) { - out[[newcol]] <- src[[c]][match(out$target, src$target)] - } else { - out[[newcol]] <- NA_real_ - } + added <- set_names( + map(colsToAdd, .sldscAlignedCol, out = out, src = src), + str_c(colsToAdd, suffixCap) + ) + mutate(out, !!!added) +} + +# One source column aligned to `out$target`, or an all-NA column when the +# source has nothing to say about it. +# @noRd +.sldscAlignedCol <- function(col, out, src) { + if (is.null(src) || !is_in(col, names(src))) { + return(NA_real_) } - out + src[[col]][match(out$target, src$target)] } # Internal helper: assemble a wide per-trait summary frame with single + joint @@ -848,9 +849,8 @@ metaSldscRandom <- function( isBinary = unname(isBinaryVec[rows]) ) - out <- .sldscAddCols(out, singleDf, "single") - out <- .sldscAddCols(out, jointDf, "joint") - out + .sldscAddCols(out, singleDf, "single") |> + .sldscAddCols(jointDf, "joint") } @@ -1060,11 +1060,18 @@ sldscSubsetMeta <- function( if (!any(avail)) { return(NULL) } - newDf <- tibble(target = df$target) - for (k in seq_along(colsHave)) { - if (avail[k]) newDf[[colsHave[k]]] <- df[[srcCols[k]]] - } - list(summary = newDf) + present <- colsHave[avail] + list( + summary = tibble( + target = df$target, + !!!set_names(map(srcCols[avail], .sldscColumnOf, df = df), present) + ) + ) +} + +# @noRd +.sldscColumnOf <- function(col, df) { + df[[col]] } # The random-effects meta result for one target category of a view. diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 23aafadeb..21ea80686 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -17,6 +17,9 @@ # R/relatednessQc.R, not here. # ============================================================================= +#' @include MethodParam.R +NULL + #' @importFrom GenomicRanges seqnames #' @importFrom S4Vectors mcols NULL @@ -31,10 +34,11 @@ NULL # @noRd .variantsToDf <- function(x) { df <- if (is(x, "GRanges")) { - mc <- as.data.frame(mcols(x)) - mc$chrom <- as.character(seqnames(x)) - mc$pos <- start(x) - as_tibble(mc) + as_tibble(mutate( + as.data.frame(mcols(x)), + chrom = as.character(seqnames(x)), + pos = start(x) + )) } else { as_tibble(x) } @@ -69,7 +73,9 @@ NULL #' v2 <- data.frame(chrom = "1", pos = 2:4, alt = "A", ref = "G") #' mergeVariantInfo(v1, v2, all = TRUE) #' @export +#' @importFrom checkmate assertFlag mergeVariantInfo <- function(variants1, variants2, all = TRUE) { + assertFlag(all) df1 <- .variantsToDf(variants1) df2 <- .variantsToDf(variants2) @@ -80,23 +86,26 @@ mergeVariantInfo <- function(variants1, variants2, all = TRUE) { matchIdx <- match(key2, key1) hasMatch <- !is.na(matchIdx) - flip <- rep(FALSE, nrow(df2)) mi <- matchIdx[hasMatch] - flip[hasMatch] <- df2$alt[hasMatch] == df1$ref[mi] & - df2$ref[hasMatch] == df1$alt[mi] + flip <- replace( + rep(FALSE, nrow(df2)), + hasMatch, + df2$alt[hasMatch] == df1$ref[mi] & df2$ref[hasMatch] == df1$alt[mi] + ) - # Apply flips to df2 + # Apply flips to df2. Both replacements read the ORIGINAL `df2`, so the + # pair swaps rather than each taking the other's already-swapped value. flipRows <- which(hasMatch)[flip[hasMatch]] - if (length(flipRows) > 0) { - tmp <- df2$alt[flipRows] - df2$alt[flipRows] <- df2$ref[flipRows] - df2$ref[flipRows] <- tmp - } + flipped <- mutate( + df2, + alt = replace(.data$alt, flipRows, df2$ref[flipRows]), + ref = replace(.data$ref, flipRows, df2$alt[flipRows]) + ) if (all) { - distinct(bind_rows(df1, df2)) + distinct(bind_rows(df1, flipped)) } else { - df2 + flipped } } @@ -167,34 +176,62 @@ resolveLdInput <- function( ) abort(msg) } - if (!is_in("pos", lc)) { - colnames(sumStat)[which(is_in(lc, "position"))] <- "pos" + withPos <- if (is_in("pos", lc)) { + sumStat + } else { + `colnames<-`( + sumStat, + replace(colnames(sumStat), which(is_in(lc, "position")), "pos") + ) } - if (!is_in("z", lc)) { - colnames(sumStat)[which(is_in(lc, "zscore"))] <- "z" + named <- if (is_in("z", lc)) { + withPos + } else { + `colnames<-`( + withPos, + replace(colnames(withPos), which(is_in(lc, "zscore")), "z") + ) } - arrange(sumStat, .data$pos) + arrange(named, .data$pos) } # Run DENTIST on a single window, unpacking the shared tuning parameters. -.dentistCallSingle <- function(zScore, ldMat, nSample, p) { - dentistSingleWindow( +.dentistCallSingle <- function(zScore, ldMat, nSample, methodArgs) { + # dentistSingleWindow is what DentistParam() is built for -- ldMismatchQc + # splices the same bundle into it -- so the tunables travel as one value + # rather than being named again at every hop down from dentist(). + exec( + dentistSingleWindow, zScore, R = ldMat, nSample = nSample, - pValueThreshold = p$pValueThreshold, - propSVD = p$propSVD, - gcControl = p$gcControl, - nIter = p$nIter, - gPvalueThreshold = p$gPvalueThreshold, - duprThreshold = p$duprThreshold, - ncpus = p$ncpus, - correctChenEtAlBug = p$correctChenEtAlBug, - seed = p$seed + !!!methodArgs ) } # Segment into windows, run DENTIST per window, and merge the results. +# DENTIST on window `k`. +# @noRd +.dentistWindowAt <- function( + k, + sumStat, + ldMat, + nSample, + windowDividedRes, + methodArgs +) { + # windowEndIdx is 1-based exclusive; convert to an inclusive range. + idxRange <- windowDividedRes$windowStartIdx[ + k + ]:(windowDividedRes$windowEndIdx[k] - 1L) + .dentistCallSingle( + sumStat$z[idxRange], + ldMat[idxRange, idxRange], + nSample, + methodArgs + ) +} + .dentistWindows <- function( sumStat, ldMat, @@ -202,7 +239,7 @@ resolveLdInput <- function( windowMode, windowSize, minDim, - p + methodArgs ) { if (windowMode == "distance") { windowDividedRes <- segmentByDist( @@ -213,21 +250,15 @@ resolveLdInput <- function( } else { windowDividedRes <- segmentByCount(sumStat$pos, maxCount = minDim) } - dentistResultByWindow <- list() - for (k in seq_len(nrow(windowDividedRes))) { - # windowEndIdx is 1-based exclusive; convert to an inclusive range. - idxRange <- windowDividedRes$windowStartIdx[ - k - ]:(windowDividedRes$windowEndIdx[k] - 1L) - zScoreK <- sumStat$z[idxRange] - ldMatK <- ldMat[idxRange, idxRange] - dentistResultByWindow[[k]] <- .dentistCallSingle( - zScoreK, - ldMatK, - nSample, - p - ) - } + dentistResultByWindow <- map( + seq_len(nrow(windowDividedRes)), + .dentistWindowAt, + sumStat = sumStat, + ldMat = ldMat, + nSample = nSample, + windowDividedRes = windowDividedRes, + methodArgs = methodArgs + ) mergeWindows(dentistResultByWindow, windowDividedRes) } @@ -256,22 +287,14 @@ resolveLdInput <- function( #' \code{"distance"} (default) creates windows by physical distance using #' \code{segmentByDist} (C++ \code{--wind-dist}), and \code{"count"} creates #' windows by variant count using \code{segmentByCount} (C++ \code{--wind}). -#' @param pValueThreshold The p-value threshold for significance. Default is -#' 5e-8. -#' @param propSVD The proportion of singular value decomposition (SVD) to use. -#' Default is 0.4. -#' @param gcControl Logical indicating whether genomic control should be -#' applied. Default is FALSE. -#' @param nIter The number of iterations for the Dentist algorithm. Default is -#' 10. -#' @param gPvalueThreshold The genomic p-value threshold for significance. -#' Default is 0.05. -#' @param duprThreshold The absolute correlation r value threshold to be -#' considered duplicate. Default is 0.99. -#' @param ncpus The number of CPU cores to use for parallel processing. Default -#' is 1. -#' @param correctChenEtAlBug Logical indicating whether to correct the Chen et -#' al. bug. Default is TRUE. +#' @param methodArgs The DENTIST algorithm settings, built with +#' \code{\link{DentistParam}}: \code{pValueThreshold}, \code{propSVD}, +#' \code{gcControl}, \code{nIter}, \code{gPvalueThreshold}, +#' \code{duprThreshold}, \code{numThreads}, \code{correctChenEtAlBug} +#' and \code{seed}. This is the same record +#' \code{\link{ldMismatchQc}} takes as +#' \code{method = DentistParam(...)}, so a setting means the same thing +#' and carries the same default whichever entry point reaches it. #' @param minDim In distance mode: minimum number of SNPs per block (default #' 2000). In count mode: the number of variants per window (i.e., the window #' size). @@ -279,12 +302,6 @@ resolveLdInput <- function( #' \code{X} is provided. Passed to \code{computeLd}. One of \code{"sample"} #' (default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is #' provided directly. -#' @param seed Integer or \code{NULL}. Random seed for the iterative -#' variant-partitioning RNG. \code{NULL} (default) preserves the original -#' DENTIST hard-coded seeds (\code{10} for the initial partition, -#' \code{20000 + t * 20000} per iteration) for exact fidelity with the -#' reference binary; a provided seed makes the partitioning reproducible under -#' a value of your choosing. #' #' @return A data frame containing the imputed result and detected outliers. #' @@ -348,18 +365,15 @@ dentist <- function( nSample = NULL, windowSize = 2000000, windowMode = c("distance", "count"), - pValueThreshold = 5.0369e-8, - propSVD = 0.4, - gcControl = FALSE, - nIter = 10, - gPvalueThreshold = 0.05, - duprThreshold = 0.99, - ncpus = 1, - correctChenEtAlBug = TRUE, minDim = 2000, ldMethod = "sample", - seed = NULL + methodArgs = DentistParam() ) { + # The tunables arrive as the record rather than as nine formals of their + # own: DentistParam() is already what ldMismatchQc(method =) takes and + # what every helper below is spliced with, and duplicating its defaults + # here left two places to change one number. + .assertMethodParam(methodArgs, "DentistParam", "methodArgs") resolved <- resolveLdInput( R = R, X = X, @@ -371,9 +385,8 @@ dentist <- function( nSample <- resolved$nSample sumStat <- .dentistResolveColumns(sumStat) windowMode <- arg_match(windowMode) - p <- as.list(environment()) if (nrow(sumStat) < minDim) { - return(.dentistCallSingle(sumStat$z, ldMat, nSample, p)) + return(.dentistCallSingle(sumStat$z, ldMat, nSample, methodArgs)) } .dentistWindows( sumStat, @@ -382,7 +395,7 @@ dentist <- function( windowMode, windowSize, minDim, - p + methodArgs ) } @@ -416,23 +429,25 @@ dentist <- function( # Optionally deduplicate near-perfectly-correlated variants before imputation. .dentistDedup <- function(zScore, ldMat, duprThreshold) { - dedupRes <- NULL + if (duprThreshold >= 1.0) { + return(list(zScore = zScore, ldMat = ldMat, dedupRes = NULL)) + } rThreshold <- round(sqrt(duprThreshold) * 1000) / 1000 - if (duprThreshold < 1.0) { - dedupRes <- .findDuplicateVariants(zScore, ldMat, rThreshold) - numDup <- sum(dedupRes$dupBearer != -1) - if (numDup > 0) { - nZ <- length(zScore) - msg <- glue( - "{numDup} duplicated variants out of a total of {nZ} ", - "were found at r threshold of {rThreshold}" - ) - inform(msg) - } - zScore <- dedupRes$filteredZ - ldMat <- dedupRes$filteredLD + dedupRes <- .findDuplicateVariants(zScore, ldMat, rThreshold) + numDup <- sum(dedupRes$dupBearer != -1) + if (numDup > 0) { + nZ <- length(zScore) + msg <- glue( + "{numDup} duplicated variants out of a total of {nZ} ", + "were found at r threshold of {rThreshold}" + ) + inform(msg) } - list(zScore = zScore, ldMat = ldMat, dedupRes = dedupRes) + list( + zScore = dedupRes$filteredZ, + ldMat = dedupRes$filteredLD, + dedupRes = dedupRes + ) } # Run the C++ iterative imputation and snake_case the output. The C++ returns @@ -440,7 +455,7 @@ dentist <- function( # warning here (no warning handler / shared env needed). .dentistRunImpute <- function(ldMat, nSample, zScore, p) { verboseIter <- getOption("pecotmr.dentist.verbose", FALSE) - res <- dentistIterativeImpute( + raw <- dentistIterativeImpute( # cpp11 requires exact integer types for int parameters ldMat, as.integer(nSample), @@ -450,13 +465,13 @@ dentist <- function( p$gcControl, as.integer(p$nIter), p$gPvalueThreshold, - as.integer(p$ncpus), + as.integer(p$numThreads), p$correctChenEtAlBug, verboseIter, if (is.null(p$seed)) NULL else as.integer(p$seed) ) - rsqExceed <- res$rsqExceed - res$rsqExceed <- NULL + rsqExceed <- raw$rsqExceed + res <- list_modify(raw, rsqExceed = zap()) if (length(rsqExceed) > 0) { nExceed <- length(rsqExceed) maxExceed <- max(rsqExceed) @@ -512,7 +527,7 @@ dentist <- function( #' @param nIter Number of iterations. Default is 10. #' @param gPvalueThreshold Grouping p-value threshold. Default is 0.05. #' @param duprThreshold Duplicate r-squared threshold. Default is 0.99. -#' @param ncpus Number of CPU cores. Default is 1. +#' @param numThreads Number of CPU cores. Default is 1. #' @param correctChenEtAlBug Correct the original DENTIST operator! bug. Default #' is TRUE. #' @param ldMethod Character string specifying the LD computation method when @@ -545,7 +560,7 @@ dentistSingleWindow <- function( nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - ncpus = 1, + numThreads = 1, correctChenEtAlBug = TRUE, ldMethod = "sample", seed = NULL @@ -566,15 +581,17 @@ dentistSingleWindow <- function( gcControl = gcControl, nIter = nIter, gPvalueThreshold = gPvalueThreshold, - ncpus = ncpus, + numThreads = numThreads, correctChenEtAlBug = correctChenEtAlBug, seed = seed ) orgZscore <- zScore dedup <- .dentistDedup(zScore, ldMat, duprThreshold) - res <- .dentistRunImpute(dedup$ldMat, nSample, dedup$zScore, p) - if (duprThreshold < 1.0) { - res <- addDupsBackDentist(orgZscore, res, dedup$dedupRes) + imputed <- .dentistRunImpute(dedup$ldMat, nSample, dedup$zScore, p) + res <- if (duprThreshold < 1.0) { + addDupsBackDentist(orgZscore, imputed, dedup$dedupRes) + } else { + imputed } .dentistOutlierStat(res, pValueThreshold) } @@ -611,18 +628,11 @@ dentistSingleWindow <- function( } # Map each variant to its row in the de-duplicated DENTIST output. -.dentistBuildAssignIdx <- function(dupBearer, nrowsDup) { - count <- 1 - assignIdx <- rep(0, nrowsDup) - for (i in seq_along(dupBearer)) { - if (dupBearer[i] == -1) { - assignIdx[i] <- count - count <- count + 1 - } else { - assignIdx[i] <- dupBearer[i] - } - } - assignIdx +.dentistBuildAssignIdx <- function(dupBearer) { + # Non-duplicates take the next free slot, which is just how many + # non-duplicates have been seen so far; duplicates point at their bearer. + isNew <- dupBearer == -1 + if_else(isNew, as.numeric(cumsum(isNew)), as.numeric(dupBearer)) } # Rebuild the full per-variant table, recovering duplicates (sign-flipped). @@ -634,40 +644,33 @@ dentistSingleWindow <- function( iterToCorrect <- dentistOutput$iter_to_correct rsq <- dentistOutput$rsq zDiff <- dentistOutput$z_diff - updatedData <- tibble( - original_z = numeric(nrowsDup), - imputed_z = numeric(nrowsDup), - iter_to_correct = numeric(nrowsDup), - rsq = numeric(nrowsDup), - z_diff = numeric(nrowsDup), - is_duplicate = logical(nrowsDup) - ) - for (i in seq_len(nrowsDup)) { - updatedData$original_z[i] <- zScore[i] - updatedData$iter_to_correct[i] <- iterToCorrect[assignIdx[i]] - updatedData$rsq[i] <- rsq[assignIdx[i]] - if (dupBearer[i] == -1) { - updatedData$imputed_z[i] <- imputedZ[assignIdx[i]] - updatedData$z_diff[i] <- zDiff[assignIdx[i]] - updatedData$is_duplicate[i] <- FALSE - } else { - # Duplicate: sign-flip imputed_z, recompute z_diff from its own - # z-score so z_diff^2 matches the binary stat (DENTIST.h l706). - updatedData$imputed_z[i] <- imputedZ[assignIdx[i]] * sign[i] - denom <- sqrt(max(1 - updatedData$rsq[i], 1e-8)) - updatedData$z_diff[i] <- - (zScore[i] - updatedData$imputed_z[i]) / denom - updatedData$is_duplicate[i] <- TRUE - } - } - updatedData + # Every row is independent of every other, so the whole table is built in + # one shot. Duplicates sign-flip imputed_z and recompute z_diff from their + # own z-score, so z_diff^2 matches the binary stat (DENTIST.h l706). + isDup <- dupBearer != -1 + originalZ <- zScore[seq_len(nrowsDup)] + rsqRow <- rsq[assignIdx] + imputedRow <- imputedZ[assignIdx] * if_else(isDup, sign, 1) + denom <- sqrt(pmax(1 - rsqRow, 1e-8)) + tibble( + original_z = originalZ, + imputed_z = imputedRow, + iter_to_correct = iterToCorrect[assignIdx], + rsq = rsqRow, + z_diff = if_else( + isDup, + (originalZ - imputedRow) / denom, + zDiff[assignIdx] + ), + is_duplicate = isDup + ) } addDupsBackDentist <- function(zScore, dentistOutput, findDupOutput) { dupBearer <- findDupOutput$dupBearer nrowsDup <- length(dupBearer) .dentistValidateDups(zScore, dentistOutput, dupBearer, nrowsDup) - assignIdx <- .dentistBuildAssignIdx(dupBearer, nrowsDup) + assignIdx <- .dentistBuildAssignIdx(dupBearer) .dentistFillDups(zScore, dentistOutput, findDupOutput, assignIdx) } @@ -693,24 +696,16 @@ addDupsBackDentist <- function(zScore, dentistOutput, findDupOutput) { detectGaps <- function(pos, gapThreshold, verbose = FALSE) { n <- length(pos) diffs <- diff(pos) - allGaps <- c(1L) - for (i in seq_along(diffs)) { - if (diffs[i] > gapThreshold) { - allGaps <- c(allGaps, i + 1L) - } - } - allGaps <- c(allGaps, n + 1L) + allGaps <- c(1L, which(diffs > gapThreshold) + 1L, n + 1L) if (verbose && length(allGaps) - 2 > 0) { nGaps <- length(allGaps) - 2 - msg <- glue("No. of gaps found: {nGaps}") - inform(msg) + inform(glue("No. of gaps found: {nGaps}")) for (i in 2:(length(allGaps) - 1)) { gapNo <- i - 1 startPos <- pos[allGaps[i] - 1] endPos <- pos[allGaps[i]] - msg <- glue(" Gap {gapNo}: {startPos} - {endPos}", .trim = FALSE) - inform(msg) + inform(glue(" Gap {gapNo}: {startPos} - {endPos}", .trim = FALSE)) } } allGaps @@ -856,17 +851,28 @@ buildSegmentResult <- function( ) } +# One field across a block's window records, typed as `c()` would have left +# it (empty when the block produced no window). +# @noRd +.swlField <- function(windows, field) { + if (length(windows) == 0L) { + return(integer(0)) + } + list_c(map(windows, field)) +} + +# The loop itself stays: where the next window starts depends on the window +# just emitted, and the block ends when the stepper says so. What is gone is +# the four parallel `c()` accumulators -- each window is one record now, and +# the vectors are read off at the end. .swlBlockWindows <- function(blockStart, blockEnd, fns, ctx) { startIdx <- blockStart endIdx <- fns$initEndFn(startIdx, blockEnd, ctx) oldStartIdx <- startIdx notStartInterval <- FALSE - notLastInterval <- TRUE - times <- 0 - starts <- ends <- fillStarts <- fillEnds <- integer(0) + windows <- list() repeat { - times <- times + 1 - if (times > 400) { + if (length(windows) >= 400) { abort("Windowing iteration limit exceeded") } win <- .swlWindow( @@ -878,26 +884,51 @@ buildSegmentResult <- function( fns, ctx ) - startIdx <- win$startIdx - notLastInterval <- win$notLastInterval - starts <- c(starts, startIdx) - ends <- c(ends, min(endIdx, blockEnd)) - fillStarts <- c(fillStarts, win$fills$start) - fillEnds <- c(fillEnds, win$fills$end) - if (!notLastInterval) { + windows[[length(windows) + 1L]] <- list( + start = win$startIdx, + end = min(endIdx, blockEnd), + fillStart = win$fills$start, + fillEnd = win$fills$end + ) + if (!win$notLastInterval) { break } - oldStartIdx <- startIdx - stepped <- fns$stepFn(startIdx, blockEnd, ctx) + oldStartIdx <- win$startIdx + stepped <- fns$stepFn(win$startIdx, blockEnd, ctx) startIdx <- stepped$startIdx endIdx <- stepped$endIdx notStartInterval <- TRUE } list( - starts = starts, - ends = ends, - fillStarts = fillStarts, - fillEnds = fillEnds + starts = .swlField(windows, "start"), + ends = .swlField(windows, "end"), + fillStarts = .swlField(windows, "fillStart"), + fillEnds = .swlField(windows, "fillEnd") + ) +} + +# Is block `k` long enough to window? +# @noRd +.swlBlockQualifies <- function(k, allGaps, minBlockFn, ctx) { + minBlockFn(allGaps[k + 1] - allGaps[k], ctx) +} + +# Block `k`'s windows, with the block's outer fill bounds snapped to the +# block's own edges. `replace()` returns a copy, so nothing is mutated. +# @noRd +.swlBlockAt <- function(k, allGaps, fns, ctx) { + w <- .swlBlockWindows(allGaps[k], allGaps[k + 1], fns, ctx) + # First window's fill starts at the window start; last window's fill ends + # at the window end. + list( + starts = w$starts, + ends = w$ends, + fillStarts = replace(w$fillStarts, 1L, w$starts[1L]), + fillEnds = replace( + w$fillEnds, + length(w$fillEnds), + w$ends[length(w$ends)] + ) ) } @@ -912,10 +943,6 @@ slidingWindowLoop <- function( adjustLastFn = NULL, verbose = FALSE ) { - startList <- integer(0) - endList <- integer(0) - fillStartList <- integer(0) - fillEndList <- integer(0) fns <- list( minBlockFn = minBlockFn, initEndFn = initEndFn, @@ -923,27 +950,25 @@ slidingWindowLoop <- function( stepFn = stepFn, adjustLastFn = adjustLastFn ) - for (k in seq_len(length(allGaps) - 1)) { - blockStart <- allGaps[k] - blockEnd <- allGaps[k + 1] - if (!minBlockFn(blockEnd - blockStart, ctx)) { - next - } - w <- .swlBlockWindows(blockStart, blockEnd, fns, ctx) - # First window's fill starts at the window start; last window's fill - # ends at the window end. - w$fillStarts[1] <- w$starts[1] - w$fillEnds[length(w$fillEnds)] <- w$ends[length(w$ends)] - startList <- c(startList, w$starts) - endList <- c(endList, w$ends) - fillStartList <- c(fillStartList, w$fillStarts) - fillEndList <- c(fillEndList, w$fillEnds) - } + blocks <- keep( + seq_len(length(allGaps) - 1), + .swlBlockQualifies, + allGaps = allGaps, + minBlockFn = minBlockFn, + ctx = ctx + ) + windowed <- map( + blocks, + .swlBlockAt, + allGaps = allGaps, + fns = fns, + ctx = ctx + ) buildSegmentResult( - startList, - endList, - fillStartList, - fillEndList, + .swlField(windowed, "starts"), + .swlField(windowed, "ends"), + .swlField(windowed, "fillStarts"), + .swlField(windowed, "fillEnds"), n, verbose ) @@ -952,11 +977,15 @@ slidingWindowLoop <- function( # Apply the quarter-distance index map `quaterIdx` `n` times to `x` (n = 1..4 # gives the 1st..4th quarter boundary from x). Used by segmentByDist. # @noRd +# One quarter-index hop; the step index is unused, `reduce` just applies it +# `n` times. +# @noRd +.nthQuaterStep <- function(x, step, quaterIdx) { + quaterIdx[x] +} + .nthQuaterIdx <- function(x, n, quaterIdx) { - for (i in seq_len(n)) { - x <- quaterIdx[x] - } - x + reduce(seq_len(n), .nthQuaterStep, quaterIdx = quaterIdx, .init = x) } #' Segment Genomic Region by Distance (Original DENTIST Algorithm) @@ -1001,22 +1030,20 @@ slidingWindowLoop <- function( # --- segmentByDist helpers -------------------------------------------------- # For each SNP, the last SNP index within cutoff/4 distance (clamped to [1, n]). +# For each SNP, the index of the last SNP within a quarter of `cutoff`. +# +# The C++ original walks a second pointer forward, which is the same thing as +# counting how many positions fall strictly below each target -- that is +# `findInterval(..., left.open = TRUE)`, so no pointer has to be carried. +# Verified identical to the pointer walk over 600 random inputs, tied +# positions included. .segByDistQuaterIdx <- function(pos, n, cutoff) { - quaterIdx <- integer(n) - j <- 1 - while (j <= n && pos[j] < cutoff / 4 + as.numeric(pos[1])) { - j <- j + 1 - } - quaterIdx[1] <- max(j - 1, 1L) - for (i in 2:n) { - j <- quaterIdx[i - 1] - while (j <= n && pos[j] < cutoff / 4 + as.numeric(pos[i])) { - j <- j + 1 - } - quaterIdx[i] <- max(j - 1, 1L) - } - quaterIdx <- pmin(quaterIdx, n) - pmax(quaterIdx, 1L) + lastBelow <- findInterval( + as.numeric(pos) + cutoff / 4, + pos, + left.open = TRUE + ) + pmax(pmin(lastBelow, n), 1L) } # Advance the window start by one quarter-step and recompute its end. @@ -1161,28 +1188,32 @@ segmentByCount <- function(pos, maxCount, gapDist = 1e6, verbose = FALSE) { #' within the fillers and combines them into a single data frame. #' #' @noRd +# Window `k`'s rows, indexed globally and trimmed to that window's fill range. +# @noRd +.dentistMergeWindowAt <- function(k, dentistResultByWindow, windowDividedRes) { + imputedK <- dentistResultByWindow[[k]] + offset <- windowDividedRes$windowStartIdx[k] - 1 + imputedK |> + mutate( + index_within_window = seq_len(nrow(imputedK)), + index_global = .data$index_within_window + offset + ) |> + filter( + .data$index_global >= windowDividedRes$fillStartIdx[k] & + .data$index_global < windowDividedRes$fillEndIdx[k] + ) +} + mergeWindows <- function(dentistResultByWindow, windowDividedRes) { if (length(dentistResultByWindow) != nrow(windowDividedRes)) { abort("Different number of windows and imputed results!") } - mergedResults <- c() - for (k in seq_len(nrow(windowDividedRes))) { - imputedK <- dentistResultByWindow[[k]] - imputedK$index_within_window <- seq_len(nrow(imputedK)) - imputedK <- imputedK |> - mutate( - index_global = .data$index_within_window + - windowDividedRes$windowStartIdx[k] - - 1 - ) - extractedResults <- imputedK |> - filter( - .data$index_global >= windowDividedRes$fillStartIdx[k] & - .data$index_global < windowDividedRes$fillEndIdx[k] - ) - mergedResults <- bind_rows(mergedResults, extractedResults) - } - return(mergedResults) + bind_rows(map( + seq_len(nrow(windowDividedRes)), + .dentistMergeWindowAt, + dentistResultByWindow = dentistResultByWindow, + windowDividedRes = windowDividedRes + )) } # ## File-I/O functions (dentist_from_files, read_dentist_sumstat, @@ -1195,14 +1226,6 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { # SLALoM: Approximate Bayes Factor single-causal-variant outlier detection # ============================================================================= -# Numerically stable log-sum-exp. -# @noRd -.logSumExp <- function(x) { - maxX <- max(x, na.rm = TRUE) - sumExp <- sum(exp(x - maxX), na.rm = TRUE) - return(maxX + log(sumExp)) -} - # Approximate (Wakefield) Bayes factors from z-scores and standard errors: # per-variant log-BF and normalized posterior probabilities. # @noRd @@ -1210,7 +1233,9 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { V <- se^2 r <- W / (W + V) lbf <- 0.5 * (log(1 - r) + (r * z^2)) - denom <- .logSumExp(lbf) + # matrixStats is an Import and its logSumExp is the same algorithm in C; + # pecotmr carried a hand-rolled R copy of it. + denom <- matrixStats::logSumExp(lbf, na.rm = TRUE) prob <- exp(lbf - denom) return(list(lbf = lbf, prob = prob)) } @@ -1229,26 +1254,12 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { # --- slalom helpers --------------------------------------------------------- # Require exactly one of R (LD matrix) or X (genotype matrix). -.slalomValidate <- function(R, X) { - if (is.null(R) && is.null(X)) { - abort("Either R (LD matrix) or X (genotype matrix) must be provided.") - } - if (!is.null(R) && !is.null(X)) { - abort("Provide either R or X, not both.") - } -} - -# Lead-variant LD column. From X, compute just that column (avoid full p x p). -.slalomLeadR <- function(zScore, R, X, leadIdx) { - if (!is.null(X)) { - if (!is.matrix(X)) { - X <- as.matrix(X) - } - return(as.numeric(cor(X, X[, leadIdx]))) - } - if (!is.matrix(R) || nrow(R) != ncol(R) || nrow(R) != length(zScore)) { - abort("R must be a square matrix matching the length of zScore.") - } +# Lead-variant LD column. `R` has already been resolved from `X` where the +# caller gave genotypes, so there is one source here and `ldMethod` has +# already been applied. +#' @importFrom checkmate assertMatrix +.slalomLeadR <- function(zScore, R, leadIdx) { + assertMatrix(R, nrows = length(zScore), ncols = length(zScore)) R[, leadIdx] } @@ -1261,8 +1272,10 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { nlog10pDentistSThreshold ) { r2Lead <- rLead^2 - tDentistS <- (zScore - rLead * zScore[leadIdx])^2 / (1 - r2Lead) - tDentistS[tDentistS < 0] <- Inf + rawT <- (zScore - rLead * zScore[leadIdx])^2 / (1 - r2Lead) + # A negative statistic means 1 - r2 went negative (|r| > 1 from a + # mismatched panel); Inf routes it straight to the outlier branch. + tDentistS <- replace(rawT, rawT < 0, Inf) nlog10pDentistS <- -log10(pchisq(tDentistS, df = 1, lower.tail = FALSE)) outliers <- (r2Lead > r2Threshold) & (nlog10pDentistS > nlog10pDentistSThreshold) @@ -1360,7 +1373,13 @@ slalom <- function( leadVariantChoice = "pvalue", ldMethod = "sample" ) { - .slalomValidate(R, X) + # Resolve the LD the same way dentist does, so `ldMethod` selects the + # estimator it advertises. This used to correlate the lead column of `X` + # with cor() directly, which skipped computeLd entirely: "population" + # and "gcta" were accepted and silently given sample LD. Building the + # full matrix is the cost of honouring the choice, and is what the + # sibling QC method already pays on the same input. + R <- resolveLdInput(R = R, X = X, ldMethod = ldMethod)$R # One-sided p-value matching the original Python (stats.norm.cdf): lead is # the most negative z-score when leadVariantChoice == "pvalue". pvalue <- pnorm(zScore) @@ -1377,7 +1396,7 @@ slalom <- function( } else { which.max(prob) } - rLead <- .slalomLeadR(zScore, R, X, leadIdx) + rLead <- .slalomLeadR(zScore, R, leadIdx) ds <- .slalomDentistS( zScore, rLead, @@ -1434,38 +1453,38 @@ slalom <- function( #' df <- data.frame(cs_name = c("L1", "L2"), top_z = c(5, 3.5), #' p_value = c(1e-10, 1e-6)) #' autoDecision(df, highCorrCols = character(0)) +#' @importFrom checkmate assertCharacter #' @export autoDecision <- function(df, highCorrCols) { + assertCharacter(highCorrCols, any.missing = FALSE) # Identify top_cs topCsIndex <- which.max(abs(df$top_z)) - df$top_cs <- FALSE - df$top_cs[topCsIndex] <- TRUE - - # Identify tagged_cs - df$tagged_cs <- map_lgl( - seq_len(nrow(df)), - .autoDecisionTagged, - df = df, - highCorrCols = highCorrCols + withTop <- mutate(df, top_cs = seq_len(nrow(df)) == topCsIndex) + # Identify tagged_cs. `.autoDecisionTagged()` reads `top_cs`, so it has to + # see the frame that already carries it. + flagged <- mutate( + withTop, + tagged_cs = map_lgl( + seq_len(nrow(withTop)), + .autoDecisionTagged, + df = withTop, + highCorrCols = highCorrCols + ) ) - # Count total and remaining CS - totalCs <- nrow(df) - taggedCsCount <- sum(df$tagged_cs) - if (totalCs > 0) { - remainingCs <- totalCs - 1 - taggedCsCount - } else { - remainingCs <- 0 - } + totalCs <- nrow(flagged) + taggedCsCount <- sum(flagged$tagged_cs) + remainingCs <- if (totalCs > 0) totalCs - 1 - taggedCsCount else 0 # Determine method - df$method <- case_when( - taggedCsCount == 0 & totalCs > 1 ~ "BVSR", - (remainingCs == 0 & totalCs > 1) | (totalCs == 1) ~ "SER", - remainingCs > 0 ~ "BCR", - TRUE ~ NA_character_ + mutate( + flagged, + method = case_when( + taggedCsCount == 0 & totalCs > 1 ~ "BVSR", + (remainingCs == 0 & totalCs > 1) | (totalCs == 1) ~ "SER", + remainingCs > 0 ~ "BCR", + TRUE ~ NA_character_ + ) ) - - return(df) } @@ -1553,6 +1572,20 @@ autoDecision <- function(df, highCorrCols) { !is_in(seq_len(n), m$idxA) } +# The retained-component mask, truncated to at most `maxRank` components. +# @noRd +.svdCapRank <- function(keep, maxRank) { + if (is.null(maxRank) || maxRank <= 0) { + return(keep) + } + keepIdx <- which(keep) + nKeep <- min(length(keepIdx), maxRank) + if (length(keepIdx) <= nKeep) { + return(keep) + } + replace(keep, keepIdx[(nKeep + 1):length(keepIdx)], FALSE) +} + # Rows that match a known sumstats variant in the opposite orientation. # @noRd .raissFlipOfKnownMask <- function(refPanelIds, knownIds) { @@ -1561,8 +1594,7 @@ autoDecision <- function(df, highCorrCols) { return(mask) } m <- matchVariants(refPanelIds, knownIds, removeStrandAmbiguous = FALSE) - mask[m$idxA[m$sign < 0]] <- TRUE - mask + replace(mask, m$idxA[m$sign < 0], TRUE) } # Positions the GWAS already typed. @@ -1638,9 +1670,9 @@ raissSingleMatrix <- function( zt <- knownZscores$z sigT <- ldMatrix[knowns, knowns, drop = FALSE] sigIT <- ldMatrix[unknowns, knowns, drop = FALSE] - results <- raissModel(zt, sigT, sigIT, lamb, rcond) - results <- formatRaissDf(results, refPanel, unknowns) - results <- filterRaissOutput(results, r2Threshold, minimumLd, verbose) + results <- raissModel(zt, sigT, sigIT, lamb, rcond) |> + formatRaissDf(refPanel, unknowns) |> + filterRaissOutput(r2Threshold, minimumLd, verbose) resultNofilter <- mergeRaissDf(results$zscoresNofilter, knownZscores) |> arrange(.data$pos) resultFilter <- mergeRaissDf(results$zscores, knownZscores) |> @@ -1729,7 +1761,7 @@ raissSingleMatrix <- function( w <- U %*% (d / d2PlusC * VtZt) # Single dgemm X' %*% [w | U]: col 1 (rows unknowns) -> mu; rest -> A. XtWU <- crossprod(X, cbind(w, U)) - mu <- as.numeric(XtWU[unknowns, 1]) + muRaw <- as.numeric(XtWU[unknowns, 1]) A <- XtWU[unknowns, -1, drop = FALSE] rm(XtWU) # Variance and LD score in one pass over A^2. @@ -1747,7 +1779,7 @@ raissSingleMatrix <- function( # R2 correction (same as raissModel). varNorm <- varInBoundaries(varRaw, lamb) R2 <- (1 + lamb) - varNorm - mu <- mu / sqrt(R2) + mu <- muRaw / sqrt(R2) list( var = varNorm, mu = mu, @@ -1786,8 +1818,8 @@ raissSingleMatrixFromX <- function( svdTol, nrow(X) ) - results <- formatRaissDf(imp, refPanel, unknowns) - results <- filterRaissOutput(results, r2Threshold, minimumLd, verbose) + results <- formatRaissDf(imp, refPanel, unknowns) |> + filterRaissOutput(r2Threshold, minimumLd, verbose) resultNofilter <- mergeRaissDf(results$zscoresNofilter, knownZscores) |> arrange(.data$pos) resultFilter <- mergeRaissDf(results$zscores, knownZscores) |> @@ -1815,36 +1847,53 @@ raissSingleMatrixFromX <- function( lastVar <- combinedResult$variant_id[nrow(combinedResult)] firstVar <- newResult$variant_id[1] - if (lastVar == firstVar) { - newR2 <- newResult$raissR2[1] - oldR2 <- combinedResult$raissR2[nrow(combinedResult)] - if (is.na(newR2) && is.na(oldR2)) { - # Both are NA - keep the existing one - } else if (is.na(oldR2)) { - # Old is NA but new is not - use new - combinedResult[nrow(combinedResult), ] <- newResult[1, ] - } else if (is.na(newR2)) { - # New is NA but old is not - keep old - } else if (newR2 > oldR2) { - # Both are non-NA and new is better - use new - combinedResult[nrow(combinedResult), ] <- newResult[1, ] - } - - # Add remaining rows from new (excluding first) - if (nrow(newResult) > 1) { - combinedResult <- bind_rows(combinedResult, newResult[-1, ]) - } - } else { + if (lastVar != firstVar) { # No overlap - combine all rows - combinedResult <- bind_rows(combinedResult, newResult) + return(bind_rows(combinedResult, newResult)) + } + # The shared boundary variant is kept from whichever side imputed it + # better; two NAs, a tie, or an NA on the new side keep the existing row. + newR2 <- newResult$raissR2[1] + oldR2 <- combinedResult$raissR2[nrow(combinedResult)] + preferNew <- !is.na(newR2) && (is.na(oldR2) || newR2 > oldR2) + resolved <- if (preferNew) { + bind_rows(combinedResult[-nrow(combinedResult), ], newResult[1, ]) + } else { + combinedResult } - - return(combinedResult) + # Every row of `newResult` past the boundary variant is new. + bind_rows(resolved, newResult[-1, ]) } # --- raiss: genotype-matrix and LD-matrix path helpers --------------------- # List of genotype-matrix blocks: impute each via SVD, then row-bind. +# One genotype block's imputation, or NULL when the block yields nothing. +# @noRd +.raissGenotypeBlockAt <- function( + i, + refPanel, + knownZscores, + genotypeMatrix, + p +) { + if (p$verbose) { + nBlocks <- length(genotypeMatrix) + msg <- glue("Processing block {i} of {nBlocks}") + inform(msg) + } + raissSingleMatrixFromX( + refPanel, + knownZscores, + genotypeMatrix[[i]], + p$lamb, + p$svdTol, + p$r2Threshold, + p$minimumLd, + verbose = FALSE + ) +} + .raissGenotypeBlocks <- function(refPanel, knownZscores, genotypeMatrix, p) { if (p$verbose) { msg <- glue( @@ -1853,27 +1902,14 @@ raissSingleMatrixFromX <- function( ) inform(msg) } - resultsList <- list() - for (i in seq_along(genotypeMatrix)) { - if (p$verbose) { - nBlocks <- length(genotypeMatrix) - msg <- glue("Processing block {i} of {nBlocks}") - inform(msg) - } - blockResult <- raissSingleMatrixFromX( - refPanel, - knownZscores, - genotypeMatrix[[i]], - p$lamb, - p$svdTol, - p$r2Threshold, - p$minimumLd, - verbose = FALSE - ) - if (!is.null(blockResult)) { - resultsList[[length(resultsList) + 1]] <- blockResult - } - } + resultsList <- compact(map( + seq_along(genotypeMatrix), + .raissGenotypeBlockAt, + refPanel = refPanel, + knownZscores = knownZscores, + genotypeMatrix = genotypeMatrix, + p = p + )) if (length(resultsList) == 0) { if (p$verbose) { inform("No blocks could be processed.") @@ -1950,20 +1986,14 @@ raissSingleMatrixFromX <- function( # Combine per-block imputation results (boundary-dedup) + rebuild LD matrix. .raissLdBlocksCombine <- function(resultsList) { - combinedNofilter <- resultsList[[1]]$resultNofilter - combinedFilter <- resultsList[[1]]$resultFilter - if (length(resultsList) > 1) { - for (i in 2:length(resultsList)) { - combinedNofilter <- .combineWithBoundaryCheck( - combinedNofilter, - resultsList[[i]]$resultNofilter - ) - combinedFilter <- .combineWithBoundaryCheck( - combinedFilter, - resultsList[[i]]$resultFilter - ) - } - } + combinedNofilter <- reduce( + map(resultsList, "resultNofilter"), + .combineWithBoundaryCheck + ) + combinedFilter <- reduce( + map(resultsList, "resultFilter"), + .combineWithBoundaryCheck + ) ldFilteredList <- map(resultsList, "ldMat") variantList <- map(ldFilteredList, .ldVariantsDf) ldMatrix <- createLdMatrix( @@ -1978,29 +2008,56 @@ raissSingleMatrixFromX <- function( } # LD-block imputation path: impute each block then combine. +# One LD block's imputation, or NULL when the block yields nothing. +# @noRd +.raissLdBlockAt <- function( + blockId, + refPanel, + knownZscores, + ldMatrix, + variantIndices, + blockIds, + p +) { + if (p$verbose) { + nBlocks <- length(blockIds) + msg <- glue("Processing block {blockId} of {nBlocks}") + inform(msg) + } + .raissLdBlockOne( + refPanel, + knownZscores, + ldMatrix, + variantIndices, + blockId, + p + ) +} + .raissLdBlocksPath <- function(refPanel, knownZscores, ldMatrix, p) { if (p$verbose) { inform("Processing multiple LD blocks...") } variantIndices <- ldMatrix$variantIndices blockIds <- unique(variantIndices$blockId) - resultsList <- list() - for (blockId in blockIds) { - if (p$verbose) { - nBlocks <- length(blockIds) - msg <- glue("Processing block {blockId} of {nBlocks}") - inform(msg) - } - blockResult <- .raissLdBlockOne( - refPanel, - knownZscores, - ldMatrix, - variantIndices, - blockId, - p - ) - if (!is.null(blockResult)) resultsList[[blockId]] <- blockResult + perBlock <- map( + blockIds, + .raissLdBlockAt, + refPanel = refPanel, + knownZscores = knownZscores, + ldMatrix = ldMatrix, + variantIndices = variantIndices, + blockIds = blockIds, + p = p + ) + # `resultsList[[blockId]] <- ...` named the entries only when blockIds are + # character, so keep that distinction rather than inventing names. + blockResults <- if (is.character(blockIds)) { + set_names(perBlock, blockIds) + } else { + perBlock } + resultsList <- compact(blockResults) if (length(resultsList) == 0) { if (p$verbose) { msg <- glue( @@ -2127,6 +2184,92 @@ raiss <- function( .raissLdBlocksPath(refPanel, knownZscores, ldMatrix, p) } +#' @rdname RaissParam +#' @aliases RaissParam-class +#' @exportClass RaissParam +setClass( + "RaissParam", + contains = "MethodParam", + slots = c( + lamb = "numeric", + svdTol = "numeric", + r2Threshold = "numeric", + minimumLd = "numeric", + mafCutoff = "numeric", + macCutoff = "numeric", + imissCutoff = "numeric", + flank = "numeric" + ) +) + +#' @title Arguments For RAISS Imputation During Summary-Statistic QC +#' @description The settings \code{\link{summaryStatsQc}} uses when +#' \code{impute = TRUE}. Four are forwarded to \code{\link{raiss}}; the +#' other four are pecotmr's own, bounding which panel variants RAISS is +#' asked to impute and how wide a window it reads. +#' +#' \code{\link{raiss}} also takes an \code{rcond}, but only on its +#' LD-matrix path. QC always hands it a genotype matrix, which routes +#' through the SVD solver and uses \code{svdTol} instead, so \code{rcond} +#' is not offered here --- naming it is an error rather than a setting that +#' silently does nothing. +#' @param lamb Regularization term added to the LD diagonal. Default +#' \code{0.01}. +#' @param svdTol Singular-value cutoff for the pseudo-inverse. Default +#' \code{1e-12}. Note this is tighter than \code{\link{raiss}}'s own +#' \code{1e-8} default. +#' @param r2Threshold Imputation \eqn{R^2} below which a variant is dropped +#' from the output. Default \code{0.6}. +#' @param minimumLd Minimum LD score for retaining an imputed variant. +#' Default \code{5}. +#' @param mafCutoff Minor-allele-frequency floor for a variant to be an +#' imputation TARGET. Default \code{0}. +#' @param macCutoff Minor-allele-count floor for a target; the stricter of +#' this and \code{mafCutoff} applies. Default \code{0}. +#' @param imissCutoff Missingness ceiling for a target. Default \code{1}. +#' @param flank Base pairs by which to widen the analysis-region window on +#' each side, retaining LD context for edge variants. Default \code{0}. +#' @return A \code{RaissParam} object, a \code{\link{MethodParam}}. +#' @seealso \code{\link{summaryStatsQc}}, \code{\link{raiss}} +#' @examples +#' RaissParam(mafCutoff = 0.01, flank = 5e5) +#' @export +RaissParam <- function( + lamb = 0.01, + svdTol = 1e-12, + r2Threshold = 0.6, + minimumLd = 5, + mafCutoff = 0, + macCutoff = 0, + imissCutoff = 1, + flank = 0 +) { + new( + "RaissParam", + lamb = lamb, + svdTol = svdTol, + r2Threshold = r2Threshold, + minimumLd = minimumLd, + mafCutoff = mafCutoff, + macCutoff = macCutoff, + imissCutoff = imissCutoff, + flank = flank + ) +} + +# The RAISS bundle as a plain list with every field present. A constructor +# result already carries all eight -- they are all formals with defaults -- +# and the empty list that means "no options" becomes the defaults outright, +# so the read sites need no per-field fallback. +# @noRd +.ssqcResolveImputeArgs <- function(imputeArgs) { + if (length(imputeArgs) == 0L) { + return(as.list(RaissParam())) + } + as.list(imputeArgs) +} + +#' @importFrom checkmate assertNumeric #' @param zt Vector of known z scores. #' @param sigT Matrix of known linkage disequilibrium (LD) correlation. #' @param sigIT Correlation matrix with rows corresponding to unknown SNPs (to @@ -2150,9 +2293,9 @@ raissModel <- function( reportConditionNumber = FALSE ) { sigTInv <- invertMatRecursive(sigT, lamb, rcond) - if (!is.numeric(zt) || !is.numeric(sigT) || !is.numeric(sigIT)) { - abort("zt, sigT, and sigIT must be numeric.") - } + assertNumeric(zt) + assertNumeric(sigT) + assertNumeric(sigIT) if (batch) { conditionNumber <- if (reportConditionNumber) { rep(kappa(sigT, exact = TRUE, norm = "2"), nrow(sigIT)) @@ -2245,29 +2388,35 @@ mergeRaissDf <- function(raissDf, knownZscores) { # Identify rows that came from knownZscores fromKnown <- !is.na(mergedDf$z.y) & is.na(mergedDf$z.x) - # Set Var to -1 and raissLdScore to Inf for these rows - mergedDf$Var[fromKnown] <- -1 - mergedDf$raissLdScore[fromKnown] <- Inf - - # If there are overlapping columns (e.g., z.x and z.y), resolve them For - # example, use z from knownZscores where available, otherwise use z from - # raissDf - mergedDf$z <- if_else(fromKnown, mergedDf$z.y, mergedDf$z.x) - - # Remove the extra columns produced by the join (z.x, z.y). - mergedDf <- select(mergedDf, -all_of(c("z.x", "z.y"))) - mergedDf <- arrange(mergedDf, .data$pos) - # assign imputed variants beta, se as NA to avoid confusion, since they are - # not imputed. beta/se are optional (knownZscores may omit them), so guard - # on column presence explicitly rather than relying on a data.frame - # silently creating an all-NA column on `$col[mask] <- NA`. - if (is_in("beta", colnames(mergedDf))) { - mergedDf$beta[mergedDf$Var == -1] <- NA - } - if (is_in("se", colnames(mergedDf))) { - mergedDf$se[mergedDf$Var == -1] <- NA - } - return(mergedDf) + resolved <- mutate( + mergedDf, + # A known variant was not imputed, so it carries no imputation + # quality: Var = -1 and an infinite LD score mark it as observed. + Var = replace(.data$Var, fromKnown, -1), + raissLdScore = replace(.data$raissLdScore, fromKnown, Inf), + # Overlapping z columns resolved: z from knownZscores where available, + # otherwise z from raissDf. + z = if_else(fromKnown, .data$z.y, .data$z.x) + ) |> + # Remove the extra columns produced by the join (z.x, z.y). + select(-all_of(c("z.x", "z.y"))) |> + arrange(.data$pos) + # Imputed variants' beta / se are NA to avoid confusion, since they are not + # imputed. Both are optional (knownZscores may omit them), so guard on + # column presence explicitly rather than relying on a data.frame silently + # creating an all-NA column on `$col[mask] <- NA`. + observed <- resolved$Var == -1 + mutate( + resolved, + !!!compact(list( + beta = if (is_in("beta", colnames(resolved))) { + replace(resolved$beta, observed, NA) + }, + se = if (is_in("se", colnames(resolved))) { + replace(resolved$se, observed, NA) + } + )) + ) } # Format one aligned "label: value" report line (label left-padded to @@ -2314,7 +2463,7 @@ filterRaissOutput <- function( minimumLd = 5, verbose = TRUE ) { - zscores <- select( + selected <- select( zscores, all_of(c( "chrom", @@ -2327,16 +2476,15 @@ filterRaissOutput <- function( "raissLdScore" )) ) - zscores$raissR2 <- 1 - zscores$Var - zscoresNofilter <- zscores - zscores <- filter( - zscores, + zscoresNofilter <- mutate(selected, raissR2 = 1 - .data$Var) + kept <- filter( + zscoresNofilter, .data$raissR2 > r2Threshold & .data$raissLdScore >= minimumLd ) if (verbose) { - .filterRaissReport(zscoresNofilter, zscores, r2Threshold, minimumLd) + .filterRaissReport(zscoresNofilter, kept, r2Threshold, minimumLd) } - list(zscoresNofilter = zscoresNofilter, zscores = zscores) + list(zscoresNofilter = zscoresNofilter, zscores = kept) } computeMu <- function(sigIT, sigTInv, zt) { @@ -2359,13 +2507,13 @@ checkInversion <- function(sigT, sigTInv) { } varInBoundaries <- function(var, lamb) { - var[var < 0] <- 0 - var[var > (0.99999 + lamb)] <- 1 - return(var) + floored <- replace(var, var < 0, 0) + replace(floored, floored > (0.99999 + lamb), 1) } +#' @importFrom rlang try_fetch invertMat <- function(mat, lamb, rcond) { - tryCatch( + try_fetch( { # Modify the diagonal elements of mat diag(mat) <- 1 + lamb @@ -2373,7 +2521,7 @@ invertMat <- function(mat, lamb, rcond) { matInv <- ginv(mat, tol = rcond) return(matInv) }, - error = function(e) { + error = function(cnd) { # Second attempt with updated lamb and rcond in case of an error diag(mat) <- 1 + lamb * 1.1 matInv <- ginv(mat, tol = rcond * 1.1) @@ -2383,7 +2531,7 @@ invertMat <- function(mat, lamb, rcond) { } invertMatRecursive <- function(mat, lamb, rcond) { - tryCatch( + try_fetch( { # Modify the diagonal elements of mat diag(mat) <- 1 + lamb @@ -2391,7 +2539,7 @@ invertMatRecursive <- function(mat, lamb, rcond) { matInv <- ginv(mat, tol = rcond) return(matInv) }, - error = function(e) { + error = function(cnd) { # Recursive call with updated lamb and rcond in case of an error invertMat(mat, lamb * 1.1, rcond * 1.1) } @@ -2409,9 +2557,15 @@ invertMatEigen <- function(mat, tol = 1e-3) { ) abort(msg) } - matInv <- eigenMat$vectors[, seq_len(L)] %*% - diag(1 / eigenMat$values[seq_len(L)]) %*% - t(eigenMat$vectors[, seq_len(L)]) + # Both guards matter when L == 1: the subscript would drop to a vector, + # and diag() of a length-one value returns an identity matrix of THAT + # ORDER -- diag(0.1) is 0x0 -- not a 1x1 matrix holding the value, so + # the product failed with "non-conformable arguments". + kept <- seq_len(L) + vectors <- eigenMat$vectors[, kept, drop = FALSE] + matInv <- vectors %*% + diag(1 / eigenMat$values[kept], nrow = L) %*% + t(vectors) return(matInv) } @@ -2421,28 +2575,174 @@ invertMatEigen <- function(mat, tol = 1e-3) { # Top-level summaryStatsQc() pipeline + helpers # ============================================================================= -#' Detect LD-Summary Statistic Mismatches -#' -#' Unified wrapper for detecting outlier variants due to LD-summary statistic -#' mismatches. Dispatches to either \code{\link{dentistSingleWindow}} or -#' \code{\link{slalom}} based on the \code{method} argument. -#' -#' @param zScore Numeric vector of z-scores. -#' @param R Square LD correlation matrix. Provide either \code{R} or \code{X}. -#' @param X Genotype matrix (samples x SNPs). If provided, LD is computed via -#' \code{computeLd} and \code{nSample} defaults to \code{nrow(X)}. -#' @param nSample Number of samples in the LD reference panel. Required when -#' \code{R} is provided and \code{method = "dentist"}; inferred from \code{X} -#' when \code{X} is provided. -#' @param method Character string specifying the QC method: \code{"slalom"} -#' (default) or \code{"dentist"}. -#' @param ldMethod Character string specifying the LD computation method when -#' \code{X} is provided. One of \code{"sample"} (default), -#' \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is provided -#' directly. -#' @param ... Additional arguments passed to the underlying QC method -#' (\code{\link{dentistSingleWindow}} or \code{\link{slalom}}). +#' @rdname SlalomParam +#' @aliases SlalomParam-class +#' @exportClass SlalomParam +setClass( + "SlalomParam", + contains = "MethodParam", + slots = c( + standardError = "numeric_OR_NULL", + abfPriorVariance = "numeric", + nlog10pDentistSThreshold = "numeric", + r2Threshold = "numeric", + leadVariantChoice = "character" + ) +) + +#' @title Arguments For The SLALOM LD-Mismatch Check +#' @description Options for \code{\link{slalom}}, pecotmr's SLALOM +#' implementation. Every field is a formal of that function, so an unknown +#' name is rejected by R as an unused argument; there is no \code{...} +#' because the contract is complete. Pass the result as +#' \code{ldMismatchQc(method = )} or +#' \code{summaryStatsQc(ldMismatchQcMethod = )}. +#' @param standardError Per-variant standard errors. \code{NULL} (default) +#' leaves \code{\link{slalom}}'s own data-dependent default in place. +#' @param abfPriorVariance Prior variance for the approximate Bayes factor. +#' Default \code{0.04}. +#' @param nlog10pDentistSThreshold \code{-log10(p)} threshold on the +#' DENTIST-S statistic above which a variant is an outlier. Default +#' \code{4.0}. +#' @param r2Threshold Minimum r-squared with the lead variant for a variant to +#' be tested. Default \code{0.6}. +#' @param leadVariantChoice How the lead variant is chosen. Default +#' \code{"pvalue"}. +#' @return A \code{SlalomParam} object, a \code{\link{MethodParam}}. +#' @examples +#' SlalomParam(r2Threshold = 0.8) +#' @export +SlalomParam <- function( + standardError = NULL, + abfPriorVariance = 0.04, + nlog10pDentistSThreshold = 4.0, + r2Threshold = 0.6, + leadVariantChoice = "pvalue" +) { + new( + "SlalomParam", + standardError = standardError, + abfPriorVariance = abfPriorVariance, + nlog10pDentistSThreshold = nlog10pDentistSThreshold, + r2Threshold = r2Threshold, + leadVariantChoice = leadVariantChoice + ) +} + +#' @rdname DentistParam +#' @aliases DentistParam-class +#' @exportClass DentistParam +setClass( + "DentistParam", + contains = "MethodParam", + slots = c( + pValueThreshold = "numeric", + propSVD = "numeric", + gcControl = "logical", + nIter = "numeric", + gPvalueThreshold = "numeric", + duprThreshold = "numeric", + numThreads = "numeric", + correctChenEtAlBug = "logical", + seed = "numeric_OR_NULL" + ) +) + +#' @title Arguments For The DENTIST LD-Mismatch Check +#' @description Options for \code{\link{dentistSingleWindow}}, pecotmr's +#' DENTIST implementation. Every field is a formal of that function, so an +#' unknown name is rejected by R as an unused argument; there is no +#' \code{...} because the contract is complete. Pass the result as +#' \code{ldMismatchQc(method = )} or +#' \code{summaryStatsQc(ldMismatchQcMethod = )}. +#' @param pValueThreshold Significance threshold for the DENTIST statistic. +#' Default \code{5e-8}. +#' @param propSVD Proportion of the singular value decomposition retained. +#' Default \code{0.4}. +#' @param gcControl Logical; apply genomic control. Default \code{FALSE}. +#' @param nIter Number of DENTIST iterations. Default \code{10}. +#' @param gPvalueThreshold Grouping p-value threshold. Default \code{0.05}. +#' @param duprThreshold Duplicate r-squared threshold. Default \code{0.99}. +#' @param numThreads Number of CPU cores. Default \code{1}. +#' @param correctChenEtAlBug Logical; apply the Chen et al. correction. +#' Default \code{TRUE}. +#' @param seed Integer or \code{NULL}. Random seed for the iteration. +#' @return A \code{DentistParam} object, a \code{\link{MethodParam}}. +#' @examples +#' DentistParam(propSVD = 0.5) +#' @export +DentistParam <- function( + pValueThreshold = 5e-8, + propSVD = 0.4, + gcControl = FALSE, + nIter = 10, + gPvalueThreshold = 0.05, + duprThreshold = 0.99, + numThreads = 1, + correctChenEtAlBug = TRUE, + seed = NULL +) { + new( + "DentistParam", + pValueThreshold = pValueThreshold, + propSVD = propSVD, + gcControl = gcControl, + nIter = nIter, + gPvalueThreshold = gPvalueThreshold, + duprThreshold = duprThreshold, + numThreads = numThreads, + correctChenEtAlBug = correctChenEtAlBug, + seed = seed + ) +} + +# The engines ldMismatchQc dispatches to, and the constructor for each. Keyed +# by the name `method` accepts, so a bare name resolves to an empty record. +# @noRd +.ldMismatchCtors <- function() { + list(slalom = SlalomParam, dentist = DentistParam) +} + +# Normalize summaryStatsQc's ldMismatchQcMethod: a name (including "none", for +# which there is no engine to configure) or the engine's constructor. Returns +# the value unchanged once validated, so it can be handed straight to +# ldMismatchQc(method = ). +# @noRd +.resolveLdMismatchChoice <- function(x) { + allowed <- c("none", names(.ldMismatchCtors())) + engine <- .engineOf(if (is.character(x)) x[[1L]] else x) + if (is.null(engine) || !is_in(engine, allowed)) { + .resolveEngineChoice( + if (is.character(x)) x[[1L]] else x, + allowed, + "ldMismatchQcMethod" + ) + } + if (is.character(x)) x[[1L]] else x +} + +#' Detect LD-Summary Statistic Mismatches +#' +#' Unified wrapper for detecting outlier variants due to LD-summary statistic +#' mismatches. Dispatches to either \code{\link{dentistSingleWindow}} or +#' \code{\link{slalom}} based on the \code{method} argument. #' +#' @param zScore Numeric vector of z-scores. +#' @param R Square LD correlation matrix. Provide either \code{R} or \code{X}. +#' @param X Genotype matrix (samples x SNPs). If provided, LD is computed via +#' \code{computeLd} and \code{nSample} defaults to \code{nrow(X)}. +#' @param nSample Number of samples in the LD reference panel. Required when +#' \code{R} is provided and \code{method = "dentist"}; inferred from \code{X} +#' when \code{X} is provided. +#' @param method Which QC method to run: \code{"slalom"} (default) or +#' \code{"dentist"}, or the matching constructor -- +#' \code{\link{SlalomParam}} / \code{\link{DentistParam}} -- to configure +#' it at the same time. The constructor carries the choice, so there is no +#' separate options argument that could disagree with it. +#' @param ldMethod Character string specifying the LD computation method when +#' \code{X} is provided. One of \code{"sample"} (default), +#' \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is provided +#' directly. #' @return A data frame with at least a logical \code{outlier} column indicating #' which variants are identified as outliers. The remaining columns depend on #' the method used. @@ -2461,30 +2761,44 @@ ldMismatchQc <- function( X = NULL, nSample = NULL, method = c("slalom", "dentist"), - ldMethod = "sample", - ... + ldMethod = "sample" ) { - method <- arg_match(method) - if (method == "dentist") { - qcResults <- dentistSingleWindow( - zScore, - R = R, - X = X, - nSample = nSample, - ldMethod = ldMethod, - ... + # `method` carries both the choice and its options: a bare name resolves + # to that engine with no options set, a constructor result to that engine + # configured. One value, so the two cannot disagree. + chosen <- .resolveEngineChoice( + if (is.character(method)) method[[1L]] else method, + names(.ldMismatchCtors()), + "method" + ) + methodArgs <- chosen$args + if (chosen$engine == "dentist") { + callArgs <- list_modify( + list( + zScore, + R = R, + X = X, + nSample = nSample, + ldMethod = ldMethod + ), + !!!methodArgs ) - return(qcResults) + return(exec(dentistSingleWindow, !!!callArgs)) } else { - qcResults <- slalom(zScore, R = R, X = X, ldMethod = ldMethod, ...) + callArgs <- list_modify( + list(zScore, R = R, X = X, ldMethod = ldMethod), + !!!methodArgs + ) + qcResults <- exec(slalom, !!!callArgs) # Standardize output: slalom uses "outliers", rename to "outlier" for # consistency - result <- qcResults$data - if ( - is_in("outliers", colnames(result)) && - !is_in("outlier", colnames(result)) - ) { - result <- rename(result, outlier = "outliers") + raw <- qcResults$data + renameOutliers <- is_in("outliers", colnames(raw)) && + !is_in("outlier", colnames(raw)) + result <- if (renameOutliers) { + rename(raw, outlier = "outliers") + } else { + raw } return(result) } @@ -2515,109 +2829,10 @@ ldMismatchQc <- function( effectiveN <- function(nCase, nControl) { nCase <- as.numeric(nCase) nControl <- as.numeric(nControl) - out <- 4 / (1 / nCase + 1 / nControl) - out[is.na(nCase) | is.na(nControl) | nCase <= 0 | nControl <= 0] <- NA_real_ - out -} - -# Require a susieR that provides the kriging RSS diagnostic. -.krigingCheckSusie <- function() { - if ( - !requireNamespace("susieR", quietly = TRUE) || - !all( - is_in( - c("estimate_s_rss", "kriging_rss"), - getNamespaceExports("susieR") - ) - ) - ) { - msg <- glue( - "krigingOutlierQc requires a susieR that provides ", - "estimate_s_rss() and kriging_rss(); the installed susieR does ", - "not. Install a susieR with the kriging RSS diagnostic, or ", - "disable alleleFlipKriging." - ) - abort(msg) - } -} - -#' Kriging-style LD-consistency outlier QC -#' -#' Flags variants whose observed z-score is inconsistent with the value -#' predicted from its LD neighbours, using susieR's kriging diagnostic. -#' \code{susieR::kriging_rss()} computes the leave-one-out conditional -#' distribution of each \code{z_i} given the rest (with the LD-mismatch scale -#' \code{s} defaulting to \code{susieR::estimate_s_rss()}) and a per-variant -#' \code{logLR} for the allele-switch hypothesis. This helper reuses susieR's -#' own allele-switch rule --- \code{logLR > logLRThreshold & abs(z) > -#' zThreshold} (the same \code{logLR > 2 & |z| > 2} used in -#' \code{susie_rss_utils}) --- to flag variants whose sign should be flipped. -#' RSS-only helper, opt-in via \code{alleleFlipKriging}; never wired into -#' \code{alleleQc()} / \code{matchRefPanel()}. Requires a susieR that provides -#' \code{kriging_rss()} and \code{estimate_s_rss()}. -#' -#' @param zScore Numeric vector of harmonized z-scores. -#' @param R Square LD correlation matrix aligned to \code{zScore}. -#' @param n Sample size, forwarded to \code{susieR::kriging_rss()} (whose -#' default \code{s} is \code{susieR::estimate_s_rss()}). -#' @param variantIds Optional variant IDs for the diagnostics table. -#' @param zThreshold Absolute-z cutoff for the allele-switch rule (default -#' \code{2}, matching susieR). -#' @param logLRThreshold Log-likelihood-ratio cutoff for the allele-switch rule -#' (default \code{2}, matching susieR). -#' @return A list with \code{flip} (logical vector; \code{TRUE} = allele switch, -#' z-score should be sign-flipped) and \code{diagnostics} (data frame of -#' per-variant \code{z}, \code{condmean}, \code{z_std_diff}, \code{logLR}, and -#' the \code{flipped} flag). -#' @importFrom stats pnorm -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:20] -#' R <- cor(X) -#' krigingOutlierQc( -#' zScore = rnorm(20), R = R, n = 415, variantIds = colnames(X)) -#' @export -krigingOutlierQc <- function( - zScore, - R, - n, - variantIds = NULL, - zThreshold = 2, - logLRThreshold = 2 -) { - zScore <- as.numeric(zScore) - m <- length(zScore) - if (is.null(R) || !is.matrix(R) || nrow(R) != m || ncol(R) != m) { - abort("krigingOutlierQc requires a square LD matrix aligned to zScore.") - } - if (missing(n) || length(n) != 1L || is.na(n) || !is.finite(n) || n <= 0) { - abort("krigingOutlierQc requires a single positive sample size 'n'.") - } - .krigingCheckSusie() - if (is.null(variantIds)) { - variantIds <- rownames(R) - } - # susieR kriging RSS diagnostic (kriging_rss(z, R, n)): s defaults to - # estimate_s_rss(); logLR matches susieR's allele-switch selection. - cd <- susieR::kriging_rss(z = zScore, R = R, n = n)$conditional_dist - condMean <- as.numeric(cd$condmean) - zStdDiff <- as.numeric(cd$z_std_diff) - logLR <- as.numeric(cd$logLR) - # susieR's allele-switch rule (susie_rss_utils.R): logLR > 2 & |z| > 2. - flip <- !is.na(logLR) & - !is.na(zScore) & - logLR > logLRThreshold & - abs(zScore) > zThreshold - list( - flip = flip, - diagnostics = tibble( - variant_id = if (is.null(variantIds)) seq_len(m) else variantIds, - z = zScore, - condmean = condMean, - z_std_diff = zStdDiff, - logLR = logLR, - flipped = flip - ) + replace( + 4 / (1 / nCase + 1 / nControl), + is.na(nCase) | is.na(nControl) | nCase <= 0 | nControl <= 0, + NA_real_ ) } @@ -2674,9 +2889,17 @@ krigingOutlierQc <- function( seqnames = chr, ranges = IRanges::IRanges(start = as.integer(df$pos), width = 1L) ) - if (is_in("variant_id", colnames(df)) && !is_in("SNP", colnames(df))) { - df$SNP <- df$variant_id - } + df <- mutate( + df, + !!!compact(list( + SNP = if ( + is_in("variant_id", colnames(df)) && + !is_in("SNP", colnames(df)) + ) { + df$variant_id + } + )) + ) baseCols <- c("SNP", "A1", "A2", "Z", "N") # AF = directional effect-allele frequency (exported as af); MAF = # directionless QC frequency. Both carried when the loader resolved them. @@ -2691,8 +2914,10 @@ krigingOutlierQc <- function( "N_CONTROL" ) use <- intersect(c(baseCols, optCols), colnames(df)) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(select(df, all_of(use))) - gr + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame(select(df, all_of(use))) + ) } # ----------------------------------------------------------------------------- @@ -2733,15 +2958,24 @@ krigingOutlierQc <- function( } # Append the optional numeric stat columns present on the entry's mcols. +# One mcols column as numeric. +# @noRd +.entryStatColumn <- function(src, mc) { + as.numeric(mc[[src]]) +} + .entryDfAddStats <- function(df, mc) { statMap <- c(z = "Z", beta = "BETA", se = "SE", N = "N", maf = "MAF") - for (out in names(statMap)) { - src <- statMap[[out]] - if (is_in(src, colnames(mc))) { - df[[out]] <- as.numeric(mc[[src]]) - } - } - df + present <- statMap[is_in(statMap, colnames(mc))] + # mutate() overwrites an existing column in place and appends a new one, + # which is what the `df[[out]] <-` loop did. + mutate( + df, + !!!set_names( + map(unname(present), .entryStatColumn, mc = mc), + names(present) + ) + ) } .entryToSumstatDf <- function( @@ -2759,21 +2993,21 @@ krigingOutlierQc <- function( abort(msg) } } - chr <- as.character(GenomicRanges::seqnames(gr)) - if (!keepChrPrefix) { - chr <- str_remove(chr, regex("^chr", ignore_case = TRUE)) - } - df <- .entryDfBase(gr, mc, chr) - df <- .entryDfAddStats(df, mc) - if ( - derive == "zFromBetaSe" && - is.null(df[["z"]]) && - !is.null(df[["beta"]]) && - !is.null(df[["se"]]) - ) { - df[["z"]] <- df[["beta"]] / df[["se"]] + seqChr <- as.character(GenomicRanges::seqnames(gr)) + chr <- if (keepChrPrefix) { + seqChr + } else { + str_remove(seqChr, regex("^chr", ignore_case = TRUE)) + } + df <- .entryDfBase(gr, mc, chr) |> .entryDfAddStats(mc) + deriveZ <- derive == "zFromBetaSe" && + is.null(df[["z"]]) && + !is.null(df[["beta"]]) && + !is.null(df[["se"]]) + if (!deriveZ) { + return(df) } - df + mutate(df, z = .data$beta / .data$se) } # Derive BETA and SE columns from signed Z when the entry has only Z. @@ -2784,7 +3018,7 @@ krigingOutlierQc <- function( # are already there, or if any required column is missing. Returns: # list(df = , audit = NULL | list(nDerived = )) # .zToPvalue (two-tailed normal p-value from a signed Z) is defined once in -# pvalCombine.R and shared package-wide. +# pvalCombineWrappers.R and shared package-wide. # Internal: thin SVD with numerical-stability filtering. Drops singular # values below `tol * max(d)` and caps the retained rank at `maxRank`. @@ -2796,7 +3030,7 @@ krigingOutlierQc <- function( } s <- svd(mat) d <- s$d - keep <- if (tol > 0 && length(d) > 0) { + aboveTol <- if (tol > 0 && length(d) > 0) { out <- d / d[1] > tol if (!any(out)) { abort("All singular values are below the tolerance threshold.") @@ -2805,13 +3039,7 @@ krigingOutlierQc <- function( } else { rep(TRUE, length(d)) } - if (!is.null(maxRank) && maxRank > 0) { - nKeep <- min(sum(keep), maxRank) - keepIdx <- which(keep) - if (length(keepIdx) > nKeep) { - keep[keepIdx[(nKeep + 1):length(keepIdx)]] <- FALSE - } - } + keep <- .svdCapRank(aboveTol, maxRank) list( u = s$u[, keep, drop = FALSE], d = d[keep], @@ -2878,13 +3106,14 @@ krigingOutlierQc <- function( bs <- .zToBetaSe(z, maf, n) se <- bs$se beta <- bs$beta - if (!hasBeta) { - df$BETA <- beta - } - if (!hasSe) { - df$SE <- se - } - list(df = df, audit = list(nDerived = sum(!is.na(se)))) + derived <- mutate( + df, + !!!compact(list( + BETA = if (!hasBeta) beta, + SE = if (!hasSe) se + )) + ) + list(df = derived, audit = list(nDerived = sum(!is.na(se)))) } # Drop variants whose (chrom, pos) overlaps any user-supplied skipRegion. @@ -2925,22 +3154,32 @@ krigingOutlierQc <- function( abort(msg) } +# Rows falling inside skip region `i`. +# @noRd +.skipRegionMask <- function(i, parsed, dfChr, pos) { + dfChr == parsed$chrom[i] & pos >= parsed$start[i] & pos <= parsed$end[i] +} + .applySkipRegion <- function(df, skipRegion) { if (is.null(skipRegion) || length(skipRegion) == 0L) { return(df) } parsed <- .parseSkipRegion(skipRegion) - dropMask <- rep(FALSE, nrow(df)) dfChr <- str_remove( as.character(df$chrom), regex("^chr", ignore_case = TRUE) ) - for (i in seq_len(nrow(parsed))) { - dropMask <- dropMask | - (dfChr == parsed$chrom[i] & - df$pos >= parsed$start[i] & - df$pos <= parsed$end[i]) - } + dropMask <- reduce( + map( + seq_len(nrow(parsed)), + .skipRegionMask, + parsed = parsed, + dfChr = dfChr, + pos = df$pos + ), + `|`, + .init = rep(FALSE, nrow(df)) + ) filter(df, !dropMask) } @@ -2984,12 +3223,16 @@ krigingOutlierQc <- function( removeStrandAmbiguous = removeStrandAmbiguous, removeDups = removeDups ) - out <- res$harmonizedData - if (!is_in("chrom", colnames(out)) && is_in("chr", colnames(out))) { - colnames(out)[colnames(out) == "chr"] <- "chrom" + raw <- res$harmonizedData + out <- if (!is_in("chrom", colnames(raw)) && is_in("chr", colnames(raw))) { + `colnames<-`( + raw, + replace(colnames(raw), colnames(raw) == "chr", "chrom") + ) + } else { + raw } - attr(out, "qcCounts") <- attr(res, "qcCounts") - out + `attr<-`(out, "qcCounts", attr(res, "qcCounts")) } # Variant-content filters (MAF / INFO / N). Pure data-frame column @@ -3050,46 +3293,60 @@ krigingOutlierQc <- function( if (!(nCutoff > 0 && is_in("N", colnames(df)) && nrow(df) > 0L)) { return(list(df = df, dropped = NULL)) } - nVals <- as.numeric(df$N) + allN <- as.numeric(df$N) before <- nrow(df) - if (any(is.na(nVals))) { - df <- filter(df, !is.na(nVals)) - nVals <- nVals[!is.na(nVals)] - } - if (length(nVals) > 0L) { - medN <- stats::median(nVals) - madN <- stats::mad(nVals, constant = 1) - if (madN > 0) { - zN <- abs(nVals - medN) / madN - df <- filter(df, zN <= nCutoff) - } + # A variant with no N cannot be scored against the cohort median. + hasN <- !is.na(allN) + nVals <- allN[hasN] + withN <- if (all(hasN)) df else filter(df, hasN) + madN <- if (length(nVals) > 0L) stats::mad(nVals, constant = 1) else 0 + # A zero MAD means every retained N is identical, so no variant is an + # outlier and the z-score would divide by zero. + kept <- if (madN > 0) { + filter(withN, abs(nVals - stats::median(nVals)) / madN <= nCutoff) + } else { + withN } - list(df = df, dropped = before - nrow(df)) + list(df = kept, dropped = before - nrow(kept)) +} + +# An audit record with the unset entries omitted. An all-unset record is the +# empty list, not a zero-length named one, so callers can compare it directly. +# @noRd +.qcAudit <- function(...) { + entries <- compact(list(...)) + if (length(entries) == 0L) { + return(list()) + } + entries +} + +# The same, for counters that are reported only when something happened. +# @noRd +.qcAuditPositive <- function(...) { + exec(.qcAudit, !!!discard(list(...), .qcCountIsZero)) } +# @noRd +.qcCountIsZero <- function(n) is.null(n) || n <= 0L + .applyContentFilters <- function( df, mafCutoff = 0, infoCutoff = 0, nCutoff = 5 ) { - audit <- list() - r <- .cfMaf(df, mafCutoff) - df <- r$df - if (!is.null(r$dropped)) { - audit$mafDropped <- r$dropped - } - r <- .cfInfo(df, infoCutoff) - df <- r$df - if (!is.null(r$dropped)) { - audit$infoDropped <- r$dropped - } - r <- .cfN(df, nCutoff) - df <- r$df - if (!is.null(r$dropped)) { - audit$nDropped <- r$dropped - } - list(df = df, audit = audit) + maf <- .cfMaf(df, mafCutoff) + info <- .cfInfo(maf$df, infoCutoff) + n <- .cfN(info$df, nCutoff) + list( + df = n$df, + audit = .qcAudit( + mafDropped = maf$dropped, + infoDropped = info$dropped, + nDropped = n$dropped + ) + ) } # Per-row variant sanity / hygiene checks ported from MungeSumstats's @@ -3116,6 +3373,20 @@ krigingOutlierQc <- function( # --- .applySanityChecks per-check helpers (each guards its own flag) -------- # Coerce known numeric columns; count NAs newly introduced by coercion. +# @noRd +.scColumnIsNumeric <- function(col, df) { + is.numeric(df[[col]]) +} + +# One column coerced to numeric, with the count of NAs that coercion +# introduced (values that were present but unparseable). +# @noRd +.scCoerceColumn <- function(col, df) { + orig <- df[[col]] + coerced <- suppressWarnings(as.numeric(orig)) + list(values = coerced, na = sum(is.na(coerced) & !is.na(orig))) +} + .scCoerceNumeric <- function(df, coerceNumeric) { if (!coerceNumeric) { return(list(df = df, audit = list())) @@ -3136,21 +3407,15 @@ krigingOutlierQc <- function( ), colnames(df) ) - naIntroduced <- 0L - for (col in numericCols) { - orig <- df[[col]] - if (is.numeric(orig)) { - next - } - coerced <- suppressWarnings(as.numeric(orig)) - naIntroduced <- naIntroduced + sum(is.na(coerced) & !is.na(orig)) - df[[col]] <- coerced - } - audit <- list() - if (naIntroduced > 0L) { - audit$nonNumericCoerced <- naIntroduced - } - list(df = df, audit = audit) + toCoerce <- numericCols[ + !map_lgl(numericCols, .scColumnIsNumeric, df = df) + ] + coercions <- map(toCoerce, .scCoerceColumn, df = df) + naIntroduced <- sum(map_int(coercions, "na")) + list( + df = mutate(df, !!!set_names(map(coercions, "values"), toCoerce)), + audit = .qcAuditPositive(nonNumericCoerced = naIntroduced) + ) } # Normalize chromosome labels; optionally drop non-standard chromosomes. @@ -3158,23 +3423,23 @@ krigingOutlierQc <- function( if (!normalizeChr || !is_in("chrom", colnames(df))) { return(list(df = df, audit = list())) } - chr <- as.character(df$chrom) - chr <- str_remove(chr, regex("^chr", ignore_case = TRUE)) - chr <- str_remove(chr, regex("^ch", ignore_case = TRUE)) - chr <- str_to_upper(chr) - chr[chr == "23"] <- "X" - chr[chr == "24"] <- "Y" - chr[chr == "M"] <- "MT" - df$chrom <- chr - audit <- list() - if (dropNonstandardChr) { - before <- nrow(df) - standardChrs <- c(as.character(seq_len(22)), "X", "Y", "MT") - df <- filter(df, is_in(chr, standardChrs)) - dropped <- before - nrow(df) - if (dropped > 0L) audit$nonstandardChrDropped <- dropped - } - list(df = df, audit = audit) + chr <- as.character(df$chrom) |> + str_remove(regex("^chr", ignore_case = TRUE)) |> + str_remove(regex("^ch", ignore_case = TRUE)) |> + str_to_upper() |> + canonChromLabel() + normalized <- mutate(df, chrom = chr) + if (!dropNonstandardChr) { + return(list(df = normalized, audit = list())) + } + standardChrs <- c(as.character(seq_len(22)), "X", "Y", "MT") + kept <- filter(normalized, is_in(chr, standardChrs)) + list( + df = kept, + audit = .qcAuditPositive( + nonstandardChrDropped = nrow(normalized) - nrow(kept) + ) + ) } # Drop rows missing any vital column (chrom/pos/A1/A2 + first signed stat). @@ -3182,22 +3447,20 @@ krigingOutlierQc <- function( if (!dropMissData || nrow(df) == 0L) { return(list(df = df, audit = list())) } - vital <- intersect(c("chrom", "pos", "A1", "A2"), colnames(df)) signedCol <- intersect(c("Z", "BETA"), colnames(df))[1L] - if (!is.na(signedCol)) { - vital <- c(vital, signedCol) - } - audit <- list() - if (length(vital) > 0L) { - before <- nrow(df) - bad <- reduce(map(vital, .scColIsNa, df = df), `|`) - if (any(bad)) { - df <- filter(df, !bad) - } - dropped <- before - nrow(df) - if (dropped > 0L) audit$missDataDropped <- dropped + vital <- c( + intersect(c("chrom", "pos", "A1", "A2"), colnames(df)), + if (!is.na(signedCol)) signedCol + ) + if (length(vital) == 0L) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + bad <- reduce(map(vital, .scColIsNa, df = df), `|`) + kept <- filter(df, !bad) + list( + df = kept, + audit = .qcAuditPositive(missDataDropped = nrow(df) - nrow(kept)) + ) } # Drop rows whose P is outside [0, 1]. @@ -3211,12 +3474,10 @@ krigingOutlierQc <- function( if (any(bad)) { df <- filter(df, !bad) } - dropped <- before - nrow(df) - audit <- list() - if (dropped > 0L) { - audit$pOutOfRangeDropped <- dropped - } - list(df = df, audit = audit) + list( + df = df, + audit = .qcAuditPositive(pOutOfRangeDropped = before - nrow(df)) + ) } # Clamp tiny P-values up to the floor. @@ -3227,15 +3488,22 @@ krigingOutlierQc <- function( p <- as.numeric(df$P) smallMask <- !is.na(p) & p >= 0 & p < smallPFloor nClamped <- sum(smallMask) - audit <- list() - if (nClamped > 0L) { - df$P[smallMask] <- smallPFloor - audit$smallPClamped <- nClamped + if (nClamped == 0L) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + clamped <- mutate(df, P = replace(.data$P, smallMask, smallPFloor)) + list(df = clamped, audit = list(smallPClamped = nClamped)) } # Drop rows whose effect equals the null sentinel (0, or 1 for OR). +# Rows whose effect column holds the no-effect sentinel (1 for OR, else 0). +# @noRd +.scZeroEffectMask <- function(col, df) { + vals <- as.numeric(df[[col]]) + sentinel <- if (col == "OR") 1 else 0 + !is.na(vals) & vals == sentinel +} + .scDropZeroEffect <- function(df, dropZeroEffect) { if (!dropZeroEffect || nrow(df) == 0L) { return(list(df = df, audit = list())) @@ -3244,22 +3512,19 @@ krigingOutlierQc <- function( c("BETA", "LOG_ODDS", "SIGNED_SUMSTAT", "OR"), colnames(df) ) - audit <- list() - if (length(effectCols) > 0L) { - before <- nrow(df) - badMask <- rep(FALSE, nrow(df)) - for (col in effectCols) { - vals <- as.numeric(df[[col]]) - sentinel <- if (col == "OR") 1 else 0 - badMask <- badMask | (!is.na(vals) & vals == sentinel) - } - if (any(badMask)) { - df <- filter(df, !badMask) - } - dropped <- before - nrow(df) - if (dropped > 0L) audit$zeroEffectDropped <- dropped + if (length(effectCols) == 0L) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + badMask <- reduce( + map(effectCols, .scZeroEffectMask, df = df), + `|`, + .init = rep(FALSE, nrow(df)) + ) + kept <- filter(df, !badMask) + list( + df = kept, + audit = .qcAuditPositive(zeroEffectDropped = nrow(df) - nrow(kept)) + ) } # Drop rows with non-positive standard error. @@ -3273,15 +3538,14 @@ krigingOutlierQc <- function( if (any(bad)) { df <- filter(df, !bad) } - dropped <- before - nrow(df) - audit <- list() - if (dropped > 0L) { - audit$nonpositiveSeDropped <- dropped - } - list(df = df, audit = audit) + list( + df = df, + audit = .qcAuditPositive(nonpositiveSeDropped = before - nrow(df)) + ) } # Per-row sanity checks: sequence the guarded checks, accumulating the audit. +#' @importFrom purrr list_modify .applySanityChecks <- function( df, coerceNumeric = TRUE, @@ -3294,32 +3558,33 @@ krigingOutlierQc <- function( dropZeroEffect = TRUE, dropNonpositiveSe = TRUE ) { - audit <- list() if (nrow(df) == 0L) { - return(list(df = df, audit = audit)) - } - r <- .scCoerceNumeric(df, coerceNumeric) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scNormalizeChr(df, normalizeChr, dropNonstandardChr) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropMissData(df, dropMissData) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropPOutOfRange(df, dropPOutOfRange) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scClampSmallP(df, clampSmallP, smallPFloor) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropZeroEffect(df, dropZeroEffect) - df <- r$df - audit <- modifyList(audit, r$audit) - r <- .scDropNonpositiveSe(df, dropNonpositiveSe) - df <- r$df - audit <- modifyList(audit, r$audit) - list(df = df, audit = audit) + return(list(df = df, audit = list())) + } + # Order matters: numeric coercion first (later checks compare numbers), + # then the label fixes, then the row drops, then the small-P clamp. + steps <- list( + list(fn = .scCoerceNumeric, args = list(coerceNumeric)), + list( + fn = .scNormalizeChr, + args = list(normalizeChr, dropNonstandardChr) + ), + list(fn = .scDropMissData, args = list(dropMissData)), + list(fn = .scDropPOutOfRange, args = list(dropPOutOfRange)), + list(fn = .scClampSmallP, args = list(clampSmallP, smallPFloor)), + list(fn = .scDropZeroEffect, args = list(dropZeroEffect)), + list(fn = .scDropNonpositiveSe, args = list(dropNonpositiveSe)) + ) + reduce(steps, .scApplyStep, .init = list(df = df, audit = list())) +} + +# Run one sanity-check step against the accumulated (df, audit) state. Every +# step takes the frame first and returns list(df, audit); a step that declines +# to run returns the frame unchanged and an empty audit. +# @noRd +.scApplyStep <- function(state, step) { + r <- exec(step$fn, state$df, !!!step$args) + list(df = r$df, audit = list_modify(state$audit, !!!r$audit)) } # Apply ldMismatchQc (SLALOM/DENTIST) against the LD sketch. Returns the @@ -3343,12 +3608,12 @@ krigingOutlierQc <- function( # @noRd .qcPanelSupportedLd <- function(df, ldSketch, label) { nIn <- nrow(df) - R <- .ldFromSketch(ldSketch, df$SNP, label = label, onMissing = "drop") - if (is.null(R)) { + raw <- .ldFromSketch(ldSketch, df$SNP, label = label, onMissing = "drop") + if (is.null(raw)) { return(list(R = NULL, df = df[0L, , drop = FALSE], dropped = nIn)) } - keptIds <- attr(R, "keptVariantIds") - attr(R, "keptVariantIds") <- NULL + keptIds <- attr(raw, "keptVariantIds") + R <- `attr<-`(raw, "keptVariantIds", NULL) if (is.null(keptIds) || length(keptIds) >= nIn) { return(list(R = R, df = df, dropped = 0L)) } @@ -3364,7 +3629,11 @@ krigingOutlierQc <- function( if (is.null(df$SNP) || any(is.na(df$SNP))) { abort("summaryStatsQc: ldMismatchQc requires SNP column on the entry.") } - panel <- .qcPanelSupportedLd(df, ldSketch, "summaryStatsQc: zMismatchQc") + panel <- .qcPanelSupportedLd( + df, + ldSketch, + "summaryStatsQc: ldMismatchQcMethod" + ) if (is.null(panel$R)) { return(list( df = panel$df, @@ -3387,8 +3656,7 @@ krigingOutlierQc <- function( # chisq for variants effectively orthogonal to the lead). Treat NA as # "no evidence of being an outlier" (conservative: keep the variant) # so the downstream df / sum() / IRanges construction stay finite. - outlierFlags <- qc$outlier - outlierFlags[is.na(outlierFlags)] <- FALSE + outlierFlags <- replace(qc$outlier, is.na(qc$outlier), FALSE) # Attach the variant_id column so the diagnostics data.frame stays # self-describing once it's separated from the input df. diagnostics <- if (is.data.frame(qc)) { @@ -3412,7 +3680,7 @@ krigingOutlierQc <- function( # Signal screen: skip an entry/block with no strong signal by a chosen metric. # ----------------------------------------------------------------------------- # The screen is driven by ONE metric at a time (enforced by -# .resolveScreenMetric): pip : max single-effect PIP (susie_ser $pip); cutoff<0 +# SignalScreenParam): pip : max single-effect PIP (susie_ser $pip); cutoff<0 # => 3/nVar absZ : max |Z| (no model fit) logBf : max per-variant single-effect # logBF (susie_ser $lbf_variable) bf : same evidence on the raw BF scale # (compare maxlogBF > log(cutoff)) A "screen spec" flowing through the pipelines @@ -3420,7 +3688,8 @@ krigingOutlierQc <- function( # `pipCutoffToSkip`) OR a resolved screen object `list(metric, cutoff)`. # .asScreen() canonicalizes either into `list(metric, cutoff)` or NULL (no # screen); the pipeline channels stay untyped so only the screen primitives need -# to interpret the spec. +# to interpret the spec. SignalScreenParam() is what the public entry points +# take; .screenResolve() turns one into the spec described above. # Canonicalize a screen spec into list(metric, cutoff) or NULL (no screen). .asScreen <- function(spec) { @@ -3447,95 +3716,6 @@ krigingOutlierQc <- function( list(metric = "pip", cutoff = as.numeric(spec)) } -# Turn the four public cutoff arguments into a single screen object (or NULL). -# Enforces one-metric-at-a-time and rejects meaningless negative cutoffs. The -# pip metric keeps its `< 0 => 3 / nVariants` adaptive convention (resolved at -# screen time); absZ / bf must be > 0; logBf may be any non-zero value. -.resolveScreenMetric <- function( - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0 -) { - scalar <- function(x) { - if (is.null(x) || length(x) != 1L || is.na(x)) 0 else as.numeric(x) - } - cuts <- c( - pip = scalar(pipCutoffToSkip), - absZ = scalar(absZCutoffToSkip), - bf = scalar(bfCutoffToSkip), - logBf = scalar(logBfCutoffToSkip) - ) - on <- cuts[cuts != 0] - if (length(on) == 0L) { - return(NULL) - } - if (length(on) > 1L) { - nonZero <- str_flatten(sprintf("%s=%g", names(on), on), collapse = ", ") - msg <- glue( - "Only one signal screen may be enabled at a time, but these ", - "are non-zero: {nonZero}. Set all but one of pipCutoffToSkip / ", - "absZCutoffToSkip / bfCutoffToSkip / logBfCutoffToSkip to 0." - ) - abort(msg) - } - metric <- names(on) - cutoff <- unname(on[[1L]]) - if (metric == "absZ" && cutoff < 0) { - abort("absZCutoffToSkip must be > 0 (it screens on max|Z|).") - } - if (metric == "bf" && cutoff < 0) { - abort("bfCutoffToSkip must be > 0 (Bayes factors are positive).") - } - list(metric = metric, cutoff = cutoff) -} - -# Decide whether the z-scores of one entry clear the chosen screen. Returns -# list(ok = logical, reason = character). susie_ser is fit at most once, and -# only for the metrics that need it (absZ stays model-free). -.entryScreenPass <- function(z, n, nVar, scr) { - metric <- scr$metric - cutoff <- scr$cutoff - if (metric == "absZ") { - m <- suppressWarnings(max(abs(as.numeric(z)), na.rm = TRUE)) - return(list( - ok = is.finite(m) && m > cutoff, - reason = sprintf( - "no variant with |Z| above %g (max |Z| = %g)", - cutoff, - m - ) - )) - } - ser <- susieR::susie_ser(z = z, n = n, coverage = NULL) - if (metric == "pip") { - eff <- if (cutoff < 0) 3 / nVar else cutoff - return(list( - ok = any(ser$pip > eff), - reason = sprintf("no signals above PIP threshold %g", eff) - )) - } - maxLbf <- suppressWarnings(max(as.numeric(ser$lbf_variable), na.rm = TRUE)) - if (metric == "logBf") { - return(list( - ok = is.finite(maxLbf) && maxLbf > cutoff, - reason = sprintf( - "no variant with logBF above %g (max logBF = %g)", - cutoff, - maxLbf - ) - )) - } - # metric == "bf": compare in log space to avoid overflow of exp(maxLbf). - list( - ok = is.finite(maxLbf) && maxLbf > log(cutoff), - reason = sprintf( - "no variant with BF above %g (max BF = %g)", - cutoff, - exp(maxLbf) - ) - ) -} # Per-entry signal screen. `screen` is a screen spec (see .asScreen). Skips # (empties) the entry when the chosen metric shows no signal above its cutoff. @@ -3608,16 +3788,25 @@ krigingOutlierQc <- function( return(list(df = df, nSource = "column")) } if (f$hasCols) { - df$N <- as.numeric(df$N_CASE) + as.numeric(df$N_CONTROL) - return(list(df = df, nSource = "total")) + return(list( + df = mutate( + df, + N = as.numeric(.data$N_CASE) + as.numeric(.data$N_CONTROL) + ), + nSource = "total" + )) } if (f$hasScalar) { - df$N <- rep(opts$nCase + opts$nControl, f$nRow) - return(list(df = df, nSource = "total")) + return(list( + df = mutate(df, N = rep(opts$nCase + opts$nControl, f$nRow)), + nSource = "total" + )) } if (f$hasNSample) { - df$N <- rep(opts$nSample, f$nRow) - return(list(df = df, nSource = "study-n")) + return(list( + df = mutate(df, N = rep(opts$nSample, f$nRow)), + nSource = "study-n" + )) } list(df = df, nSource = NA_character_) } @@ -3632,8 +3821,10 @@ krigingOutlierQc <- function( "n_case/n_control." ) } - df$N <- effectiveN(df$N_CASE, df$N_CONTROL) - return(list(df = df, nSource = "effective")) + return(list( + df = mutate(df, N = effectiveN(.data$N_CASE, .data$N_CONTROL)), + nSource = "effective" + )) } if (f$hasScalar) { if (f$hasN) { @@ -3643,15 +3834,22 @@ krigingOutlierQc <- function( "nCase/nControl." ) } - df$N <- rep(effectiveN(opts$nCase, opts$nControl), f$nRow) - return(list(df = df, nSource = "effective")) + return(list( + df = mutate( + df, + N = rep(effectiveN(opts$nCase, opts$nControl), f$nRow) + ), + nSource = "effective" + )) } if (f$hasN) { return(list(df = df, nSource = "column")) } if (f$hasNSample) { - df$N <- rep(opts$nSample, f$nRow) - return(list(df = df, nSource = "study-n")) + return(list( + df = mutate(df, N = rep(opts$nSample, f$nRow)), + nSource = "study-n" + )) } list(df = df, nSource = NA_character_) } @@ -3700,6 +3898,10 @@ krigingOutlierQc <- function( # frame, plus whichever of N / BETA / SE the caller carries, sorted by position # to match the reference panel. # @noRd +.qcRaissNumericColumn <- function(nm, df) { + as.numeric(df[[nm]]) +} + .qcRaissKnownZ <- function(df) { knownVariantIds <- if (!is.null(df$SNP)) { as.character(df$SNP) @@ -3719,43 +3921,45 @@ krigingOutlierQc <- function( # merged output so the imputed rows sit in the same frame as the known # ones. optional <- c(N = "n", BETA = "beta", SE = "se") - for (nm in names(optional)) { - if (is_in(nm, colnames(df))) { - knownZ[[optional[[nm]]]] <- as.numeric(df[[nm]]) - } - } - arrange(knownZ, .data$pos) + present <- optional[is_in(names(optional), colnames(df))] + extras <- set_names( + map(names(present), .qcRaissNumericColumn, df = df), + unname(present) + ) + knownZ |> mutate(!!!extras) |> arrange(.data$pos) } .qcRaissBuildInputs <- function(df, ldSketch, windowIdx, opts) { - refPanel <- .refVariantsFromSketch(ldSketch)[windowIdx, , drop = FALSE] - refPanel$variant_id <- normalizeVariantId(refPanel$variant_id) - refPanel <- arrange(refPanel, .data$pos) + windowPanel <- .refVariantsFromSketch(ldSketch)[ + windowIdx, + , + drop = FALSE + ] |> + mutate(variant_id = normalizeVariantId(.data$variant_id)) |> + arrange(.data$pos) knownZ <- .qcRaissKnownZ(df) # meanImpute = FALSE so per-variant missingness is still visible; the # surviving columns are mean-imputed below, which is what meanImpute = # TRUE did. - dosage <- .ldSketchDosage(ldSketch, windowIdx, meanImpute = FALSE) - colnames(dosage) <- normalizeVariantId( - .ldSketchMatchIds(ldSketch)[windowIdx] - ) - dosage <- dosage[, refPanel$variant_id, drop = FALSE] - keep <- .qcRaissTargetMask(refPanel, knownZ, dosage, opts) - nDropped <- sum(!keep) - refPanel <- refPanel[keep, , drop = FALSE] - dosage <- dosage[, keep, drop = FALSE] - scaledDosage <- scale(.qtlMeanImpute(dosage)) - scaledDosage[is.na(scaledDosage)] <- 0 + windowDosage <- `colnames<-`( + .ldSketchDosage(ldSketch, windowIdx, meanImpute = FALSE), + normalizeVariantId(.ldSketchMatchIds(ldSketch)[windowIdx]) + ) + windowed <- windowDosage[, windowPanel$variant_id, drop = FALSE] + keep <- .qcRaissTargetMask(windowPanel, knownZ, windowed, opts) + refPanel <- windowPanel[keep, , drop = FALSE] + scaled <- scale(.qtlMeanImpute(windowed[, keep, drop = FALSE])) + scaledDosage <- replace(scaled, is.na(scaled), 0) list( refPanel = refPanel, knownZ = knownZ, scaledDosage = scaledDosage, - nDroppedTargets = nDropped + nDroppedTargets = sum(!keep) ) } # Which reference-panel variants to keep, given the MAF / MAC / missingness -# cutoffs in `imputeOpts`. +# cutoffs in `imputeArgs`. # # The cutoffs govern what RAISS is willing to IMPUTE, not what it is willing to # keep, so an observed variant survives whatever its frequency in the LD panel. @@ -3769,9 +3973,9 @@ krigingOutlierQc <- function( # study is much smaller than the panel. # @noRd .qcRaissTargetMask <- function(refPanel, knownZ, dosage, opts) { - mafCutoff <- opts$imputeOpts$mafCutoff %||% 0 - macCutoff <- opts$imputeOpts$macCutoff %||% 0 - imissCutoff <- opts$imputeOpts$imissCutoff %||% 1 + mafCutoff <- opts$imputeArgs$mafCutoff + macCutoff <- opts$imputeArgs$macCutoff + imissCutoff <- opts$imputeArgs$imissCutoff keep <- rep(TRUE, nrow(refPanel)) if (mafCutoff <= 0 && macCutoff <= 0 && imissCutoff >= 1) { return(keep) @@ -3802,17 +4006,30 @@ krigingOutlierQc <- function( .panelVariantStats(dosage) } + +# RaissParam() covers two audiences: four fields are raiss()'s own formals and +# four bound what RAISS is asked to impute. Splitting the bundle here lets the +# call site splice rather than name each field, and keeps the two groups from +# being confused for one another. +# @noRd +.raissForwardedNames <- function() { + c("lamb", "svdTol", "r2Threshold", "minimumLd") +} + +# @noRd +.raissForwardedArgs <- function(imputeArgs) { + as.list(imputeArgs)[.raissForwardedNames()] +} + # Run RAISS with per-call option defaults. .qcRaissRun <- function(inp, opts) { - raiss( + exec( + raiss, refPanel = inp$refPanel, knownZscores = inp$knownZ, genotypeMatrix = inp$scaledDosage, - svdTol = opts$imputeOpts$svdTol %||% 1e-12, - lamb = opts$imputeOpts$lamb %||% 0.01, - r2Threshold = opts$imputeOpts$r2Threshold %||% 0.6, - minimumLd = opts$imputeOpts$minimumLd %||% 5, - verbose = FALSE + verbose = FALSE, + !!!.raissForwardedArgs(opts$imputeArgs) ) } @@ -3822,38 +4039,45 @@ krigingOutlierQc <- function( return(list(df = df, total = NA_integer_, imputed = 0L)) } impDf <- imputed$resultFilter - out <- tibble( - chrom = impDf$chrom, - pos = impDf$pos, - SNP = impDf$variant_id, - A1 = impDf$A1, - A2 = impDf$A2, - Z = impDf$z + rebuilt <- mutate( + tibble( + chrom = impDf$chrom, + pos = impDf$pos, + SNP = impDf$variant_id, + A1 = impDf$A1, + A2 = impDf$A2, + Z = impDf$z + ), + !!!compact(list( + N = if (is_in("n", colnames(impDf))) impDf$n, + BETA = if (is_in("beta", colnames(impDf))) impDf$beta, + SE = if (is_in("se", colnames(impDf))) impDf$se + )) ) - if (is_in("n", colnames(impDf))) { - out$N <- impDf$n - } - if (is_in("beta", colnames(impDf))) { - out$BETA <- impDf$beta - } - if (is_in("se", colnames(impDf))) { - out$SE <- impDf$se - } # RAISS reconstructs the z-score only, so it has no frequency for an # imputed variant. But the OBSERVED variants came in with a (harmonized, - # directional) AF, which the rebuilt `out` above would otherwise discard -- + # directional) AF, which the rebuilt frame above would otherwise discard -- # leaving top_loci$af NA for the whole entry under --impute. Re-attach it by # SNP so observed variants keep their AF and imputed variants (absent from # `df`) get NA. No-op when the study declared no frequency. - if (is_in("AF", colnames(df))) { - out$AF <- as.numeric(df$AF)[match(out$SNP, df$SNP)] - } - if (is_in("N", colnames(out)) && any(is.na(out$N))) { - out$N[is.na(out$N)] <- stats::median(out$N, na.rm = TRUE) + withAf <- if (is_in("AF", colnames(df))) { + mutate(rebuilt, AF = as.numeric(df$AF)[match(.data$SNP, df$SNP)]) + } else { + rebuilt } + out <- .qcFillMissingN(withAf) list(df = out, total = nrow(out), imputed = nrow(out) - nrow(knownZ)) } +# Imputed variants carry no sample size, so they inherit the observed median. +# @noRd +.qcFillMissingN <- function(out) { + if (!is_in("N", colnames(out)) || !any(is.na(out$N))) { + return(out) + } + mutate(out, N = replace_na(.data$N, stats::median(.data$N, na.rm = TRUE))) +} + # Emit the RAISS net-change QC track line. .qcRaissReport <- function(imputeBefore, imputeAfter, lbl) { .qcEmit( @@ -3899,12 +4123,7 @@ krigingOutlierQc <- function( # fields + before/after counts (imputation adds variants, so not monotonic). .qcRaissImpute <- function(df, ldSketch, opts, lbl) { imputeBefore <- nrow(df) - audit <- list() - flank <- if (is.null(opts$imputeOpts$flank)) { - 0L - } else { - as.integer(opts$imputeOpts$flank) - } + flank <- as.integer(opts$imputeArgs$flank) windowIdx <- .qcRaissWindowIdx(df, ldSketch, flank) if (length(windowIdx) == 0L) { .qcEmit( @@ -3913,10 +4132,9 @@ krigingOutlierQc <- function( "(no LD-panel variants in the ", "region window)." ) - audit$raissImputedVariants <- 0L return(list( df = df, - audit = audit, + audit = list(raissImputedVariants = 0L), imputeBefore = imputeBefore, imputeAfter = nrow(df) )) @@ -3933,10 +4151,12 @@ krigingOutlierQc <- function( imputed <- .qcRaissRun(inp, opts) merged <- .qcRaissMerge(imputed, inp$knownZ, df) df <- merged$df - if (!is.na(merged$total)) { - audit$raissTotalVariants <- merged$total - } - audit$raissImputedVariants <- merged$imputed + audit <- c( + .qcAudit( + raissTotalVariants = if (!is.na(merged$total)) merged$total + ), + list(raissImputedVariants = merged$imputed) + ) imputeAfter <- nrow(df) .qcRaissReport(imputeBefore, imputeAfter, lbl) list( @@ -3958,7 +4178,7 @@ krigingOutlierQc <- function( .qcRemovedSegments <- function(entryAudit, qcCount, opts) { sc <- entryAudit$sanityChecks cf <- entryAudit$contentFilters - segs <- c( + c( .qcSeg(sc$nonstandardChrDropped, "nonstdChr"), .qcSeg(sc$missDataDropped, "missData"), .qcSeg(sc$pOutOfRangeDropped, "badP"), @@ -3967,12 +4187,11 @@ krigingOutlierQc <- function( .qcSeg(cf$mafDropped, "maf"), .qcSeg(cf$infoDropped, "info"), .qcSeg(cf$nDropped, "nCutoff"), - .qcSeg(qcCount$harmDropped, "harmonization") + .qcSeg(qcCount$harmDropped, "harmonization"), + if (!identical(.engineOf(opts$ldMismatchQcMethod), "none")) { + str_c("mismatch ", qcCount$mismatchRemoved) + } ) - if (!identical(opts$zMismatchQc, "none")) { - segs <- c(segs, str_c("mismatch ", qcCount$mismatchRemoved)) - } - segs } # Emit the per-entry QC rollup: corrected (retained), removed, imputed. @@ -3982,15 +4201,13 @@ krigingOutlierQc <- function( "sign-flip ", qcCount$harmCorrSign, ", strand-flip ", - qcCount$harmCorrStrand + qcCount$harmCorrStrand, + if (isTRUE(opts$alleleFlipKriging)) { + str_c(", kriging-flip ", qcCount$krigingFlipped) + } else { + "" + } ) - if (isTRUE(opts$alleleFlipKriging)) { - correctedSeg <- str_c( - correctedSeg, - ", kriging-flip ", - qcCount$krigingFlipped - ) - } impSeg <- if (isTRUE(opts$impute) && !is.na(qcCount$imputeAfter)) { str_c( " | imputed ", @@ -4022,35 +4239,43 @@ krigingOutlierQc <- function( # Panel-vs-sumstats allele harmonization + counter bookkeeping. .qcHarmonizeEntry <- function(df, ldSketch, opts, lbl) { nHarmIn <- nrow(df) - df <- .matchAgainstSketch( + matched <- .matchAgainstSketch( df, ldSketch, matchMinProp = opts$matchMinProp, - removeIndels = opts$removeIndels, - removeStrandAmbiguous = opts$removeStrandAmbiguous, + removeIndels = opts$sumstatsFilterArgs$removeIndels, + removeStrandAmbiguous = opts$sumstatsFilterArgs$removeStrandAmbiguous, removeDups = TRUE ) - harmCounts <- attr(df, "qcCounts") - attr(df, "qcCounts") <- NULL + harmCounts <- attr(matched, "qcCounts") # Re-key SNP to the harmonized id: .matchAgainstSketch rewrites variant_id # to the panel orientation + sign-flips swapped variants but leaves SNP; a # stale SNP makes flipped variants miss the panel in later lookups. - if (!is.null(df$variant_id)) { - df$SNP <- df$variant_id - } - counts <- list( - harmCorrSign = 0L, - harmCorrStrand = 0L, - harmDropped = nHarmIn - nrow(df) + reKeyed <- mutate( + `attr<-`(matched, "qcCounts", NULL), + !!!compact(list(SNP = matched$variant_id)) + ) + counts <- list_assign( + list( + harmCorrSign = 0L, + harmCorrStrand = 0L, + harmDropped = nHarmIn - nrow(reKeyed) + ), + !!!compact(list( + harmCorrSign = harmCounts$signFlip, + harmCorrStrand = harmCounts$strandFlip + )) + ) + .qcHarmonizeReport( + nrow(reKeyed), + nHarmIn, + counts, + !is.null(harmCounts), + lbl ) - if (!is.null(harmCounts)) { - counts$harmCorrSign <- harmCounts$signFlip - counts$harmCorrStrand <- harmCounts$strandFlip - } - .qcHarmonizeReport(nrow(df), nHarmIn, counts, !is.null(harmCounts), lbl) list( - df = df, - audit = list(matchedAgainstSketch = nrow(df)), + df = reKeyed, + audit = list(matchedAgainstSketch = nrow(reKeyed)), counts = counts ) } @@ -4091,11 +4316,15 @@ krigingOutlierQc <- function( if (!any(flip)) { return(df) } - df$Z[flip] <- -df$Z[flip] - if (is_in("BETA", colnames(df))) { - df$BETA[flip] <- -df$BETA[flip] - } - df + mutate( + df, + Z = replace(.data$Z, flip, -df$Z[flip]), + !!!compact(list( + BETA = if (is_in("BETA", colnames(df))) { + replace(df$BETA, flip, -df$BETA[flip]) + } + )) + ) } # @noRd @@ -4116,17 +4345,17 @@ krigingOutlierQc <- function( audit = list(krigingFlipped = 0L, panelUnsupportedDropped = nKrIn) )) } - df <- panel$df + supported <- panel$df nPanelDrop <- panel$dropped .qcEmitPanelDrop(lbl, nPanelDrop, nKrIn) kr <- krigingOutlierQc( - df$Z, + supported$Z, panel$R, - n = .qcKrigingN(df, opts), - variantIds = df$SNP + n = .qcKrigingN(supported, opts), + variantIds = supported$SNP ) nKr <- sum(kr$flip) - df <- .qcApplyKrigingFlips(df, kr$flip) + flipped <- .qcApplyKrigingFlips(supported, kr$flip) .qcEmit( lbl, "QC track: kriging sign-flipped ", @@ -4136,7 +4365,7 @@ krigingOutlierQc <- function( " LD-inconsistent variant(s)." ) list( - df = df, + df = flipped, count = nKr, audit = list( krigingFlipped = nKr, @@ -4148,19 +4377,28 @@ krigingOutlierQc <- function( # LD-mismatch QC (SLALOM / DENTIST). Retains full per-variant diagnostics. .qcMismatchQc <- function(df, ldSketch, opts, lbl) { - if (identical(opts$zMismatchQc, "none") || nrow(df) < 2L) { + if ( + identical(.engineOf(opts$ldMismatchQcMethod), "none") || + nrow(df) < 2L + ) { return(list(df = df, audit = list(), count = 0L)) } nMmIn <- nrow(df) - ldQc <- .applyLdMismatchQcToEntry(df, ldSketch, opts$zMismatchQc) + ldQc <- .applyLdMismatchQcToEntry(df, ldSketch, opts$ldMismatchQcMethod) df <- ldQc$df - audit <- list( + baseAudit <- list( ldMismatchOutliersDropped = ldQc$outliers, - ldMismatchMethod = opts$zMismatchQc + ldMismatchMethod = .engineOf(opts$ldMismatchQcMethod) ) nPanelDrop <- ldQc$panelUnsupportedDropped %||% 0L + audit <- c( + baseAudit, + .qcAudit( + panelUnsupportedDropped = if (nPanelDrop > 0L) nPanelDrop, + ldMismatchDiagnostics = ldQc$diagnostics + ) + ) if (nPanelDrop > 0L) { - audit$panelUnsupportedDropped <- nPanelDrop .qcEmit( lbl, "QC track: dropped ", @@ -4170,13 +4408,10 @@ krigingOutlierQc <- function( " variant(s) with no LD-panel entry after panel filtering." ) } - if (!is.null(ldQc$diagnostics)) { - audit$ldMismatchDiagnostics <- ldQc$diagnostics - } .qcEmit( lbl, "QC track: ", - opts$zMismatchQc, + .engineOf(opts$ldMismatchQcMethod), " removed ", ldQc$outliers, " of ", @@ -4217,23 +4452,14 @@ krigingOutlierQc <- function( # numeric coercion, CHR normalization, missing-data drop). Runs first. .qcStepSanity <- function(df, opts, lbl) { nSanIn <- nrow(df) - sanity <- .applySanityChecks( - df, - coerceNumeric = opts$coerceNumeric, - normalizeChr = opts$normalizeChr, - dropNonstandardChr = opts$dropNonstandardChr, - dropMissData = opts$dropMissData, - dropPOutOfRange = opts$dropPOutOfRange, - clampSmallP = opts$clampSmallP, - smallPFloor = opts$smallPFloor, - dropZeroEffect = opts$dropZeroEffect, - dropNonpositiveSe = opts$dropNonpositiveSe - ) + # The boundary: the bundle travels this far, and .applySanityChecks and + # the per-check helpers below it keep plain scalars. + cleaning <- opts$sumstatsCleaningArgs + sanity <- exec(.applySanityChecks, df, !!!cleaning) df <- sanity$df - audit <- list() - if (length(sanity$audit) > 0L) { - audit$sanityChecks <- sanity$audit - } + audit <- .qcAudit( + sanityChecks = if (length(sanity$audit) > 0L) sanity$audit + ) if (nSanIn > 0L && nrow(df) != nSanIn) { .qcEmit( lbl, @@ -4252,29 +4478,39 @@ krigingOutlierQc <- function( .qcStepEffectiveN <- function(df, opts, lbl) { nRes <- .resolveEffectiveN(df, opts, lbl) df <- nRes$df - if ( - isTRUE(is_in(nRes$nSource, c("effective", "total"))) && - is_in("N", colnames(df)) - ) { - opts$nForPip <- stats::median(as.numeric(df$N), na.rm = TRUE) - } - list(df = df, nSource = nRes$nSource, opts = opts) + applied <- isTRUE(is_in(nRes$nSource, c("effective", "total"))) && + is_in("N", colnames(df)) + list( + df = df, + nSource = nRes$nSource, + opts = list_assign( + opts, + !!!compact(list( + nForPip = if (applied) { + stats::median(as.numeric(df$N), na.rm = TRUE) + } + )) + ) + ) } # Variant-content filters (MAF / INFO / N). .qcStepContentFilters <- function(df, opts, lbl) { nFiltIn <- nrow(df) + # One mafCutoff drives two filters: the sumstats' own MAF column here, + # and the LD panel in .ssqcPrunePanel. It has always been a single knob, + # so it is read from panelFilter in both places rather than quietly + # becoming two separate settings. cf <- .applyContentFilters( df, - mafCutoff = opts$mafCutoff, - infoCutoff = opts$infoCutoff, - nCutoff = opts$nCutoff + mafCutoff = opts$panelFilterArgs$mafCutoff, + infoCutoff = opts$sumstatsFilterArgs$infoCutoff, + nCutoff = opts$sumstatsFilterArgs$nCutoff ) df <- cf$df - audit <- list() - if (length(cf$audit) > 0L) { - audit$contentFilters <- cf$audit - } + audit <- .qcAudit( + contentFilters = if (length(cf$audit) > 0L) cf$audit + ) if (nFiltIn > 0L && nrow(df) != nFiltIn) { .qcEmit( lbl, @@ -4291,110 +4527,282 @@ krigingOutlierQc <- function( # Derive BETA/SE from signed Z, then P from Z (re-clamping tiny P). .qcStepDerive <- function(df, opts, entryAudit) { derived <- .deriveBetaSeFromZ(df) - df <- derived$df - if (!is.null(derived$audit)) { - entryAudit$betaSeFromZ <- derived$audit - } - if (is_in("Z", colnames(df)) && !is_in("P", colnames(df))) { - df$P <- .zToPvalue(df$Z) - entryAudit$pValueFromZ <- sum(!is.na(df$P)) - if (isTRUE(opts$clampSmallP) && nrow(df) > 0L) { - smallMask <- !is.na(df$P) & df$P >= 0 & df$P < opts$smallPFloor - nClamped <- sum(smallMask) - if (nClamped > 0L) { - df$P[smallMask] <- opts$smallPFloor - prev <- entryAudit$sanityChecks$smallPClamped %||% 0L - if (is.null(entryAudit$sanityChecks)) { - entryAudit$sanityChecks <- list() - } - entryAudit$sanityChecks$smallPClamped <- prev + nClamped - } - } + withBetaSe <- list_assign( + entryAudit, + !!!compact(list(betaSeFromZ = derived$audit)) + ) + if (!is_in("Z", colnames(derived$df)) || is_in("P", colnames(derived$df))) { + return(list(df = derived$df, entryAudit = withBetaSe)) } - list(df = df, entryAudit = entryAudit) + withP <- mutate(derived$df, P = .zToPvalue(.data$Z)) + clamped <- .qcClampDerivedP(withP, opts) + list( + df = clamped$df, + entryAudit = list_assign( + withBetaSe, + pValueFromZ = sum(!is.na(withP$P)), + !!!compact(list( + sanityChecks = .qcAddClampCount( + entryAudit$sanityChecks, + clamped$nClamped + ) + )) + ) + ) +} + +# Re-clamp the P values just derived from Z, and report how many moved. +# @noRd +.qcClampDerivedP <- function(df, opts) { + cleaning <- opts$sumstatsCleaningArgs + if (!isTRUE(cleaning$clampSmallP) || nrow(df) == 0L) { + return(list(df = df, nClamped = 0L)) + } + floorP <- cleaning$smallPFloor + smallMask <- !is.na(df$P) & df$P >= 0 & df$P < floorP + if (sum(smallMask) == 0L) { + return(list(df = df, nClamped = 0L)) + } + list( + df = mutate(df, P = replace(.data$P, smallMask, floorP)), + nClamped = sum(smallMask) + ) +} + +# Fold this step's clamp count into the sanity-check record the earlier +# per-row checks may already have written. NULL when nothing was clamped, so +# the caller can drop the key rather than record an empty record. +# @noRd +.qcAddClampCount <- function(sanityChecks, nClamped) { + if (nClamped == 0L) { + return(NULL) + } + list_assign( + sanityChecks %||% list(), + smallPClamped = (sanityChecks$smallPClamped %||% 0L) + nClamped + ) } # keepVariants subset + skipRegion drop. .qcStepKeepSkip <- function(df, opts) { - audit <- list() - if (length(opts$keepVariants) > 0L) { - before <- nrow(df) - df <- filter(df, is_in(.data$SNP, opts$keepVariants)) - audit$keepVariantsDropped <- before - nrow(df) + nIn <- nrow(df) + kept <- if (length(opts$keepVariants) > 0L) { + filter(df, is_in(.data$SNP, opts$keepVariants)) + } else { + df } - if (!is.null(opts$skipRegion) && length(opts$skipRegion) > 0L) { - before <- nrow(df) - df <- .applySkipRegion(df, opts$skipRegion) - audit$skipRegionDropped <- before - nrow(df) + nKept <- nrow(kept) + skipped <- if (!is.null(opts$skipRegion) && length(opts$skipRegion) > 0L) { + .applySkipRegion(kept, opts$skipRegion) + } else { + kept } - list(df = df, audit = audit) + list( + df = skipped, + audit = .qcAudit( + keepVariantsDropped = if (length(opts$keepVariants) > 0L) { + nIn - nKept + }, + skipRegionDropped = if ( + !is.null(opts$skipRegion) && length(opts$skipRegion) > 0L + ) { + nKept - nrow(skipped) + } + ) + ) } # Optional post-harmonization signal screen (PIP / |Z| / BF / logBF). .qcStepScreen <- function(df, opts) { - audit <- list() - if (!is.null(opts$screen)) { - scr <- .applyEntryScreen(df, n = opts$nForPip, screen = opts$screen) - df <- scr$df - audit$pipScreenSkipped <- isTRUE(scr$skipped) - if (isTRUE(scr$skipped)) audit$pipScreenReason <- scr$reason + if (is.null(opts$screen)) { + return(list(df = df, audit = list())) } - list(df = df, audit = audit) + scr <- .applyEntryScreen(df, n = opts$nForPip, screen = opts$screen) + list( + df = scr$df, + audit = c( + list(pipScreenSkipped = isTRUE(scr$skipped)), + .qcAudit(pipScreenReason = if (isTRUE(scr$skipped)) scr$reason) + ) + ) } # Optional RAISS imputation step wrapper (guarded; threads impute counters). .qcRaissImputeStep <- function(df, ldSketch, opts, lbl, qcCount) { - audit <- list() - if (isTRUE(opts$impute) && nrow(df) >= 1L) { - imp <- .qcRaissImpute(df, ldSketch, opts, lbl) - df <- imp$df - audit <- imp$audit - qcCount$imputeBefore <- imp$imputeBefore - qcCount$imputeAfter <- imp$imputeAfter + if (!isTRUE(opts$impute) || nrow(df) < 1L) { + return(list(df = df, audit = list(), qcCount = qcCount)) } - list(df = df, audit = audit, qcCount = qcCount) + imp <- .qcRaissImpute(df, ldSketch, opts, lbl) + list( + df = imp$df, + audit = imp$audit, + qcCount = list_assign( + qcCount, + imputeBefore = imp$imputeBefore, + imputeAfter = imp$imputeAfter + ) + ) } # Early return when too few variants survive pre-harmonization QC. .qcEarlyExit <- function(df, entryAudit, qcCount, opts, nIn, lbl) { - entryAudit$earlyExit <- - "fewer than two variants after pre-harmonization QC" + withExit <- list_assign( + entryAudit, + earlyExit = "fewer than two variants after pre-harmonization QC" + ) # Still emit the rollup. An entry that QC empties is precisely the case a # user needs told about, and returning early used to make those drops # invisible in the log -- the audit recorded them, nothing said so. - .qcEmitRollup(entryAudit, qcCount, opts, nIn, nrow(df), lbl) - list(gr = .dfToEntryGranges(df), audit = entryAudit) + .qcEmitRollup(withExit, qcCount, opts, nIn, nrow(df), lbl) + list(gr = .dfToEntryGranges(df), audit = withExit) +} + +# Each QC phase below is (state) -> state, so the sequence reads as a pipeline +# rather than a run of reassignments. `state` carries df + entryAudit + opts + +# qcCount + lbl (+ ldSketch for the panel-aware phases); a phase touches only +# the parts it owns and passes the rest through. + +# Per-row sanity checks. +# @noRd +.qcPhaseSanity <- function(state) { + san <- .qcStepSanity(state$df, state$opts, state$lbl) + list_assign( + state, + df = san$df, + entryAudit = list_modify(state$entryAudit, !!!san$audit) + ) +} + +# Effective-N canonicalization, which also rewrites `opts$nForPip`. +# @noRd +.qcPhaseEffectiveN <- function(state) { + eff <- .qcStepEffectiveN(state$df, state$opts, state$lbl) + list_assign( + state, + df = eff$df, + entryAudit = list_assign(state$entryAudit, nSource = eff$nSource), + opts = eff$opts + ) +} + +# MAF / INFO / N content filters. +# @noRd +.qcPhaseContentFilters <- function(state) { + cf <- .qcStepContentFilters(state$df, state$opts, state$lbl) + list_assign( + state, + df = cf$df, + entryAudit = list_modify(state$entryAudit, !!!cf$audit) + ) +} + +# BETA/SE from Z, then P from Z. Owns the audit outright (it folds its own +# clamp count into the sanity record the earlier phase may have written). +# @noRd +.qcPhaseDerive <- function(state) { + der <- .qcStepDerive(state$df, state$opts, state$entryAudit) + list_assign(state, df = der$df, entryAudit = der$entryAudit) +} + +# keepVariants subset + skipRegion drop. +# @noRd +.qcPhaseKeepSkip <- function(state) { + ks <- .qcStepKeepSkip(state$df, state$opts) + list_assign( + state, + df = ks$df, + entryAudit = list_modify(state$entryAudit, !!!ks$audit) + ) +} + +# Panel-vs-sumstats allele harmonization. +# @noRd +.qcPhaseHarmonize <- function(state) { + harm <- .qcHarmonizeEntry( + state$df, + state$ldSketch, + state$opts, + state$lbl + ) + list_assign( + state, + df = harm$df, + entryAudit = list_modify(state$entryAudit, !!!harm$audit), + qcCount = list_modify(state$qcCount, !!!harm$counts) + ) +} + +# Post-harmonization signal screen. +# @noRd +.qcPhaseScreen <- function(state) { + scr <- .qcStepScreen(state$df, state$opts) + list_assign( + state, + df = scr$df, + entryAudit = list_modify(state$entryAudit, !!!scr$audit) + ) +} + +# Kriging sign-flips and LD-mismatch QC. One phase, because the mismatch check +# reads the kriging-corrected frame and the two counts are reported together. +# @noRd +.qcPhaseLdChecks <- function(state) { + kr <- .qcKrigingFlip(state$df, state$ldSketch, state$opts, state$lbl) + mm <- .qcMismatchQc(kr$df, state$ldSketch, state$opts, state$lbl) + list_assign( + state, + df = mm$df, + entryAudit = list_modify( + list_modify(state$entryAudit, !!!kr$audit), + !!!mm$audit + ), + qcCount = list_assign( + state$qcCount, + krigingFlipped = kr$count, + mismatchRemoved = mm$count + ) + ) +} + +# Optional RAISS imputation. +# @noRd +.qcPhaseImpute <- function(state) { + imp <- .qcRaissImputeStep( + state$df, + state$ldSketch, + state$opts, + state$lbl, + state$qcCount + ) + list_assign( + state, + df = imp$df, + entryAudit = list_modify(state$entryAudit, !!!imp$audit), + qcCount = imp$qcCount + ) } # Pre-harmonization phase: init + sanity + effective-N + content + derive + # keep/skip. Returns the QC state carried into the harmonization phase. .qcPreHarmonize <- function(gr, opts, entryLabel) { init <- .qcInitEntry(gr, entryLabel) - df <- init$df - entryAudit <- init$entryAudit - lbl <- init$lbl - san <- .qcStepSanity(df, opts, lbl) - df <- san$df - entryAudit <- modifyList(entryAudit, san$audit) - eff <- .qcStepEffectiveN(df, opts, lbl) - df <- eff$df - entryAudit$nSource <- eff$nSource - opts <- eff$opts - cf <- .qcStepContentFilters(df, opts, lbl) - df <- cf$df - entryAudit <- modifyList(entryAudit, cf$audit) - der <- .qcStepDerive(df, opts, entryAudit) - df <- der$df - entryAudit <- der$entryAudit - ks <- .qcStepKeepSkip(df, opts) - df <- ks$df - entryAudit <- modifyList(entryAudit, ks$audit) - list( - df = df, - entryAudit = entryAudit, + final <- list( + df = init$df, + entryAudit = init$entryAudit, opts = opts, + lbl = init$lbl + ) |> + .qcPhaseSanity() |> + .qcPhaseEffectiveN() |> + .qcPhaseContentFilters() |> + .qcPhaseDerive() |> + .qcPhaseKeepSkip() + list( + df = final$df, + entryAudit = final$entryAudit, + opts = final$opts, qcCount = init$qcCount, - lbl = lbl, + lbl = final$lbl, nStudyIn = init$nStudyIn ) } @@ -4402,41 +4810,44 @@ krigingOutlierQc <- function( .runEntrySummaryStatsQc <- function( gr, ldSketch, - refGenome, opts, entryLabel = NULL ) { pre <- .qcPreHarmonize(gr, opts, entryLabel) - df <- pre$df - entryAudit <- pre$entryAudit - opts <- pre$opts - qcCount <- pre$qcCount - lbl <- pre$lbl - if (nrow(df) < 2L) { - return(.qcEarlyExit(df, entryAudit, qcCount, opts, length(gr), lbl)) - } - harm <- .qcHarmonizeEntry(df, ldSketch, opts, lbl) - df <- harm$df - entryAudit <- modifyList(entryAudit, harm$audit) - qcCount <- modifyList(qcCount, harm$counts) - scr <- .qcStepScreen(df, opts) - df <- scr$df - entryAudit <- modifyList(entryAudit, scr$audit) - kr <- .qcKrigingFlip(df, ldSketch, opts, lbl) - df <- kr$df - entryAudit <- modifyList(entryAudit, kr$audit) - qcCount$krigingFlipped <- kr$count - mm <- .qcMismatchQc(df, ldSketch, opts, lbl) - df <- mm$df - entryAudit <- modifyList(entryAudit, mm$audit) - qcCount$mismatchRemoved <- mm$count - imp <- .qcRaissImputeStep(df, ldSketch, opts, lbl, qcCount) - df <- imp$df - entryAudit <- modifyList(entryAudit, imp$audit) - qcCount <- imp$qcCount - .qcEmitRollup(entryAudit, qcCount, opts, pre$nStudyIn, nrow(df), lbl) - entryAudit$variantsOut <- nrow(df) - list(gr = .dfToEntryGranges(df), audit = entryAudit) + if (nrow(pre$df) < 2L) { + return(.qcEarlyExit( + pre$df, + pre$entryAudit, + pre$qcCount, + pre$opts, + length(gr), + pre$lbl + )) + } + final <- list( + df = pre$df, + entryAudit = pre$entryAudit, + qcCount = pre$qcCount, + opts = pre$opts, + lbl = pre$lbl, + ldSketch = ldSketch + ) |> + .qcPhaseHarmonize() |> + .qcPhaseScreen() |> + .qcPhaseLdChecks() |> + .qcPhaseImpute() + .qcEmitRollup( + final$entryAudit, + final$qcCount, + final$opts, + pre$nStudyIn, + nrow(final$df), + final$lbl + ) + list( + gr = .dfToEntryGranges(final$df), + audit = list_assign(final$entryAudit, variantsOut = nrow(final$df)) + ) } # Shrink an LD-sketch GenotypeHandle to the panel variants inside the summary @@ -4457,11 +4868,11 @@ krigingOutlierQc <- function( if (is.null(ldSketch)) { return(NULL) } - chrom <- unlist(map(entries, .entryChrom), use.names = FALSE) - pos <- unlist(map(entries, .entryPos), use.names = FALSE) - ok <- !is.na(chrom) & !is.na(pos) - chrom <- chrom[ok] - pos <- pos[ok] + chromAll <- unname(list_c(map(entries, .entryChrom))) + posAll <- unname(list_c(map(entries, .entryPos))) + ok <- !is.na(chromAll) & !is.na(posAll) + chrom <- chromAll[ok] + pos <- posAll[ok] if (length(pos) == 0L) { # No span to keep: a zero-variant object references no LD, so the # retained panel is empty rather than the full genome-wide sketch. @@ -4508,7 +4919,7 @@ krigingOutlierQc <- function( if (nRanges == 0L) { return(.emptySketch(ldSketch)) } - ids <- unlist(map(entries, .entrySnpIds), use.names = FALSE) + ids <- unname(list_c(map(entries, .entrySnpIds))) if (length(ids) == 0L) { return(ldSketch) } @@ -4533,13 +4944,9 @@ krigingOutlierQc <- function( # --- summaryStatsQc orchestration helpers ---------------------------------- # Validate input class + per-entry MAF/INFO column availability. -.ssqcCheckEntries <- function(sumstats, mafCutoff, infoCutoff) { - if ( - !methods::is(sumstats, "QtlSumStats") && - !methods::is(sumstats, "GwasSumStats") - ) { - abort("summaryStatsQc requires a QtlSumStats or GwasSumStats input.") - } +#' @importFrom checkmate assertMultiClass +.ssqcCheckEntries <- function(sumstats, infoCutoff) { + assertMultiClass(sumstats, c("QtlSumStats", "GwasSumStats")) for (i in seq_len(nrow(sumstats))) { cols <- colnames(S4Vectors::mcols(.collectionEntry(sumstats, i))) # mafCutoff no longer pre-aborts on a missing frequency: .cfMaf @@ -4564,13 +4971,10 @@ krigingOutlierQc <- function( # Shape-check the panel-filter trio. Runs before the panel is opened, so a # malformed cutoff fails on the call rather than after a dosage read. # @noRd -.ssqcCheckPanelCutoffs <- function(mafCutoff, macCutoff, imissCutoff) { - cutoffs <- list( - mafCutoff = mafCutoff, - macCutoff = macCutoff, - imissCutoff = imissCutoff - ) - bad <- names(cutoffs)[!map_lgl(cutoffs, .ssqcIsCutoff)] +.ssqcCheckPanelCutoffs <- function(panelFilterArgs) { + bad <- names(panelFilterArgs)[ + !map_lgl(as.list(panelFilterArgs), .ssqcIsCutoff) + ] if (length(bad) > 0L) { msg <- glue( "summaryStatsQc: {str_flatten(bad, ', ')} must each be a single ", @@ -4582,70 +4986,64 @@ krigingOutlierQc <- function( } # Build the per-entry QC options list from the captured call parameters. -.ssqcBuildOpts <- function(p) { - optNames <- c( - "removeIndels", - "removeStrandAmbiguous", - "mafCutoff", - "macCutoff", - "imissCutoff", - "infoCutoff", - "nCutoff", - "skipRegion", - "zMismatchQc", - "alleleFlipKriging", - "effectiveN", - "impute", - "imputeOpts", - "matchMinProp", - "coerceNumeric", - "normalizeChr", - "dropNonstandardChr", - "dropMissData", - "dropPOutOfRange", - "clampSmallP", - "smallPFloor", - "dropZeroEffect", - "dropNonpositiveSe" - ) - opts <- p[optNames] - opts$keepVariants <- as.character(p$keepVariants) - opts$screen <- .resolveScreenMetric( - p$pipCutoffToSkip, - p$absZCutoffToSkip, - p$bfCutoffToSkip, - p$logBfCutoffToSkip - ) - opts$nCase <- NULL - opts$nControl <- NULL - opts$nForPip <- NULL - opts +.ssqcBuildOpts <- function( + sumstatsFilterArgs, + panelFilterArgs, + skipRegion, + ldMismatchQcMethod, + alleleFlipKriging, + effectiveN, + impute, + imputeArgs, + matchMinProp, + sumstatsCleaningArgs, + keepVariants, + signalScreenArgs +) { + # Built explicitly rather than by subsetting a captured environment with a + # character vector: a renamed argument is now an error, not a NULL entry. + opts <- list( + sumstatsFilterArgs = sumstatsFilterArgs, + panelFilterArgs = panelFilterArgs, + skipRegion = skipRegion, + ldMismatchQcMethod = ldMismatchQcMethod, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + imputeArgs = imputeArgs, + matchMinProp = matchMinProp, + sumstatsCleaningArgs = sumstatsCleaningArgs + ) + # nCase / nControl / nForPip are deliberately absent here: they are + # per-entry, and `.ssqcEntryOpts()` adds them for the entry being run. + list_assign( + opts, + keepVariants = as.character(keepVariants), + screen = .screenResolve(signalScreenArgs) + ) } # Per-entry sample-size options: median N for PIP, study case/control/total N. .ssqcEntryOpts <- function(opts, sumstats, i) { mc <- S4Vectors::mcols(.collectionEntry(sumstats, i)) - opts$nForPip <- if (is_in("N", colnames(mc))) { - stats::median(mc$N, na.rm = TRUE) - } else { - NULL - } - opts$nCase <- if (is_in("nCase", .tupleColumnNames(sumstats))) { - as.numeric(sumstats$nCase)[[i]] - } else { - NULL - } - opts$nControl <- if (is_in("nControl", .tupleColumnNames(sumstats))) { - as.numeric(sumstats$nControl)[[i]] - } else { - NULL - } - opts$nSample <- if (is_in("nSample", .tupleColumnNames(sumstats))) { - as.numeric(sumstats$nSample)[[i]] - } else { - NULL - } - opts + cols <- .tupleColumnNames(sumstats) + list_assign( + opts, + !!!compact(list( + nForPip = if (is_in("N", colnames(mc))) { + stats::median(mc$N, na.rm = TRUE) + }, + nCase = if (is_in("nCase", cols)) { + as.numeric(sumstats$nCase)[[i]] + }, + nControl = if (is_in("nControl", cols)) { + as.numeric(sumstats$nControl)[[i]] + }, + nSample = if (is_in("nSample", cols)) { + as.numeric(sumstats$nSample)[[i]] + } + )) + ) } # Per-entry log label: study/context/trait (QTL) or study (GWAS). @@ -4694,70 +5092,101 @@ krigingOutlierQc <- function( .genotypeExperiment(pruned) } +# One entry's QC result: list(gr, audit). `opts` arrives as the shared base +# options; the per-entry fields are derived here rather than carried over from +# the previous entry. +# @noRd +.ssqcRunEntry <- function(i, sumstats, opts, ldSketch, isQtl) { + .runEntrySummaryStatsQc( + gr = .collectionEntry(sumstats, i), + ldSketch = ldSketch, + opts = .ssqcEntryOpts(opts, sumstats, i), + entryLabel = .ssqcEntryLabel(sumstats, i, isQtl) + ) +} + # Run the per-entry QC pipeline across all entries. .ssqcRunEntries <- function(sumstats, opts) { - newEntries <- vector("list", nrow(sumstats)) - entryAudits <- vector("list", nrow(sumstats)) isQtl <- methods::is(sumstats, "QtlSumStats") # Panel filter, once for the shared LD reference and BEFORE any entry is # harmonized, so a variant the panel cannot support is gone from the LD # and from the summary statistics alike. ldSketch <- .ssqcPrunePanel( getLdSketch(sumstats), - .panelCutoffs(opts), + .panelCutoffs(opts$panelFilterArgs), "summaryStatsQc" ) refGenome <- getGenome(sumstats) - for (i in seq_len(nrow(sumstats))) { - opts <- .ssqcEntryOpts(opts, sumstats, i) - result <- .runEntrySummaryStatsQc( - gr = .collectionEntry(sumstats, i), - ldSketch = ldSketch, - refGenome = refGenome, - opts = opts, - entryLabel = .ssqcEntryLabel(sumstats, i, isQtl) - ) - newEntries[[i]] <- result$gr - entryAudits[[i]] <- result$audit - } + results <- map( + seq_len(nrow(sumstats)), + .ssqcRunEntry, + sumstats = sumstats, + opts = opts, + ldSketch = ldSketch, + isQtl = isQtl + ) list( - newEntries = newEntries, - entryAudits = entryAudits, + newEntries = map(results, "gr"), + entryAudits = map(results, "audit"), ldSketch = ldSketch ) } +# One screen metric's cutoff as qcInfo echoes it. The bundle leaves an unset +# metric absent; the echoed record has always spelled "off" as 0, and readers +# like getQcDiagnostics() index these four names, so the output shape is kept +# even though the input is now one argument. +# @noRd +.ssqcScreenEcho <- function(signalScreenArgs, metric) { + signalScreenArgs[[metric]] %||% 0 +} + # Assemble the qcInfo record (echoed options + per-entry audits). -.ssqcBuildQcInfo <- function(p, entryAudits) { - optNames <- c( - "removeIndels", - "removeStrandAmbiguous", - "mafCutoff", - "macCutoff", - "imissCutoff", - "infoCutoff", - "nCutoff", - "pipCutoffToSkip", - "absZCutoffToSkip", - "bfCutoffToSkip", - "logBfCutoffToSkip", - "zMismatchQc", - "alleleFlipKriging", - "effectiveN", - "impute", - "coerceNumeric", - "normalizeChr", - "dropNonstandardChr", - "dropMissData", - "dropPOutOfRange", - "clampSmallP", - "smallPFloor", - "dropZeroEffect", - "dropNonpositiveSe" - ) +.ssqcBuildQcInfo <- function( + entryAudits, + sumstatsFilterArgs, + panelFilterArgs, + signalScreenArgs, + ldMismatchQcMethod, + alleleFlipKriging, + effectiveN, + impute, + sumstatsCleaningArgs +) { list( timestamp = NA_character_, - options = p[optNames], + # Echoed FLAT, not nested: this record is part of the returned + # object's shape, which readers like getQcDiagnostics() index by + # these names. The bundles are an argument convention, not an + # output one. + options = list( + removeIndels = sumstatsFilterArgs$removeIndels, + removeStrandAmbiguous = sumstatsFilterArgs$removeStrandAmbiguous, + mafCutoff = panelFilterArgs$mafCutoff, + macCutoff = panelFilterArgs$macCutoff, + imissCutoff = panelFilterArgs$imissCutoff, + infoCutoff = sumstatsFilterArgs$infoCutoff, + nCutoff = sumstatsFilterArgs$nCutoff, + pipCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "pip"), + absZCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "absZ"), + bfCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "bf"), + logBfCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "logBf"), + ldMismatchQcMethod = ldMismatchQcMethod, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + # Echoed FLAT for the same reason the screen cutoffs are: these + # nine names are part of the returned object's shape. + coerceNumeric = sumstatsCleaningArgs$coerceNumeric, + normalizeChr = sumstatsCleaningArgs$normalizeChr, + dropNonstandardChr = sumstatsCleaningArgs$dropNonstandardChr, + dropMissData = sumstatsCleaningArgs$dropMissData, + dropPOutOfRange = sumstatsCleaningArgs$dropPOutOfRange, + clampSmallP = sumstatsCleaningArgs$clampSmallP, + smallPFloor = sumstatsCleaningArgs$smallPFloor, + dropZeroEffect = sumstatsCleaningArgs$dropZeroEffect, + dropNonpositiveSe = sumstatsCleaningArgs$dropNonpositiveSe + ), entryAudit = entryAudits ) } @@ -4850,49 +5279,46 @@ krigingOutlierQc <- function( #' variant common in the panel but rare in the study is dropped as well. #' #' @param sumstats A \code{QtlSumStats} or \code{GwasSumStats} collection. -#' @param removeIndels Logical (length 1). When \code{TRUE}, drop indels during -#' panel harmonization. Default \code{FALSE}. -#' @param removeStrandAmbiguous Logical (length 1). When \code{TRUE}, drop A/T -#' and C/G strand-ambiguous variants. Default \code{TRUE}. -#' @param mafCutoff Numeric (length 1). Minor-allele-frequency threshold, -#' measured wherever it can be: against the summary statistics' own -#' \code{AF} / \code{MAF} / \code{FRQ} column when one is present, and -#' against the LD reference panel. Default 0 (off). See the panel-filters -#' section below. -#' @param macCutoff Numeric (length 1). Minor-allele-count threshold for the -#' LD reference panel, converted to a MAF equivalent using -#' \code{macCutoff / (2 * nSamples)}; the stricter of it and -#' \code{mafCutoff} applies. Default 0 (off). -#' @param imissCutoff Numeric (length 1). Per-variant missingness-rate ceiling -#' for the LD reference panel. Default 1 (off). -#' @param infoCutoff Numeric (length 1). INFO score threshold. Default 0. -#' Requires \code{INFO} column when non-zero. -#' @param nCutoff Numeric (length 1). Sample-size deviation threshold: drop -#' variants whose \code{N} is more than \code{nCutoff} -#' median-absolute-deviations from the median. Set to 0 to disable. Default 5. +#' @param sumstatsFilterArgs Row filters applied to the summary statistics +#' themselves, built with \code{\link{SumstatsFilterParam}}: +#' \code{removeIndels} drops indels during panel harmonization, +#' \code{removeStrandAmbiguous} drops A/T and C/G variants, +#' \code{infoCutoff} is an INFO-score floor (requiring an \code{INFO} +#' column when non-zero), and \code{nCutoff} drops variants whose \code{N} +#' is more than that many median-absolute-deviations from the median (0 +#' disables it). +#' @param panelFilterArgs LD-reference-panel filters, built with +#' \code{\link{PanelFilterParam}}. \code{macCutoff} is converted to a MAF +#' equivalent using \code{macCutoff / (2 * nSamples)} and the stricter of +#' it and \code{mafCutoff} applies; \code{imissCutoff} is a per-variant +#' missingness ceiling. See the panel-filters section below. +#' +#' \code{mafCutoff} is the one setting that reaches past the panel: it is +#' measured wherever it can be, against the summary statistics' own +#' \code{AF} / \code{MAF} / \code{FRQ} column when one is present +#' \emph{and} against the panel. It has always been a single knob, so it +#' lives here rather than being split into two that could disagree. #' @param keepVariants Optional character vector of variant IDs (SNP column) to #' retain prior to harmonization. #' @param skipRegion Optional character vector of \code{"chr:start-end"} #' strings, or a \code{GRanges}, of regions to drop. -#' @param pipCutoffToSkip Numeric (length 1). When \code{!= 0}, run an -#' LD-independent single-effect SER screen and skip the entry if no PIP -#' exceeds the cutoff. \code{< 0} resolves to \code{3 / nVariants}. Default 0 -#' (no screen). -#' @param absZCutoffToSkip Numeric (length 1). Alternative signal screen: skip -#' the entry when \code{max(abs(Z))} does not exceed the cutoff. No model fit. -#' Default 0 (off). -#' @param bfCutoffToSkip Numeric (length 1). Alternative signal screen: skip the -#' entry when the largest per-variant single-effect Bayes factor (from the -#' same \code{susie_ser} fit as the PIP screen) does not exceed the cutoff. -#' Compared in log space (\code{maxlogBF > log(cutoff)}). Must be \code{> 0}. -#' Default 0 (off). -#' @param logBfCutoffToSkip Numeric (length 1). As \code{bfCutoffToSkip} but the -#' cutoff is on the log Bayes factor scale (\code{maxlogBF > cutoff}). Default -#' 0 (off). Exactly one of \code{pipCutoffToSkip} / \code{absZCutoffToSkip} / -#' \code{bfCutoffToSkip} / \code{logBfCutoffToSkip} may be non-zero (one -#' screening metric at a time); enabling more than one is an error. -#' @param zMismatchQc One of \code{"none"} (default), \code{"slalom"}, -#' \code{"dentist"}. +#' @param signalScreenArgs Whether to skip an entry before fitting it, +#' built with +#' \code{\link{SignalScreenParam}} --- the same bundle +#' \code{\link{fineMappingPipeline}} and \code{\link{colocboostPipeline}} +#' take. \code{pip} runs an LD-independent single-effect SER screen and +#' skips the entry if no PIP exceeds the cutoff (\code{< 0} resolves to +#' \code{3 / nVariants}); \code{absZ} skips when \code{max(abs(Z))} does +#' not exceed the cutoff, with no model fit; \code{bf} and \code{logBf} +#' screen the largest per-variant single-effect Bayes factor from that same +#' \code{susie_ser} fit, on the raw and log scales respectively. One metric +#' at a time --- the constructor rejects a conflicting pair. Unset (the +#' default) screens nothing. +#' @param ldMismatchQcMethod Which LD-mismatch check to run: \code{"none"} +#' (default), \code{"slalom"} or \code{"dentist"}, or the matching +#' constructor -- \code{\link{SlalomParam}} / \code{\link{DentistParam}} -- +#' to configure it at the same time. Exactly one engine is selected either +#' way, since the constructor carries the choice. #' @param alleleFlipKriging Logical (length 1). Opt-in kriging LD-consistency #' prefilter run before SLALOM/DENTIST. Default \code{FALSE}. #' @param effectiveN Logical (length 1). When \code{TRUE} (default) and the @@ -4912,18 +5338,20 @@ krigingOutlierQc <- function( #' \code{ldSketch}. Default \code{FALSE}. (Note: RAISS against the sketch is #' not yet fully wired for the new path; the option is accepted but currently #' emits a warning and is skipped.) -#' @param imputeOpts Named list of RAISS parameters. RAISS imputation scopes its -#' reference panel to the analysis-region window (so a per-chromosome / -#' genome-wide \code{ldSketch} does not materialize its full dosage); -#' \code{flank} (default 0) widens that window by the given number of base -#' pairs on each side to retain LD context for edge variants. +#' @param imputeArgs RAISS settings, built with \code{\link{RaissParam}}. +#' A bare list is refused, since it cannot be checked. #' -#' \code{mafCutoff} (default 0), \code{macCutoff} (default 0) and -#' \code{imissCutoff} (default 1) bound which panel variants RAISS will -#' attempt to impute. Without them every rare variant in the window of a -#' large LD sketch becomes an imputation target, which is slow and of little -#' value when the study is far smaller than the panel. The stricter of -#' \code{mafCutoff} and \code{macCutoff / (2 * nSamples)} applies, matching +#' RAISS imputation scopes its reference panel to the analysis-region window +#' (so a per-chromosome / genome-wide \code{ldSketch} does not materialize +#' its full dosage); \code{flank} widens that window by the given number of +#' base pairs on each side to retain LD context for edge variants. +#' +#' \code{mafCutoff}, \code{macCutoff} and \code{imissCutoff} bound which +#' panel variants RAISS will attempt to impute. Without them every rare +#' variant in the window of a large LD sketch becomes an imputation target, +#' which is slow and of little value when the study is far smaller than the +#' panel. The stricter of \code{mafCutoff} and +#' \code{macCutoff / (2 * nSamples)} applies, matching #' \code{\link{QtlDataset}}. #' #' These are a \strong{further} tightening applied to imputation targets @@ -4931,32 +5359,21 @@ krigingOutlierQc <- function( #' the panel handed to RAISS holds nothing below those. Use them to impute #' only common variants from a panel deliberately kept wider than that --- #' e.g. \code{mafCutoff = 0.001} with -#' \code{imputeOpts = list(mafCutoff = 0.01)}. A variant present in the -#' sumstats is never dropped here: RAISS derives its LD basis from those +#' \code{imputeArgs = RaissParam(mafCutoff = 0.01)}. A variant present in +#' the sumstats is never dropped here: RAISS derives its LD basis from those #' same panel rows. +#' +#' \code{lamb}, \code{svdTol}, \code{r2Threshold} and \code{minimumLd} +#' are forwarded to \code{\link{raiss}} itself. #' @param matchMinProp Minimum proportion of LD panel variants that must be #' matched by the sumstats; default 0. -#' @param coerceNumeric Logical. Coerce signed columns -#' (Z/BETA/SE/OR/LOG_ODDS/SIGNED_SUMSTAT/P/MAF/FRQ/INFO/N) to numeric. Default -#' \code{TRUE}. -#' @param normalizeChr Logical. Strip \code{"chr"} prefix, uppercase the -#' chromosome label, and map 23->X, 24->Y, M->MT. Default \code{TRUE}. -#' @param dropNonstandardChr Logical. Drop variants whose CHR (after -#' normalization) is outside 1..22, X, Y, MT. Default \code{TRUE}. -#' @param dropMissData Logical. Drop rows with NA in any vital column (chrom, -#' pos, A1, A2, and at least one of Z / BETA). Default \code{TRUE}. -#' @param dropPOutOfRange Logical. Drop rows where \code{P < 0} or \code{P > 1}. -#' Default \code{TRUE}. -#' @param clampSmallP Logical. Floor non-negative P values below -#' \code{smallPFloor} to \code{smallPFloor} so \code{-log10(P)} stays finite. -#' Applied to both input and Z-derived P values. Default \code{TRUE}. -#' @param smallPFloor Numeric (length 1). Floor for \code{clampSmallP}. Default -#' \code{5e-324} (R's smallest positive double). -#' @param dropZeroEffect Logical. Drop rows where any effect column is exactly 0 -#' (\code{BETA}, \code{LOG_ODDS}, \code{SIGNED_SUMSTAT}) or \code{OR} is -#' exactly 1. Default \code{TRUE}. -#' @param dropNonpositiveSe Logical. Drop rows where \code{SE <= 0}. Default -#' \code{TRUE}. +#' @param sumstatsCleaningArgs What makes a row a well-formed record, built with +#' \code{\link{SumstatsCleaningParam}}: \code{coerceNumeric}, +#' \code{normalizeChr} / \code{dropNonstandardChr}, \code{dropMissData}, +#' \code{dropPOutOfRange}, \code{clampSmallP} / \code{smallPFloor}, +#' \code{dropZeroEffect} and \code{dropNonpositiveSe}. Applied before any +#' filter or screen. Distinct from \code{sumstatsFilter}, which applies +#' quality thresholds to rows that are already well formed. #' @return A new \code{QtlSumStats} / \code{GwasSumStats} with cleaned entries #' and \code{qcInfo} populated. #' @examples @@ -4965,47 +5382,113 @@ krigingOutlierQc <- function( #' @export summaryStatsQc <- function( sumstats, - removeIndels = FALSE, - removeStrandAmbiguous = TRUE, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - infoCutoff = 0, - nCutoff = 5, + sumstatsFilterArgs = SumstatsFilterParam(), + panelFilterArgs = PanelFilterParam(), keepVariants = NULL, skipRegion = NULL, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, - zMismatchQc = c("none", "slalom", "dentist"), + signalScreenArgs = SignalScreenParam(), + ldMismatchQcMethod = c("none", "slalom", "dentist"), alleleFlipKriging = FALSE, effectiveN = TRUE, impute = FALSE, - imputeOpts = list( - rcond = 0.01, - r2Threshold = 0.6, - minimumLd = 5, - lamb = 0.01 - ), + imputeArgs = RaissParam(), matchMinProp = 0, - coerceNumeric = TRUE, - normalizeChr = TRUE, - dropNonstandardChr = TRUE, - dropMissData = TRUE, - dropPOutOfRange = TRUE, - clampSmallP = TRUE, - smallPFloor = 5e-324, - dropZeroEffect = TRUE, - dropNonpositiveSe = TRUE + sumstatsCleaningArgs = SumstatsCleaningParam() ) { - zMismatchQc <- arg_match(zMismatchQc) - .ssqcCheckEntries(sumstats, mafCutoff, infoCutoff) - .ssqcCheckPanelCutoffs(mafCutoff, macCutoff, imissCutoff) - p <- as.list(environment()) - opts <- .ssqcBuildOpts(p) + r <- .ssqcResolveInputs( + sumstats, + sumstatsFilterArgs, + panelFilterArgs, + signalScreenArgs, + sumstatsCleaningArgs, + imputeArgs, + ldMismatchQcMethod + ) + opts <- .ssqcBuildOpts( + sumstatsFilterArgs = sumstatsFilterArgs, + panelFilterArgs = panelFilterArgs, + skipRegion = skipRegion, + ldMismatchQcMethod = r$ldMismatchQcMethod, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + imputeArgs = r$imputeArgs, + matchMinProp = matchMinProp, + sumstatsCleaningArgs = r$cleaning, + keepVariants = keepVariants, + signalScreenArgs = signalScreenArgs + ) res <- .ssqcRunEntries(sumstats, opts) - qcInfo <- .ssqcBuildQcInfo(p, res$entryAudits) + .ssqcAssemble( + sumstats, + res, + sumstatsFilterArgs = sumstatsFilterArgs, + panelFilterArgs = panelFilterArgs, + signalScreenArgs = signalScreenArgs, + ldMismatchQcMethod = r$ldMismatchQcMethod, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + cleaning = r$cleaning + ) +} + +# Validate every bundle and resolve the three that have a resolved form: +# the LD-mismatch choice (a name or the engine's own constructor -- the +# record carries both the choice and its options, so they cannot +# disagree), the cleaning defaults, and the imputation arguments. +# @noRd +.ssqcResolveInputs <- function( + sumstats, + sumstatsFilterArgs, + panelFilterArgs, + signalScreenArgs, + sumstatsCleaningArgs, + imputeArgs, + ldMismatchQcMethod +) { + .assertMethodParam( + sumstatsFilterArgs, + "SumstatsFilterParam", + "sumstatsFilter" + ) + .assertMethodParam(panelFilterArgs, "PanelFilterParam", "panelFilter") + .assertMethodParam(signalScreenArgs, "SignalScreenParam", "signalScreen") + .assertMethodParam(imputeArgs, "RaissParam", "imputeArgs") + .ssqcCheckEntries(sumstats, sumstatsFilterArgs$infoCutoff) + .ssqcCheckPanelCutoffs(panelFilterArgs) + list( + ldMismatchQcMethod = .resolveLdMismatchChoice(ldMismatchQcMethod), + cleaning = .sumstatsCleaningResolve(sumstatsCleaningArgs), + imputeArgs = .ssqcResolveImputeArgs(imputeArgs) + ) +} + +# The QC record and the rebuilt object around the filtered entries. +# @noRd +.ssqcAssemble <- function( + sumstats, + res, + sumstatsFilterArgs, + panelFilterArgs, + signalScreenArgs, + ldMismatchQcMethod, + alleleFlipKriging, + effectiveN, + impute, + cleaning +) { + qcInfo <- .ssqcBuildQcInfo( + res$entryAudits, + sumstatsFilterArgs = sumstatsFilterArgs, + panelFilterArgs = panelFilterArgs, + signalScreenArgs = signalScreenArgs, + ldMismatchQcMethod = ldMismatchQcMethod, + alleleFlipKriging = alleleFlipKriging, + effectiveN = effectiveN, + impute = impute, + sumstatsCleaningArgs = cleaning + ) # From the PRUNED panel, not the input's: narrowing the original again # would hand back a sketch the panel filter never reached. newLdSketch <- .subsetSketchToIds(res$ldSketch, res$newEntries) @@ -5127,10 +5610,7 @@ summaryStatsQc <- function( # `variants` column: .ldMergeVariants then reads $variants as character(0) # (length 0 -> the block is skipped) instead of hitting an absent column # (which a data.frame returned silently as NULL and a tibble warns on). - variants <- colnames(ld) - if (is.null(variants)) { - variants <- character(0) - } + variants <- colnames(ld) %||% character(0) tibble(variants = variants) } @@ -5161,3 +5641,151 @@ summaryStatsQc <- function( snp <- S4Vectors::mcols(gr)$SNP if (is.null(snp)) character(0) else as.character(snp) } + +#' @rdname SumstatsFilterParam +#' @aliases SumstatsFilterParam-class +#' @exportClass SumstatsFilterParam +setClass( + "SumstatsFilterParam", + contains = "MethodParam", + slots = c( + removeIndels = "logical", + removeStrandAmbiguous = "logical", + infoCutoff = "numeric", + nCutoff = "numeric" + ) +) + +#' @title Summary-Statistic Row Filtering Options +#' @description Which rows of a summary-statistics table survive QC, as one +#' checked bundle. These act on the sumstats themselves, not on any genotype +#' matrix, which is why they are separate from +#' \code{\link{GenotypeFilterParam}}. +#' @param removeIndels Logical. Drop insertions and deletions. Default +#' \code{FALSE}. +#' @param removeStrandAmbiguous Logical. Drop strand-ambiguous variants (A/T +#' and C/G). Default \code{TRUE}. +#' @param infoCutoff Imputation-INFO floor. Default \code{0}. +#' @param nCutoff Per-variant sample-size floor. Default \code{5}. +#' @return A \code{SumstatsFilterParam} object, a \code{\link{MethodParam}}. +#' @seealso \code{\link{GenotypeFilterParam}}, \code{\link{PanelFilterParam}} +#' @examples +#' SumstatsFilterParam(removeIndels = TRUE, infoCutoff = 0.8) +#' @export +SumstatsFilterParam <- function( + removeIndels = FALSE, + removeStrandAmbiguous = TRUE, + infoCutoff = 0, + nCutoff = 5 +) { + new( + "SumstatsFilterParam", + removeIndels = removeIndels, + removeStrandAmbiguous = removeStrandAmbiguous, + infoCutoff = infoCutoff, + nCutoff = nCutoff + ) +} + +#' @rdname SumstatsCleaningParam +#' @aliases SumstatsCleaningParam-class +#' @exportClass SumstatsCleaningParam +setClass( + "SumstatsCleaningParam", + contains = "MethodParam", + slots = c( + coerceNumeric = "logical", + normalizeChr = "logical", + dropNonstandardChr = "logical", + dropMissData = "logical", + dropPOutOfRange = "logical", + clampSmallP = "logical", + smallPFloor = "numeric", + dropZeroEffect = "logical", + dropNonpositiveSe = "logical" + ) +) + +#' @title Summary-Statistics Cleaning Settings +#' @description What makes a summary-statistics row a well-formed record: +#' type coercion, chromosome-label normalization, dropping malformed or +#' impossible rows, and flooring underflowed p-values. +#' +#' Separate from \code{\link{SumstatsFilterParam}} on purpose. That one +#' applies quality thresholds to \emph{valid} records (INFO, N, indels, +#' strand-ambiguous variants); this one decides whether a row is a valid +#' record at all. All of it is applied by \code{\link{summaryStatsQc}} +#' before any filter or screen runs. +#' @param coerceNumeric Logical. Coerce the signed columns +#' (Z/BETA/SE/OR/LOG_ODDS/SIGNED_SUMSTAT/P/MAF/FRQ/INFO/N) to numeric. +#' Default \code{TRUE}. +#' @param normalizeChr Logical. Strip the \code{"chr"} prefix, uppercase the +#' chromosome label, and map 23->X, 24->Y, M->MT. Default \code{TRUE}. +#' @param dropNonstandardChr Logical. Drop variants whose CHR (after +#' normalization) is outside 1..22, X, Y, MT. Default \code{TRUE}. +#' @param dropMissData Logical. Drop rows with NA in any vital column (chrom, +#' pos, A1, A2, and at least one of Z / BETA). Default \code{TRUE}. +#' @param dropPOutOfRange Logical. Drop rows where \code{P < 0} or +#' \code{P > 1}. Default \code{TRUE}. +#' @param clampSmallP Logical. Floor non-negative P values below +#' \code{smallPFloor} to \code{smallPFloor}, so \code{-log10(P)} stays +#' finite. Applied to both input and Z-derived P values. Default +#' \code{TRUE}. +#' @param smallPFloor Numeric (length 1). The floor \code{clampSmallP} +#' applies. Default \code{5e-324} (R's smallest positive double). +#' @param dropZeroEffect Logical. Drop rows where any effect column is exactly +#' 0 (\code{BETA}, \code{LOG_ODDS}, \code{SIGNED_SUMSTAT}) or \code{OR} +#' is exactly 1. Default \code{TRUE}. +#' @param dropNonpositiveSe Logical. Drop rows where \code{SE <= 0}. Default +#' \code{TRUE}. +#' @return A \code{SumstatsCleaningParam} object, a \code{\link{MethodParam}}. +#' @examples +#' SumstatsCleaningParam(clampSmallP = FALSE, dropZeroEffect = FALSE) +#' @export +SumstatsCleaningParam <- function( + coerceNumeric = TRUE, + normalizeChr = TRUE, + dropNonstandardChr = TRUE, + dropMissData = TRUE, + dropPOutOfRange = TRUE, + clampSmallP = TRUE, + smallPFloor = 5e-324, + dropZeroEffect = TRUE, + dropNonpositiveSe = TRUE +) { + new( + "SumstatsCleaningParam", + coerceNumeric = coerceNumeric, + normalizeChr = normalizeChr, + dropNonstandardChr = dropNonstandardChr, + dropMissData = dropMissData, + dropPOutOfRange = dropPOutOfRange, + clampSmallP = clampSmallP, + smallPFloor = smallPFloor, + dropZeroEffect = dropZeroEffect, + dropNonpositiveSe = dropNonpositiveSe + ) +} + +# The cleaning settings as a plain list with every default applied. +# .assertMethodOptions accepts `list()` as "no options", and .applySanityChecks +# tests these with `if (!flag)`, so a missing field must not arrive as NULL. +# @noRd +.sumstatsCleaningResolve <- function(sumstatsCleaningArgs) { + .assertMethodParam( + sumstatsCleaningArgs, + "SumstatsCleaningParam", + "sumstatsCleaning" + ) + list( + coerceNumeric = sumstatsCleaningArgs$coerceNumeric %||% TRUE, + normalizeChr = sumstatsCleaningArgs$normalizeChr %||% TRUE, + dropNonstandardChr = sumstatsCleaningArgs$dropNonstandardChr %||% TRUE, + dropMissData = sumstatsCleaningArgs$dropMissData %||% TRUE, + dropPOutOfRange = sumstatsCleaningArgs$dropPOutOfRange %||% TRUE, + clampSmallP = sumstatsCleaningArgs$clampSmallP %||% TRUE, + smallPFloor = sumstatsCleaningArgs$smallPFloor %||% 5e-324, + dropZeroEffect = sumstatsCleaningArgs$dropZeroEffect %||% TRUE, + dropNonpositiveSe = sumstatsCleaningArgs$dropNonpositiveSe %||% TRUE + ) +} diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 1aa329e18..bc74d5ed7 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -18,11 +18,16 @@ if (length(keys) == 0L) { return(seq_len(nrow(x))) } - ok <- rep(TRUE, nrow(x)) - for (k in names(keys)) { - ok <- ok & as.character(.tupleColumn(x, k)) == keys[[k]] - } - which(ok) + which(reduce( + map(names(keys), .tupleKeyEquals, x = x, keys = keys), + `&`, + .init = rep(TRUE, nrow(x)) + )) +} + +# @noRd +.tupleKeyEquals <- function(k, x, keys) { + as.character(.tupleColumn(x, k)) == keys[[k]] } # Read an identity column by name. Every collection keeps its identity @@ -72,9 +77,9 @@ # rather than reported as NA). # @noRd .fmrTupleLabel <- function(side, ident, block = NULL) { - fields <- compact(c(ident, list(block = block))) - fields <- fields[!map_lgl(fields, is.na)] - shown <- str_c(names(fields), "='", unlist(fields), "'") + supplied <- compact(c(ident, list(block = block))) + fields <- discard(supplied, is.na) + shown <- str_c(names(fields), "='", map_chr(fields, as.character), "'") glue("{side} ({str_flatten(shown, ', ')})") } @@ -119,6 +124,7 @@ # TwasWeights accessors. Returns an error when no row matches; returns # the single row index when the collection has exactly one row and any # selector argument was omitted. +#' @importFrom checkmate assertVector .tupleSelectRow <- function( x, study, @@ -149,16 +155,10 @@ ) abort(msg) } - if ( - length(study) != 1L || - length(context) != 1L || - length(trait) != 1L || - length(method) != 1L - ) { - abort( - "`study`, `context`, `trait`, and `method` must each be length 1." - ) - } + assertVector(study, len = 1L) + assertVector(context, len = 1L) + assertVector(trait, len = 1L) + assertVector(method, len = 1L) .tupleMatchQtl(x, study, context, trait, method) } @@ -183,6 +183,7 @@ # index of a GwasFineMappingResult collection. `region` may be NULL when # the (study, method) pair maps to a single row; otherwise it disambiguates # among per-block rows of a genome-wide collection. +#' @importFrom checkmate assertVector .tupleSelectRowGwasFmr <- function(x, study, method, region = NULL) { if (nrow(x) == 0L) { abort("GwasFineMappingResult has no rows.") @@ -201,22 +202,19 @@ ) abort(msg) } - if (length(study) != 1L || length(method) != 1L) { - abort("`study` and `method` must each be length 1.") - } - if (!is.null(region) && length(region) != 1L) { - abort("`region` must be length 1 when supplied.") - } + assertVector(study, len = 1L) + assertVector(method, len = 1L) + assertVector(region, len = 1L, null.ok = TRUE) .tupleMatchGwas(x, study, method, region) } # Resolve a (study, method[, blockId]) tuple to a single row index. # @noRd .tupleMatchGwas <- function(x, study, method, region) { - keys <- list(study = study, method = method) - if (!is.null(region)) { - keys$blockId <- region - } + keys <- c( + list(study = study, method = method), + compact(list(blockId = region)) + ) idx <- .matchTupleRows(x, keys) if (length(idx) == 0L) { regionPart <- if (is.null(region)) { @@ -265,24 +263,27 @@ method = NULL, region = NULL ) { - keys <- list( + supplied <- compact(list( study = study, context = context, trait = trait, method = method, blockId = region - ) - keys <- keys[!map_lgl(keys, is.null)] - keys <- keys[is_in(names(keys), .tupleColumnNames(x))] + )) + keys <- supplied[is_in(names(supplied), .tupleColumnNames(x))] if (length(keys) == 0L) { return(seq_len(nrow(x))) } - ok <- rep(TRUE, nrow(x)) - for (k in names(keys)) { - ok <- ok & - is_in(as.character(.tupleColumn(x, k)), as.character(keys[[k]])) - } - which(ok) + which(reduce( + map(names(keys), .tupleKeyIsIn, x = x, keys = keys), + `&`, + .init = rep(TRUE, nrow(x)) + )) +} + +# @noRd +.tupleKeyIsIn <- function(k, x, keys) { + is_in(as.character(.tupleColumn(x, k)), as.character(keys[[k]])) } # Internal: per-row identity metadata for a FineMappingResultBase collection, @@ -292,9 +293,7 @@ .fmrRowMetadata <- function(x) { cols <- c("study", "context", "trait", "blockId", "method") n <- nrow(x) - vals <- map(cols, .fmrMetadataCol, x = x, n = n) - names(vals) <- cols - as_tibble(vals) + as_tibble(set_names(map(cols, .fmrMetadataCol, x = x, n = n), cols)) } # Internal: row-bind view tibbles whose column sets may differ; bind_rows @@ -342,8 +341,7 @@ ) abort(msg) } - cols[["blockId"]] <- as.character(blockId) - cols + c(cols, list(blockId = as.character(blockId))) } # Internal: append a validated `region` GRanges to a constructor's column list @@ -383,17 +381,18 @@ if (length(traitPos) != n) { abort("`traitPos` must have the same length as `study`.") } - cols[["traitPos"]] <- traitPos - cols + c(cols, list(traitPos = traitPos)) } +#' @importFrom checkmate checkClass .validateTraitPosColumn <- function(object) { if (!is_in("traitPos", .tupleColumnNames(object))) { return(character(0)) } traitPos <- .tupleColumn(object, "traitPos") - if (!methods::is(traitPos, "GRanges")) { - return("'traitPos' column must be a GRanges") + res <- checkClass(traitPos, "GRanges") + if (!isTRUE(res)) { + return(str_c("'traitPos' column ", res)) } if (length(traitPos) != nrow(object)) { return("'traitPos' column must have one range per row") @@ -485,7 +484,7 @@ region = NULL, perEntry, onSingle = perEntry, - ... + viewArgs = list() ) { single <- .fmrTrySingle( x, @@ -495,7 +494,7 @@ method, region, onSingle, - ... + viewArgs ) if (single$done) { return(single$result) @@ -518,7 +517,7 @@ x = x, perEntry = perEntry, meta = meta, - ... + viewArgs = viewArgs )) if (length(parts) == 0L) { return(slice(meta, integer(0))) @@ -541,6 +540,7 @@ # list(done, result) on a successful single-select, else list(done = FALSE, sel) # carrying the selection error (or NULL when no selector was given). # @noRd +#' @importFrom rlang try_fetch .fmrTrySingle <- function( x, study, @@ -549,7 +549,7 @@ method, region, onSingle, - ... + viewArgs ) { anySelector <- !is.null(study) || !is.null(context) || @@ -559,7 +559,7 @@ if (!anySelector) { return(list(done = FALSE, sel = NULL)) } - sel <- tryCatch( + sel <- try_fetch( .fmrSelectEntry( x, study = study, @@ -568,10 +568,10 @@ method = method, region = region ), - error = function(e) e + error = function(cnd) cnd ) if (!inherits(sel, "error")) { - return(list(done = TRUE, result = onSingle(sel, ...))) + return(list(done = TRUE, result = exec(onSingle, sel, !!!viewArgs))) } list(done = FALSE, sel = sel) } @@ -579,15 +579,15 @@ # Project one entry to its per-entry view with the row's identity metadata # prepended; NULL when the entry yields no rows. # @noRd -.fmrEntryPart <- function(i, x, perEntry, meta, ...) { +.fmrEntryPart <- function(i, x, perEntry, meta, viewArgs) { # `perEntry` is an internal per-row function taking the stored payload, not # an S4 generic dispatching on a rebuilt entry. That indirection is what # the FineMappingRow class existed for. - v <- perEntry(.fmrRowParts(x, i), ...) - if (is.null(v) || nrow(v) == 0L) { + raw <- exec(perEntry, .fmrRowParts(x, i), !!!viewArgs) + if (is.null(raw) || nrow(raw) == 0L) { return(NULL) } - v <- select(v, all_of(setdiff(names(v), names(meta)))) + v <- select(raw, all_of(setdiff(names(raw), names(meta)))) bind_cols(slice(meta, rep(i, nrow(v))), v) } @@ -637,15 +637,16 @@ !!!c(combined, list(check.names = FALSE)) ) elements <- list_flatten(map(parts, as.list)) - grl <- GenomicRanges::GRangesList(elements) # Rebuilding from as.list() merges each part's seqinfo, so a part whose # elements never had a build set would leave the result carrying both the # real build and NA. The agreed build is written back explicitly to keep # seqinfo single-valued, which validity requires. - if (!is.null(genome)) { - GenomeInfoDb::genome(grl) <- genome - } - mcols(grl) <- md + built <- .withGenomeBuild( + GenomicRanges::GRangesList(elements), + !is.null(genome), + genome + ) + grl <- S4Vectors::`mcols<-`(built, value = md) out <- exec( methods::new, cls, @@ -730,8 +731,7 @@ type = c("data.frame", "GRanges"), signalCutoff = 0.025, minPurity = NULL, - raw = FALSE, - ... + raw = FALSE ) { tl <- .fmrPartsTopLoci(parts) # raw = TRUE returns the stored canonical table verbatim: every variant, @@ -748,7 +748,7 @@ } # @noRd -.fmrRowPip <- function(parts, ...) { +.fmrRowPip <- function(parts) { tl <- .fmrPartsTopLoci(parts) if (nrow(tl) == 0L || !is_in("pip", names(tl))) { return(numeric(0)) @@ -757,21 +757,22 @@ } # @noRd -.fmrRowMarginalEffects <- function(parts, maxPval = NULL, ...) { +.fmrRowMarginalEffects <- function(parts, maxPval = NULL) { tl <- .fmrPartsTopLoci(parts) if (nrow(tl) == 0L) { return(.projectMarginalView(tl)) } - out <- .projectMarginalView(tl) - if (!is.null(maxPval) && nrow(out) > 0L) { - keep <- !is.na(out$p) & out$p <= maxPval - out <- filter(out, keep) + allRows <- .projectMarginalView(tl) + out <- if (is.null(maxPval) || nrow(allRows) == 0L) { + allRows + } else { + filter(allRows, !is.na(.data$p) & .data$p <= maxPval) } out } # @noRd -.fmrRowCs <- function(parts, coverage = 0.95, minPurity = NULL, ...) { +.fmrRowCs <- function(parts, coverage = 0.95, minPurity = NULL) { tl <- .fmrPartsTopLoci(parts) if (nrow(tl) == 0L) { return(.projectPosteriorView(tl)) @@ -783,51 +784,53 @@ if (length(csCol) == 0L) { return(.projectPosteriorView(slice(tl, 0))) } - keep <- !is.na(tl[[csCol[1L]]]) & + inCs <- !is.na(tl[[csCol[1L]]]) & str_length(tl[[csCol[1L]]]) > 0L & !str_detect(tl[[csCol[1L]]], "_0$") # 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 <- str_c(csCol[1L], "_purity") - if (is_in(purCol, names(tl))) { - pur <- as.numeric(tl[[purCol]]) - keep <- keep & !is.na(pur) & pur >= minPurity - } else { - msg <- glue( - "getCs: no purity column '{purCol}' for coverage ", - "{coverage}; minPurity filter skipped." - ) - warn(msg) - } + purCol <- str_c(csCol[1L], "_purity") + hasPurity <- is_in(purCol, names(tl)) + if (!is.null(minPurity) && !hasPurity) { + msg <- glue( + "getCs: no purity column '{purCol}' for coverage ", + "{coverage}; minPurity filter skipped." + ) + warn(msg) + } + keep <- if (is.null(minPurity) || !hasPurity) { + inCs + } else { + pur <- as.numeric(tl[[purCol]]) + inCs & !is.na(pur) & pur >= minPurity } .projectPosteriorView(tl[keep, , drop = FALSE]) } # @noRd -.fmrRowLbf <- function(parts, ...) { +.fmrRowLbf <- function(parts) { lbf <- .asLbfMatrix(getSusieFit(parts)) vids <- .fmrPartsVariantIds(parts) if (is.null(lbf) || ncol(lbf) != length(vids)) { return(tibble(variant_id = character(0))) } - w <- as_tibble(t(as.matrix(lbf)), .name_repair = "minimal") - names(w) <- str_c("lbf_L", seq_len(ncol(w))) + wide <- as_tibble(t(as.matrix(lbf)), .name_repair = "minimal") + w <- `names<-`(wide, str_c("lbf_L", seq_len(ncol(wide)))) bind_cols(tibble(variant_id = as.character(vids)), w) } # @noRd -.fmrRowCredibleSetSummary <- function(parts, coverage = 0.95, ...) { +.fmrRowCredibleSetSummary <- function(parts, coverage = 0.95) { .csSummaryFit(.fmrPartsTopLoci(parts), getSusieFit(parts), coverage) } # @noRd -.fmrRowFsusieCredibleBand <- function(parts, ...) { +.fmrRowFsusieCredibleBand <- function(parts) { .fsusieCredibleBandFit(getSusieFit(parts)) } # @noRd -.fmrRowFsusieAffectedRegions <- function(parts, ...) { +.fmrRowFsusieAffectedRegions <- function(parts) { .fsusieAffectedRegionsFit( getSusieFit(parts), topLoci = .fmrPartsTopLoci(parts) @@ -835,7 +838,7 @@ } # @noRd -.fmrRowResolveWeights <- function(parts, ...) { +.fmrRowResolveWeights <- function(parts) { empty <- list(variantIds = character(0), weights = numeric(0)) # The topLoci posterior view projects the effect to `beta`; use it as the # per-variant weight, aligned with variant_id. @@ -882,14 +885,14 @@ # The weight vector aligned to the row's variant ids -- what resolveWeights # produced from a TwasWeightsRow. # @noRd -.twrRowResolveWeights <- function(parts, ...) { +.twrRowResolveWeights <- function(parts) { empty <- list(variantIds = character(0), weights = numeric(0)) vids <- .twrPartsVariantIds(parts) - w <- getWeights(parts) - if (length(vids) == 0L || is.null(w)) { + raw <- getWeights(parts) + if (length(vids) == 0L || is.null(raw)) { return(empty) } - w <- as.numeric(w) + w <- as.numeric(raw) if (length(w) != length(vids)) { return(empty) } @@ -914,11 +917,11 @@ # The per-variant weight vector of one row, whichever weight source it came # from. # @noRd -.rowResolveWeights <- function(parts, ...) { +.rowResolveWeights <- function(parts) { if (methods::is(parts, "TwasWeightsRow")) { - return(.twrRowResolveWeights(parts, ...)) + return(.twrRowResolveWeights(parts)) } - .fmrRowResolveWeights(parts, ...) + .fmrRowResolveWeights(parts) } # The cross-validated / per-method fits of one row, or NULL for a @@ -1076,10 +1079,9 @@ # @noRd .rtlExtraSlots <- function(parts, fn) { own <- setdiff(.rtlOwnSlots(parts[[1L]]), "ldSketch") - out <- list() - if (is_in("qcInfo", own)) { - out$qcInfo <- .ssCombineQcInfo(parts, fn) - } + out <- compact(list( + qcInfo = if (is_in("qcInfo", own)) .ssCombineQcInfo(parts, fn) + )) unknown <- setdiff(own, names(out)) if (length(unknown) > 0L) { cls <- class(parts[[1L]])[[1L]] @@ -1163,9 +1165,10 @@ abort(msg) } .ssCheckQcOptions(populated, fn) - out <- getQcInfo(populated[[1L]]) - out$entryAudit <- list_flatten(map(parts, .ssEntryAudit)) - out + list_assign( + getQcInfo(populated[[1L]]), + entryAudit = list_flatten(map(parts, .ssEntryAudit)) + ) } # @noRd @@ -1226,9 +1229,11 @@ } handles <- map(sketches, .ldSketchHandle) .ssCheckSameSource(handles, fn) - handle <- handles[[1L]] - handle@snpInfo <- .ssUnionSnpInfo(handles) - handle@chromPaths <- .ssUnionChromPaths(handles, fn) + handle <- methods::initialize( + handles[[1L]], + snpInfo = .ssUnionSnpInfo(handles), + chromPaths = .ssUnionChromPaths(handles, fn) + ) .asLdSketch(handle) } @@ -1239,22 +1244,39 @@ # two different files means the parts are not the same panel after all. # @noRd .ssUnionChromPaths <- function(handles, fn) { - out <- character(0) - for (h in handles) { - cp <- h@chromPaths - for (ch in names(cp)) { - if (is_in(ch, names(out)) && !identical(out[[ch]], cp[[ch]])) { - msg <- glue( - "{fn}: chromosome '{ch}' maps to two different genotype ", - "files across the inputs, so their LD sketches cannot ", - "be unioned." - ) - abort(msg) - } - out[[ch]] <- cp[[ch]] - } + combined <- .ssConcatChr(map(handles, .ssHandleChromPaths)) + byChrom <- split(unname(combined), names(combined)) + walk2(names(byChrom), byChrom, .ssCheckOneFilePerChrom, fn = fn) + # Every chromosome agrees, so the first mapping stands for all of them. + combined[!duplicated(names(combined))] +} + +# @noRd +.ssHandleChromPaths <- function(h) { + h@chromPaths +} + +# @noRd +.ssConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) } - out + list_c(pieces) +} + +# A chromosome resolving to two different files means the inputs are not the +# same panel, so their sketches cannot be unioned. +# @noRd +.ssCheckOneFilePerChrom <- function(ch, paths, fn) { + if (n_distinct(paths) <= 1L) { + return(invisible(NULL)) + } + msg <- glue( + "{fn}: chromosome '{ch}' maps to two different genotype ", + "files across the inputs, so their LD sketches cannot ", + "be unioned." + ) + abort(msg) } # Every panel must read from the same file(s): the union keeps the first @@ -1296,10 +1318,17 @@ # @noRd .ssUnionSnpInfo <- function(handles) { first <- getSnpInfo(handles[[1L]]) - si <- list_rbind(map(handles, .ssHandleSnpInfo)) - if (nrow(si) > 0L && all(is_in(c("SNP", "CHR", "BP"), names(si)))) { - si <- si[!duplicated(si$SNP), , drop = FALSE] - si <- si[order(canonChrom(si$CHR), as.integer(si$BP)), , drop = FALSE] + combined <- list_rbind(map(handles, .ssHandleSnpInfo)) + keyed <- all(is_in(c("SNP", "CHR", "BP"), names(combined))) + si <- if (nrow(combined) > 0L && keyed) { + deduped <- combined[!duplicated(combined$SNP), , drop = FALSE] + deduped[ + order(canonChrom(deduped$CHR), as.integer(deduped$BP)), + , + drop = FALSE + ] + } else { + combined } if (inherits(first, "tbl_df")) si else as.data.frame(si) } diff --git a/R/twasWeights.R b/R/twasWeights.R index 8d7a4dfd4..3c86820b5 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -1,3 +1,25 @@ +# Check a token's arguments against the union of formals along the chain this +# run will actually take. Stricter than the constructor, which cannot know the +# input class: every summary-statistics chain ends in one of pecotmr's own +# solvers and enumerates its formals, so the RSS path is checkable even where +# the individual path is not (ncvreg, glmnet and RcppDPR all take `...`). +# @noRd +.twasCheckMethodArgsForInput <- function(methodArgs, inputKind) { + for (token in names(methodArgs)) { + accepted <- .twasChainAccepted(token, inputKind) + if (is.null(accepted)) { + next + } + .engineCheckExtra( + methodArgs[[token]], + accepted, + glue("twasWeightsPipeline: method '{token}'"), + str_flatten(.twasMethodChainFor(token, inputKind), " -> ") + ) + } + invisible(NULL) +} + # ============================================================================= # TwasWeights S4 class # ----------------------------------------------------------------------------- @@ -38,7 +60,7 @@ NULL setClass( "TwasWeights", contains = "RangedTupleList", - representation(ldSketch = "LdSketchOrNULL"), + representation(ldSketch = "LdSketch_OR_NULL"), validity = function(object) .validateTwasWeights(object) ) @@ -46,25 +68,23 @@ setClass( # region/traitPos provenance, joint* column types, tuple uniqueness, and the # optional ldSketch. Returns TRUE or a character vector of error messages. # @noRd +#' @importFrom checkmate makeAssertCollection assertNames .validateTwasWeights <- function(object) { - errors <- .twasValidateRequiredCols(object) - if (length(errors) == 0L) { - errors <- .twasValidateColumns(object) - } - errors <- c(errors, .twasValidateLdSketch(object)) - if (length(errors) == 0L) TRUE else errors -} - -# Required key/entry columns must all be present. -# @noRd -.twasValidateRequiredCols <- function(object) { - required <- c("study", "context", "trait", "method") - missingCols <- setdiff(required, .tupleColumnNames(object)) - if (length(missingCols) > 0L) { - str_c("missing columns: ", str_flatten(missingCols, ", ")) - } else { - character() + coll <- makeAssertCollection() + assertNames( + .tupleColumnNames(object), + must.include = c("study", "context", "trait", "method"), + what = "colnames", + .var.name = "mcols", + add = coll + ) + # The checks below read those columns; running them on an object missing + # them reports the consequence rather than the cause. + if (!coll$isEmpty()) { + return(coll$getMessages()) } + coll$push(.twasValidateColumns(object)) + coll$getMessages() } # Column-level checks that run only once the required columns are present. @@ -127,14 +147,6 @@ setClass( } } -# The ldSketch slot's class union enforces its type, so there is nothing left -# for validity to check. -# @noRd -.twasValidateLdSketch <- function(object) { - character() -} - - # ============================================================================= #' @title Create a TwasWeights Collection Object @@ -169,6 +181,8 @@ setClass( #' tw <- TwasWeights(study = "s1", context = "brain", trait = "gene1", #' method = "susie", entry = list(twe)) #' tw +#' @importFrom checkmate assertCharacter assert checkList +#' @importFrom checkmate checkClass #' @export TwasWeights <- function( study, @@ -182,10 +196,84 @@ TwasWeights <- function( traitPos = NULL, ldSketch = NULL ) { + .twasAssertArgs( + study, + context, + trait, + method, + entry, + jointStudies, + jointContexts, + jointTraits + ) n <- .twasCheckRowLengths(study, context, trait, method, entry) entry <- map(entry, .asTwRowPayload) .checkRowPayloads(entry, "TwasWeightsRow", "TWAS-weight") - cols <- c( + cols <- .twasMetadataCols( + study, + context, + trait, + method, + entry, + jointStudies, + jointContexts, + jointTraits, + traitPos, + n + ) + obj <- new( + "TwasWeights", + .rtlGrlWithMetadata(entry, cols), + ldSketch = .asLdSketch(ldSketch) + ) + validObject(obj) + obj +} + +# The identity and joint-axis arguments, checked. Mirrors +# .qfmrAssertArgs(); `entry` is documented as "List / SimpleList", and +# SimpleList is S4 and fails checkList, so that one is an or-combination. +# @noRd +.twasAssertArgs <- function( + study, + context, + trait, + method, + entry, + jointStudies, + jointContexts, + jointTraits +) { + assertCharacter(study, any.missing = FALSE) + assertCharacter(context, any.missing = FALSE) + assertCharacter(trait, any.missing = FALSE) + assertCharacter(method, any.missing = FALSE) + assert( + checkList(entry), + checkClass(entry, "SimpleList"), + .var.name = "entry" + ) + assertCharacter(jointStudies, null.ok = TRUE) + assertCharacter(jointContexts, null.ok = TRUE) + assertCharacter(jointTraits, null.ok = TRUE) +} + +# The outer-mcols columns for a TwasWeights: the four identity columns, the +# per-row payload columns, then the optional joint axes and trait position. +# @noRd +.twasMetadataCols <- function( + study, + context, + trait, + method, + entry, + jointStudies, + jointContexts, + jointTraits, + traitPos, + n +) { + baseCols <- c( list( study = as.character(study), context = as.character(context), @@ -194,26 +282,14 @@ TwasWeights <- function( ), .twRowPayloadCols(entry) ) - cols <- .twasAppendJointCols( - cols, + withJoint <- .twasAppendJointCols( + baseCols, jointStudies, jointContexts, jointTraits, n ) - cols <- .appendTraitPosCol(cols, traitPos, n) - dfArgs <- c(cols, list(check.names = FALSE)) - # Each entry's variants become one ELEMENT; its weights become that - # element's inner mcols and the rest of its payload becomes outer mcols. - # A multi-seqname entry is split into one element per chromosome, with its - # metadata row replicated alongside. - split <- .rtlSplitBySeqname(map(entry, rowVariants)) - grl <- GenomicRanges::GRangesList(split$entry) - md <- exec(S4Vectors::DataFrame, !!!dfArgs) - mcols(grl) <- md[split$fromIdx, , drop = FALSE] - obj <- new("TwasWeights", grl, ldSketch = .asLdSketch(ldSketch)) - validObject(obj) - obj + .appendTraitPosCol(withJoint, traitPos, n) } # One entry -> its element: the variants as a GRanges, with the per-variant @@ -262,32 +338,32 @@ TwasWeights <- function( jointTraits, n ) { - joint <- list( + supplied <- compact(list( jointStudies = jointStudies, jointContexts = jointContexts, jointTraits = jointTraits - ) - for (nm in names(joint)) { - val <- joint[[nm]] - if (is.null(val)) { - next - } - if (length(val) != n) { - msg <- glue("`{nm}` must have the same length as `study`.") - abort(msg) - } - cols[[nm]] <- as.character(val) + )) + walk2(names(supplied), supplied, .twasCheckJointColLength, n = n) + c(cols, map(supplied, as.character)) +} + +# Each joint-provenance column must be one value per row. +# @noRd +.twasCheckJointColLength <- function(nm, val, n) { + if (length(val) == n) { + return(invisible(NULL)) } - cols + msg <- glue("`{nm}` must have the same length as `study`.") + abort(msg) } #' @rdname getRegion #' @export -setMethod("getRegion", "TwasWeights", function(x, ...) .getRegionColumn(x)) +setMethod("getRegion", "TwasWeights", function(x) .getRegionColumn(x)) #' @rdname getTraitPosition #' @export -setMethod("getTraitPosition", "TwasWeights", function(x, ...) { +setMethod("getTraitPosition", "TwasWeights", function(x) { .getTraitPosColumn(x) }) @@ -376,8 +452,7 @@ setMethod( study = NULL, context = NULL, trait = NULL, - method = NULL, - ... + method = NULL ) { .twrRowResolveWeights( .twrSelectRowParts(x, study, context, trait, method) @@ -395,8 +470,7 @@ setMethod( study = NULL, context = NULL, trait = NULL, - method = NULL, - ... + method = NULL ) { getWeights(.twrSelectRowParts(x, study, context, trait, method)) } @@ -412,8 +486,7 @@ setMethod( study = NULL, context = NULL, trait = NULL, - method = NULL, - ... + method = NULL ) { getCvResult(.twrSelectRowParts(x, study, context, trait, method)) } @@ -429,8 +502,7 @@ setMethod( study = NULL, context = NULL, trait = NULL, - method = NULL, - ... + method = NULL ) { getFits(.twrSelectRowParts(x, study, context, trait, method)) } @@ -474,8 +546,7 @@ setMethod( study = NULL, context = NULL, trait = NULL, - method = NULL, - ... + method = NULL ) { .twrPartsVariantIds( .twrSelectRowParts(x, study, context, trait, method) @@ -489,7 +560,7 @@ setMethod("getStudy", "TwasWeights", function(x) unique(as.character(x$study))) #' @rdname getLdSketch #' @export -setMethod("getLdSketch", "TwasWeights", function(x, ...) x@ldSketch) +setMethod("getLdSketch", "TwasWeights", function(x) x@ldSketch) #' @rdname getContexts #' @export @@ -563,9 +634,8 @@ setMethod("show", "TwasWeights", function(object) { str_to_upper(str_sub(target, 1, 1)), str_sub(target, 2) ) - x <- str_replace(x, "_weights$", str_c("_", target)) - x <- str_replace(x, "Weights$", cap) - x + str_replace(x, "_weights$", str_c("_", target)) |> + str_replace("Weights$", cap) } # Method name/impl/args lookup for TWAS weight methods. `fn` is the @@ -576,7 +646,8 @@ setMethod("show", "TwasWeights", function(object) { susie = list( fn = "susie_weights", impl = "susieWeights", - args = list(refine = FALSE, L = 10) + # No fitting defaults: susieWeights extracts from a supplied fit. + args = list() ), susieAsh = list( fn = "susie_ash_weights", @@ -656,10 +727,17 @@ setMethod("show", "TwasWeights", function(object) { impl = "l0learnWeights", args = list() ), + ser = list( + fn = "ser_weights", + impl = "serWeights", + # No fitting defaults: serWeights extracts from a supplied fit. + args = list() + ), mvsusie = list( fn = "mvsusie_weights", impl = "mvsusieWeights", - args = list(L = 10) + # No fitting defaults: mvsusieWeights extracts from a supplied fit. + args = list() ), mrmash = list( fn = "mrmash_weights", @@ -697,6 +775,332 @@ setMethod("show", "TwasWeights", function(object) { methods } +# --- TWAS method-token registry --------------------------------------------- + +# The per-token kwargs carried by a normalized methodList, keyed by canonical +# token. The list is keyed by weight-function name, which is the spelling the +# fitters want but not the one the engine map uses. +# @noRd +.twasMethodListArgs <- function(methodList) { + if (length(methodList) == 0L || is.null(names(methodList))) { + return(list()) + } + set_names( + as.list(methodList), + str_remove(names(methodList), "(_weights|Weights)$") + ) +} + +# --- per-token argument chains ---------------------------------------------- +# +# A token's kwargs are consumed incrementally: each function along the way +# takes the names matching its own formals and forwards the rest. So the set +# of legal names is the union of formals along the WHOLE chain, not the +# formals of any one function -- validating against the final engine alone +# rejects legitimate wrapper arguments such as mrmash's +# `canonicalPriorMatrices`, which belongs to a middle hop. +# +# These chains were established by EXECUTION -- tracing which functions a real +# fit enters -- not by reading the sources, which hides forwarding behind +# list_modify()/exec() and imported-without-:: calls. test_twasWeights.R +# re-traces them and fails if one drifts. +# @noRd +# Which wrapper and engine each TWAS weight method actually reaches. Split +# by data path because the two share almost nothing: a method's individual +# and summary-statistic routes usually run different engines entirely, and +# only the token spelling is common. +# @noRd +.twasMethodChains <- function() { + list( + individual = .twasMethodChainsIndividual(), + sumstat = .twasMethodChainsSumstat() + ) +} + +# Individual-level data: X and y are in hand, so these are ordinary fitters. +# @noRd +.twasMethodChainsIndividual <- function() { + list( + lasso = c("lassoWeights", "glmnetWeights", "glmnet::cv.glmnet"), + enet = c("enetWeights", "glmnetWeights", "glmnet::cv.glmnet"), + scad = c("scadWeights", "ncvregWeights", "ncvreg::cv.ncvreg"), + mcp = c("mcpWeights", "ncvregWeights", "ncvreg::cv.ncvreg"), + l0learn = c("l0learnWeights", "L0Learn::L0Learn.cvfit"), + mrash = c("mrashWeights", "susieR::mr.ash"), + mrmash = c( + "mrmashWeights", + "mrmashWrapper", + "MrmashPriorParam", + "buildMrmashPriorMatrices", + "mr.mashr::mr.mash" + ), + bayesA = c("bayesAWeights", "bayesAlphabetWeights", "qgg::gbayes"), + bayesC = c("bayesCWeights", "bayesAlphabetWeights", "qgg::gbayes"), + bayesN = c("bayesNWeights", "bayesAlphabetWeights", "qgg::gbayes"), + bayesR = c("bayesRWeights", "bayesAlphabetWeights", "qgg::gbayes"), + bayesB = c("bayesBWeights", "bglrWeights", "BGLR::BGLR"), + bayesL = c("bLassoWeights", "bglrWeights", "BGLR::BGLR"), + bLasso = c("bLassoWeights", "bglrWeights", "BGLR::BGLR"), + dprVb = c("dprVbWeights", "dprWeights", "RcppDPR::fit_model"), + dprGibbs = c( + "dprGibbsWeights", + "dprWeights", + "RcppDPR::fit_model" + ), + dprAdaptiveGibbs = c( + "dprAdaptiveGibbsWeights", + "dprWeights", + "RcppDPR::fit_model" + ) + ) +} + +# Summary statistics: each chain ends in pecotmr's own RSS solver or an +# upstream *.rss entry point, never the individual-level engine. +# @noRd +.twasMethodChainsSumstat <- function() { + list( + scad = c( + "scadRssWeights", + ".penalizedRssWeights", + ".rssShrinkGridWeights", + "penalizedRss" + ), + mcp = c( + "mcpRssWeights", + ".penalizedRssWeights", + ".rssShrinkGridWeights", + "penalizedRss" + ), + l0learn = c( + "l0learnRssWeights", + ".rssShrinkGridWeights", + "penalizedRss" + ), + lasso = c( + "lassosumRssWeights", + ".rssShrinkGridWeights", + "lassosumRss" + ), + prsCs = c("prsCsWeights", "prsCs"), + dprGibbs = c("sdprWeights", "sdpr"), + mrash = c("mrashRssWeights", "susieR::mr.ash.rss"), + mrmash = c( + "mrmashRssWeights", + "buildMrmashPriorMatrices", + "mr.mashr::mr.mash.rss" + ) + ) +} + +# The chain for one token and input class, or NULL when the token has no path +# for that class. +# @noRd +.twasMethodChainFor <- function(token, inputKind) { + chains <- .twasMethodChains() + side <- if (identical(inputKind, "QtlDataset")) "individual" else "sumstat" + chains[[side]][[token]] +} + +# Argument names that are data or plumbing rather than settable options, so +# naming one is not a user choice the check should endorse. +# @noRd +.twasChainDataArgs <- function() { + c( + "X", + "Y", + "y", + "stat", + "LD", + "bhat", + "shat", + "R", + "n", + "S0", + "w0", + "sumstats", + "Bhat", + "Shat", + "methodArgs", + "dotArgs", + "...", + "solverInput", + "LDs", + "config", + "bInit", + "vInit", + "K" + ) +} + +# One hop's formals. A hop is either an external "pkg::fn" or a pecotmr +# function; NA marks one that could not be read, which makes the whole chain +# uncheckable rather than silently narrower. +# @noRd +.twasChainHopFormals <- function(nm) { + fn <- if (str_detect(nm, fixed("::"))) { + .engineCallee(nm) + } else { + tryCatch( + get(nm, envir = asNamespace("pecotmr")), + error = function(cnd) NULL + ) + } + if (!is.function(fn)) { + return(NA_character_) + } + names(formals(fn)) +} + +# Every name legal for a token on one input class: the union of formals along +# its chain. NULL when a hop takes `...`, since anything then reaches it. +# @noRd +.twasChainAccepted <- function(token, inputKind) { + chain <- .twasMethodChainFor(token, inputKind) + if (is.null(chain)) { + return(NULL) + } + perHop <- map(chain, .twasChainHopFormals) + if (any(map_lgl(perHop, .twasChainHopUnknown))) { + return(NULL) + } + setdiff(unique(list_c(perHop)), .twasChainDataArgs()) +} + +# A hop contributes nothing checkable when it could not be read, or when it +# takes `...` and so accepts any name. +# @noRd +.twasChainHopUnknown <- function(fm) { + (length(fm) == 1L && is.na(fm[[1L]])) || is_in("...", fm) +} + + +# The argument constructor for each weight-method token. Several tokens share +# an engine, so this maps token -> constructor rather than token -> package. +# Tokens absent from this list take no options at all; .twasTokenNoArgsReason +# says why, so the error can be specific. +# @noRd +# The implementation that runs one method on one input path. +# @noRd +.twasMethodImplFor <- function(token, inputKind) { + info <- .twasMethodCapabilities[[token]] + if (is.null(info)) { + return(NULL) + } + if (identical(inputKind, "QtlDataset")) { + info$individualImpl + } else { + info$sumstatImpl + } +} + +# The Options constructor for one implementation, read off that function's +# own `methodArgs` default rather than transcribed into a table here. +# +# Derived because a second table would be a second source of truth: the +# individual and summary-statistics paths of one method often reach +# DIFFERENT packages -- lasso is glmnet on individual data and lassosum on +# summary statistics, dprGibbs is RcppDPR then SDPR -- so a hand-written +# registry has to restate a pairing the implementation already declares. +# @noRd +.twasImplCtorName <- function(impl) { + if (is.null(impl)) { + return(NULL) + } + fn <- tryCatch( + get(impl, envir = asNamespace("pecotmr")), + error = function(cnd) NULL + ) + if (is.null(fn)) { + return(NULL) + } + default <- formals(fn)$methodArgs + if (!is.call(default)) { + return(NULL) + } + as.character(default[[1L]]) +} + +# The constructor itself. Deliberately separate from the name: the +# input-type index below needs the NAME and must not call the constructor, +# which would re-enter .newMethodOptions() and recurse forever. +# @noRd +.twasImplCtor <- function(impl) { + nm <- .twasImplCtorName(impl) + if (is.null(nm)) { + return(NULL) + } + tryCatch( + get(nm, envir = asNamespace("pecotmr")), + error = function(cnd) NULL + ) +} + +# One method's Options constructor on one input path; NULL when the method +# does not run on that path at all. +# @noRd +.twasMethodCtorFor <- function(token, inputKind) { + .twasImplCtor(.twasMethodImplFor(token, inputKind)) +} + +# Every TWAS weight method that runs on one input path: the configurable +# ones with an implementation there, plus the fit-derived ones, whose +# availability is not ours to state -- a fit can only be extracted from +# where fineMappingPipeline() could produce it, so it comes from the +# fine-mapping registry. +# @noRd +.twasMethodsFor <- function(inputKind) { + conf <- keep( + .twasConfigurableMethods(), + function(tk) !is.null(.twasMethodImplFor(tk, inputKind)) + ) + unique(c( + conf, + intersect(.twasFineMappingTokens(), .fmMethodsFor(inputKind)) + )) +} + +# Every configurable method's name, independent of input path. The answer to +# "is this a method that takes options", which the token normalisers ask. +# @noRd +.twasConfigurableMethods <- function() { + names(.twasMethodCapabilities) +} + +# Path-blind view, kept for the callers that have not yet been taught which +# input class they are serving: the individual-level constructor, or the +# summary-statistics one for a method that only runs there (prsCs). +# @noRd +.twasMethodCtors <- function() { + toks <- .twasConfigurableMethods() + set_names( + map(toks, function(tk) { + .twasMethodCtorFor(tk, "QtlDataset") %||% + .twasMethodCtorFor(tk, "QtlSumStats") + }), + toks + ) +} + +# Why a token takes no options, so the error can say something useful rather +# than just "unknown method". +# @noRd +.twasTokenNoArgsReason <- function(token) { + # Derived, not transcribed: this list was hand-written and had already + # drifted from .twasFineMappingTokens(), which is what the character + # path uses -- `ser` was in that one and missing here, so asking the + # aggregator about it answered "unknown method" instead of saying there + # is nothing to configure. + if (is_in(token, .twasFineMappingTokens())) { + return(glue( + "'{token}' extracts weights from a fit supplied via ", + "`fineMappingResult`, so there is nothing to configure here. ", + "Configure the fit in fineMappingPipeline() instead." + )) + } + NULL +} + # Map short method names and presets to weightMethods lists. # @param methods A character vector of short method names, or a preset string # ("default" or "fastDefault"). @@ -704,11 +1108,15 @@ setMethod("show", "TwasWeights", function(object) { # @importFrom purrr map_chr set_names # @noRd .twasMethodLookup <- function(methods) { - methods <- .twasExpandPresets(methods) + expanded <- .twasExpandPresets(methods) # Accept full function names too by mapping them back to short names. fnToShort <- set_names(names(.twasMethodMap), map_chr(.twasMethodMap, "fn")) - methods <- map_chr(methods, .twasCanonicalShortName, fnToShort = fnToShort) - unknown <- setdiff(methods, names(.twasMethodMap)) + shortNames <- map_chr( + expanded, + .twasCanonicalShortName, + fnToShort = fnToShort + ) + unknown <- setdiff(shortNames, names(.twasMethodMap)) if (length(unknown) > 0) { msg <- glue( "unknown method token(s): {str_flatten(unknown, ', ')}. ", @@ -717,8 +1125,8 @@ setMethod("show", "TwasWeights", function(object) { abort(msg) } # Track the impl name as an attr so dispatchers resolve snake_case -> impl. - entries <- map(methods, .twasMethodArgsWithImpl) - set_names(entries, map_chr(methods, .twasMethodFn)) + entries <- map(shortNames, .twasMethodArgsWithImpl) + set_names(entries, map_chr(shortNames, .twasMethodFn)) } # TRUE if `name` is a function visible in the search path or in namespace `ns`. @@ -766,7 +1174,7 @@ setMethod("show", "TwasWeights", function(object) { if (!all(is_in(c("Sample", "Fold"), names(df)))) { abort("samplePartition must have columns `Sample` and `Fold`.") } - df$Sample <- as.character(df$Sample) + df <- mutate(df, Sample = as.character(.data$Sample)) dup <- unique(df$Sample[duplicated(df$Sample)]) if (length(dup) > 0L) { msg <- glue( @@ -909,191 +1317,341 @@ setMethod("show", "TwasWeights", function(object) { XColnames = NULL, YColnames = NULL ) { - full <- matrix(0, nrow = nColsX, ncol = nColsY) - if (!is.null(XColnames)) { - rownames(full) <- XColnames - } - if (!is.null(YColnames)) { - colnames(full) <- YColnames - } + full <- matrix( + 0, + nrow = nColsX, + ncol = nColsY, + dimnames = list(XColnames, YColnames) + ) full[validColumns, ] <- weightsMatrix full } +# The canonical fine-mapping token behind a weight-method name, accepting the +# token itself (`susieInf`), its camelCase weight function (`susieInfWeights`) +# and its snake_case registry key (`susie_inf_weights`). Stripping the suffix +# is not enough on its own: that turns `susie_inf_weights` into `susie_inf`, +# which is not the registry's token. +# @noRd +.twasFmTokenFor <- function(method) { + methodKeys <- map_chr(.twasFineMappingMethodAdapters, "methodKey") + hit <- names(methodKeys)[methodKeys == method] + if (length(hit) == 1L) { + return(hit) + } + bare <- str_remove(method, "(_weights|Weights)$") + if (is_in(bare, names(.twasFineMappingMethodAdapters))) { + return(bare) + } + NA_character_ +} + +# The `weightMethods` name under which `token` was supplied, or NA when it was +# not requested. Every lookup keyed by method name goes through this, so one +# spelling cannot resolve where another silently misses. +# @noRd +.twasMethodNameFor <- function(weightMethods, token) { + adapter <- .twasFineMappingMethodAdapters[[token]] + spellings <- c(adapter$methodKey, adapter$weightFn, token) + hit <- spellings[is_in(spellings, names(weightMethods))] + if (length(hit) == 0L) { + return(NA_character_) + } + hit[[1]] +} + +# The arguments supplied for `token`, under whichever of its spellings the +# caller used as the `weightMethods` name. +# @noRd +.twasMethodArgsFor <- function(weightMethods, token) { + nm <- .twasMethodNameFor(weightMethods, token) + if (is.na(nm)) { + return(NULL) + } + weightMethods[[nm]] +} + +# The per-fold fits supplied for `token`, under any of its spellings. The gate +# and `.twasFoldFit()` must agree on this, or the gate can refuse fits the +# fold lookup would have found. +# @noRd +.twasFoldFitsFor <- function(fittedModelsCv, token) { + if (is.null(fittedModelsCv)) { + return(NULL) + } + adapter <- .twasFineMappingMethodAdapters[[token]] + spellings <- c(token, adapter$methodKey, adapter$weightFn) + hit <- spellings[is_in(spellings, names(fittedModelsCv))] + if (length(hit) == 0L) { + return(NULL) + } + fittedModelsCv[[hit[[1]]]] +} + +# The SuSiE-family methods requested in `weightMethods`, as canonical tokens. +# @noRd +.twasSusieTokensRequested <- function(weightMethods) { + if (is.null(weightMethods) || length(weightMethods) == 0L) { + return(character(0)) + } + keys <- if (is.character(weightMethods)) { + weightMethods + } else { + names(weightMethods) + } + tokens <- map_chr(keys, .twasFmTokenFor) + unique(tokens[!is.na(tokens)]) +} + +# Fail before any fitting work when a SuSiE-family method is requested without +# the fit it needs. These wrappers extract weights from an existing fit and +# never fine-map, so the run is already doomed; checking here reports the +# missing fit by name instead of surfacing it from inside the per-fold map. +# `available(token)` answers "is this token's fit present?" for the caller's +# own supply channel. +# @noRd +.twasRequireSusieFits <- function(weightMethods, available, fnLabel, how) { + tokens <- .twasSusieTokensRequested(weightMethods) + if (length(tokens) == 0L) { + return(invisible(NULL)) + } + missing <- tokens[!map_lgl(tokens, available)] + if (length(missing) == 0L) { + return(invisible(NULL)) + } + missingStr <- str_flatten(missing, ", ") + msg <- glue( + "{fnLabel}: method(s) {missingStr} extract weights from an existing ", + "fine-mapping fit and never run fine-mapping themselves, but no fit ", + "was supplied for them. {how}" + ) + abort(msg) +} + # Resolve the incoming susie / susieInf fits for the weight run: prefer a fit # carried on the method args, else one from `fittedModels`, tagging each with # its fine-mapping class. Returns list(susieFit, susieInfFit, hasSusie, -# hasSusieInf). +# hasSusieInf, susieName, susieInfName) -- the names being the spellings the +# caller actually used, so the write-back lands where the fitter will look. # @noRd .twasResolveSusieFits <- function(weightMethods, fittedModels) { - hasSusie <- !is.null(weightMethods[["susie_weights"]]) - hasSusieInf <- !is.null(weightMethods[["susie_inf_weights"]]) - susieFit <- if (hasSusie) { - weightMethods[["susie_weights"]][["susieFit"]] + susieName <- .twasMethodNameFor(weightMethods, "susie") + susieInfName <- .twasMethodNameFor(weightMethods, "susieInf") + hasSusie <- !is.na(susieName) + hasSusieInf <- !is.na(susieInfName) + argSusie <- if (hasSusie) { + weightMethods[[susieName]][["susieFit"]] } else { NULL } - susieInfFit <- if (hasSusieInf) { - weightMethods[["susie_inf_weights"]][["susieInfFit"]] + argSusieInf <- if (hasSusieInf) { + weightMethods[[susieInfName]][["susieInfFit"]] } else { NULL } - if (is.null(susieFit)) { - susieFit <- fittedModels[["susie"]] - } - if (is.null(susieInfFit)) { - susieInfFit <- fittedModels[["susieInf"]] - } - if (!is.null(susieFit)) { - susieFit <- .setFinemappingFitClass(susieFit, "susie") + # A fit the caller passed in the method arguments wins; otherwise the + # pipeline's already-fitted model, if it produced one. + susieRaw <- argSusie %||% fittedModels[["susie"]] + susieInfRaw <- argSusieInf %||% fittedModels[["susieInf"]] + susieFit <- if (is.null(susieRaw)) { + NULL + } else { + .setFinemappingFitClass(susieRaw, "susie") } - if (!is.null(susieInfFit)) { - susieInfFit <- .setFinemappingFitClass(susieInfFit, "susieInf") + susieInfFit <- if (is.null(susieInfRaw)) { + NULL + } else { + .setFinemappingFitClass(susieInfRaw, "susieInf") } list( susieFit = susieFit, susieInfFit = susieInfFit, hasSusie = hasSusie, - hasSusieInf = hasSusieInf - ) -} - -# Chained susieInf -> susie fit for the single-outcome case where both methods -# are requested and no fit was supplied. Returns list(susieFit, susieInfFit). -# @noRd -.twasChainedSusieFit <- function(X, Y, weightMethods) { - fitArgNames <- c("susieFit", "susieInfFit", "retainFit") - susieArgs <- weightMethods[["susie_weights"]][setdiff( - names(weightMethods[["susie_weights"]]), - fitArgNames - )] - # modifyList (not list_modify): a NULL user arg should UNSET the key here. - susieInfArgs <- modifyList( - list(convergence_method = "pip"), - weightMethods[["susie_inf_weights"]][setdiff( - names(weightMethods[["susie_inf_weights"]]), - fitArgNames - )] - ) - fits <- fitSusieInfThenSusie( - X, - Y[, 1], - args = susieArgs, - susieInfArgs = susieInfArgs, - fittedModels = list(susie = NULL, susieInf = NULL) + hasSusieInf = hasSusieInf, + susieName = susieName, + susieInfName = susieInfName ) - list(susieFit = fits[["susie"]], susieInfFit = fits[["susieInf"]]) } -# Write the resolved susie / susieInf fits back onto the method args, deriving -# the susie args from a susieInf fit when susie was requested without its own. +# Write the resolved susie / susieInf fits back onto the method args. Deriving +# susie's arguments from a susieInf fit belongs to fine-mapping, not here: it +# prepares a susie *fit* (model_init, unmappable_effects), which +# `susieWeights()` neither accepts nor runs. # @noRd .twasWriteBackSusieFits <- function(weightMethods, r) { - if (!is.null(r$susieInfFit) && r$hasSusieInf) { - weightMethods[["susie_inf_weights"]][["susieInfFit"]] <- r$susieInfFit - } - if (!is.null(r$susieFit) && r$hasSusie) { - weightMethods[["susie_weights"]][["susieFit"]] <- r$susieFit - } - if ( - r$hasSusie && - is.null(weightMethods[["susie_weights"]][["susieFit"]]) && - !is.null(r$susieInfFit) - ) { - weightMethods[["susie_weights"]] <- prepareSusieFromInfArgs( - weightMethods[["susie_weights"]], + withInf <- if (!is.null(r$susieInfFit) && r$hasSusieInf) { + .twasSetMethodArg( + weightMethods, + r$susieInfName, + "susieInfFit", r$susieInfFit ) + } else { + weightMethods } - weightMethods + if (is.null(r$susieFit) || !r$hasSusie) { + return(withInf) + } + .twasSetMethodArg(withInf, r$susieName, "susieFit", r$susieFit) } -.prepareSusieWeightMethods <- function( - X, - Y, - weightMethods, - fittedModels = NULL -) { - if (is.vector(Y)) { - Y <- matrix(Y, ncol = 1) - } +# One method's argument list with `arg` set, leaving every other method and +# every other argument of that method untouched. +# @noRd +.twasSetMethodArg <- function(weightMethods, method, arg, value) { + updated <- list_assign( + weightMethods[[method]], + !!!set_names(list(value), arg) + ) + list_assign(weightMethods, !!!set_names(list(updated), method)) +} + +# Resolve the supplied susie / susieInf fits onto the method args. This never +# fine-maps: the SuSiE-family weight methods extract from a fit that +# fineMappingPipeline() produced, and a missing one is an error, not a cue to +# fit here. +# @noRd +.prepareSusieWeightMethods <- function(weightMethods, fittedModels = NULL) { if (is.null(fittedModels)) { fittedModels <- list() } r <- .twasResolveSusieFits(weightMethods, fittedModels) - if ( - r$hasSusie && - r$hasSusieInf && - ncol(Y) == 1 && - is.null(r$susieFit) && - is.null(r$susieInfFit) - ) { - fits <- .twasChainedSusieFit(X, Y, weightMethods) - r$susieFit <- fits$susieFit - r$susieInfFit <- fits$susieInfFit - } .twasWriteBackSusieFits(weightMethods, r) } # Per-fold TWAS weight fit for the CV engine. `ctx` carries weightMethods, -# multivariateWeightMethods, cvArgs, retainFits, verbose. Weights are keyed by +# multivariateWeightMethods, cvArgs, fitRetention, verbose. Weights are keyed by # the canonical method key; captured fits keep the full method name. # @noRd .weightFitFold <- function(Xtr, Ytr, j, ctx) { - foldWeightMethods <- .prepareSusieWeightMethods(Xtr, Ytr, ctx$weightMethods) - weights <- list() - fits <- list() - for (method in names(foldWeightMethods)) { - res <- .twasFoldMethodWeights( - method, - foldWeightMethods[[method]], - Xtr, - Ytr, - j, - ctx - ) - weights[[res$mk]] <- res$W - fits[[method]] <- res$fit - } - list(weights = weights, fits = fits) + foldWeightMethods <- .prepareSusieWeightMethods(ctx$weightMethods) + methods <- names(foldWeightMethods) + results <- map( + methods, + .twasFoldMethodWeightsAt, + foldWeightMethods = foldWeightMethods, + Xtr = Xtr, + Ytr = Ytr, + j = j, + ctx = ctx + ) + # Weights are keyed by the canonical method key, captured fits by the + # full method name; a later method wins a shared key, as the keyed + # assignment did. + weights <- set_names(map(results, "W"), map_chr(results, "mk")) + list( + weights = weights[!duplicated(names(weights), fromLast = TRUE)], + fits = set_names(map(results, "fit"), methods) + ) +} + +# @noRd +.twasFoldMethodWeightsAt <- function( + method, + foldWeightMethods, + Xtr, + Ytr, + j, + ctx +) { + .twasFoldMethodWeights( + method, + foldWeightMethods[[method]], + Xtr, + Ytr, + j, + ctx + ) } # Per-fold priors bound to a multivariate fitter's camelCase args (mr.mash # data-driven matrices / mvsusie reweighted mixture prior for fold `j`). # @noRd -.twasFoldPriors <- function(args, method, j, cvArgs) { - if ( - !is.null(cvArgs$data_driven_priorMatricesCv) && - is_in(method, c("mrmash_weights", "mrmashWeights")) - ) { - args$dataDrivenPriorMatrices <- cvArgs$data_driven_priorMatricesCv[[j]] +.twasFoldPriors <- function( + args, + method, + j, + dataDrivenPriorMatricesCv, + reweightedMixturePriorCv +) { + list_assign( + args, + !!!compact(list( + dataDrivenPriorMatrices = if ( + !is.null(dataDrivenPriorMatricesCv) && + is_in(method, c("mrmash_weights", "mrmashWeights")) + ) { + dataDrivenPriorMatricesCv[[j]] + }, + prior_variance = if ( + !is.null(reweightedMixturePriorCv) && + is_in(method, c("mvsusie_weights", "mvsusieWeights")) + ) { + reweightedMixturePriorCv[[j]] + } + )) + ) +} + +# Inject the fold's own fine-mapping fit for a SuSiE-family method. Those +# weight wrappers extract from a supplied fit and never fine-map, so a fold +# can only be scored if fineMappingPipeline's CV retained that fold's fit +# (`fittedModelsCv`, keyed method -> fold_). +# @noRd +.twasFoldFit <- function(args, method, j, fittedModelsCv) { + if (is.null(fittedModelsCv)) { + return(args) } - if ( - !is.null(cvArgs$reweightedMixturePriorCv) && - is_in(method, c("mvsusie_weights", "mvsusieWeights")) - ) { - args$prior_variance <- cvArgs$reweightedMixturePriorCv[[j]] + mk <- .twasFmTokenFor(method) + if (is.na(mk)) { + return(args) } - args + adapter <- .twasFineMappingMethodAdapters[[mk]] + perFold <- .twasFoldFitsFor(fittedModelsCv, mk) + if (is.null(perFold)) { + return(args) + } + key <- str_c("fold_", j) + fit <- if (is_in(key, names(perFold))) { + perFold[[key]] + } else if (length(perFold) >= j) { + perFold[[j]] + } else { + NULL + } + if (is.null(fit)) { + return(args) + } + list_assign(args, !!!set_names(list(fit), adapter$fitArg)) } # One fold's multivariate weight fit; returns list(W, fit). # @noRd .twasFoldMultivariate <- function(method, fnName, args, Xtr, Ytr, j, ctx) { - args <- .twasFoldPriors(args, method, j, ctx$cvArgs) - if (isTRUE(ctx$retainFits) && is_in("retainFit", names(formals(fnName)))) { - args$retainFit <- TRUE - } - callArgs <- c(list(X = Xtr, Y = Ytr), args) + withPriors <- .twasFoldPriors( + args, + method, + j, + ctx$dataDrivenPriorMatricesCv, + ctx$reweightedMixturePriorCv + ) + retaining <- !identical(ctx$fitRetention, "none") && + is_in("fitRetention", names(formals(fnName))) + fitArgs <- list_assign( + withPriors, + !!!compact(list( + fitRetention = if (retaining) ctx$fitRetention + )) + ) + callArgs <- .twasWeightCallArgs(fnName, list(X = Xtr, Y = Ytr), fitArgs) W <- if (ctx$verbose < 2) { .quietEval(exec(fnName, !!!callArgs)) } else { exec(fnName, !!!callArgs) } capturedFit <- attr(W, "fit") - attr(W, "fit") <- NULL - rownames(W) <- colnames(Xtr) - list(W = W, fit = capturedFit) + bare <- `attr<-`(W, "fit", NULL) + list(W = `rownames<-`(bare, colnames(Xtr)), fit = capturedFit) } # One fold's univariate weight fit (per Y column, column-bound); no fit kept. @@ -1108,8 +1666,7 @@ setMethod("show", "TwasWeights", function(object) { Ytr = Ytr, args = args ) - W <- exec(cbind, !!!Wcols) - rownames(W) <- colnames(Xtr) + W <- `rownames<-`(exec(cbind, !!!Wcols), colnames(Xtr)) list(W = W, fit = NULL) } @@ -1118,6 +1675,7 @@ setMethod("show", "TwasWeights", function(object) { # @noRd .twasFoldMethodWeights <- function(method, args, Xtr, Ytr, j, ctx) { fnName <- .resolveMethodFunction(method, args) + args <- .twasFoldFit(args, method, j, ctx$fittedModelsCv) mk <- str_remove(method, "_weights$|Weights$") fit <- if (is_in(method, ctx$multivariateWeightMethods)) { .twasFoldMultivariate(method, fnName, args, Xtr, Ytr, j, ctx) @@ -1161,8 +1719,11 @@ setMethod("show", "TwasWeights", function(object) { #' @param verbose Integer controlling verbosity level: 0 = suppress all #' messages, 1 = suppress external package messages (default), 2 = show all #' messages including those from external packages. -#' @param retainFits Logical. Retain the per-fold / per-method fitted-model -#' objects on the result. Default \code{FALSE}. +#' @param fitRetention How much of each per-method fit is kept on the result: +#' \code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed +#' payload downstream needs, \code{"full"} keeps the whole fitted object. +#' Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; +#' for every other method the two behave alike. #' @param seed Integer or \code{NULL}. When supplied, seeds both the #' main-process RNG (fold partitioning, variant sub-sampling) and the #' parallel fold-fitting RNG via the \code{BiocParallel} \code{RNGseed}, so @@ -1170,7 +1731,16 @@ setMethod("show", "TwasWeights", function(object) { #' seed is scoped to the call, so the session RNG is left as it was found. #' \code{NULL} (default) does not seed at all and uses the historical #' parallel default. -#' @param ... Additional arguments forwarded to the per-method weight learners. +#' @param fittedModelsCv Optional per-fold fine-mapping fits, as +#' \code{method -> fold_ -> fit}, from a \code{fineMappingPipeline()} +#' run with \code{cvFolds > 1}. SuSiE-family weight wrappers extract from a +#' supplied fit and never fine-map, so this is what makes cross-validating +#' them possible; it must have been produced on \code{samplePartitions}, +#' since a fit trained on different folds would leak held-out samples. +#' @param dataDrivenPriorMatricesCv Optional list, one element per fold, of +#' data-driven prior matrices for the mr.mash learner. +#' @param reweightedMixturePriorCv Optional list, one element per fold, of +#' reweighted mixture priors for the mvSuSiE learner. #' @return A list with the following components: #' \itemize{ #' \item `samplePartition`: A dataframe showing the sample partitioning used @@ -1196,14 +1766,19 @@ setMethod("show", "TwasWeights", function(object) { #' process. #' } #' @importFrom purrr map -#' @importFrom BiocParallel bplapply bpworkers MulticoreParam +#' @importFrom BiocParallel bplapply multicoreWorkers MulticoreParam #' @importFrom quadprog solve.QP #' @examples #' data(multiTraitData) #' X <- multiTraitData$X[, 1:80] #' Y <- multiTraitData$Y +#' # A cross-validated method is refit on each fold's training rows. The +#' # SuSiE family never fine-maps, so it needs each fold's own fit, passed +#' # as `fittedModelsCv` from a fineMappingPipeline() run with cvFolds > 1. #' twasWeightsCv(X, Y[, 1, drop = FALSE], fold = 3, -#' weightMethods = list(susie_weights = list())) +#' weightMethods = list(lasso_weights = list())) +#' @importFrom checkmate assertDataFrame assertNumber assertInt +#' @importFrom checkmate assertFlag assertCount #' @export twasWeightsCv <- function( X, @@ -1215,13 +1790,40 @@ twasWeightsCv <- function( variantsToKeep = NULL, numThreads = 1, verbose = 1, - retainFits = FALSE, + fitRetention = c("none", "slim", "full"), seed = NULL, - ... + dataDrivenPriorMatricesCv = NULL, + reweightedMixturePriorCv = NULL, + fittedModelsCv = NULL ) { - p <- as.list(environment()) - p$cvArgs <- list(...) - .twasWeightsCvImpl(p) + # X / Y / fold are asserted downstream in .cvPrepareData; these are the + # arguments nothing else checks. + assertDataFrame(samplePartitions, null.ok = TRUE) + # NOT assertCount: `Inf` is the "no cap" sentinel (jointEngine passes it + # when cfg$crossValidation$maxVariants is unset), and + # .cvSubsampleVariants relies on `ncol(X) <= maxNumVariants` being FALSE + # for it. + assertNumber(maxNumVariants, lower = 1, null.ok = TRUE) + assertInt(numThreads) + assertCount(verbose) + fitRetention <- arg_match(fitRetention) + assertInt(seed, null.ok = TRUE) + .twasWeightsCvImpl( + X = X, + Y = Y, + fold = fold, + samplePartitions = samplePartitions, + weightMethods = weightMethods, + maxNumVariants = maxNumVariants, + variantsToKeep = variantsToKeep, + numThreads = numThreads, + verbose = verbose, + fitRetention = fitRetention, + seed = seed, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + reweightedMixturePriorCv = reweightedMixturePriorCv, + fittedModelsCv = fittedModelsCv + ) } # Multivariate weight methods (snake + camel) fit on the whole Y for a fold; @@ -1236,82 +1838,182 @@ twasWeightsCv <- function( "mvsusieWeights" ) -# twasWeightsCv worker. `p` is the captured public arguments plus `cvArgs` -# (the `...`). With no weightMethods the caller only wants the fold partition. +# Refuse per-fold fits that were not produced on the folds being scored. A +# fit trained on a different split has seen some of this split's held-out +# samples, so its out-of-fold predictions are contaminated and the CV metrics +# come out optimistic -- silently. Fits carry the producer's partition +# fingerprint (see .cvPartitionKey); anything unstamped is refused too, since +# it cannot be shown to match. # @noRd -.twasWeightsCvImpl <- function(p) { - weightMethods <- if (is.character(p$weightMethods)) { - .twasMethodLookup(p$weightMethods) - } else { - p$weightMethods +.twasCheckFoldFitPartition <- function(fittedModelsCv, samplePartitions) { + if (is.null(fittedModelsCv) || length(fittedModelsCv) == 0L) { + return(invisible(NULL)) } - if (is.null(p$seed) && !exists(".Random.seed") && p$verbose >= 1) { - inform(str_c( - "! No seed set. Pass `seed=` or call ", - "set.seed() for reproducibility." - )) + if (is.null(samplePartitions)) { + msg <- glue( + "twasWeightsCv: `fittedModelsCv` needs the fold partition those ", + "fits were trained on. Pass the fine-mapping CV's ", + "`samplePartition` as `samplePartitions`; a freshly drawn ", + "partition would score each fold with a fit that saw its ", + "held-out samples." + ) + abort(msg) + } + want <- .cvPartitionKey(samplePartitions) + for (m in names(fittedModelsCv)) { + got <- attr(fittedModelsCv[[m]], "partitionKey") + if (is.null(got)) { + msg <- glue( + "twasWeightsCv: the per-fold fits for '{m}' carry no ", + "partition fingerprint, so they cannot be shown to match ", + "`samplePartitions`. Take them from a fineMappingPipeline() ", + "run with cvFolds > 1." + ) + abort(msg) + } + if (!identical(got, want)) { + msg <- glue( + "twasWeightsCv: the per-fold fits for '{m}' were trained on ", + "a different fold partition than the one being scored. Use ", + "the fine-mapping CV's own `samplePartition`." + ) + abort(msg) + } } + invisible(NULL) +} + +# What .weightFitFold() needs to refit one fold, or NULL on the +# partition-only path where .cvNoopFitFold() reads nothing. +# @noRd +.twasCvFoldCtx <- function( + weightMethods, + dataDrivenPriorMatricesCv, + reweightedMixturePriorCv, + fittedModelsCv, + fitRetention, + verbose +) { if (is.null(weightMethods)) { - res <- .crossValidateWeights( - p$X, - p$Y, - fold = p$fold, - samplePartitions = p$samplePartitions, - fitFold = .cvNoopFitFold, - numThreads = p$numThreads, - maxNumVariants = p$maxNumVariants, - variantsToKeep = p$variantsToKeep, - retainFits = p$retainFits, - verbose = p$verbose, - seed = p$seed - ) - return(list(samplePartition = res$samplePartition)) + return(NULL) } - cvFitCtx <- list( + list( weightMethods = weightMethods, multivariateWeightMethods = .twasCvMultivariateMethods, - cvArgs = p$cvArgs, - retainFits = p$retainFits, - verbose = p$verbose + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + reweightedMixturePriorCv = reweightedMixturePriorCv, + fittedModelsCv = fittedModelsCv, + fitRetention = fitRetention, + verbose = verbose + ) +} + +# twasWeightsCv worker. With no weightMethods the caller only wants the fold +# partition. +# @noRd +.twasWeightsCvImpl <- function( + X, + Y, + fold, + samplePartitions, + weightMethods, + maxNumVariants, + variantsToKeep, + numThreads, + verbose, + fitRetention, + seed, + dataDrivenPriorMatricesCv, + reweightedMixturePriorCv, + fittedModelsCv +) { + weightMethods <- .twasCvResolveMethods( + weightMethods, + fittedModelsCv, + samplePartitions, + seed, + verbose ) - .crossValidateWeights( - p$X, - p$Y, - fold = p$fold, - samplePartitions = p$samplePartitions, - fitFold = .weightFitFold, - fitFoldCtx = cvFitCtx, - numThreads = p$numThreads, - maxNumVariants = p$maxNumVariants, - variantsToKeep = p$variantsToKeep, - retainFits = p$retainFits, - verbose = p$verbose, - seed = p$seed + # No methods means "partition only": the no-op fold fit walks the same + # engine so the returned partition is the one a real run would use. + noMethods <- is.null(weightMethods) + res <- .crossValidateWeights( + X, + Y, + fold = fold, + samplePartitions = samplePartitions, + fitFold = if (noMethods) .cvNoopFitFold else .weightFitFold, + fitFoldCtx = .twasCvFoldCtx( + weightMethods, + dataDrivenPriorMatricesCv, + reweightedMixturePriorCv, + fittedModelsCv, + fitRetention, + verbose + ), + numThreads = numThreads, + maxNumVariants = maxNumVariants, + variantsToKeep = variantsToKeep, + fitRetention = fitRetention, + verbose = verbose, + seed = seed ) + if (noMethods) list(samplePartition = res$samplePartition) else res +} + +# Check the fold-fit inputs and turn a character `weightMethods` into the +# method record the fold fitter takes. Also the one place that notices an +# unseeded call, since this is where the partition is about to be drawn. +# @noRd +.twasCvResolveMethods <- function( + weightMethods, + fittedModelsCv, + samplePartitions, + seed, + verbose +) { + .twasCheckFoldFitPartition(fittedModelsCv, samplePartitions) + .twasRequireSusieFits( + weightMethods, + available = function(tk) { + !is.null(.twasFoldFitsFor(fittedModelsCv, tk)) + }, + fnLabel = "twasWeightsCv", + how = str_c( + "Cross-validation refits on each fold, so it needs that fold's ", + "own fit: pass `fittedModelsCv = list( = )` ", + "from a fineMappingPipeline() run with cvFolds > 1." + ) + ) + if (is.null(seed) && !exists(".Random.seed") && verbose >= 1) { + inform(str_c( + "! No seed set. Pass `seed=` or call ", + "set.seed() for reproducibility." + )) + } + .twasAsMethodRecord(weightMethods) } # Fit one TWAS weight method by name against the filtered design matrix, # embedding the fitted weights back into the full variant space. `ctx` carries -# the shared fit state (X, Y, Xfiltered, validColumns, retainFits, -# retainFitDetail, verbose). +# the shared fit state (X, Y, Xfiltered, validColumns, fitRetention, +# verbose). # @noRd .computeMethodWeights <- function(methodName, weightMethods, ctx) { shortName <- str_remove(methodName, "_weights$") if (ctx$verbose >= 1) { - msg <- glue(" Fitting {shortName} ...") - inform(msg) + inform(glue(" Fitting {shortName} ...")) tic() } - args <- weightMethods[[methodName]] - fnName <- .resolveMethodFunction(methodName, args) - args <- .twasApplyRetainFit( - args, + userArgs <- weightMethods[[methodName]] + fnName <- .resolveMethodFunction(methodName, userArgs) + fitArgs <- .twasApplyRetainFit( + userArgs, fnName, - ctx$retainFits, - ctx$retainFitDetail + ctx$fitRetention ) - fit <- .twasFitWeightsMatrix(fnName, args, ctx, methodName) - result <- .embedWeights( + fit <- .twasFitWeightsMatrix(fnName, fitArgs, ctx, methodName) + embedded <- .embedWeights( fit$weights, ctx$validColumns, ncol(ctx$X), @@ -1319,14 +2021,15 @@ twasWeightsCv <- function( colnames(ctx$X), colnames(ctx$Y) ) - if (!is.null(fit$methodFit)) { - attr(result, "fit") <- fit$methodFit + result <- if (is.null(fit$methodFit)) { + embedded + } else { + `attr<-`(embedded, "fit", fit$methodFit) } if (ctx$verbose >= 1) { elapsed <- toc(quiet = TRUE) secs <- sprintf("%.1f", elapsed$toc - elapsed$tic) - msg <- glue(" Fitting {shortName} done in {secs}s") - inform(msg) + inform(glue(" Fitting {shortName} done in {secs}s")) } result } @@ -1344,23 +2047,18 @@ twasWeightsCv <- function( "fsusieWeights" ) -# Add retainFit (or its legacy retain_fit alias) + fitDetail to `args` when the -# target weight function accepts them and fits are being retained. +# Pass the retention level down to the target weight function, when it takes +# one and the caller is keeping fits at all. A target that does not take +# `fitRetention` keeps nothing, which is what "no such argument" means. # @noRd -.twasApplyRetainFit <- function(args, fnName, retainFits, retainFitDetail) { - if (!retainFits) { +.twasApplyRetainFit <- function(args, fnName, fitRetention) { + if (identical(fitRetention, "none")) { return(args) } - fnFormals <- names(formals(fnName)) - if (is_in("retainFit", fnFormals)) { - args$retainFit <- TRUE - } else if (is_in("retain_fit", fnFormals)) { - args$retain_fit <- TRUE - } - if (is_in("fitDetail", fnFormals) && is.null(args$fitDetail)) { - args$fitDetail <- retainFitDetail + if (!is_in("fitRetention", names(formals(fnName)))) { + return(args) } - args + list_assign(args, fitRetention = args$fitRetention %||% fitRetention) } # Dispatch weight fitting to the multivariate or per-column univariate path; @@ -1377,15 +2075,25 @@ twasWeightsCv <- function( # Multivariate fit: one call producing the full variants x features matrix. # @noRd .twasFitMultivariate <- function(fnName, args, ctx) { - call <- c(list(X = ctx$Xfiltered, Y = ctx$Y), args) - weightsMatrix <- if (ctx$verbose < 2) { + call <- .twasWeightCallArgs( + fnName, + list(X = ctx$Xfiltered, Y = ctx$Y), + args + ) + fitted <- if (ctx$verbose < 2) { .quietEval(exec(fnName, !!!call)) } else { exec(fnName, !!!call) } - methodFit <- if (ctx$retainFits) attr(weightsMatrix, "fit") else NULL - if (nrow(weightsMatrix) != length(ctx$validColumns)) { - weightsMatrix <- weightsMatrix[names(ctx$validColumns), , drop = FALSE] + methodFit <- if (!identical(ctx$fitRetention, "none")) { + attr(fitted, "fit") + } else { + NULL + } + weightsMatrix <- if (nrow(fitted) == length(ctx$validColumns)) { + fitted + } else { + fitted[names(ctx$validColumns), , drop = FALSE] } list(weights = weightsMatrix, methodFit = methodFit) } @@ -1394,29 +2102,54 @@ twasWeightsCv <- function( # weights matrix. # @noRd .twasFitUnivariate <- function(fnName, args, ctx) { - weightsMatrix <- matrix(0, nrow = ncol(ctx$Xfiltered), ncol = ncol(ctx$Y)) - methodFit <- NULL - for (k in seq_len(ncol(ctx$Y))) { - call <- c(list(X = ctx$Xfiltered, y = ctx$Y[, k]), args) - weightsVector <- if (ctx$verbose < 2) { - .quietEval(exec(fnName, !!!call)) + columns <- map( + seq_len(ncol(ctx$Y)), + .twasUnivariateColumn, + fnName = fnName, + args = args, + ctx = ctx + ) + fits <- compact(map(columns, "fit")) + list( + weights = matrix( + unname(list_c(map(columns, "weights"))), + nrow = ncol(ctx$Xfiltered), + ncol = ncol(ctx$Y) + ), + # The first outcome that carries one defines the method fit, which is + # what "set it only while still NULL" produced. + methodFit = if (length(fits) == 0L) NULL else fits[[1L]] + ) +} + +# One outcome column's weights, plus the fit the method attached to them. A +# method that answers with a matrix is reporting every outcome at once, so +# this column's own slice is taken. +# @noRd +.twasUnivariateColumn <- function(k, fnName, args, ctx) { + call <- .twasWeightCallArgs( + fnName, + list(X = ctx$Xfiltered, y = ctx$Y[, k]), + args + ) + w <- if (ctx$verbose < 2) { + .quietEval(exec(fnName, !!!call)) + } else { + exec(fnName, !!!call) + } + list( + weights = if (is.matrix(w)) w[, k] else w, + fit = if (!identical(ctx$fitRetention, "none")) { + attr(w, "fit") } else { - exec(fnName, !!!call) + NULL } - if (ctx$retainFits && is.null(methodFit)) { - methodFit <- attr(weightsVector, "fit") - } - if (is.matrix(weightsVector)) { - weightsVector <- weightsVector[, k] - } - weightsMatrix[, k] <- weightsVector - } - list(weights = weightsMatrix, methodFit = methodFit) + ) } # Assemble the (study, context, trait, method, entry) row vectors for the # TwasWeights collection from the fitted `weightsList`. `ctx` carries the shared -# identity + flags (study, context, trait, Y, retainFits, standardized, +# identity + flags (study, context, trait, Y, fitRetention, standardized, # dataType). # @noRd .buildTwasWeightEntries <- function(weightsList, variantIds, ctx) { @@ -1455,8 +2188,8 @@ twasWeightsCv <- function( # @noRd .twasMethodRows <- function(m, wMat, variantIds, ctx) { fitVal <- attr(wMat, "fit") - attr(wMat, "fit") <- NULL - fits <- if (ctx$retainFits) fitVal else NULL + wMat <- `attr<-`(wMat, "fit", NULL) + fits <- if (!identical(ctx$fitRetention, "none")) fitVal else NULL shortMethod <- str_remove(m, "(_weights|Weights)$") nY <- ncol(ctx$Y) perOutcome <- length(ctx$trait) == nY && @@ -1511,9 +2244,17 @@ twasWeightsCv <- function( #' set to -1, the function uses all available cores. If set to 0 or 1, no #' parallel processing is performed. If set to 2 or more, parallel processing #' is enabled with that many threads. -#' @param fittedModels Optional named list of fitted SuSiE-family models. -#' @param retainFits If TRUE, retain fitted model objects as attributes on -#' returned weight matrices when supported by the weight method. +#' @param fittedModels Named list of fitted SuSiE-family models, keyed by +#' token (\code{susie}, \code{susieInf}, \code{mvsusie}, \code{fsusie}). +#' Required whenever a SuSiE-family weight method is requested: those +#' methods extract weights from an existing fit and never fine-map, so a +#' missing fit is an error. Run \code{\link{fineMappingPipeline}} to +#' produce the fits. +#' @param fitRetention How much of each per-method fit is kept on the result: +#' \code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed +#' payload downstream needs, \code{"full"} keeps the whole fitted object. +#' Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; +#' for every other method the two behave alike. #' @param verbose Integer controlling verbosity level: 0 = suppress all #' messages, 1 = suppress external package messages (default), 2 = show all #' messages including those from external packages. @@ -1523,8 +2264,6 @@ twasWeightsCv <- function( #' weights. #' @param trait Character. Trait identity label recorded on the resulting #' weights. -#' @param retainFitDetail Character. Level of fit detail to retain: -#' \code{"slim"} (default) or \code{"full"}. #' @param standardized Logical. Whether the supplied \code{X} / \code{Y} are #' already standardized. Default \code{FALSE}. #' @param dataType Character or \code{NULL}. Data-type label recorded on the @@ -1543,13 +2282,19 @@ twasWeightsCv <- function( #' data(multiTraitData) #' X <- multiTraitData$X[, 1:80] #' Y <- multiTraitData$Y +#' # SuSiE-family methods extract weights from an existing fit and never +#' # fine-map themselves, so the fit is supplied via `fittedModels`. +#' fit <- susieR::susie(X, Y[, 1], L = 5) #' learnTwasWeights(X, Y[, 1, drop = FALSE], -#' weightMethods = list(susie_weights = list())) +#' weightMethods = list(susie_weights = list()), +#' fittedModels = list(susie = fit)) #' @export #' @importFrom purrr map exec #' @importFrom rlang !!! abort warn inform arg_match cnd_signal .data #' @importFrom glue glue #' @importFrom tictoc tic toc +#' @importFrom checkmate assertString assertInt assertFlag assertCount +#' @importFrom checkmate assert checkList checkCharacter learnTwasWeights <- function( X, Y, @@ -1559,29 +2304,56 @@ learnTwasWeights <- function( trait = "", numThreads = 1, fittedModels = NULL, - retainFits = FALSE, - retainFitDetail = c("slim", "full"), + fitRetention = c("none", "slim", "full"), standardized = FALSE, dataType = NULL, ldSketch = NULL, verbose = 1, seed = NULL ) { - .learnTwasWeightsImpl(as.list(environment())) + assertString(study) + assertString(context) + assertString(trait) + assertInt(numThreads) + fitRetention <- arg_match(fitRetention) + assertFlag(standardized) + assertString(dataType, null.ok = TRUE) + assertCount(verbose) + assertInt(seed, null.ok = TRUE) + # weightMethods is documented as a named list OR a character vector. + assert( + checkList(weightMethods), + checkCharacter(weightMethods), + .var.name = "weightMethods" + ) + .learnTwasWeightsImpl( + X = X, + Y = Y, + weightMethods = weightMethods, + study = study, + context = context, + trait = trait, + numThreads = numThreads, + fittedModels = fittedModels, + fitRetention = fitRetention, + standardized = standardized, + dataType = dataType, + ldSketch = ldSketch, + verbose = verbose, + seed = seed + ) } # Validate X/Y shapes; coerce a vector Y to a one-column matrix. Returns Y. # @noRd +#' @importFrom checkmate assert assertMatrix checkAtomicVector checkMatrix .twasValidateXY <- function(X, Y) { - if (!is.matrix(X) || (!is.matrix(Y) && !is.vector(Y))) { - abort("X must be a matrix and Y must be a matrix or a vector.") - } + assertMatrix(X) + assert(checkMatrix(Y), checkAtomicVector(Y), .var.name = "Y") if (is.vector(Y)) { Y <- matrix(Y, ncol = 1) } - if (nrow(X) != nrow(Y)) { - abort("The number of rows in X and Y must be the same.") - } + assertMatrix(Y, nrows = nrow(X)) Y } @@ -1589,7 +2361,7 @@ learnTwasWeights <- function( # requested count capped at what is available. # @noRd .twasResolveCores <- function(numThreads) { - avail <- bpworkers(MulticoreParam()) + avail <- multicoreWorkers() min(if (numThreads == -1) avail else numThreads, avail) } @@ -1627,8 +2399,7 @@ learnTwasWeights <- function( } else { map(names(weightMethods), .computeMethodWeights, weightMethods, ctx) } - names(weightsList) <- names(weightMethods) - weightsList + set_names(weightsList, names(weightMethods)) } # Set weight-matrix rownames to colnames(X), preserving any retained `fit` attr. @@ -1640,59 +2411,109 @@ learnTwasWeights <- function( map(weightsList, .twasSetRownames, X = X) } -# learnTwasWeights worker: validate, resolve methods, fit each, and assemble the -# TwasWeights collection. `p` is the captured public arguments. +# Whether a fine-mapping token's fit is already available -- on the method's +# own arguments, or in `fittedModels`. # @noRd -.learnTwasWeightsImpl <- function(p) { - .applySeed(p$seed) - retainFitDetail <- p$retainFitDetail - retainFitDetail <- arg_match(retainFitDetail, c("slim", "full")) - Y <- .twasValidateXY(p$X, p$Y) - weightMethods <- if (is.character(p$weightMethods)) { - .twasMethodLookup(p$weightMethods) - } else { - p$weightMethods - } - validColumns <- .nonzeroVarColumns(p$X) - Xfiltered <- as.matrix(p$X[, validColumns, drop = FALSE]) - weightMethods <- .prepareSusieWeightMethods( - Xfiltered, - Y, - weightMethods, - p$fittedModels +.twasLearnFitAvailable <- function(tk, resolvedMethods, fittedModels) { + adapter <- .twasFineMappingMethodAdapters[[tk]] + args <- .twasMethodArgsFor(resolvedMethods, tk) + !is.null(args[[adapter$fitArg]]) || !is.null(fittedModels[[tk]]) +} + +# Refuse a fine-mapping token that learnTwasWeights() has no fit for, naming +# both ways one can be supplied. +# @noRd +.twasRequireLearnFits <- function(resolvedMethods, fittedModels) { + .twasRequireSusieFits( + resolvedMethods, + available = partial( + .twasLearnFitAvailable, + resolvedMethods = resolvedMethods, + fittedModels = fittedModels + ), + fnLabel = "learnTwasWeights", + how = str_c( + "Pass it as `fittedModels = list( = )`, or on the ", + "method's own arguments; run fineMappingPipeline() first to ", + "produce one." + ) ) +} + +.learnTwasWeightsImpl <- function( + X, + Y, + weightMethods, + study, + context, + trait, + numThreads, + fittedModels, + fitRetention, + standardized, + dataType, + ldSketch, + verbose, + seed +) { + .applySeed(seed) + # fitRetention arrives already matched: learnTwasWeights is the only + # caller and validates it there, where the choices are declared. + Y <- .twasValidateXY(X, Y) + resolvedMethods <- .twasAsMethodRecord(weightMethods) + .twasRequireLearnFits(resolvedMethods, fittedModels) + validColumns <- .nonzeroVarColumns(X) + Xfiltered <- as.matrix(X[, validColumns, drop = FALSE]) + prepared <- .prepareSusieWeightMethods(resolvedMethods, fittedModels) ctx <- list( - X = p$X, + X = X, Y = Y, Xfiltered = Xfiltered, validColumns = validColumns, - study = p$study, - context = p$context, - trait = p$trait, - retainFits = p$retainFits, - retainFitDetail = retainFitDetail, - standardized = p$standardized, - dataType = p$dataType, - verbose = p$verbose, - rngSeed = p$seed + study = study, + context = context, + trait = trait, + fitRetention = fitRetention, + standardized = standardized, + dataType = dataType, + verbose = verbose, + rngSeed = seed ) weightsList <- .twasFitAllMethods( - weightMethods, + prepared, ctx, - .twasResolveCores(p$numThreads) - ) - weightsList <- .twasApplyRownames(weightsList, p$X) - rows <- .buildTwasWeightEntries(weightsList, .twasVariantIds(p$X), ctx) + .twasResolveCores(numThreads) + ) |> + .twasApplyRownames(X) + rows <- .buildTwasWeightEntries(weightsList, .twasVariantIds(X), ctx) + .twasLearnResult(rows, ldSketch) +} + +# The learn path's column-wise row record as a TwasWeights collection. NOT +# the pipeline's same-shaped helper, which takes a LIST of per-row records +# and map_chr()s across them -- a different input entirely, and sharing a +# name with it would let collate order decide which one a call reaches. +# @noRd +.twasLearnResult <- function(rows, ldSketch) { TwasWeights( study = rows$study, context = rows$context, trait = rows$trait, method = rows$method, entry = rows$entry, - ldSketch = p$ldSketch + ldSketch = ldSketch ) } +# `weightMethods` takes the method record or a character shorthand for it. +# @noRd +.twasAsMethodRecord <- function(weightMethods) { + if (is.character(weightMethods)) { + return(.twasMethodLookup(weightMethods)) + } + weightMethods +} + #' Predict outcomes using TWAS weights #' #' This function takes a matrix of predictors (\code{X}) and a list of TWAS @@ -1724,7 +2545,15 @@ learnTwasWeights <- function( #' tw <- TwasWeights(study = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(twe)) #' twasPredict(X, tw) +#' @importFrom checkmate assert checkList checkClass +#' @importFrom checkmate assertList twasPredict <- function(X, weightsList) { + # The body branches on TwasWeights, so this is a list OR that S4 class. + assert( + checkList(weightsList), + checkClass(weightsList, "TwasWeights"), + .var.name = "weightsList" + ) if (is(weightsList, "TwasWeights")) { # Per-row weights vector/matrix payloads. Use the method name as key # for compatibility with the legacy snake_case "_predicted" @@ -1758,7 +2587,8 @@ twasPredict <- function(X, weightsList) { #' @param weightResults Named list of weight vectors or matrices as returned by #' \code{\link{learnTwasWeights}}. The mr.ash element should have a #' \code{"fit"} attribute containing the model fit object (set -#' \code{retainFits = TRUE} in \code{learnTwasWeights} to obtain this). +#' \code{fitRetention = "slim"} in \code{learnTwasWeights} to obtain +#' this). #' #' @return A scalar sparsity estimate (proportion of non-zero effects). #' @examples @@ -1775,8 +2605,8 @@ estimateSparsity <- function(weightResults) { msg <- glue( "mr.ash entry not found in TwasWeights. Run ", "learnTwasWeights() ", - "with retainFits = TRUE and ensure 'mrash' is in the ", - "method list." + "with fitRetention = \"slim\" and ensure 'mrash' is in ", + "the method list." ) abort(msg) } @@ -1784,7 +2614,7 @@ estimateSparsity <- function(weightResults) { if (is.null(fit) || is.null(fit$pi)) { msg <- glue( "mr.ash fit object not found. Run learnTwasWeights() with ", - "retainFits = TRUE ", + "fitRetention = \"slim\" ", "and ensure mrash_weights is included." ) abort(msg) @@ -1800,7 +2630,7 @@ estimateSparsity <- function(weightResults) { if (is.null(fit) || is.null(fit$pi)) { msg <- glue( "mr.ash fit object not found. Run learnTwasWeights() with ", - "retainFits = TRUE ", + "fitRetention = \"slim\" ", "and ensure mrash_weights is included." ) abort(msg) @@ -1844,9 +2674,11 @@ estimateSparsity <- function(weightResults) { # The per-method args list for short name `m`, tagged with its `impl` attribute. # @noRd .twasMethodArgsWithImpl <- function(m) { - args <- .twasMethodMap[[m]]$args - attr(args, "impl") <- .twasMethodMap[[m]]$impl - args + `attr<-`( + .twasMethodMap[[m]]$args, + "impl", + .twasMethodMap[[m]]$impl + ) } # The implementation function name for short method name `m`. @@ -1861,10 +2693,21 @@ estimateSparsity <- function(weightResults) { .twasFoldRow(k, cvFolds[[k]], sampleNames) } +# Route a caller's per-method arguments into a weight function. A wrapper's +# own formals (a pre-fit, fitRetention, initPriorSd, ...) bind by name; any +# else is a tool option and goes in the wrapper's `methodArgs` list, so an +# unknown option errors inside the wrapper rather than vanishing. Wrappers +# with no `methodArgs` formal get everything by name, and R reports an unused +# argument -- which is the point. +# @noRd +.twasWeightCallArgs <- function(fnName, baseArgs, userArgs) { + c(baseArgs, .splitMethodArgs(fnName, userArgs)) +} + # One univariate fold's weight column for outcome `k` (quiet unless verbose). # @noRd .twasFitColWeight <- function(k, ctx, fnName, Xtr, Ytr, args) { - callArgs <- c(list(X = Xtr, y = Ytr[, k]), args) + callArgs <- .twasWeightCallArgs(fnName, list(X = Xtr, y = Ytr[, k]), args) w <- if (ctx$verbose < 2) { .quietEval(exec(fnName, !!!callArgs)) } else { @@ -1904,11 +2747,11 @@ estimateSparsity <- function(weightResults) { # @noRd .twasSetRownames <- function(x, X) { fit <- attr(x, "fit") - rownames(x) <- colnames(X) - if (!is.null(fit)) { - attr(x, "fit") <- fit + named <- `rownames<-`(x, colnames(X)) + if (is.null(fit)) { + return(named) } - x + `attr<-`(named, "fit", fit) } # X %*% w for one weight vector/matrix (coerced to a 1-column matrix if needed). diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index 1f6b1d866..8083d2d2a 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -6,10 +6,10 @@ # column (delegates to the generic `.rbindCollections`, which unions columns # and pads a side lacking an optional column such as joint* / region). # @noRd +#' @importFrom checkmate assertClass .rbindTwasWeights <- function(a, b, ldSketch = NULL) { - if (!is(a, "TwasWeights") || !is(b, "TwasWeights")) { - abort(".rbindTwasWeights expects two TwasWeights inputs.") - } + assertClass(a, "TwasWeights") + assertClass(b, "TwasWeights") # Carry forward every column (joint*, region, ...) and reconcile the # collection-level slots via the shared combine. .combineTupleCollections(list(a, b), ldSketch, ".rbindTwasWeights") @@ -18,23 +18,27 @@ # Normalize combine() varargs: accept either N objects or a single list of # them; drop NULLs; require at least one input of the expected class `cls`. .asCombineList <- function(parts, cls, fn) { - if ( + # A single list argument is the collection itself, not a one-element + # variadic call. + unwrapped <- if ( length(parts) == 1L && is.list(parts[[1L]]) && !methods::is(parts[[1L]], cls) ) { - parts <- parts[[1L]] + parts[[1L]] + } else { + parts } - parts <- compact(parts) - if (length(parts) == 0L) { + present <- compact(unwrapped) + if (length(present) == 0L) { msg <- glue("{fn}: nothing to combine (need at least one {cls}).") abort(msg) } - if (!all(map_lgl(parts, methods::is, cls))) { + if (!all(map_lgl(present, methods::is, cls))) { msg <- glue("{fn}: every input must be a {cls}.") abort(msg) } - parts + present } #' Combine TwasWeights collections @@ -113,31 +117,28 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # reporting data.frame. .twasMergeRegionEntries <- function(entries, regionLabels) { keep <- !map_lgl(entries, is.null) - entries <- entries[keep] - regionLabels <- regionLabels[keep] - if (length(entries) == 0L) { + fitted <- entries[keep] + fittedLabels <- regionLabels[keep] + if (length(fitted) == 0L) { return(NULL) } - if (length(entries) == 1L) { - return(entries[[1L]]) + if (length(fitted) == 1L) { + return(fitted[[1L]]) } - entries <- map(entries, .asTwRowPayload) - wList <- map(entries, getWeights) + payloads <- map(fitted, .asTwRowPayload) + wList <- map(payloads, getWeights) weights <- if (is.matrix(wList[[1L]])) { exec(rbind, !!!wList) } else { - unlist(wList, use.names = FALSE) + unname(list_c(wList)) } twasWeightsRow( - variantIds = unlist( - map(entries, .twrPartsVariantIds), - use.names = FALSE - ), + variantIds = unname(list_c(map(payloads, .twrPartsVariantIds))), weights = weights, - fits = set_names(map(entries, getFits), regionLabels), - cvResult = .twasRegionCvDf(entries, regionLabels), - standardized = getStandardized(entries[[1L]]), - dataType = getDataType(entries[[1L]]) + fits = set_names(map(payloads, getFits), fittedLabels), + cvResult = .twasRegionCvDf(payloads, fittedLabels), + standardized = getStandardized(payloads[[1L]]), + dataType = getDataType(payloads[[1L]]) ) } @@ -148,6 +149,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # otherwise the partition the per-fold priors were computed on) NULL input # returns all-NULL, preserving the supplied samplePartition. # @noRd +#' @importFrom checkmate assertClass .unpackMashPrior <- function(mashPrior, samplePartition = NULL) { if (is.null(mashPrior)) { return(list( @@ -156,15 +158,10 @@ combineTwasWeights <- function(..., ldSketch = NULL) { samplePartition = samplePartition )) } - if (!is(mashPrior, "MashPrior")) { - abort("`mashPrior` must be a MashPrior object (see ?MashPrior).") - } + assertClass(mashPrior, "MashPrior") cvFits <- getCvFits(mashPrior) perFold <- if (!is.null(cvFits)) cvFits$perFoldFits else NULL - sp <- samplePartition - if (is.null(sp) && !is.null(cvFits) && !is.null(cvFits$samplePartition)) { - sp <- cvFits$samplePartition - } + sp <- samplePartition %||% cvFits$samplePartition list( fullPrior = getFullFit(mashPrior), dataDrivenPriorMatricesCv = perFold, @@ -313,7 +310,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # lookup) and `methodList` (the `_weights = args` list passed to # `learnTwasWeights` / sumstat helpers). # @noRd -.twasNormalizeMethods <- function(methods) { +.twasNormalizeMethods <- function(methods, inputKind = "QtlDataset") { if (is.null(methods)) { methodList <- .twasMethodLookup("default") return(list( @@ -324,12 +321,28 @@ combineTwasWeights <- function(..., ldSketch = NULL) { if (is.character(methods)) { return(.twasNormalizeCharMethods(methods)) } - if (is.list(methods)) { - return(.twasNormalizeListMethods(methods)) + if (is(methods, "MethodsSelectionParam") || is.list(methods)) { + # Routable here, unlike in the constructor: this call knows its + # input class, so a plain list of overrides goes into that path's + # slot and is checked against the engine that receives it. + resolved <- .methodsParamResolve( + .methodsParamFor( + methods, + inputKind, + "TwasWeightsMethodsParam", + "twasWeightsPipeline" + ), + inputKind + ) + return(.twasNormalizeListMethods(resolved$methodArgs)) + } + if (.isMethodOptions(methods)) { + # The retired TwasWeightsMethodsParam() record. + return(.twasNormalizeListMethods(map(as.list(methods), as.list))) } msg <- glue( - "`methods` must be a character vector, preset string, or ", - "named list." + "`methods` must be a character vector, a preset string, a named ", + "list of per-method options, or a TwasWeightsMethodsParam() record." ) abort(msg) } @@ -345,14 +358,12 @@ combineTwasWeights <- function(..., ldSketch = NULL) { .twasKnownMethodLookupNames() ) regular <- setdiff(methods, fmExtra) - methodList <- if (length(regular) > 0L) { - .twasMethodLookup(regular) - } else { - list() - } - for (tk in fmExtra) { - methodList[[str_c(tk, "_weights")]] <- list() - } + # Fine-mapping tokens carry no learner arguments of their own, so each + # gets an empty stub entry under its `_weights` key. + methodList <- c( + if (length(regular) > 0L) .twasMethodLookup(regular) else list(), + .twasEmptyMethodArgs(str_c(fmExtra, "_weights")) + ) # Tokens come from the user input (canonical camelCase) -- the snake keys in # methodList are an internal detail of learnTwasWeights. list(tokens = unique(methods), methodList = methodList) @@ -363,21 +374,31 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # token->impl map as an "impl" attribute (without this, downstream # .resolveMethodFunction falls back to the bare token, which is not a function). # @noRd +# One `methods` entry re-keyed to its canonical name, with the caller's +# kwargs merged over the method's defaults. A token with no learner default +# is kept under its own name (the capability gate reports it downstream). +# @noRd +.twasNormalizeOneMethod <- function(tk, methods) { + base <- try_fetch(.twasMethodLookup(tk), error = function(cnd) NULL) + if (is.null(base)) { + return(list(key = tk, args = methods[[tk]])) + } + snake <- names(base)[[1L]] + merged <- list_modify(base[[snake]], !!!compact(methods[[tk]])) + # `impl` tells .resolveMethodFunction which function backs the token; + # without it the bare token is used, which is not a function. + list( + key = snake, + args = `attr<-`(merged, "impl", attr(base[[snake]], "impl")) + ) +} + .twasNormalizeListMethods <- function(methods) { - methodList <- list() - for (tk in names(methods)) { - base <- tryCatch(.twasMethodLookup(tk), error = function(e) NULL) - if (is.null(base)) { - # Fine-mapping-only / unknown token with no learner default: keep - # as-is (the downstream capability gate produces the message). - methodList[[tk]] <- methods[[tk]] - next - } - snake <- names(base)[[1L]] - merged <- modifyList(base[[snake]], methods[[tk]]) - attr(merged, "impl") <- attr(base[[snake]], "impl") - methodList[[snake]] <- merged - } + entries <- map(names(methods), .twasNormalizeOneMethod, methods = methods) + # Later entries win on a repeated canonical key, as the keyed assignment + # in the loop did. + keyed <- set_names(map(entries, "args"), map_chr(entries, "key")) + methodList <- keyed[!duplicated(names(keyed), fromLast = TRUE)] list( tokens = .twasTokensFromMethodList(methodList), methodList = methodList @@ -597,19 +618,26 @@ combineTwasWeights <- function(..., ldSketch = NULL) { return(character(0)) } methods <- str_to_lower(as.character(fineMappingResult$method)) - present <- character(0) - for (canonical in .twasFineMappingTokens()) { - candidates <- str_to_lower(c( - canonical, - str_c( - str_to_lower(str_sub(canonical, 1L, 1L)), - str_sub(canonical, 2L) - ), - str_replace_all(canonical, "([A-Z])", "_\\1") - )) - if (any(is_in(methods, candidates))) present <- c(present, canonical) - } - present + keep(.twasFineMappingTokens(), .twasTokenPresentIn, methods = methods) +} + +# The spellings one canonical token may appear under: itself, its camelCase +# form, and its snake_case form -- all lowercased for comparison. +# @noRd +.twasSpellingCandidates <- function(canonical) { + str_to_lower(c( + canonical, + str_c( + str_to_lower(str_sub(canonical, 1L, 1L)), + str_sub(canonical, 2L) + ), + str_replace_all(canonical, "([A-Z])", "_\\1") + )) +} + +# @noRd +.twasTokenPresentIn <- function(canonical, methods) { + any(is_in(methods, .twasSpellingCandidates(canonical))) } # Reject fine-mapping methods (susie / susieInf / susieAsh / mvsusie / @@ -621,7 +649,12 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # step with fineMappingPipeline. Methods with no TWAS-weight extractor # (fsusie) are rejected with a method-specific message. # @noRd -.twasCheckFineMappingMethods <- function(tokens, fineMappingResult, inputKind) { +.twasCheckFineMappingMethods <- function( + tokens, + fineMappingResult, + inputKind, + cvFolds = 0 +) { fmTokens <- intersect(tokens, .twasFineMappingTokens()) if (length(fmTokens) == 0L) { return(invisible(NULL)) @@ -632,9 +665,56 @@ combineTwasWeights <- function(..., ldSketch = NULL) { .twasCheckFmAdapters(fmTokens) .twasRequireFmResult(fineMappingResult, fmTokens) .twasCheckFmPresent(fmTokens, fineMappingResult) + .twasCheckFmCvPresent(fmTokens, fineMappingResult, cvFolds) invisible(NULL) } +# Whether row `i` of a FineMappingResult carries a cross-validation result. +# @noRd +.fmrRowHasCv <- function(i, fineMappingResult) { + !is.null(getCvResult(.fmrRowParts(fineMappingResult, i))) +} + +# Whether a FineMappingResult carries any cross-validation result at all. +# @noRd +.fmrAnyCvResult <- function(fineMappingResult) { + if (!is(fineMappingResult, "FineMappingResultBase")) { + return(FALSE) + } + n <- nrow(fineMappingResult) + if (is.null(n) || n == 0L) { + return(FALSE) + } + any(map_lgl( + seq_len(n), + .fmrRowHasCv, + fineMappingResult = fineMappingResult + )) +} + +# Cross-validating a fine-mapping method needs that method's per-fold fits, +# and this pipeline never fine-maps for itself. Only fineMappingPipeline() run +# with cvFolds > 1 produces them, so require them up front rather than +# discovering the gap once the folds are already being scored. +# @noRd +.twasCheckFmCvPresent <- function(fmTokens, fineMappingResult, cvFolds) { + if (is.null(cvFolds) || cvFolds <= 1L) { + return(invisible(NULL)) + } + if (.fmrAnyCvResult(fineMappingResult)) { + return(invisible(NULL)) + } + fmStr <- str_flatten(fmTokens, ", ") + msg <- glue( + "twasWeightsPipeline: cross-validating method(s) {fmStr} needs each ", + "fold's own fine-mapping fit, but the supplied fineMappingResult ", + "carries no cross-validation. Run fineMappingPipeline() with ", + "cvFolds > 1; its fold partition is then reused for every other ", + "weight method so all of them are scored on the same folds." + ) + abort(msg) +} + # Reject fine-mapping methods that have no TWAS-weight extractor (e.g. fsusie). # @noRd .twasCheckFmAdapters <- function(fmTokens) { @@ -654,6 +734,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # A supplied fineMappingResult is mandatory (fine-mapping is never re-fit) and # must be a FineMappingResult. # @noRd +#' @importFrom checkmate assertClass .twasRequireFmResult <- function(fineMappingResult, fmTokens) { if (is.null(fineMappingResult)) { fmStr <- str_flatten(unique(fmTokens), ", ") @@ -665,9 +746,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { ) abort(msg) } - if (!is(fineMappingResult, "FineMappingResultBase")) { - abort("`fineMappingResult` must be a FineMappingResult or NULL.") - } + assertClass(fineMappingResult, "FineMappingResultBase") invisible(NULL) } @@ -714,6 +793,55 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # doc). Multivariate methods need at least 2 traits *or* at least 2 # contexts in the Y matrix passed to learnTwasWeights. # @noRd +# The multivariate rule across a MultiStudyQtlDataset's components. +# +# A multivariate method -- mvsusie, mr.mash, fsusie, and the PCA alternative +# to fsusie -- fits one model across a tuple's traits and contexts, so it +# needs a multivariate Y from EVERY component it will run on, not just from +# one. A collection mixing multivariate and univariate studies cannot answer +# that, so the request is refused here rather than failing partway through +# the per-component recursion with only some studies fitted. +# +# .twasCheckMultivariateY asks the same question of a single QtlDataset; this +# asks it of each component and names the ones that cannot comply. +# @noRd +.twasCheckMultivariateComponents <- function(tokens, data) { + mv <- keep(tokens, .twasIsMultivariateToken) + if (length(mv) == 0L) { + return(invisible(NULL)) + } + components <- getQtlDatasets(data) + if (length(components) == 0L) { + return(invisible(NULL)) + } + bad <- keep( + names(components) %||% seq_along(components), + .twasComponentIsUnivariate, + components = components + ) + if (length(bad) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "twasWeightsPipeline: method(s) {str_flatten(mv, ', ')} fit one ", + "model across a tuple's traits and contexts, so every study in a ", + "MultiStudyQtlDataset must be multivariate. These are not: ", + "{str_flatten(as.character(bad), ', ')}." + )) +} + +# TRUE when one component offers neither multiple traits nor multiple +# contexts, which is what a multivariate fit needs. +# @noRd +.twasComponentIsUnivariate <- function(key, components) { + d <- components[[key]] + nTraits <- length(tryCatch(getTraits(d), error = function(cnd) { + character(0) + })) + nCtx <- length(tryCatch(getContexts(d), error = function(cnd) character(0))) + nTraits < 2L && nCtx < 2L +} + .twasCheckMultivariateY <- function(tokens, nTraits, nContexts) { multivariateTokens <- tokens[map_lgl(tokens, .twasIsMultivariateToken)] if (length(multivariateTokens) == 0L) { @@ -772,39 +900,52 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # suitable for `learnTwasWeights`. Pulls the trimmedFit from the matching # entry. Returns a (possibly empty) list. # @noRd +#' @importFrom checkmate assertClass .twasFineMappingFits <- function(fineMappingResult, study, context, trait) { if (is.null(fineMappingResult)) { return(list()) } - if (!is(fineMappingResult, "FineMappingResultBase")) { - abort("`fineMappingResult` must be a FineMappingResult or NULL.") - } - out <- list() - methods <- as.character(fineMappingResult$method) - for (canonical in c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie")) { - candidates <- c( - canonical, - str_c( - str_to_lower(str_sub(canonical, 1L, 1L)), - str_sub(canonical, 2L) - ), - str_replace_all(canonical, "([A-Z])", "_\\1") - ) - candidates <- str_to_lower(candidates) - idx <- which( - is_in(str_to_lower(methods), candidates) & - as.character(fineMappingResult$study) == study & - as.character(fineMappingResult$context) == context & - as.character(fineMappingResult$trait) == trait - ) - if (length(idx) > 0L) { - out[[canonical]] <- getSusieFit(.fmrRowParts( - fineMappingResult, - idx[[1L]] - )) - } + assertClass(fineMappingResult, "FineMappingResultBase") + tokens <- c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie") + found <- compact(set_names( + map( + tokens, + .twasFitForToken, + fineMappingResult = fineMappingResult, + study = study, + context = context, + trait = trait + ), + tokens + )) + # compact() on an all-NULL named list leaves a zero-length names + # attribute, which is not the bare list() the contract promises. + if (length(found) == 0L) list() else found +} + +# The fit this result holds for one token on one tuple, or NULL when it has +# none. The first matching row wins, as the keyed assignment it replaced did. +# @noRd +.twasFitForToken <- function( + canonical, + fineMappingResult, + study, + context, + trait +) { + idx <- which( + is_in( + str_to_lower(as.character(fineMappingResult$method)), + .twasSpellingCandidates(canonical) + ) & + as.character(fineMappingResult$study) == study & + as.character(fineMappingResult$context) == context & + as.character(fineMappingResult$trait) == trait + ) + if (length(idx) == 0L) { + return(NULL) } - out + getSusieFit(.fmrRowParts(fineMappingResult, idx[[1L]])) } # Locate a fine-mapping fit for one (study, context, trait, token) tuple. @@ -842,6 +983,34 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # per-region list; the first region carrying CV is used. Returns NULL when no # fine-mapping entry for the tuple recorded CV. # @noRd +# Concatenate per-row lists, empty-safe. +# @noRd +.twasCvConcat <- function(pieces) { + if (length(pieces) == 0L) { + return(list()) + } + list_c(pieces) +} + +# Row `i`'s cross-validation result, or NULL when it has none. Multi-region +# entries store cvResult as a named per-region list, so the first region that +# carries a partition stands for the row. +# @noRd +.twasRowCvResult <- function(i, fineMappingResult) { + cv <- getCvResult(.fmrRowParts(fineMappingResult, i)) + if (is.null(cv)) { + return(NULL) + } + if (!is.null(cv$samplePartition)) { + return(cv) + } + hit <- keep(cv, .twasCvHasPartition) + if (length(hit) == 0L) { + return(NULL) + } + hit[[1L]] +} + .twasCvResultFor <- function(fineMappingResult, study, context, trait) { if (is.null(fineMappingResult)) { return(NULL) @@ -857,36 +1026,21 @@ combineTwasWeights <- function(..., ldSketch = NULL) { if (length(idx) == 0L) { return(NULL) } - samplePartition <- NULL - prediction <- list() - performance <- list() - for (i in idx) { - cv <- getCvResult(.fmrRowParts(fineMappingResult, i)) - if (is.null(cv)) { - next - } - # Multi-region entries store cvResult as a named per-region list; pick - # the first region that carries a partition. - if (is.null(cv$samplePartition)) { - hit <- keep(cv, .twasCvHasPartition) - if (length(hit) == 0L) { - next - } - cv <- hit[[1L]] - } - if (is.null(samplePartition)) { - samplePartition <- cv$samplePartition - } - prediction <- c(prediction, cv$prediction) - performance <- c(performance, cv$performance) - } + cvs <- compact(map( + idx, + .twasRowCvResult, + fineMappingResult = fineMappingResult + )) + prediction <- .twasCvConcat(map(cvs, "prediction")) if (length(prediction) == 0L) { return(NULL) } list( - samplePartition = samplePartition, + # The first row that carries one defines the partition, as the + # "only set it if still NULL" assignment did. + samplePartition = cvs[[1L]]$samplePartition, prediction = prediction, - performance = performance + performance = .twasCvConcat(map(cvs, "performance")) ) } @@ -958,28 +1112,31 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' position when extracting variants. Required when \code{traitId} is #' supplied. Mutually exclusive with \code{region}. #' @section Panel filters on the RSS path: On \code{QtlSumStats} input there -#' is no genotype matrix to filter, so \code{mafCutoff} / \code{macCutoff} / -#' \code{imissCutoff} are measured against the \strong{LD reference panel} -#' instead: a variant whose panel genotypes fall below the cutoffs is dropped -#' before the z-scores and LD matrix are built. The thresholds mean the same -#' thing as on the \code{QtlDataset} path (MAC is converted to a MAF -#' equivalent and the stricter of the two applies), so one number carries -#' across input types. Defaults (\code{0}, \code{0}, \code{1}) filter -#' nothing. +#' is no genotype matrix to filter, so \code{panelFilter}'s +#' \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured +#' against the \strong{LD reference panel} instead: a variant whose panel +#' genotypes fall below the cutoffs is dropped before the z-scores and LD +#' matrix are built. The thresholds mean the same thing as +#' \code{genotypeFilter}'s on the \code{QtlDataset} path (MAC is converted +#' to a MAF equivalent and the stricter of the two applies), so one number +#' carries across input types. The defaults filter nothing. #' #' This discards \emph{observed} variants, unlike -#' \code{summaryStatsQc(imputeOpts = ...)}, which only bounds which variants +#' \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants #' RAISS will impute. #' -#' @param mafCutoff,macCutoff,xvarCutoff,imissCutoff For QtlDataset: optional -#' per-call genotype-filter overrides. Each replaces the corresponding -#' construct-time \code{\link{QtlDataset}} slot for this call only (applied to -#' a validated copy); \code{NULL} (default) leaves the stored value in place. -#' Variant QC is a property of the data, so these are applied identically here -#' and in \code{\link{fineMappingPipeline}} -- there is deliberately no +#' @param genotypeFilterArgs For QtlDataset: per-call genotype-filter overrides, +#' built with \code{\link{GenotypeFilterParam}}. Each field that is set +#' replaces the corresponding construct-time \code{\link{QtlDataset}} slot +#' for this call only (applied to a validated copy); a field left unset +#' leaves the stored value in place. Variant QC is a property of the data, +#' so these are applied identically here and in +#' \code{\link{fineMappingPipeline}} --- there is deliberately no #' TWAS-specific variant filter. -#' @param keepIndel,keepSamples,keepVariants As above: per-call -#' \code{\link{QtlDataset}} genotype-filter overrides. +#' @param panelFilterArgs For QtlSumStats: LD-reference-panel filters, +#' built with +#' \code{\link{PanelFilterParam}}. See \emph{Panel filters on the RSS path} +#' above. #' @param jointRegions For QtlDataset with a multi-range \code{region}: #' \code{FALSE} (default) learns weights for each range independently and #' concatenates them into one entry per (study, context, trait, method); the @@ -1012,41 +1169,68 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' data-driven prior matrices for mr.mash weight methods; \code{NULL} to skip. #' @param fitFullData Logical. If \code{TRUE}, fit final weights on the full #' data after cross-validation. Default \code{TRUE}. -#' @param retainFit Logical. Retain the fitted-model object on each entry. -#' Default \code{FALSE}. -#' @param retainFitDetail Character. Level of fit detail to retain: -#' \code{"slim"} (default) or \code{"full"}. +#' @param usePCA Logical (length 1). \code{QtlDataset} only. When +#' \code{TRUE}, each multi-trait context is additionally PCA-reduced and +#' weights are fitted for each top principal component \emph{as a trait} +#' (\code{topPC1}, \code{topPC2}, ...), alongside the per-trait rows. The +#' same reduction \code{\link{fineMappingPipeline}} applies, sharing its +#' scores helper and producing groups the ordinary CV / ensemble / +#' retention machinery handles unchanged. A single-trait context, or one +#' with no usable component, contributes nothing. +#' @param nPCs Integer (length 1). Caps the number of top principal +#' components fitted per context when \code{usePCA = TRUE} (default +#' \code{10}). The effective count is \code{min(nPCs, usable traits)}. +#' @param fitRetention How much of each fit is kept on the entry: +#' \code{"slim"} (default), \code{"none"} to keep no fit at all, or +#' \code{"full"}. The same setting \code{\link{fineMappingPipeline}} +#' takes, which has no \code{"none"} --- its \code{susieFit} slot is part +#' of the returned object's contract. +#' +#' \code{"full"} is honoured only by the mr.mash engines, the only ones +#' that distinguish the two retaining levels; every other method keeps its +#' fit whole or not at all. Requesting \code{"full"} for a run where no +#' method can honour it is an error, and a mixed run warns rather than +#' dropping it in silence. #' @param naAction Character. How to handle missing values in the extracted #' data. -#' @param cvFolds Integer. Cross-validation folds. Default 5. Set to 0 to skip -#' CV (and ensemble). -#' @param samplePartition Optional pre-defined CV partition data.frame. -#' @param maxCvVariants Maximum number of variants for CV. Default -1 (no -#' limit). -#' @param cvThreads Threads for CV parallelism. Default 1. -#' @param cvWeightMethods Optional override of methods used for CV. -#' @param ensemble Logical. Compute SR-TWAS ensemble weights. Default -#' \code{TRUE}. -#' @param ensembleR2Threshold Minimum CV R-squared for ensemble inclusion. -#' Default 0.01. -#' @param ensembleSolver Solver for ensemble stacking. Default -#' \code{"quadprog"}. -#' @param ensembleAlpha Elastic-net mixing parameter (only when -#' \code{ensembleSolver = "glmnet"}). Default 1. +#' @param crossValidationArgs Cross-validation settings, built with +#' \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no +#' CV), \code{threads}, \code{samplePartition}, \code{maxVariants} (cap +#' on the CV design matrix) and \code{weightMethods} (which methods to +#' cross-validate; unset means every method with non-zero weights). +#' +#' \code{folds} defaulted to \code{5} before, while +#' \code{\link{fineMappingPipeline}}'s defaulted to \code{0}. The two now +#' agree on \code{0}, so an unspecified setting means one thing. +#' +#' Cross-validation holds out \strong{samples}, so it is not possible on +#' \code{QtlSumStats} input; that method \strong{errors} if it is set +#' rather than returning results that were never cross-validated. +#' @param ensembleArgs SR-TWAS ensemble settings, built with +#' \code{\link{EnsembleParam}}: \code{enabled} (default \code{FALSE}), +#' \code{r2Threshold}, \code{solver} and \code{alpha}. Stacking reads +#' out-of-fold predictions, so \code{enabled = TRUE} requires +#' \code{crossValidation} with \code{folds >= 2} and is an error +#' otherwise --- it previously returned a result quietly missing its +#' ensemble row. #' @param estimatePi If TRUE, estimate spike-and-slab sparsity from mr.ash #' before BGLR / qgg spike-and-slab methods that consume it. -#' @param phenotypeCovariatesToResidualize,genotypeCovariatesToResidualize -#' Character vector (or \code{NULL}) of covariate column names to residualize -#' against. Forwarded to \code{\link{getResidualizedPhenotypes}} / -#' \code{\link{getResidualizedGenotypes}} for \code{QtlDataset} / -#' \code{MultiStudyQtlDataset} input. Default \code{NULL} (use all available -#' covariates). Ignored for sumstat inputs. -#' @param residualizePhenotypeCovariates Logical (length 1). When \code{TRUE} -#' (default) residualize against the phenotype-side covariates listed in -#' \code{phenotypeCovariatesToResidualize}; set \code{FALSE} to disable. -#' @param residualizeGenotypeCovariates Logical (length 1). When \code{TRUE} -#' (default) residualize against the genotype-side covariates listed in -#' \code{genotypeCovariatesToResidualize}; set \code{FALSE} to disable. +#' @param residualizationArgs Covariate residualization settings, built with +#' \code{\link{ResidualizationParam}} and forwarded to +#' \code{\link{getResidualizedPhenotypes}} / +#' \code{\link{getResidualizedGenotypes}}: \code{phenotypeCovariates} and +#' \code{genotypeCovariates} name which covariates to regress out +#' (\code{NULL}, the default, uses every available one), and +#' \code{residualizePhenotype} / \code{residualizeGenotype} turn each side +#' off. +#' +#' \code{QtlDataset} / \code{MultiStudyQtlDataset} input only. A +#' \code{QtlSumStats} run has no covariates to regress out, so the bundle +#' is \strong{ignored} there rather than refused --- unlike +#' \code{crossValidation}, which errors. Residualization is on by default, +#' so refusing a non-default value would reject the default bundle; CV is +#' off by default, so a non-default value there is an explicit request for +#' something the input cannot do. #' @param dataType Optional data-type label recorded on every #' \code{TwasWeightsRow$dataType} (e.g. \code{"expression"}). #' @param verbose Verbosity (0 silent, 1 default, 2 includes external package @@ -1071,9 +1255,25 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' set_names #' @export setGeneric("twasWeightsPipeline", function(data, ...) { + .twasAssertInputClass(data) standardGeneric("twasWeightsPipeline") }) +# @noRd +.twasAssertInputClass <- function(data) { + ok <- c("QtlDataset", "MultiStudyQtlDataset", "QtlSumStats") + if (any(map_lgl(ok, is, object = data))) { + return(invisible(NULL)) + } + abort(glue( + "twasWeightsPipeline does not accept inputs of class ", + "'{class(data)[[1L]]}'. Pass a QtlDataset, MultiStudyQtlDataset, ", + "or QtlSumStats. (GwasSumStats inputs are not supported; GWAS-side ", + "per-LD-block weights are produced inside the new ctwasPipeline / ", + "qtlEnrichmentPipeline.)" + )) +} + # Run the multivariate joint TWAS-weight fit over the (context, trait) grid for # `traits`: dispatch each cis-region through the joint engine and merge # per-region results. `marker` = the TwasJointPipeline config; `ctx` bundles the @@ -1083,8 +1283,8 @@ setGeneric("twasWeightsPipeline", function(data, ...) { # @noRd .twasRunMultivariateGrid <- function(traits, marker, ctx) { synthSpec <- list(list(axes = c("context", "trait"), scope = NULL)) - labs <- map_chr(ctx$xRegions, .twasRegionLabel) - perRegion <- map( + allLabs <- map_chr(ctx$xRegions, .twasRegionLabel) + allRegions <- map( seq_along(ctx$xRegions), .twasMvGridRegion, synthSpec = synthSpec, @@ -1092,9 +1292,9 @@ setGeneric("twasWeightsPipeline", function(data, ...) { ctx = ctx, traits = traits ) - keep <- !map_lgl(perRegion, is.null) - perRegion <- perRegion[keep] - labs <- labs[keep] + keep <- !map_lgl(allRegions, is.null) + perRegion <- allRegions[keep] + labs <- allLabs[keep] if (length(perRegion) == 0L) { return(NULL) } @@ -1104,104 +1304,242 @@ setGeneric("twasWeightsPipeline", function(data, ...) { .twasMergeResultsByKey(perRegion, labs) } -#' @rdname twasWeightsPipeline -#' @export -setMethod( - "twasWeightsPipeline", - "QtlDataset", - function( - data, - methods = "default", - contexts = NULL, - traitId = NULL, - region = NULL, - cisWindow = NULL, - mafCutoff = NULL, - macCutoff = NULL, - xvarCutoff = NULL, - imissCutoff = NULL, - keepIndel = NULL, - keepSamples = NULL, - keepVariants = NULL, - jointRegions = FALSE, - jointSpecification = NULL, - fineMappingResult = NULL, - twasWeights = NULL, - mashPrior = NULL, - cvFolds = 5, - samplePartition = NULL, - fitFullData = TRUE, - maxCvVariants = -1, - cvThreads = 1, - cvWeightMethods = NULL, - ensemble = TRUE, - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", - ensembleAlpha = 1, - estimatePi = TRUE, - retainFit = TRUE, - retainFitDetail = c("slim", "full"), - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - dataType = NULL, - naAction = c("drop", "impute"), - verbose = 1, - seed = NULL, - ... - ) { - naAction <- arg_match(naAction) - retainFitDetail <- arg_match(retainFitDetail) - p <- as.list(environment()) - p$dots <- list(...) - .twasPipelineQtlDataset(p) +# ---- QtlDataset pipeline worker + phase helpers ---------------------------- + +# The multivariate half of .twasQdsRunGrid: one fit across all traits, +# against the shared grid context. +# @noRd +.twasQdsRunMultivariate <- function( + grid, + marker, + data, + xRegions, + norm, + fineMappingResult, + dataDrivenPriorMatricesCv, + cisWindow, + residualizationArgs, + verbose +) { + .twasRunMultivariateGrid( + grid$allTraits, + marker, + list( + xRegions = xRegions, + data = data, + norm = norm, + useCtx = grid$useCtx, + fineMappingResult = fineMappingResult, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + residualizationArgs = residualizationArgs, + verbose = verbose + ) + ) +} + +# Run the resolved grid: the multivariate engine when the grid says so, the +# per-tuple univariate engine otherwise. `grid` carries the axes +# (.twasQdsResolveGrid) and `marker` the per-run fit settings. +# @noRd +.twasQdsRunGrid <- function( + grid, + marker, + data, + xRegions, + norm, + fineMappingResult, + twasWeights, + dataDrivenPriorMatricesCv, + cisWindow, + naAction, + residualizationArgs, + usePCA, + nPCs, + verbose +) { + if (grid$multivariate) { + return(.twasQdsRunMultivariate( + grid, + marker, + data = data, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + residualizationArgs = residualizationArgs, + verbose = verbose + )) } -) + .twasQdsUnivariateEngine( + study = grid$study, + useCtx = grid$useCtx, + allTraits = grid$allTraits, + marker = marker, + data = data, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + naAction = naAction, + residualizationArgs = residualizationArgs, + usePCA = usePCA, + nPCs = nPCs, + verbose = verbose + ) +} -# ---- QtlDataset pipeline worker + phase helpers ---------------------------- +# The QtlDataset worker's argument checks, grouped so its entry point names +# the validation phase once instead of listing four calls inline. +# @noRd +.twasQdsAssertParams <- function( + methods, + fitRetention, + crossValidationArgs, + ensembleArgs +) { + .twasWarnUnretainableDetail(fitRetention, methods) + .assertMethodParam( + crossValidationArgs, + "CrossValidationParam", + "crossValidation" + ) + .assertMethodParam(ensembleArgs, "EnsembleParam", "ensemble") + .ensembleAssertCv(ensembleArgs, crossValidationArgs) + invisible(NULL) +} -.twasPipelineQtlDataset <- function(p) { - .twasQdsCheckRegionCisWindow(p) - p$xRegions <- .makeXRegions(p$region, p$jointRegions) - # Per-call filter overrides replace the construct-time slot values on a - # validated copy. Variant QC is a data property applied identically to - # fine-mapping and TWAS -- there is no TWAS-specific variant filter. - p$data <- .qtlApplyFilterOverrides( - p$data, - p$mafCutoff, - p$macCutoff, - p$xvarCutoff, - p$imissCutoff, - p$keepIndel, - p$keepSamples, - p$keepVariants - ) - p$parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - p$norm <- .twasNormalizeMethods(p$methods) - .twasCheckMethodCapabilities(p$norm$tokens, "QtlDataset") - .twasCheckFineMappingMethods( - p$norm$tokens, - p$fineMappingResult, - "QtlDataset" +.twasPipelineQtlDataset <- function( + data, + methods = "default", + contexts = NULL, + traitId = NULL, + region = NULL, + cisWindow = NULL, + genotypeFilterArgs = GenotypeFilterParam(), + jointRegions = FALSE, + jointSpecification = NULL, + fineMappingResult = NULL, + twasWeights = NULL, + mashPrior = NULL, + crossValidationArgs = CrossValidationParam(), + fitFullData = TRUE, + ensembleArgs = EnsembleParam(), + estimatePi = TRUE, + usePCA = FALSE, + nPCs = 10L, + fitRetention = c("slim", "none", "full"), + residualizationArgs = ResidualizationParam(), + dataType = NULL, + naAction = c("drop", "impute"), + verbose = 1, + seed = NULL +) { + naAction <- arg_match(naAction) + fitRetention <- arg_match(fitRetention) + .twasQdsAssertParams( + methods, + fitRetention, + crossValidationArgs, + ensembleArgs + ) + cvCfg <- .cvResolve(crossValidationArgs) + # Each stage returns only the values it derives; nothing is grafted onto a + # captured environment. + resolved <- .twasQdsResolveInputs( + data = data, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + genotypeFilterArgs = genotypeFilterArgs + ) + data <- resolved$data + xRegions <- resolved$xRegions + # One record of the settings the joint phase and the shared dispatcher + # both need, so each names them once. + jointCfg <- list( + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + dataType = dataType, + verbose = verbose, + xRegions = xRegions, + fitRetention = fitRetention, + seed = seed + ) + joint <- .twasQdsResolveTokens( + jointSpecification, + methods, + fineMappingResult, + cvCfg$folds, + fitFullData, + mashPrior, + cvCfg$samplePartition, + jointCfg ) - .twasQdsCheckFitFull(p) - p <- .twasQdsUnpackMash(p) - joint <- .twasQdsJointPhase(p) if (joint$done) { return(joint$result) } - p$norm <- joint$norm - p$jointResult <- joint$result - p <- .twasQdsResolveGrid(p) - .twasQdsAssemble(.twasQdsDispatch(p), p$jointResult) + # The joint phase consumes the mrmash token; `norm` comes back holding + # only the methods that still have to go through the per-tuple loop. + norm <- joint$norm + samplePartition <- joint$samplePartition + dataDrivenPriorMatricesCv <- joint$dataDrivenPriorMatricesCv + grid <- .twasQdsResolveGrid(data, contexts, traitId, region, norm$tokens) + # The bundles are the user-facing form; below this line the marker and + # the joint engine that reads it keep plain scalars. + marker <- .twasQdsMarker( + crossValidationArgs = list_assign( + cvCfg, + samplePartition = samplePartition + ), + ensembleArgs = .ensembleResolve(ensembleArgs), + fitFullData = fitFullData, + dataType = dataType, + fitRetention = fitRetention, + estimatePi = estimatePi, + verbose = verbose, + seed = seed + ) + tw <- .twasQdsRunGrid( + grid, + marker, + data = data, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + naAction = naAction, + residualizationArgs = residualizationArgs, + usePCA = usePCA, + nPCs = nPCs, + verbose = verbose + ) + .twasQdsAssemble(tw, joint$result) } +#' @rdname twasWeightsPipeline +#' @export +setMethod( + "twasWeightsPipeline", + "QtlDataset", + .twasPipelineQtlDataset +) + # `cisWindow` expands a trait's own coordinates; `region` is literal. Supplying # both signals a misunderstanding -> reject. # @noRd -.twasQdsCheckRegionCisWindow <- function(p) { - if (!is.null(p$region) && !is.null(p$cisWindow)) { +.twasQdsCheckRegionCisWindow <- function( + region, + cisWindow +) { + if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "twasWeightsPipeline(QtlDataset): specify either `region` or ", "`cisWindow`, not both. `cisWindow` expands each trait's own ", @@ -1214,8 +1552,11 @@ setMethod( # fitFullData = FALSE (CV-only) is meaningful only with cross-validation. # @noRd -.twasQdsCheckFitFull <- function(p) { - if (!isTRUE(p$fitFullData) && p$cvFolds <= 1L) { +.twasQdsCheckFitFull <- function( + fitFullData, + cvFolds +) { + if (!isTRUE(fitFullData) && cvFolds <= 1L) { msg <- glue( "twasWeightsPipeline: fitFullData = FALSE requires ", "cross-validation (cvFolds > 1)." @@ -1229,24 +1570,83 @@ setMethod( # args, the per-fold priors + fold partition into the CV machinery. Returns the # updated parameter bundle. # @noRd -.twasQdsUnpackMash <- function(p) { - mp <- .unpackMashPrior(p$mashPrior, p$samplePartition) - p$samplePartition <- mp$samplePartition - p$dataDrivenPriorMatricesCv <- mp$dataDrivenPriorMatricesCv - if (!is.null(p$mashPrior) && !is_in("mrmash", p$norm$tokens)) { +.twasQdsUnpackMash <- function( + mashPrior, + samplePartition, + norm +) { + mp <- .unpackMashPrior(mashPrior, samplePartition) + if (!is.null(mashPrior) && !is_in("mrmash", norm$tokens)) { msg <- glue( "`mashPrior` was supplied but 'mrmash' is not among `methods`; ", "the data-driven prior is ignored." ) warn(msg) } - if ( + withPrior <- if ( !is.null(mp$fullPrior) && - is_in("mrmash_weights", names(p$norm$methodList)) + is_in("mrmash_weights", names(norm$methodList)) ) { - p$norm$methodList$mrmash_weights$dataDrivenPriorMatrices <- mp$fullPrior + .twasQdsSetMrmashPrior(norm, mp$fullPrior) + } else { + norm } - p + list( + samplePartition = mp$samplePartition, + dataDrivenPriorMatricesCv = mp$dataDrivenPriorMatricesCv, + norm = withPrior + ) +} + +# The normalized argument list with mr.mash's full-data prior attached, +# leaving every other method's arguments untouched. +# @noRd +.twasQdsSetMrmashPrior <- function(norm, fullPrior) { + updated <- list_assign( + norm$methodList$mrmash_weights, + dataDrivenPriorMatrices = fullPrior + ) + list_assign( + norm, + methodList = list_assign(norm$methodList, mrmash_weights = updated) + ) +} + +# Reject the region + cisWindow combination, derive the X windows, and apply +# the per-call filter overrides to a validated copy of the dataset. Mirrors +# .fmQdsResolveInputs; variant QC is a data property applied identically to +# fine-mapping and TWAS, so there is no TWAS-specific variant filter. +# @noRd +.twasQdsResolveInputs <- function( + data, + region, + cisWindow, + jointRegions, + genotypeFilterArgs +) { + .twasQdsCheckRegionCisWindow(region, cisWindow) + list( + data = .qtlApplyFilterOverrides(data, genotypeFilterArgs), + xRegions = .makeXRegions(region, jointRegions) + ) +} + +# Run the joint engine for a QtlDataset with the given spec + token set. +# @noRd +.twasQdsJointDispatch <- function(jointSpec, tokens, cfg) { + .twasDispatchJointSpecsQtlDataset( + jointSpec, + cfg$data, + tokens, + cfg$contexts, + cfg$traitId, + cfg$cisWindow, + cfg$dataType, + cfg$verbose, + xRegions = cfg$xRegions, + fitRetention = cfg$fitRetention, + seed = cfg$seed + ) } # Explicit jointSpecification path: run the per-spec axis dispatcher for @@ -1254,25 +1654,16 @@ setMethod( # with `result`; otherwise `norm` is the mrmash-stripped normalization for the # per-tuple loop below. # @noRd -.twasQdsJointPhase <- function(p) { - if (length(p$parsedJointSpec) == 0L) { - return(list(done = FALSE, result = NULL, norm = p$norm)) - } - jointResult <- .twasDispatchJointSpecsQtlDataset( - p$parsedJointSpec, - p$data, - intersect(p$norm$tokens, "mrmash"), - p$contexts, - p$traitId, - p$cisWindow, - p$dataType, - p$verbose, - xRegions = p$xRegions, - retainFit = p$retainFit, - retainFitDetail = p$retainFitDetail, - seed = p$seed - ) - keep <- setdiff(p$norm$tokens, intersect(p$norm$tokens, "mrmash")) +.twasQdsJointPhase <- function(parsedJointSpec, norm, cfg) { + if (length(parsedJointSpec) == 0L) { + return(list(done = FALSE, result = NULL, norm = norm)) + } + jointResult <- .twasQdsJointDispatch( + parsedJointSpec, + intersect(norm$tokens, "mrmash"), + cfg + ) + keep <- setdiff(norm$tokens, intersect(norm$tokens, "mrmash")) if (length(keep) == 0L) { if (is.null(jointResult)) { msg <- glue( @@ -1284,33 +1675,77 @@ setMethod( } return(list(done = TRUE, result = jointResult)) } - norm <- p$norm - norm$tokens <- keep keepKeys <- which( is_in(str_remove(names(norm$methodList), "(_weights|Weights)$"), keep) ) - norm$methodList <- norm$methodList[keepKeys] - list(done = FALSE, result = jointResult, norm = norm) + list( + done = FALSE, + result = jointResult, + norm = list_assign( + norm, + tokens = keep, + methodList = norm$methodList[keepKeys] + ) + ) +} + +# Normalize methods, run the capability / fine-mapping / fit-full gates and the +# mash-prior unpacking, then hand off to the joint phase. Returns the phase +# record extended with the mash-derived sample partition and CV prior matrices +# the per-tuple loop still needs. Mirrors .fmQdsResolveTokens. +# @noRd +.twasQdsResolveTokens <- function( + jointSpecification, + methods, + fineMappingResult, + cvFolds, + fitFullData, + mashPrior, + samplePartition, + cfg +) { + parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) + rawNorm <- .twasNormalizeMethods(methods) + .twasCheckMethodCapabilities(rawNorm$tokens, "QtlDataset") + .twasCheckMethodArgsForInput( + .twasMethodListArgs(rawNorm$methodList), + "QtlDataset" + ) + .twasCheckFineMappingMethods( + rawNorm$tokens, + fineMappingResult, + "QtlDataset", + cvFolds = cvFolds + ) + .twasQdsCheckFitFull(fitFullData, cvFolds) + mash <- .twasQdsUnpackMash(mashPrior, samplePartition, rawNorm) + list_assign( + .twasQdsJointPhase(parsedJointSpec, mash$norm, cfg), + samplePartition = mash$samplePartition, + dataDrivenPriorMatricesCv = mash$dataDrivenPriorMatricesCv + ) } # Resolve the (context, trait) grid + multivariate flag and build the joint- # pipeline marker + shared grid context. Returns the updated parameter bundle. # @noRd -.twasQdsResolveGrid <- function(p) { - p$study <- getStudy(p$data) - p$useCtx <- .twasQdsResolveContexts(p$data, p$contexts) - p$allTraits <- .twasQdsResolveTraits( - p$data, - p$useCtx, - p$traitId, - p$region +.twasQdsResolveGrid <- function( + data, + contexts, + traitId, + region, + tokens +) { + study <- getStudy(data) + useCtx <- .twasQdsResolveContexts(data, contexts) + allTraits <- .twasQdsResolveTraits(data, useCtx, traitId, region) + .twasCheckMultivariateY(tokens, length(allTraits), length(useCtx)) + list( + study = study, + useCtx = useCtx, + allTraits = allTraits, + multivariate = any(map_lgl(tokens, .twasIsMultivariateToken)) ) - p$nCtx <- length(p$useCtx) - .twasCheckMultivariateY(p$norm$tokens, length(p$allTraits), p$nCtx) - p$multivariate <- any(map_lgl(p$norm$tokens, .twasIsMultivariateToken)) - p$marker <- .twasQdsMarker(p) - p$twasGridCtx <- .twasQdsGridCtx(p) - p } # Selected contexts (all when NULL; else validated against the dataset). @@ -1342,7 +1777,7 @@ setMethod( traitId = traitId, region = region ) - allTraits <- unique(unlist(perCtxTraits)) + allTraits <- unique(list_c(perCtxTraits)) if (length(allTraits) == 0L) { abort("twasWeightsPipeline(QtlDataset): no traits selected.") } @@ -1351,72 +1786,99 @@ setMethod( # Joint-pipeline marker carrying the CV / ensemble config for the engine. # @noRd -.twasQdsMarker <- function(p) { +.twasQdsMarker <- function( + crossValidationArgs, + ensembleArgs, + fitFullData, + dataType, + fitRetention, + estimatePi, + verbose, + seed +) { new( "TwasJointPipeline", config = list( - cvFolds = p$cvFolds, - samplePartition = p$samplePartition, - fitFullData = p$fitFullData, - dataType = p$dataType, - retainFitDetail = p$retainFitDetail, + # The two groups travel as records, not as nine loose fields: + # this function's only job is to store them, so unrolling them + # into its signature would name each one twice for nothing. + crossValidationArgs = crossValidationArgs, + ensembleArgs = ensembleArgs, + fitFullData = fitFullData, + dataType = dataType, + fitRetention = fitRetention, standardized = FALSE, - ensemble = p$ensemble, - ensembleR2Threshold = p$ensembleR2Threshold, - ensembleSolver = p$ensembleSolver, - ensembleAlpha = p$ensembleAlpha, - maxCvVariants = p$maxCvVariants, - cvThreads = p$cvThreads, - estimatePi = p$estimatePi, - verbose = p$verbose, - seed = p$seed, + estimatePi = estimatePi, + verbose = verbose, + seed = seed, ldSketch = NULL ) ) } -# Shared grid context consumed by both dispatch paths. +# Which joint cells run, and over which study/context/trait scope. usePCA +# adds top-PC rows ALONGSIDE the per-trait ones, matching +# fineMappingPipeline's c(univRows, pcaRows). # @noRd -.twasQdsGridCtx <- function(p) { +.twasQdsUnivPlan <- function(usePCA, study, useCtx, allTraits) { + univCell <- .lookupJointCell("univariate", "individual") list( - xRegions = p$xRegions, - data = p$data, - norm = p$norm, - useCtx = p$useCtx, - fineMappingResult = p$fineMappingResult, - dataDrivenPriorMatricesCv = p$dataDrivenPriorMatricesCv, - cisWindow = p$cisWindow, - verbose = p$verbose + cells = if (isTRUE(usePCA)) { + list(univCell, .lookupJointCell("topPc", "individual")) + } else { + list(univCell) + }, + scope = list( + studies = study, + contexts = set_names(list(useCtx), study), + traits = set_names(list(allTraits), study) + ) ) } -# Top-level dispatch: multivariate joint grid vs univariate engine path. -# @noRd -.twasQdsDispatch <- function(p) { - if (p$multivariate) { - return(.twasRunMultivariateGrid(p$allTraits, p$marker, p$twasGridCtx)) - } - .twasQdsUnivariateEngine(p) -} - # Univariate methods ROUTED THROUGH THE ENGINE: one 1-condition group per # (context, trait), per region -> the SAME per-method fitter (+ ensemble layer # for >= 2 methods + resume cache) as the joint paths, merged across regions. # @noRd -.twasQdsUnivariateEngine <- function(p) { - univCell <- .lookupJointCell("univariate", "individual") - scope <- list( - studies = p$study, - contexts = set_names(list(p$useCtx), p$study), - traits = set_names(list(p$allTraits), p$study) - ) - labs <- map_chr(p$xRegions, .twasRegionLabel) +.twasQdsUnivariateEngine <- function( + study, + useCtx, + allTraits, + marker, + data, + xRegions, + norm, + fineMappingResult, + twasWeights, + dataDrivenPriorMatricesCv, + cisWindow, + naAction, + residualizationArgs, + usePCA, + nPCs, + verbose +) { + plan <- .twasQdsUnivPlan(usePCA, study, useCtx, allTraits) + cells <- plan$cells + scope <- plan$scope + labs <- map_chr(xRegions, .twasRegionLabel) perRegion <- map( - seq_along(p$xRegions), + seq_along(xRegions), .twasQdsUnivRegion, - univCell = univCell, - p = p, - scope = scope + cells = cells, + scope = scope, + marker = marker, + data = data, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + naAction = naAction, + residualizationArgs = residualizationArgs, + nPCs = nPCs, + verbose = verbose ) keep <- !map_lgl(perRegion, is.null) .twasMergeRegionResults(perRegion[keep], labs[keep]) @@ -1424,18 +1886,32 @@ setMethod( # Per-region engine args for the univariate path. # @noRd -.twasQdsUnivArgs <- function(p, bi) { +.twasQdsUnivArgs <- function( + bi, + xRegions, + norm, + fineMappingResult, + twasWeights, + dataDrivenPriorMatricesCv, + cisWindow, + naAction, + residualizationArgs, + nPCs, + verbose +) { list( - methodList = p$norm$methodList, - fineMappingResult = p$fineMappingResult, - cache = p$twasWeights, - dataDrivenPriorMatricesCv = p$dataDrivenPriorMatricesCv, - cisWindow = p$cisWindow, - region = p$xRegions[[bi]], + methodList = norm$methodList, + fineMappingResult = fineMappingResult, + cache = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + region = xRegions[[bi]], regionIndex = bi, - nRegions = length(p$xRegions), - naAction = p$naAction, - verbose = p$verbose + nRegions = length(xRegions), + naAction = naAction, + residualizationArgs = residualizationArgs, + nPCs = nPCs, + verbose = verbose ) } @@ -1483,44 +1959,165 @@ setMethod( jointSpecification = NULL, fineMappingResult = NULL, twasWeights = NULL, - retainFit = TRUE, - retainFitDetail = c("slim", "full"), + fitRetention = c("slim", "none", "full"), dataType = NULL, verbose = 1L, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + panelFilterArgs = PanelFilterParam(), + crossValidationArgs = CrossValidationParam() ) { - retainFitDetail <- arg_match(retainFitDetail) - p <- as.list(environment()) - p$dots <- list(...) - .twasPipelineQtlSumStats(p) + fitRetention <- arg_match(fitRetention) + .twasWarnUnretainableDetail(fitRetention, methods) + .cvRefuseOnSumstats( + crossValidationArgs, + "twasWeightsPipeline", + "QtlSumStats" + ) + .twasPipelineQtlSumStats( + data = data, + methods = methods, + contexts = contexts, + traitId = traitId, + jointSpecification = jointSpecification, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + fitRetention = fitRetention, + dataType = dataType, + verbose = verbose, + panelFilterArgs = panelFilterArgs + ) } ) # ---- QtlSumStats pipeline worker + phase helpers --------------------------- -.twasPipelineQtlSumStats <- function(p) { +# Univariate + multivariate per-tuple rows for the QtlSumStats path. `part` +# carries the selected rows and the token split from +# .twasQssSelectAndPartition(); `cfg` the settings both builders share. +# @noRd +.twasQssBuildRows <- function(part, methodArgs, cfg) { + rowArgs <- list( + part$selRows, + studyCol = part$studyCol, + contextCol = part$contextCol, + traitCol = part$traitCol, + ldSketch = part$ldSketch, + methodArgs = methodArgs + ) + c( + # The univariate builder keeps whatever the per-method fit returns, + # so it takes no fitRetention. + exec( + .twasQssUnivariateRows, + !!!rowArgs, + univariateTokens = part$univariateTokens, + data = cfg$data, + twasWeights = cfg$twasWeights, + dataType = cfg$dataType, + fineMappingResult = cfg$fineMappingResult, + panelFilterArgs = cfg$panelFilterArgs + ), + # `twasWeights` is the resume cache. The univariate builder looks + # up one (study, context, trait, method) row; the multivariate one + # asks for a whole (study, trait) group and reuses it only when + # every context's row is present -- see .twasMvCacheHits. + exec( + .twasQssMultivariateRows, + !!!rowArgs, + multivariateTokens = part$multivariateTokens, + twasWeights = cfg$twasWeights, + data = cfg$data, + dataType = cfg$dataType, + fitRetention = cfg$fitRetention, + fineMappingResult = cfg$fineMappingResult, + panelFilterArgs = cfg$panelFilterArgs + ) + ) +} + +.twasPipelineQtlSumStats <- function( + data, + methods, + contexts, + traitId, + jointSpecification, + fineMappingResult, + twasWeights, + fitRetention, + dataType, + verbose, + panelFilterArgs +) { # summaryStatsQc() is mandatory before twasWeightsPipeline for SumStats # input; it also drops variants not present in the ldSketch, so every # entry's SNP set is a subset of the ldSketch panel by the time we get here. - .twasAssertQcd(p$data) - p$parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - tm <- .twasSumStatsMethodTokens(p$methods) - p$tokens <- tm$tokens - p$methodArgs <- tm$methodArgs - .twasCheckMethodCapabilities(p$tokens, "QtlSumStats") - .twasCheckFineMappingMethods(p$tokens, p$fineMappingResult, "QtlSumStats") - joint <- .twasQssJointPhase(p) + .twasAssertQcd(data) + # One record of the settings the joint phase and the shared dispatcher + # both need, so each names them once. + jointCfg <- list( + data = data, + contexts = contexts, + traitId = traitId, + dataType = dataType, + verbose = verbose, + fitRetention = fitRetention, + panelFilterArgs = panelFilterArgs + ) + joint <- .twasQssResolveTokens( + jointSpecification, + methods, + fineMappingResult, + jointCfg + ) if (joint$done) { return(joint$result) } - p$tokens <- joint$tokens - p$methodArgs <- joint$methodArgs - p <- .twasQssSelectAndPartition(p) - rows <- c(.twasQssUnivariateRows(p), .twasQssMultivariateRows(p)) - .twasQssAssemble(rows, joint$result, p) + .twasQssAfterJoint( + data, + joint = joint, + contexts = contexts, + traitId = traitId, + twasWeights = twasWeights, + dataType = dataType, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + panelFilterArgs = panelFilterArgs + ) +} + +# The per-tuple loop, after the joint phase has consumed the tokens it +# owns (mrmash); `joint` carries the remainder, their options, and +# whatever the joint phase itself produced. +# @noRd +.twasQssAfterJoint <- function( + data, + joint, + contexts, + traitId, + twasWeights, + dataType, + fineMappingResult, + fitRetention, + panelFilterArgs +) { + part <- .twasQssSelectAndPartition( + data, + joint$tokens, + contexts, + traitId + ) + rows <- .twasQssBuildRows( + part, + joint$methodArgs, + list( + data = data, + twasWeights = twasWeights, + dataType = dataType, + fineMappingResult = fineMappingResult, + fitRetention = fitRetention, + panelFilterArgs = panelFilterArgs + ) + ) + .twasQssAssemble(rows, joint$result, part$ldSketch) } # Normalize the methods argument into (tokens, methodArgs). The default set @@ -1538,12 +2135,28 @@ setMethod( methodArgs = .twasEmptyMethodArgs(methods) )) } - if (is.list(methods)) { - return(list(tokens = names(methods), methodArgs = methods)) + if (is(methods, "MethodsSelectionParam") || is.list(methods)) { + # This resolver only ever serves the summary-statistics path, so + # the path is not a parameter -- it is the function's identity. + return(.methodsParamResolve( + .methodsParamFor( + methods, + "QtlSumStats", + "TwasWeightsMethodsParam", + "twasWeightsPipeline" + ), + "QtlSumStats" + )) + } + if (.isMethodOptions(methods)) { + return(list( + tokens = names(methods), + methodArgs = map(as.list(methods), as.list) + )) } msg <- glue( - "`methods` must be NULL, a character vector, or a named list ", - "of = entries." + "`methods` must be NULL, a character vector, a named list of ", + "per-method options, or a TwasWeightsMethodsParam() record." ) abort(msg) } @@ -1554,34 +2167,41 @@ setMethod( set_names(rep(list(list()), length(tokens)), tokens) } +# Run the joint engine for a QtlSumStats with the given spec + token set. +# @noRd +.twasQssJointDispatch <- function(jointSpec, tokens, cfg) { + .twasDispatchJointSpecsQtlSumStats( + jointSpec, + cfg$data, + tokens, + cfg$contexts, + cfg$traitId, + cfg$dataType, + cfg$verbose, + fitRetention = cfg$fitRetention, + panelFilterArgs = cfg$panelFilterArgs %||% PanelFilterParam() + ) +} + # Joint-specification dispatch for mrmash. Returns list(done, result, tokens, # methodArgs): `done` requests an early return with `result`; otherwise the # remaining (non-mrmash) tokens + args continue through the per-tuple loop. # @noRd -.twasQssJointPhase <- function(p) { - if (length(p$parsedJointSpec) == 0L) { +.twasQssJointPhase <- function(parsedJointSpec, tokens, methodArgs, cfg) { + if (length(parsedJointSpec) == 0L) { return(list( done = FALSE, result = NULL, - tokens = p$tokens, - methodArgs = p$methodArgs + tokens = tokens, + methodArgs = methodArgs )) } - jointResult <- .twasDispatchJointSpecsQtlSumStats( - p$parsedJointSpec, - p$data, - intersect(p$tokens, "mrmash"), - p$contexts, - p$traitId, - p$dataType, - p$verbose, - retainFit = p$retainFit, - retainFitDetail = p$retainFitDetail, - mafCutoff = p$mafCutoff %||% 0, - macCutoff = p$macCutoff %||% 0, - imissCutoff = p$imissCutoff %||% 1 - ) - keep <- setdiff(p$tokens, "mrmash") + jointResult <- .twasQssJointDispatch( + parsedJointSpec, + intersect(tokens, "mrmash"), + cfg + ) + keep <- setdiff(tokens, "mrmash") if (length(keep) == 0L) { if (is.null(jointResult)) { abort("twasWeightsPipeline(QtlSumStats): no joint fits produced.") @@ -1592,36 +2212,81 @@ setMethod( done = FALSE, result = jointResult, tokens = keep, - methodArgs = p$methodArgs[keep] + methodArgs = methodArgs[keep] ) } +# Normalize the method tokens, run the capability / fine-mapping gates, then +# hand off to the joint phase. Mirrors .fmQssResolveTokens. +# @noRd +.twasQssResolveTokens <- function( + jointSpecification, + methods, + fineMappingResult, + cfg +) { + parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) + tm <- .twasSumStatsMethodTokens(methods) + .twasCheckMethodCapabilities(tm$tokens, "QtlSumStats") + .twasCheckMethodArgsForInput(tm$methodArgs, "QtlSumStats") + .twasCheckFineMappingMethods(tm$tokens, fineMappingResult, "QtlSumStats") + .twasQssJointPhase(parsedJointSpec, tm$tokens, tm$methodArgs, cfg) +} + # Resolve the selected rows, partition tokens into univariate vs multivariate, # attach the LD sketch, and enforce the multivariate >=2-contexts rule. Returns # the updated parameter bundle. # @noRd -.twasQssSelectAndPartition <- function(p) { - p$studyCol <- as.character(p$data$study) - p$contextCol <- as.character(p$data$context) - p$traitCol <- as.character(p$data$trait) - p$selRows <- .twasQssSelectRows(p) - isMv <- map_lgl(p$tokens, .twasIsMultivariateToken) - p$multivariateTokens <- p$tokens[isMv] - p$univariateTokens <- p$tokens[!isMv] - p$ldSketch <- getLdSketch(p$data) - .twasQssCheckMultivariate(p) - p +.twasQssSelectAndPartition <- function(data, tokens, contexts, traitId) { + studyCol <- as.character(data$study) + contextCol <- as.character(data$context) + traitCol <- as.character(data$trait) + selRows <- .twasQssSelectRows( + data, + contextCol, + traitCol, + contexts, + traitId + ) + isMv <- map_lgl(tokens, .twasIsMultivariateToken) + multivariateTokens <- tokens[isMv] + univariateTokens <- tokens[!isMv] + .twasQssCheckMultivariate( + multivariateTokens, + selRows, + studyCol, + contextCol, + traitCol + ) + list( + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + selRows = selRows, + multivariateTokens = multivariateTokens, + univariateTokens = univariateTokens, + ldSketch = getLdSketch(data) + ) } # Row indices matching the contexts / traitId filters (error if none). # @noRd -.twasQssSelectRows <- function(p) { - selRows <- seq_len(nrow(p$data)) - if (!is.null(p$contexts)) { - selRows <- selRows[is_in(p$contextCol[selRows], p$contexts)] +.twasQssSelectRows <- function( + data, + contextCol, + traitCol, + contexts, + traitId +) { + byContext <- if (is.null(contexts)) { + seq_len(nrow(data)) + } else { + which(is_in(contextCol, contexts)) } - if (!is.null(p$traitId)) { - selRows <- selRows[is_in(p$traitCol[selRows], p$traitId)] + selRows <- if (is.null(traitId)) { + byContext + } else { + byContext[is_in(traitCol[byContext], traitId)] } if (length(selRows) == 0L) { msg <- glue( @@ -1635,18 +2300,24 @@ setMethod( # Multivariate methods require at least two contexts within some (study, trait). # @noRd -.twasQssCheckMultivariate <- function(p) { - if (length(p$multivariateTokens) == 0L) { +.twasQssCheckMultivariate <- function( + multivariateTokens, + selRows, + studyCol, + contextCol, + traitCol +) { + if (length(multivariateTokens) == 0L) { return(invisible(NULL)) } groupKey <- str_c( - p$studyCol[p$selRows], - p$traitCol[p$selRows], + studyCol[selRows], + traitCol[selRows], sep = "||" ) - perGroupNCtx <- map_int(split(p$contextCol[p$selRows], groupKey), length) + perGroupNCtx <- map_int(split(contextCol[selRows], groupKey), length) if (all(perGroupNCtx < 2L)) { - mvStr <- str_flatten(p$multivariateTokens, ", ") + mvStr <- str_flatten(multivariateTokens, ", ") msg <- glue( "twasWeightsPipeline(QtlSumStats): multivariate method(s) ", "{mvStr} require at least two contexts per (study, trait); the ", @@ -1709,32 +2380,35 @@ setMethod( # Retain-fit defaults for the mr.mash producer (only when tk == "mrmash" and it # has no fine-mapping adapter); respects explicit caller overrides. # @noRd -.twasMrmashRetainDefaults <- function(userArgs, adapter, tk, retainFitDetail) { +.twasMrmashRetainDefaults <- function(userArgs, adapter, tk, fitRetention) { if (!is.null(adapter) || tk != "mrmash") { return(userArgs) } - if (is.null(userArgs$retainFit)) { - userArgs$retainFit <- TRUE - } - if (is.null(userArgs$fitDetail)) { - userArgs$fitDetail <- retainFitDetail - } - userArgs + # mr.mash is the producer of the mvSuSiE prior payload, so it retains + # even when the run as a whole does not -- but at the level asked for. + level <- if (identical(fitRetention, "none")) "slim" else fitRetention + list_assign( + userArgs, + fitRetention = userArgs$fitRetention %||% level + ) } # Run a weight function, warning (with `errPrefix`) and returning NULL on error. # @noRd +#' @importFrom rlang try_fetch .twasTryWeights <- function(fn, stat, ldMat, userArgs, errPrefix) { - tryCatch( + try_fetch( { wfn <- get(fn, mode = "function") - wArgs <- c(list(stat = stat, LD = ldMat), userArgs) + wArgs <- .twasWeightCallArgs( + fn, + list(stat = stat, LD = ldMat), + userArgs + ) exec(wfn, !!!wArgs) }, - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue("{errPrefix}{eMsg}") - warn(msg) + error = function(cnd) { + warn(errPrefix, parent = cnd) NULL } ) @@ -1742,45 +2416,96 @@ setMethod( # ---- Univariate dispatch: per (study, context, trait), per method ---------- -.twasQssUnivariateRows <- function(p) { - if (length(p$univariateTokens) == 0L) { +.twasQssUnivariateRows <- function( + selRows, + univariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + twasWeights, + dataType, + fineMappingResult, + methodArgs, + panelFilterArgs +) { + if (length(univariateTokens) == 0L) { return(list()) } - list_flatten(map(p$selRows, .twasQssUnivariateRowsForEntry, p = p)) + list_flatten(map( + selRows, + .twasQssUnivariateRowsForEntry, + univariateTokens = univariateTokens, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + data = data, + ldSketch = ldSketch, + twasWeights = twasWeights, + dataType = dataType, + fineMappingResult = fineMappingResult, + methodArgs = methodArgs, + panelFilterArgs = panelFilterArgs + )) } -# Cached + freshly-fitted rows for one sumstats entry. Resume cache: pull cached -# entries up front and reduce the per-entry fit work to the un-cached tokens. +# Which of this tuple's tokens the resume cache already answers, as rows, +# and which still have to be fitted. # @noRd -.twasQssUnivariateRowsForEntry <- function(i, p) { - st <- p$studyCol[i] - ctx <- p$contextCol[i] - tr <- p$traitCol[i] +.twasQssCacheSplit <- function(twasWeights, st, ctx, tr, univariateTokens) { cacheHits <- .twasResolveCacheHits( - p$twasWeights, + twasWeights, st, ctx, tr, - p$univariateTokens + univariateTokens ) - cachedRows <- imap( - cacheHits, - .twasCachedRowRecord, - st = st, - ctx = ctx, - tr = tr + list( + rows = imap( + cacheHits, + .twasCachedRowRecord, + st = st, + ctx = ctx, + tr = tr + ), + toFit = setdiff(univariateTokens, names(cacheHits)) ) - toFit <- setdiff(p$univariateTokens, names(cacheHits)) +} + +# Cached + freshly-fitted rows for one sumstats entry. Resume cache: pull cached +# entries up front and reduce the per-entry fit work to the un-cached tokens. +# @noRd +.twasQssUnivariateRowsForEntry <- function( + i, + univariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + twasWeights, + dataType, + fineMappingResult, + methodArgs, + panelFilterArgs +) { + st <- studyCol[i] + ctx <- contextCol[i] + tr <- traitCol[i] + cached <- .twasQssCacheSplit(twasWeights, st, ctx, tr, univariateTokens) + cachedRows <- cached$rows + toFit <- cached$toFit if (length(toFit) == 0L) { return(unname(cachedRows)) } fitCtx <- .twasQssUnivariateFitCtx( - p$data, + data, st, ctx, tr, - p$ldSketch, - cutoffs = .panelCutoffs(p) + ldSketch, + cutoffs = .panelCutoffs(panelFilterArgs) ) fitted <- compact(map( toFit, @@ -1789,11 +2514,49 @@ setMethod( ctx = ctx, tr = tr, fitCtx = fitCtx, - p = p + methodArgs = methodArgs, + fineMappingResult = fineMappingResult, + dataType = dataType )) c(unname(cachedRows), fitted) } +# Cache hits for ONE multivariate group: a named list of the group's rows, +# or NULL when any of them is absent. +# +# A multivariate fit spans every context in its (study, trait) group and +# emits one row each, so it can only be resumed when the cache holds ALL of +# them. A partial hit is not usable: reusing some contexts' weights while +# refitting the others would mix two fits inside one group, and the whole +# point of a multivariate method is that the contexts were fitted together. +# +# This is why the resume cache used to skip multivariate rows entirely -- +# `.twasCacheLookup` keys on a single trait/context, so there was no +# per-group question to ask. There is; it is just all-or-nothing. +# @noRd +.twasMvCacheHits <- function(twasWeights, st, tr, ctxNames, tk) { + if (is.null(twasWeights)) { + return(NULL) + } + hits <- map( + ctxNames, + .twasMvCacheHitOne, + twasWeights = twasWeights, + st = st, + tr = tr, + tk = tk + ) + if (any(map_lgl(hits, is.null))) { + return(NULL) + } + set_names(hits, ctxNames) +} + +# @noRd +.twasMvCacheHitOne <- function(ctx, twasWeights, st, tr, tk) { + .twasCacheLookup(twasWeights, st, ctx, tr, tk) +} + # Cache hits for a (study, context, trait): named list token -> cached entry. # @noRd .twasResolveCacheHits <- function(twasWeights, st, ctx, tr, tokens) { @@ -1821,7 +2584,7 @@ setMethod( ldSketch, cutoffs = NULL ) { - df <- getSumStatsDf( + allDf <- getSumStatsDf( data, study = st, context = ctx, @@ -1836,16 +2599,13 @@ setMethod( "twasWeightsPipeline(QtlSumStats): study='{st}', ", "context='{ctx}', trait='{tr}'" ) - df <- df[ - .panelKeepMask(df$variant_id, ldSketch, cutoffs, label), + df <- allDf[ + .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label), , drop = FALSE ] variantIds <- df$variant_id - varY <- getVarY(data, study = st, context = ctx, trait = tr) - if (is.null(varY)) { - varY <- 1 - } + varY <- getVarY(data, study = st, context = ctx, trait = tr) %||% 1 stat <- list( z = df$z, n = stats::median(df$N, na.rm = TRUE), @@ -1865,25 +2625,61 @@ setMethod( # Fit one univariate method for one entry -> a row record, or NULL on skip. # @noRd -.twasQssUnivariateFitOne <- function(tk, st, ctx, tr, fitCtx, p) { +# The weight function's arguments for one tuple: the user's args and, when the +# token is a fine-mapping method, the precomputed fit threaded into its +# dedicated *Fit argument. NULL when such a token has no fit to thread. +# @noRd +.twasQssUnivariateArgs <- function( + spec, + methodArgs, + tk, + st, + ctx, + tr, + fineMappingResult +) { + baseArgs <- .twasUserArgs(methodArgs, tk) + if (is.null(spec$adapter)) { + return(baseArgs) + } + fit <- .twasFineMappingFitFor( + fineMappingResult, + study = st, + context = ctx, + trait = tr, + token = tk + ) + if (is.null(fit)) { + .twasWarnNoFitUniv(tk, st, ctx, tr) + return(NULL) + } + list_assign(baseArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) +} + +.twasQssUnivariateFitOne <- function( + tk, + st, + ctx, + tr, + fitCtx, + methodArgs, + fineMappingResult, + dataType +) { spec <- .twasResolveWeightFn(tk) - userArgs <- .twasUserArgs(p$methodArgs, tk) - # When the token is a fine-mapping method, pass the precomputed fit into the - # *Rss weight function via its dedicated *Fit arg. The gate above ensures - # fineMappingResult is non-NULL here. - if (!is.null(spec$adapter)) { - fit <- .twasFineMappingFitFor( - p$fineMappingResult, - study = st, - context = ctx, - trait = tr, - token = tk - ) - if (is.null(fit)) { - .twasWarnNoFitUniv(tk, st, ctx, tr) - return(NULL) - } - userArgs[[spec$adapter$rssFitArg]] <- fit + userArgs <- .twasQssUnivariateArgs( + spec, + methodArgs, + tk, + st, + ctx, + tr, + fineMappingResult + ) + # NULL means a fine-mapping token whose fit is missing; it has already + # warned, and there is nothing to fit against. + if (is.null(userArgs)) { + return(NULL) } weights <- .twasTryWeights( spec$fn, @@ -1895,8 +2691,13 @@ setMethod( if (is.null(weights)) { return(NULL) } - fitAttr <- attr(weights, "fit") - attr(weights, "fit") <- NULL + .twasQssRowFromWeights(weights, st, ctx, tr, tk, fitCtx, dataType) +} + +# The weights come back with the fit hung off them as an attribute; the row +# stores the two separately, so they are split apart here. +# @noRd +.twasQssRowFromWeights <- function(weights, st, ctx, tr, tk, fitCtx, dataType) { .twasRowRecord( st, ctx, @@ -1904,11 +2705,11 @@ setMethod( tk, twasWeightsRow( variantIds = fitCtx$variantIds, - weights = as.numeric(weights), - fits = fitAttr, + weights = as.numeric(`attr<-`(weights, "fit", NULL)), + fits = attr(weights, "fit"), cvResult = NULL, standardized = TRUE, - dataType = p$dataType + dataType = dataType ) ) } @@ -1935,50 +2736,97 @@ setMethod( # ---- Multivariate dispatch: per (study, trait), all selected contexts ------ -.twasQssMultivariateRows <- function(p) { - if (length(p$multivariateTokens) == 0L) { +.twasQssMultivariateRows <- function( + selRows, + multivariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + methodArgs, + fitRetention, + fineMappingResult, + dataType, + panelFilterArgs, + twasWeights = NULL +) { + if (length(multivariateTokens) == 0L) { return(list()) } groupKey <- str_c( - p$studyCol[p$selRows], - p$traitCol[p$selRows], + studyCol[selRows], + traitCol[selRows], sep = "||" ) - groups <- split(p$selRows, groupKey) - list_flatten(map(groups, .twasQssMultivariateGroupRows, p = p)) + groups <- split(selRows, groupKey) + list_flatten(map( + groups, + .twasQssMultivariateGroupRows, + twasWeights = twasWeights, + multivariateTokens = multivariateTokens, + studyCol = studyCol, + contextCol = contextCol, + traitCol = traitCol, + data = data, + ldSketch = ldSketch, + methodArgs = methodArgs, + fitRetention = fitRetention, + fineMappingResult = fineMappingResult, + dataType = dataType, + panelFilterArgs = panelFilterArgs + )) } # Multivariate rows for one (study, trait) group across its contexts. # @noRd -.twasQssMultivariateGroupRows <- function(gIdx, p) { +.twasQssMultivariateGroupRows <- function( + gIdx, + multivariateTokens, + studyCol, + contextCol, + traitCol, + data, + ldSketch, + methodArgs, + fitRetention, + fineMappingResult, + dataType, + panelFilterArgs, + twasWeights = NULL +) { if (length(gIdx) < 2L) { return(list()) } - st <- p$studyCol[gIdx[[1L]]] - tr <- p$traitCol[gIdx[[1L]]] - ctxNames <- p$contextCol[gIdx] + st <- studyCol[gIdx[[1L]]] + tr <- traitCol[gIdx[[1L]]] + ctxNames <- contextCol[gIdx] mvStat <- .twasQssMultivariateStat( - p$data, + data, st, tr, ctxNames, - ldSketch = p$ldSketch, - cutoffs = .panelCutoffs(p) + ldSketch = ldSketch, + cutoffs = .panelCutoffs(panelFilterArgs) ) ldMat <- .ldFromSketch( - p$ldSketch, + ldSketch, mvStat$variantIds, label = "twasWeightsPipeline" ) list_flatten(map( - p$multivariateTokens, + multivariateTokens, .twasQssMultivariateFitOne, + twasWeights = twasWeights, st = st, tr = tr, ctxNames = ctxNames, mvStat = mvStat, ldMat = ldMat, - p = p + methodArgs = methodArgs, + fitRetention = fitRetention, + fineMappingResult = fineMappingResult, + dataType = dataType )) } @@ -1994,7 +2842,7 @@ setMethod( ldSketch = NULL, cutoffs = NULL ) { - firstDf <- getSumStatsDf( + allDf <- getSumStatsDf( data, study = st, context = ctxNames[[1L]], @@ -2009,16 +2857,10 @@ setMethod( "twasWeightsPipeline(QtlSumStats, multivariate): study='{st}', ", "trait='{tr}'" ) - keep <- .panelKeepMask(firstDf$variant_id, ldSketch, cutoffs, label) - firstDf <- firstDf[keep, , drop = FALSE] + keep <- .panelKeepMask(allDf$variant_id, ldSketch, cutoffs, label) + firstDf <- allDf[keep, , drop = FALSE] variantIds <- firstDf$variant_id - Z <- matrix( - NA_real_, - nrow = length(variantIds), - ncol = length(ctxNames), - dimnames = list(variantIds, ctxNames) - ) - filled <- .twasQssFillContexts(data, st, tr, ctxNames, variantIds, Z) + filled <- .twasQssFillContexts(data, st, tr, ctxNames, variantIds) list( variantIds = variantIds, stat = list( @@ -2034,24 +2876,43 @@ setMethod( # position, not by name, so a differing order would silently pair one context's # variant with another's. # @noRd -.twasQssFillContexts <- function(data, st, tr, ctxNames, variantIds, Z) { - nVec <- numeric(length(ctxNames)) - for (kk in seq_along(ctxNames)) { - d <- getSumStatsDf( - data, - study = st, - context = ctxNames[[kk]], - trait = tr, - require = c("Z", "N"), - derive = "zFromBetaSe" - ) - d <- d[is_in(d$variant_id, variantIds), , drop = FALSE] - .twasQssCheckSnpOrder(d$variant_id, variantIds, st, tr) - Z[, kk] <- d$z - nVec[kk] <- stats::median(d$N, na.rm = TRUE) - } - names(nVec) <- ctxNames - list(z = Z, n = nVec) +# One context's z column and median N, checked against the shared SNP order. +# @noRd +.twasQssContextStats <- function(ctx, data, st, tr, variantIds) { + d <- getSumStatsDf( + data, + study = st, + context = ctx, + trait = tr, + require = c("Z", "N"), + derive = "zFromBetaSe" + ) + kept <- d[is_in(d$variant_id, variantIds), , drop = FALSE] + .twasQssCheckSnpOrder(kept$variant_id, variantIds, st, tr) + list(z = kept$z, n = stats::median(kept$N, na.rm = TRUE)) +} + +# Every context shares one SNP order (asserted per context), which is what +# lets the columns simply be laid side by side rather than filled into a +# preallocated matrix. +.twasQssFillContexts <- function(data, st, tr, ctxNames, variantIds) { + stats <- map( + ctxNames, + .twasQssContextStats, + data = data, + st = st, + tr = tr, + variantIds = variantIds + ) + list( + z = matrix( + unname(list_c(map(stats, "z"))), + nrow = length(variantIds), + ncol = length(ctxNames), + dimnames = list(variantIds, ctxNames) + ), + n = set_names(map_dbl(stats, "n"), ctxNames) + ) } # @noRd @@ -2067,23 +2928,74 @@ setMethod( )) } +# The engine arguments for one multivariate token. mvsusie is +# fine-mapping, so its pre-fit is threaded through (mr.mash is not); +# .twasMvThreadFit() answers NULL when that pre-fit is missing. +# @noRd +.twasQssMvArgs <- function( + spec, + methodArgs, + tk, + st, + tr, + ctxNames, + fitRetention, + fineMappingResult +) { + baseArgs <- .twasMrmashRetainDefaults( + .twasUserArgs(methodArgs, tk), + spec$adapter, + tk, + fitRetention + ) + if (is.null(spec$adapter)) { + return(baseArgs) + } + .twasMvThreadFit( + spec, + baseArgs, + tk, + st, + tr, + ctxNames, + fineMappingResult + ) +} + # Fit one multivariate method for a group -> one row record per context (empty # list on skip). # @noRd -.twasQssMultivariateFitOne <- function(tk, st, tr, ctxNames, mvStat, ldMat, p) { +.twasQssMultivariateFitOne <- function( + tk, + st, + tr, + ctxNames, + mvStat, + ldMat, + methodArgs, + fitRetention, + fineMappingResult, + dataType, + twasWeights = NULL +) { + cached <- .twasMvCacheHits(twasWeights, st, tr, ctxNames, tk) + if (!is.null(cached)) { + return(.twasMvCachedRows(cached, st, tr, tk)) + } spec <- .twasResolveWeightFn(tk) - userArgs <- .twasMrmashRetainDefaults( - .twasUserArgs(p$methodArgs, tk), - spec$adapter, - tk, - p$retainFitDetail + userArgs <- .twasQssMvArgs( + spec, + methodArgs, + tk = tk, + st = st, + tr = tr, + ctxNames = ctxNames, + fitRetention = fitRetention, + fineMappingResult = fineMappingResult ) - # mvsusie is fine-mapping; thread its pre-fit through (mr.mash is not). - if (!is.null(spec$adapter)) { - userArgs <- .twasMvThreadFit(spec, userArgs, tk, st, tr, ctxNames, p) - if (is.null(userArgs)) { - return(list()) - } + # NULL when the pre-fit a fine-mapping token needs is missing. + if (is.null(userArgs)) { + return(list()) } weights <- .twasTryWeights( spec$fn, @@ -2095,29 +3007,28 @@ setMethod( if (is.null(weights)) { return(list()) } - if (!is.matrix(weights)) { - weights <- as.matrix(weights) - } - fitAttr <- attr(weights, "fit") - attr(weights, "fit") <- NULL - .twasMvContextRows( - weights, - fitAttr, - ctxNames, - mvStat, - st, - tr, - tk, - p$dataType - ) + # The fit is hung off the weights as an attribute; the rows store the + # two separately. + wMatrix <- if (is.matrix(weights)) weights else as.matrix(weights) + fitAttr <- attr(wMatrix, "fit") + bare <- `attr<-`(wMatrix, "fit", NULL) + .twasMvContextRows(bare, fitAttr, ctxNames, mvStat, st, tr, tk, dataType) } # Thread the precomputed fine-mapping fit into a multivariate method's args; # returns NULL (signalling skip) when the fit is absent. # @noRd -.twasMvThreadFit <- function(spec, userArgs, tk, st, tr, ctxNames, p) { +.twasMvThreadFit <- function( + spec, + userArgs, + tk, + st, + tr, + ctxNames, + fineMappingResult +) { fit <- .twasFineMappingFitFor( - p$fineMappingResult, + fineMappingResult, study = st, context = ctxNames[[1L]], trait = tr, @@ -2127,8 +3038,7 @@ setMethod( .twasWarnNoFitMv(tk, st, tr) return(NULL) } - userArgs[[spec$adapter$rssFitArg]] <- fit - userArgs + list_assign(userArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) } # Warning for a missing multivariate fine-mapping fit. @@ -2181,8 +3091,12 @@ setMethod( # Combine the per-tuple result with any joint result (error if both empty). # @noRd -.twasQssAssemble <- function(rows, jointResult, p) { - perTupleResult <- .twasRowsToWeights(rows, p$ldSketch) +.twasQssAssemble <- function( + rows, + jointResult, + ldSketch +) { + perTupleResult <- .twasRowsToWeights(rows, ldSketch) if (is.null(jointResult)) { if (is.null(perTupleResult)) { msg <- glue( @@ -2196,10 +3110,9 @@ setMethod( if (is.null(perTupleResult)) { return(jointResult) } - .rbindTwasWeights(perTupleResult, jointResult, ldSketch = p$ldSketch) + .rbindTwasWeights(perTupleResult, jointResult, ldSketch = ldSketch) } - # ============================================================================= # MultiStudyQtlDataset method # ============================================================================= @@ -2214,80 +3127,103 @@ setMethod( # args. # @noRd .twasPerStudy <- function(qd, cfg) { - twArgs <- c( - list( - data = qd, - methods = cfg$methods, - contexts = cfg$contexts, - traitId = cfg$traitId, - region = cfg$region, - cisWindow = cfg$cisWindow, - jointRegions = cfg$jointRegions, - jointSpecification = NULL, - fineMappingResult = cfg$fineMappingResult, - twasWeights = cfg$twasWeights, - naAction = cfg$naAction, - verbose = cfg$verbose, - seed = cfg$seed - ), - cfg$dotArgs + # Checked forwarding, not the `...`/dotArgs channel this used to splice: + # that is what made multi-study TWAS inherit the per-study CV default and + # silently drop residualization / fitRetention. + # Every setting is named -- NOT the `...`/dotArgs channel this once + # spliced, which is what made multi-study TWAS inherit the per-study CV + # default and silently drop residualization / fitRetention. A name this + # entry point does not accept is an "unused argument" error; `cfg`'s + # panelFilterArgs belongs to the summary-statistics path and is + # deliberately not forwarded. + twasWeightsPipeline( + data = qd, + jointSpecification = NULL, + fitRetention = .twasRetentionEnum(cfg), + methods = cfg$methods, + contexts = cfg$contexts, + traitId = cfg$traitId, + region = cfg$region, + cisWindow = cfg$cisWindow, + jointRegions = cfg$jointRegions, + fineMappingResult = cfg$fineMappingResult, + twasWeights = cfg$twasWeights, + naAction = cfg$naAction, + verbose = cfg$verbose, + crossValidationArgs = cfg$crossValidationArgs, + ensembleArgs = cfg$ensembleArgs, + seed = cfg$seed, + genotypeFilterArgs = cfg$genotypeFilterArgs, + mashPrior = cfg$mashPrior, + fitFullData = cfg$fitFullData, + estimatePi = cfg$estimatePi, + dataType = cfg$dataType, + residualizationArgs = cfg$residualizationArgs ) - exec(twasWeightsPipeline, !!!twArgs) } # Embedded-sumstats TWAS-weights worker for .multiStudyPipelineDriver. # @noRd .twasSumStats <- function(ss, cfg) { - twArgs <- c( - list( - data = ss, - methods = cfg$methods, - contexts = cfg$contexts, - traitId = cfg$traitId, - jointSpecification = NULL, - fineMappingResult = cfg$fineMappingResult, - twasWeights = cfg$twasWeights, - verbose = cfg$verbose - ), - cfg$dotArgs + # Summary statistics carry no genotypes: nothing to select a region + # from, residualize, cross-validate, stack or fit on full data. `cfg` + # carries those for the individual-level sibling and they are not + # forwarded here. + twasWeightsPipeline( + data = ss, + jointSpecification = NULL, + fitRetention = .twasRetentionEnum(cfg), + methods = cfg$methods, + contexts = cfg$contexts, + traitId = cfg$traitId, + fineMappingResult = cfg$fineMappingResult, + twasWeights = cfg$twasWeights, + verbose = cfg$verbose, + panelFilterArgs = cfg$panelFilterArgs, + dataType = cfg$dataType ) - exec(twasWeightsPipeline, !!!twArgs) } -#' @rdname twasWeightsPipeline -#' @export -setMethod( - "twasWeightsPipeline", - "MultiStudyQtlDataset", - function( - data, - methods = "default", - contexts = NULL, - traitId = NULL, - region = NULL, - cisWindow = NULL, - jointRegions = FALSE, - jointSpecification = NULL, - fineMappingResult = NULL, - twasWeights = NULL, - retainFit = TRUE, - retainFitDetail = c("slim", "full"), - naAction = c("drop", "impute"), - verbose = 1, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - seed = NULL, - ... - ) { - naAction <- arg_match(naAction) - retainFitDetail <- arg_match(retainFitDetail) - p <- as.list(environment()) - p$dots <- list(...) - .twasPipelineMultiStudy(p) +# The config carries the engine-facing pair; the per-study recursion re-enters +# the public method, which takes the single enum. One place converts back. +# @noRd +.twasRetentionEnum <- function(cfg) { + if (!isTRUE(cfg$fitRetention)) { + return("none") } -) + cfg$fitRetention %||% "slim" +} + +# Only the mr.mash engines distinguish the retention levels; every other +# weight method keeps its fit whole or not at all, so "full" is the same as +# "slim" for them. Erroring when NO requested method can honour it, and +# warning when only some can, is the alternative to dropping it in silence. +# @noRd +.twasWarnUnretainableDetail <- function(fitRetention, methods) { + if (!identical(fitRetention, "full")) { + return(invisible(NULL)) + } + tokens <- .twasMethodTokensFromArg(methods) + if (length(tokens) == 0L) { + return(invisible(NULL)) + } + honours <- str_detect(tokens, regex("mrmash", ignore_case = TRUE)) + if (!any(honours)) { + abort(glue( + "twasWeightsPipeline: fitRetention = \"full\" is only honoured ", + "by the mr.mash methods; {str_flatten(tokens, ', ')} cannot vary ", + "the retained detail. Use fitRetention = \"slim\"." + )) + } + if (!all(honours)) { + warn(glue( + "twasWeightsPipeline: fitRetention = \"full\" applies to ", + "{str_flatten(tokens[honours], ', ')}; ", + "{str_flatten(tokens[!honours], ', ')} retain their usual fit." + )) + } + invisible(NULL) +} # ---- MultiStudyQtlDataset pipeline worker + phase helpers ------------------ @@ -2295,6 +3231,10 @@ setMethod( # canonical bare tokens; otherwise empty. # @noRd .twasMethodTokensFromArg <- function(methods) { + if (.twasMethodsIsParam(methods)) { + return(.methodsParamTokens(methods)) + } + methods <- .twasMethodsAsList(methods) if (is.character(methods)) { methods } else if (is.list(methods)) { @@ -2306,7 +3246,28 @@ setMethod( # Drop mrmash (handled by the joint dispatcher) from a `methods` arg. # @noRd +# A methods argument as an ordinary named list, whatever form it arrived in. +# A MethodOptions record is a SimpleList, so `is.list()` is FALSE for it and the +# helpers below would otherwise fall through to their "leave it alone" branch. +# @noRd +.twasMethodsAsList <- function(methods) { + if (.isMethodOptions(methods)) as.list(methods) else methods +} + +# A MethodsSelectionParam keeps its structure through these helpers: the +# token questions read across all three slots, and dropping a method drops +# it from each, so the per-component recursion still receives a Param that +# knows which path each entry is for. +# @noRd +.twasMethodsIsParam <- function(methods) { + is(methods, "MethodsSelectionParam") +} + .twasMsStripMrmash <- function(methods) { + if (.twasMethodsIsParam(methods)) { + return(.methodsParamDrop(methods, "mrmash")) + } + methods <- .twasMethodsAsList(methods) if (is.character(methods)) { setdiff(methods, "mrmash") } else if (is.list(methods)) { @@ -2319,58 +3280,161 @@ setMethod( # TRUE when a character/list `methods` arg has become empty. # @noRd .twasMethodsEmpty <- function(methods) { + # A Param is neither a character vector nor a list, so it has to be + # asked directly: with every slot empty it names no methods, which is + # what the joint phase produces after stripping mrmash. + if (.twasMethodsIsParam(methods)) { + return(length(.methodsParamTokens(methods)) == 0L) + } + methods <- .twasMethodsAsList(methods) (is.character(methods) || is.list(methods)) && length(methods) == 0L } -.twasPipelineMultiStudy <- function(p) { - if (!is.null(p$region) && !is.null(p$cisWindow)) { +# Resolve the MultiStudyQtlDataset inputs: the region/cisWindow guard, the +# naAction choice and the joint-region spec. Mirrors .fmMsResolveInputs so +# both MultiStudy workers read the same way, rather than one open-coding +# what the other names. +# @noRd +.twasMsResolveInputs <- function(naAction, region, cisWindow, jointRegions) { + if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "twasWeightsPipeline(MultiStudyQtlDataset): specify either ", "`region` or `cisWindow`, not both." ) abort(msg) } - xRegions <- .makeXRegions(p$region, p$jointRegions) - parsedJointSpec <- parseJointSpecification(p$jointSpecification, p$data) - # Gate fine-mapping methods early so the recursion into the embedded - # QtlDataset / QtlSumStats components doesn't re-run fine-mapping. - .twasCheckFineMappingMethods( - .twasMethodTokensFromArg(p$methods), - p$fineMappingResult, - "MultiStudyQtlDataset" + list( + naAction = arg_match(naAction, c("drop", "impute")), + xRegions = .makeXRegions(region, jointRegions) + ) +} + +.twasPipelineMultiStudy <- function( + data, + methods = "default", + contexts = NULL, + traitId = NULL, + region = NULL, + cisWindow = NULL, + genotypeFilterArgs = GenotypeFilterParam(), + panelFilterArgs = PanelFilterParam(), + jointRegions = FALSE, + jointSpecification = NULL, + fineMappingResult = NULL, + twasWeights = NULL, + mashPrior = NULL, + fitFullData = TRUE, + estimatePi = TRUE, + fitRetention = c("slim", "none", "full"), + dataType = NULL, + naAction = c("drop", "impute"), + verbose = 1, + residualizationArgs = ResidualizationParam(), + crossValidationArgs = CrossValidationParam(), + ensembleArgs = EnsembleParam(), + seed = NULL +) { + fitRetention <- arg_match(fitRetention) + .twasWarnUnretainableDetail(fitRetention, methods) + inputs <- .twasMsResolveInputs(naAction, region, cisWindow, jointRegions) + naAction <- inputs$naAction + # One record of the settings the joint phase and the shared dispatcher + # both need, so each names them once. + jointCfg <- list( + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + verbose = verbose, + xRegions = inputs$xRegions, + fitRetention = fitRetention, + seed = seed + ) + joint <- .twasMsResolveTokens( + jointSpecification, + methods, + fineMappingResult, + jointCfg ) - joint <- .twasMsJointPhase(p, parsedJointSpec, xRegions) if (joint$done) { return(joint$result) } - .twasMsDriver(p, joint$result, joint$methods) + .twasMsDriver( + data = data, + contexts = contexts, + traitId = traitId, + cisWindow = cisWindow, + region = region, + jointRegions = jointRegions, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + naAction = naAction, + verbose = verbose, + crossValidationArgs = crossValidationArgs, + ensembleArgs = ensembleArgs, + seed = seed, + genotypeFilterArgs = genotypeFilterArgs, + panelFilterArgs = panelFilterArgs, + mashPrior = mashPrior, + fitFullData = fitFullData, + estimatePi = estimatePi, + fitRetention = fitRetention, + dataType = dataType, + residualizationArgs = residualizationArgs, + joint$result, + joint$methods + ) +} + +#' @rdname twasWeightsPipeline +#' @export +setMethod( + "twasWeightsPipeline", + "MultiStudyQtlDataset", + .twasPipelineMultiStudy +) + +# Run the joint engine for a MultiStudyQtlDataset with the given spec + token +# set. The NULL in the dataType slot is deliberate: the per-component +# recursion resolves each study's own data type. +# @noRd +.twasMsJointDispatch <- function(jointSpec, tokens, cfg) { + .twasDispatchJointSpecsMultiStudy( + jointSpec, + cfg$data, + tokens, + cfg$contexts, + cfg$traitId, + cfg$cisWindow, + NULL, + cfg$verbose, + xRegions = cfg$xRegions, + fitRetention = cfg$fitRetention, + seed = cfg$seed + ) } # Joint-specification dispatch for mrmash. Returns list(done, result, methods) # where `done` requests an early return with `result` and `methods` is the # mrmash-stripped set for the per-component recursion. # @noRd -.twasMsJointPhase <- function(p, parsedJointSpec, xRegions) { +.twasMsJointPhase <- function(parsedJointSpec, methods, cfg) { if (length(parsedJointSpec) == 0L) { - return(list(done = FALSE, result = NULL, methods = p$methods)) + # No joint spec: every token is fitted per component, so each must + # find a multivariate Y there. + .twasCheckMultivariateComponents( + .twasMethodTokensFromArg(methods), + cfg$data + ) + return(list(done = FALSE, result = NULL, methods = methods)) } - jointMethods <- intersect(.twasMethodTokensFromArg(p$methods), "mrmash") - jointResult <- .twasDispatchJointSpecsMultiStudy( + jointResult <- .twasMsJointDispatch( parsedJointSpec, - p$data, - jointMethods, - p$contexts, - p$traitId, - p$cisWindow, - NULL, - p$verbose, - xRegions = xRegions, - retainFit = p$retainFit, - retainFitDetail = p$retainFitDetail, - seed = p$seed + intersect(.twasMethodTokensFromArg(methods), "mrmash"), + cfg ) - methods <- .twasMsStripMrmash(p$methods) - if (.twasMethodsEmpty(methods)) { + stripped <- .twasMsStripMrmash(methods) + if (.twasMethodsEmpty(stripped)) { if (is.null(jointResult)) { msg <- glue( "twasWeightsPipeline(MultiStudyQtlDataset): no joint fits ", @@ -2380,28 +3444,95 @@ setMethod( } return(list(done = TRUE, result = jointResult)) } - list(done = FALSE, result = jointResult, methods = methods) + # Whatever the joint phase did not handle falls to the per-component + # recursion, and is held to the same requirement. + .twasCheckMultivariateComponents( + .twasMethodTokensFromArg(stripped), + cfg$data + ) + list(done = FALSE, result = jointResult, methods = stripped) +} + +# Gate fine-mapping methods early so the recursion into the embedded +# QtlDataset / QtlSumStats components doesn't re-run fine-mapping, then hand +# off to the joint phase. Mirrors .fmMsResolveTokens. +# @noRd +.twasMsResolveTokens <- function( + jointSpecification, + methods, + fineMappingResult, + cfg +) { + parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) + # Translated here, where the dataset is in hand, so the Param is what + # travels into the per-component recursion; each component reads the + # slot for its own input class. + methods <- .methodsParamForMulti( + methods, + "TwasWeightsMethodsParam", + "twasWeightsPipeline", + !is.null(getSumStats(cfg$data)) + ) + .twasCheckFineMappingMethods( + .twasMethodTokensFromArg(methods), + fineMappingResult, + "MultiStudyQtlDataset" + ) + .twasMsJointPhase(parsedJointSpec, methods, cfg) } # Run the per-study / per-component recursion via the shared multi-study driver. # @noRd -.twasMsDriver <- function(p, jointResult, methods) { +.twasMsDriver <- function( + data, + contexts, + traitId, + cisWindow, + region, + jointRegions, + fineMappingResult, + twasWeights, + naAction, + verbose, + crossValidationArgs, + ensembleArgs, + seed, + genotypeFilterArgs, + panelFilterArgs, + mashPrior, + fitFullData, + estimatePi, + fitRetention, + dataType, + residualizationArgs, + jointResult, + methods +) { cfg <- list( methods = methods, - contexts = p$contexts, - traitId = p$traitId, - region = p$region, - cisWindow = p$cisWindow, - jointRegions = p$jointRegions, - fineMappingResult = p$fineMappingResult, - twasWeights = p$twasWeights, - naAction = p$naAction, - verbose = p$verbose, - seed = p$seed, - dotArgs = p$dots + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + jointRegions = jointRegions, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + naAction = naAction, + verbose = verbose, + crossValidationArgs = crossValidationArgs, + ensembleArgs = ensembleArgs, + seed = seed, + genotypeFilterArgs = genotypeFilterArgs, + panelFilterArgs = panelFilterArgs, + mashPrior = mashPrior, + fitFullData = fitFullData, + estimatePi = estimatePi, + fitRetention = fitRetention, + dataType = dataType, + residualizationArgs = residualizationArgs ) .multiStudyPipelineDriver( - p$data, + data, jointResult, .twasPerStudy, .twasSumStats, @@ -2413,21 +3544,6 @@ setMethod( ) } - -#' @rdname twasWeightsPipeline -#' @export -setMethod("twasWeightsPipeline", "ANY", function(data, ...) { - cls <- class(data)[[1L]] - msg <- glue( - "twasWeightsPipeline does not accept inputs of class '{cls}'. ", - "Pass a QtlDataset, MultiStudyQtlDataset, or QtlSumStats. ", - "(GwasSumStats inputs are not supported; GWAS-side per-LD-block ", - "weights are produced inside the new ctwasPipeline / ", - "qtlEnrichmentPipeline.)" - ) - abort(msg) -}) - # ============================================================================= # SR-TWAS ensemble stacking solvers (used by ensembleWeights, the primitive the # engine's .twasEnsembleLayer calls per context) @@ -2442,32 +3558,27 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @noRd .solveEnsembleQuadprog <- function(Pvalid, yObs, Kvalid) { if (!requireNamespace("quadprog", quietly = TRUE)) { - msg <- glue( - "Package 'quadprog' is required for solver='quadprog'. ", - "Install with: install.packages('quadprog')" - ) - abort(msg) + abort("Package 'quadprog' is required for solver='quadprog'.") } - Dmat <- crossprod(Pvalid) + gram <- crossprod(Pvalid) dvec <- as.vector(crossprod(Pvalid, yObs)) # Ridge term for numerical stability (small relative to trace) - Dmat <- Dmat + 1e-8 * mean(diag(Dmat)) * diag(Kvalid) + Dmat <- gram + 1e-8 * mean(diag(gram)) * diag(Kvalid) # Constraint matrix: first constraint is equality (sum = 1), then Kvalid # non-negativity constraints. Amat <- cbind(rep(1, Kvalid), diag(Kvalid)) bvec <- c(1, rep(0, Kvalid)) - qpSol <- tryCatch( + qpSol <- try_fetch( solve.QP(Dmat = Dmat, dvec = dvec, Amat = Amat, bvec = bvec, meq = 1), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( - "QP solver failed: {eMsg}. Falling back to equal weights ", - "among valid methods." + "QP solver failed. Falling back to equal weights among ", + "valid methods." ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -2494,22 +3605,19 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @return Normalized coefficient vector of length Kvalid. # @noRd .solveEnsembleNnls <- function(Pvalid, yObs, Kvalid) { + # Engine-call exception: nnls solves for the ensemble's stacking weights + # over the per-method prediction matrix. It is an optimisation primitive + # used by pipeline logic, not an interface to a TWAS weight-learning + # method, so it does not belong in a *Wrapper.R file. if (!requireNamespace("nnls", quietly = TRUE)) { - msg <- glue( - "Package 'nnls' is required for solver='nnls'. ", - "Install with: install.packages('nnls')" - ) - abort(msg) + abort("Package 'nnls' is required for solver='nnls'.") } - fit <- tryCatch( + fit <- try_fetch( nnls::nnls(Pvalid, yObs), - error = function(e) { - eMsg <- conditionMessage(e) - msg <- glue( - "NNLS solver failed: {eMsg}. Falling back to equal weights." - ) - warn(msg) + error = function(cnd) { + msg <- "NNLS solver failed. Falling back to equal weights." + warn(msg, parent = cnd) NULL } ) @@ -2532,12 +3640,24 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # Ensemble stacking objective (sum of squared residuals). `...` absorbs the # gradient's extra optim args (PtP, Pty). # @noRd -.ensembleObj <- function(z, Pvalid, yObs, ...) sum((yObs - Pvalid %*% z)^2) +.ensembleObj <- function(Pvalid, yObs) { + # Captured by name, and forced here so the closure holds values rather + # than promises into a frame that has already returned. + force(Pvalid) + force(yObs) + function(z) sum((yObs - Pvalid %*% z)^2) +} -# Gradient of the ensemble stacking objective. `...` absorbs the objective's -# extra optim args (Pvalid, yObs). +# Gradient of the ensemble stacking objective, same construction. Building +# both as closures of exactly what each needs is what lets optim() be called +# with no `...`: previously it forwarded the union of both callbacks' +# arguments to both, and each absorbed the other's half in a `...` tail. # @noRd -.ensembleGrad <- function(z, PtP, Pty, ...) as.vector(2 * (PtP %*% z - Pty)) +.ensembleGrad <- function(PtP, Pty) { + force(PtP) + force(Pty) + function(z) as.vector(2 * (PtP %*% z - Pty)) +} # Solve ensemble stacking via L-BFGS-B (box-constrained optimization, then # normalize). Uses base R optim() with analytical gradient. No extra @@ -2551,25 +3671,19 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { PtP <- crossprod(Pvalid) Pty <- as.vector(crossprod(Pvalid, yObs)) - fit <- tryCatch( + fit <- try_fetch( optim( par = rep(1 / Kvalid, Kvalid), - fn = .ensembleObj, - gr = .ensembleGrad, - Pvalid = Pvalid, - yObs = yObs, - PtP = PtP, - Pty = Pty, + fn = .ensembleObj(Pvalid, yObs), + gr = .ensembleGrad(PtP, Pty), method = "L-BFGS-B", lower = rep(0, Kvalid) ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( - "L-BFGS-B solver failed: {eMsg}. Falling back to equal ", - "weights." + "L-BFGS-B solver failed. Falling back to equal weights." ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -2601,15 +3715,15 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @return Normalized coefficient vector of length Kvalid. # @noRd .solveEnsembleGlmnet <- function(Pvalid, yObs, Kvalid, alpha = 1) { + # Engine-call exception: glmnet is a constrained-regression solver here, + # fitting the ensemble's stacking weights -- a different role from its use + # as a weight-learning engine in regularizedRegressionWrappers.R. The + # stacking step is pipeline logic, so the call stays with it. if (!requireNamespace("glmnet", quietly = TRUE)) { - msg <- glue( - "Package 'glmnet' is required for solver='glmnet'. ", - "Install with: install.packages('glmnet')" - ) - abort(msg) + abort("Package 'glmnet' is required for solver='glmnet'.") } - fit <- tryCatch( + fit <- try_fetch( glmnet::cv.glmnet( x = Pvalid, y = yObs, @@ -2617,13 +3731,11 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { alpha = alpha, intercept = FALSE ), - error = function(e) { - eMsg <- conditionMessage(e) + error = function(cnd) { msg <- glue( - "glmnet solver failed: {eMsg}. Falling back to equal ", - "weights." + "glmnet solver failed. Falling back to equal weights." ) - warn(msg) + warn(msg, parent = cnd) NULL } ) @@ -2632,8 +3744,8 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { return(rep(1 / Kvalid, Kvalid)) } - zetaValid <- as.numeric(coef(fit, s = "lambda.min"))[-1] # drop intercept - zetaValid <- pmax(zetaValid, 0) + # [-1] drops the intercept. + zetaValid <- pmax(as.numeric(coef(fit, s = "lambda.min"))[-1], 0) zetaSum <- sum(zetaValid) if (zetaSum <= 0) { warn( @@ -2644,7 +3756,6 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { zetaValid / zetaSum } - #' Ensemble TWAS Weights via Stacked Regression #' #' Given cross-validated predictions from multiple TWAS weight methods, learns @@ -2787,6 +3898,7 @@ ensembleWeights <- function( # Validate the required scalar / presence constraints on the raw inputs. # @noRd +#' @importFrom checkmate assertCount .ensembleValidateArgs <- function(cvResults, Y, contextIndex) { if (is.null(cvResults)) { abort("'cvResults' is required.") @@ -2794,13 +3906,7 @@ ensembleWeights <- function( if (is.null(Y)) { abort("'Y' is required.") } - if ( - !is.numeric(contextIndex) || - length(contextIndex) != 1 || - contextIndex < 1 - ) { - abort("'contextIndex' must be a positive integer scalar.") - } + assertCount(contextIndex, positive = TRUE) invisible(NULL) } @@ -3000,30 +4106,45 @@ ensembleWeights <- function( # Assemble one dataset's (samples x methods) prediction matrix. # @noRd -.ensembleBuildPd <- function(predsD, nm, aln, contextIndex, d) { - Pd <- matrix(NA_real_, nrow = aln$nD, ncol = nm$K) - colnames(Pd) <- nm$baseNames - for (k in seq_along(nm$predNames)) { - predMat <- predsD[[nm$predNames[k]]] - pCol <- if (is.matrix(predMat)) { - predMat[aln$predOrder, contextIndex] - } else { - as.numeric(predMat)[aln$predOrder] - } - if (length(pCol) != aln$nD) { - methodName <- nm$predNames[k] - nCol <- length(pCol) - nAligned <- aln$nD - msg <- glue( - "Prediction length for method '{methodName}' in dataset ", - "{d} ({nCol}) does not match number of aligned samples ", - "({nAligned})." - ) - abort(msg) - } - Pd[, k] <- pCol +# One method's aligned prediction column for dataset `d`. +# @noRd +.ensemblePredColumn <- function(k, predsD, nm, aln, contextIndex, d) { + methodName <- nm$predNames[k] + predMat <- predsD[[methodName]] + pCol <- if (is.matrix(predMat)) { + predMat[aln$predOrder, contextIndex] + } else { + as.numeric(predMat)[aln$predOrder] + } + if (length(pCol) != aln$nD) { + nCol <- length(pCol) + nAligned <- aln$nD + msg <- glue( + "Prediction length for method '{methodName}' in dataset ", + "{d} ({nCol}) does not match number of aligned samples ", + "({nAligned})." + ) + abort(msg) } - Pd + pCol +} + +.ensembleBuildPd <- function(predsD, nm, aln, contextIndex, d) { + cols <- map( + seq_along(nm$predNames), + .ensemblePredColumn, + predsD = predsD, + nm = nm, + aln = aln, + contextIndex = contextIndex, + d = d + ) + matrix( + unname(list_c(cols)), + nrow = aln$nD, + ncol = nm$K, + dimnames = list(NULL, nm$baseNames) + ) } # Drop rows with any NA prediction/outcome; error when too few remain. @@ -3073,18 +4194,14 @@ ensembleWeights <- function( solver, alpha ) - zeta <- rep(0, nm$K) - zeta[validMethods] <- zetaValid - names(zeta) <- nm$baseNames - zeta + zeta <- replace(rep(0, nm$K), validMethods, zetaValid) + set_names(zeta, nm$baseNames) } # Degenerate case: a single signal-bearing method takes full weight. # @noRd .ensembleSingleMethodZeta <- function(validMethods, baseNames, K) { - zeta <- rep(0, K) - zeta[validMethods] <- 1 - names(zeta) <- baseNames + zeta <- set_names(replace(rep(0, K), validMethods, 1), baseNames) methodName <- baseNames[validMethods] msg <- glue( "Only one method ('{methodName}') has non-zero variance ", @@ -3160,24 +4277,45 @@ ensembleWeights <- function( # Zeta-weighted sum of the matched weight matrices; univariate -> named vector. # @noRd +# One method's zeta-scaled contribution, or NULL when its weight matrix does +# not line up with the first one's shape. +# @noRd +.ensembleWeightTerm <- function(i, wtList, wtKeys, zeta, shape) { + wMat <- .ensembleAsMatrix(wtList[[wtKeys[i]]]) + if (!identical(dim(wMat), shape)) { + wtKey <- wtKeys[i] + msg <- glue( + "Weight matrix for '{wtKey}' has inconsistent dimensions; ", + "skipping." + ) + warn(msg) + return(NULL) + } + zeta[i] * wMat +} + .ensembleAccumulateWeights <- function(wtList, wtKeys, matched, zeta) { firstWt <- .ensembleAsMatrix(wtList[[wtKeys[which(matched)[1]]]]) - ensembleTwasWt <- matrix(0, nrow = nrow(firstWt), ncol = ncol(firstWt)) - rownames(ensembleTwasWt) <- rownames(firstWt) - colnames(ensembleTwasWt) <- colnames(firstWt) - for (i in which(matched)) { - wMat <- .ensembleAsMatrix(wtList[[wtKeys[i]]]) - if (!identical(dim(wMat), dim(ensembleTwasWt))) { - wtKey <- wtKeys[i] - msg <- glue( - "Weight matrix for '{wtKey}' has inconsistent dimensions; ", - "skipping." - ) - warn(msg) - next - } - ensembleTwasWt <- ensembleTwasWt + zeta[i] * wMat - } + shape <- dim(firstWt) + # The ensemble is the sum of the scaled contributions, so it is a fold + # over them rather than a matrix added into repeatedly. + ensembleTwasWt <- reduce( + compact(map( + which(matched), + .ensembleWeightTerm, + wtList = wtList, + wtKeys = wtKeys, + zeta = zeta, + shape = shape + )), + `+`, + .init = matrix( + 0, + nrow = nrow(firstWt), + ncol = ncol(firstWt), + dimnames = dimnames(firstWt) + ) + ) # For the univariate case, return as a named vector. if (ncol(ensembleTwasWt) == 1) { return(set_names(as.numeric(ensembleTwasWt), rownames(ensembleTwasWt))) @@ -3271,6 +4409,7 @@ ensembleWeights <- function( region = ctx$xRegions[[bi]], regionIndex = bi, nRegions = length(ctx$xRegions), + residualizationArgs = ctx$residualizationArgs, verbose = ctx$verbose ) ) @@ -3292,17 +4431,65 @@ ensembleWeights <- function( } } -# One region's univariate joint-cell fit (region `bi` of p$xRegions). +# One region's univariate joint-cell fit (region `bi` of `xRegions`). # @noRd -.twasQdsUnivRegion <- function(bi, univCell, p, scope) { - .runJointCell( - univCell, - p$marker, - p$data, - scope, - p$norm$tokens, - args = .twasQdsUnivArgs(p, bi) +.twasQdsUnivRegion <- function( + bi, + cells, + scope, + marker, + data, + xRegions, + norm, + fineMappingResult, + twasWeights, + dataDrivenPriorMatricesCv, + cisWindow, + naAction, + residualizationArgs, + nPCs, + verbose +) { + # `cells` is the univariate cell, plus the top-PC cell when usePCA. Each + # enumerates its own groups from the same data and returns its own rows. + args <- .twasQdsUnivArgs( + bi, + xRegions = xRegions, + norm = norm, + fineMappingResult = fineMappingResult, + twasWeights = twasWeights, + dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, + cisWindow = cisWindow, + naAction = naAction, + residualizationArgs = residualizationArgs, + nPCs = nPCs, + verbose = verbose ) + out <- compact(map( + cells, + .runJointCell, + pipeline = marker, + data = data, + scope = scope, + tokens = norm$tokens, + args = args + )) + .twasCombineCellRows(out) +} + +# Combine the per-cell results of one region. rbind, NOT +# .twasMergeResultsByKey(): that one merges the SAME rows across regions, +# keeping results[[1]]'s row set. The top-PC rows are different rows, so +# merging would silently drop them. +# @noRd +.twasCombineCellRows <- function(out) { + if (length(out) == 0L) { + return(NULL) + } + if (length(out) == 1L) { + return(out[[1L]]) + } + reduce(out, .rbindTwasWeights) } # One cached row record from an imap over (entry, token) cache hits. @@ -3311,6 +4498,21 @@ ensembleWeights <- function( .twasRowRecord(st, ctx, tr, tk, entry) } +# A resumed multivariate group as row records. `.twasMvCacheHits` hands back +# bare TwasWeightsRow entries keyed by context, but the assembler reads the +# tuple axes off each row, so they are attached here exactly as the fitted +# path attaches them -- returning the bare entries leaves `study` absent. +# @noRd +.twasMvCachedRows <- function(cached, st, tr, tk) { + unname(imap(cached, .twasMvCachedRow, st = st, tr = tr, tk = tk)) +} + +# One resumed row from an imap over (entry, context) cache hits. +# @noRd +.twasMvCachedRow <- function(entry, ctx, st, tr, tk) { + .twasRowRecord(st, ctx, tr, tk, entry) +} + # Cache lookup for one token in a (study, context, trait). # @noRd .twasCacheLookupTok <- function(tk, twasWeights, st, ctx, tr) { @@ -3371,3 +4573,149 @@ ensembleWeights <- function( .twasCvHasPartition <- function(z) { is.list(z) && !is.null(z$samplePartition) } + +#' @rdname TwasWeightsMethodsParam +#' @aliases TwasWeightsMethodsParam-class +#' @exportClass TwasWeightsMethodsParam +setClass("TwasWeightsMethodsParam", contains = "MethodsSelectionParam") + +#' @title Which TWAS Weight Methods To Run, And How +#' @description Selects the methods \code{\link{twasWeightsPipeline}} runs and +#' carries each one's engine arguments. +#' +#' A method that runs on both individual-level and summary-statistic data +#' reaches a different engine on each path, so for a +#' \code{MultiStudyQtlDataset} carrying both there is no single set of +#' arguments per method. Name such a method under +#' \code{qtlDatasetMethods} or \code{qtlSumStatsMethods} to say which +#' path its options are for; name it under \code{methods} when the path +#' need not be stated --- a single-type run, or a method with nothing +#' path-specific to configure. +#' +#' Naming a method selects it. A method belongs in exactly one of the +#' three slots. +#' @param methods Named list of per-method options whose input path need not +#' be stated. Each entry is that method's \code{*Options()} record, or +#' \code{list()} to run it with its defaults. +#' @param qtlDatasetMethods Named list of per-method options for the +#' individual-level path. +#' @param qtlSumStatsMethods Named list of per-method options for the +#' summary-statistics path. +#' @return A \code{TwasWeightsMethodsParam} object, a \code{\link{MethodParam}}. +#' @examples +#' TwasWeightsMethodsParam(methods = list(lasso = list(), susie = list())) +#' TwasWeightsMethodsParam( +#' methods = list(susie = list()), +#' qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), +#' qtlSumStatsMethods = list(lasso = LassosumOptions()) +#' ) +#' @export +TwasWeightsMethodsParam <- function( + methods = NULL, + qtlDatasetMethods = NULL, + qtlSumStatsMethods = NULL +) { + new( + "TwasWeightsMethodsParam", + methods = .methodsNormalizeSlot( + methods, + "methods", + "TwasWeightsMethodsParam" + ), + qtlDatasetMethods = .methodsNormalizeSlot( + qtlDatasetMethods, + "qtlDatasetMethods", + "TwasWeightsMethodsParam" + ), + qtlSumStatsMethods = .methodsNormalizeSlot( + qtlSumStatsMethods, + "qtlSumStatsMethods", + "TwasWeightsMethodsParam" + ) + ) +} + +#' @rdname EnsembleParam +#' @aliases EnsembleParam-class +#' @exportClass EnsembleParam +setClass( + "EnsembleParam", + contains = "MethodParam", + slots = c( + enabled = "logical", + r2Threshold = "numeric", + solver = "character", + alpha = "numeric" + ) +) + +#' @title SR-TWAS Ensemble Settings +#' @description Whether and how \code{\link{twasWeightsPipeline}} stacks its +#' per-method weights into an SR-TWAS ensemble. +#' @section Requires cross-validation: +#' Stacking combines each method's \strong{out-of-fold} predictions, so it +#' cannot run without cross-validation. \code{enabled = TRUE} together with +#' \code{CrossValidationParam(folds < 2)} is an error. It used to be +#' neither: the ensemble row was simply absent from the result, with +#' \code{ensemble = TRUE} still reading as on. +#' +#' \code{enabled} defaults to \code{FALSE} because +#' \code{\link{CrossValidationParam}} defaults to no folds. To get an +#' ensemble, ask for both. +#' @param enabled Logical. Compute SR-TWAS ensemble weights. Default +#' \code{FALSE}. +#' @param r2Threshold Minimum cross-validated \eqn{R^2} for a method to enter +#' the stack. Default \code{0.01}. Stacking needs at least two methods to +#' clear it. +#' @param solver Stacking solver, \code{"quadprog"} (default) or +#' \code{"glmnet"}. +#' @param alpha Elastic-net mixing parameter, used only when +#' \code{solver = "glmnet"}. Default \code{1}. +#' @return A \code{EnsembleParam} object, a \code{\link{MethodParam}}. +#' @seealso \code{\link{CrossValidationParam}} +#' @examples +#' EnsembleParam(enabled = TRUE, r2Threshold = 0.05) +#' @export +EnsembleParam <- function( + enabled = FALSE, + r2Threshold = 0.01, + solver = c("quadprog", "glmnet"), + alpha = 1 +) { + solver <- arg_match(solver) + new( + "EnsembleParam", + enabled = enabled, + r2Threshold = r2Threshold, + solver = solver, + alpha = alpha + ) +} + +# Refuse an ensemble that cannot be built. Stacking reads out-of-fold +# predictions, so without folds there is nothing to stack -- and the old +# behaviour was to return a result silently missing its ensemble row. +# @noRd +.ensembleAssertCv <- function(ensembleArgs, crossValidationArgs) { + if (!isTRUE(ensembleArgs$enabled) || .cvEnabled(crossValidationArgs)) { + return(invisible(NULL)) + } + abort(glue( + "twasWeightsPipeline: EnsembleParam(enabled = TRUE) needs ", + "out-of-fold predictions to stack, so it requires ", + "CrossValidationParam(folds >= 2); got folds = ", + "{crossValidationArgs$folds %||% 0}." + )) +} + +# The ensemble settings as a plain list, so a cfg record can carry the group +# as one named field instead of four loose ones. +# @noRd +.ensembleResolve <- function(ensembleArgs) { + list( + enabled = isTRUE(ensembleArgs$enabled), + r2Threshold = ensembleArgs$r2Threshold %||% 0.01, + solver = ensembleArgs$solver %||% "quadprog", + alpha = ensembleArgs$alpha %||% 1 + ) +} diff --git a/R/twasWeightsRow.R b/R/twasWeightsRow.R index c96120d28..eda278417 100644 --- a/R/twasWeightsRow.R +++ b/R/twasWeightsRow.R @@ -41,30 +41,25 @@ setClass( ) ) +#' @importFrom checkmate makeAssertCollection assert assertFlag +#' @importFrom checkmate checkNumeric checkMatrix methods::setValidity("TwasWeightsRow", function(object) { - errors <- character(0) + coll <- makeAssertCollection() w <- object@weights n <- length(object@variants) if (!is.null(w)) { # A matrix carries one ROW per variant (columns are conditions), so # the two shapes need separate checks -- validating only the vector # case would let a mis-sized matrix through. - if (is.null(dim(w)) && length(w) != n) { - errors <- c( - errors, - "length(weights) must equal length(variantIds)" - ) - } else if (!is.null(dim(w)) && nrow(w) != n) { - errors <- c( - errors, - "nrow(weights) must equal length(variantIds)" - ) - } - } - if (length(object@standardized) != 1L || is.na(object@standardized)) { - errors <- c(errors, "'standardized' must be a single logical value") + assert( + checkNumeric(w, len = n), + checkMatrix(w, nrows = n), + .var.name = "weights", + add = coll + ) } - if (length(errors) == 0L) TRUE else errors + assertFlag(object@standardized, .var.name = "standardized", add = coll) + coll$getMessages() }) #' @title Build One TWAS-Weight Row @@ -117,10 +112,13 @@ twasWeightsRow <- function( ) abort(msg) } - mcols(gr)$weight <- w + withWeight <- S4Vectors::`mcols<-`( + gr, + value = `[[<-`(mcols(gr, use.names = FALSE), "weight", value = w) + ) obj <- new( "TwasWeightsRow", - variants = gr, + variants = withWeight, weights = w, fits = fits, cvResult = cvResult, @@ -136,34 +134,34 @@ twasWeightsRow <- function( #' @rdname getVariantIds #' @export -setMethod("getVariantIds", "TwasWeightsRow", function(x, ...) { +setMethod("getVariantIds", "TwasWeightsRow", function(x) { .grVariantIds(x@variants) }) #' @rdname getWeights #' @export -setMethod("getWeights", "TwasWeightsRow", function(x, ...) x@weights) +setMethod("getWeights", "TwasWeightsRow", function(x) x@weights) #' @rdname getFits #' @export -setMethod("getFits", "TwasWeightsRow", function(x, ...) x@fits) +setMethod("getFits", "TwasWeightsRow", function(x) x@fits) #' @rdname getCvResult #' @export -setMethod("getCvResult", "TwasWeightsRow", function(x, ...) x@cvResult) +setMethod("getCvResult", "TwasWeightsRow", function(x) x@cvResult) #' @rdname getStandardized #' @export -setMethod("getStandardized", "TwasWeightsRow", function(x, ...) { +setMethod("getStandardized", "TwasWeightsRow", function(x) { isTRUE(x@standardized) }) #' @rdname getDataType #' @export -setMethod("getDataType", "TwasWeightsRow", function(x, ...) x@dataType) +setMethod("getDataType", "TwasWeightsRow", function(x) x@dataType) # @noRd -setMethod("rowVariants", "TwasWeightsRow", function(x, ...) x@variants) +setMethod("rowVariants", "TwasWeightsRow", function(x) x@variants) #' @rdname show-methods #' @export diff --git a/R/variantId.R b/R/variantId.R index af71ee717..a8f8e70ea 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -31,15 +31,22 @@ stripChrPrefix <- function(x) str_remove(x, "^chr") #' @return Character vector of normalized chromosome names. #' @noRd canonChrom <- function(x) { - x <- as.character(x) - x <- str_remove(x, regex("^chr", ignore_case = TRUE)) - x <- str_remove(x, regex("^ch", ignore_case = TRUE)) - x <- str_to_upper(x) + bare <- as.character(x) |> + str_remove(regex("^chr", ignore_case = TRUE)) |> + str_remove(regex("^ch", ignore_case = TRUE)) |> + str_to_upper() + canonChromLabel(bare) +} + +# Fold the numeric / abbreviated synonyms of the non-autosomes onto their +# canonical labels. NA passes through as NA. +# @noRd +canonChromLabel <- function(x) { ok <- !is.na(x) - x[ok & x == "23"] <- "X" - x[ok & x == "24"] <- "Y" - x[ok & x == "M"] <- "MT" - x + x |> + replace(ok & x == "23", "X") |> + replace(ok & x == "24", "Y") |> + replace(ok & x == "M", "MT") } #' Ensure a leading chr prefix on a chromosome identifier. @@ -139,14 +146,17 @@ isSnpAlleles <- function(a1, a2) { if (!any(repair)) { return(ids) } - ids[repair] <- formatVariantId( - p$chrom[repair], - p$pos[repair], - A2[repair], - A1[repair], - convention = attr(p, "convention") + replace( + ids, + repair, + formatVariantId( + p$chrom[repair], + p$pos[repair], + A2[repair], + A1[repair], + convention = attr(p, "convention") + ) ) - ids } # Backwards-compat alias @@ -227,8 +237,15 @@ detectVariantConvention <- function(ids) { #' stored as \code{attr(result, "convention")}. #' @examples #' parseVariantId(c("chr1:100:A:G", "chr2:200:T:C")) +#' @importFrom checkmate assert checkCharacter checkDataFrame #' @export parseVariantId <- function(ids) { + # `ids` is documented as a character vector OR a data.frame. + assert( + checkCharacter(ids), + checkDataFrame(ids), + .var.name = "ids" + ) if (is.data.frame(ids)) { return(.parseVariantIdDf(ids)) } @@ -244,8 +261,18 @@ parseVariantId <- function(ids) { A2 = m[, 4L], A1 = m[, 5L] ) - attr(data, "convention") <- convention - data + `attr<-`(data, "convention", convention) +} + +# `[[<-` rather than mutate(): callers hand this frame straight through from +# a user-supplied table, which may carry NA or "" column names -- and +# dplyr refuses to transform such a frame at all. +# @noRd +.withCanonicalCoords <- function(ids) { + # `value =` named: tibble's `[[<-` method carries an extra `j` formal, so a + # third POSITIONAL argument binds to `j` and the write silently misfires. + coerced <- `[[<-`(ids, "chrom", value = canonChrom(ids$chrom)) + `[[<-`(coerced, "pos", value = as.integer(ids$pos)) } # Parse a data.frame of already-split ids: resolve the 4 identity columns @@ -255,22 +282,26 @@ parseVariantId <- function(ids) { .parseVariantIdDf <- function(ids) { # minimal repair: preserve any empty/duplicate extra-column names (e.g. an # unnamed passthrough column) for .sanitizeNames() to canonicalize later. - ids <- as_tibble(ids, .name_repair = "minimal") - hasA2A1 <- all(is_in(c("chrom", "pos", "A2", "A1"), names(ids))) - hasA1A2 <- all(is_in(c("chrom", "pos", "A1", "A2"), names(ids))) - if (!hasA2A1 && !hasA1A2 && ncol(ids) >= 4) { - names(ids)[seq_len(4)] <- c("chrom", "pos", "A2", "A1") + tbl <- as_tibble(ids, .name_repair = "minimal") + hasA2A1 <- all(is_in(c("chrom", "pos", "A2", "A1"), names(tbl))) + hasA1A2 <- all(is_in(c("chrom", "pos", "A1", "A2"), names(tbl))) + # With neither allele naming present the frame is positional: its first + # four columns are the variant key. + named <- if (!hasA2A1 && !hasA1A2 && ncol(tbl) >= 4) { + `names<-`( + tbl, + replace(names(tbl), seq_len(4), c("chrom", "pos", "A2", "A1")) + ) + } else { + tbl } conv <- list( - hasChr = any(str_detect(as.character(ids$chrom), "^chr")), + hasChr = any(str_detect(as.character(named$chrom), "^chr")), alleleSep = ":", hasBuild = FALSE, example = NA_character_ ) - ids$chrom <- canonChrom(ids$chrom) - ids$pos <- as.integer(ids$pos) - attr(ids, "convention") <- conv - ids + `attr<-`(.withCanonicalCoords(named), "convention", conv) } #' Format variant ID strings from component columns @@ -355,33 +386,38 @@ formatVariantId <- function( #' rsIDs) are returned unchanged. #' @examples #' normalizeVariantId(c("1:100:A:G", "2:200:T:C")) +#' @importFrom checkmate assertCharacter assertFlag assertList #' @export normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { + assertCharacter(ids) + assertFlag(chrPrefix) + assertList(convention, null.ok = TRUE) parsed <- parseVariantId(ids) out <- as.character(ids) # Only re-format ids that parsed into a chrom + pos; leave unparseable ids # (e.g. rsIDs) unchanged rather than emitting "chrNA:..." garbage. ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) - if (any(ok)) { - out[ok] <- if (!is.null(convention)) { - formatVariantId( - parsed$chrom[ok], - parsed$pos[ok], - parsed$A2[ok], - parsed$A1[ok], - convention = convention - ) - } else { - formatVariantId( - parsed$chrom[ok], - parsed$pos[ok], - parsed$A2[ok], - parsed$A1[ok], - chrPrefix = chrPrefix - ) - } + if (!any(ok)) { + return(out) } - out + reformatted <- if (!is.null(convention)) { + formatVariantId( + parsed$chrom[ok], + parsed$pos[ok], + parsed$A2[ok], + parsed$A1[ok], + convention = convention + ) + } else { + formatVariantId( + parsed$chrom[ok], + parsed$pos[ok], + parsed$A2[ok], + parsed$A1[ok], + chrPrefix = chrPrefix + ) + } + replace(out, ok, reformatted) } # Complement a DNA allele string (A<->T, C<->G) for strand flipping. @@ -392,16 +428,10 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { # `unnamed_`, duplicates de-duplicated with make.unique). # @noRd .sanitizeNames <- function(df) { - nm <- colnames(df) - if (is.null(nm)) { - nm <- rep("unnamed", ncol(df)) - } + nm <- colnames(df) %||% rep("unnamed", ncol(df)) emptyIdx <- is.na(nm) | nm == "" - if (any(emptyIdx)) { - nm[emptyIdx] <- str_c("unnamed_", seq_len(sum(emptyIdx))) - } - colnames(df) <- make.unique(nm, sep = "_") - df + named <- replace(nm, emptyIdx, str_c("unnamed_", seq_len(sum(emptyIdx)))) + `colnames<-`(df, make.unique(named, sep = "_")) } #' Harmonize variant alleles against a reference @@ -468,21 +498,20 @@ harmonizeAlleles <- function( removeIndels = FALSE, removeStrandAmbiguous = TRUE, removeDups = FALSE, - colToComplement = character(), - ... + colToComplement = character() ) { coerced <- .harmonizeCoerceInputs(targetData, refVariants) - targetData <- coerced$targetData - refVariants <- coerced$refVariants + target <- coerced$targetData + panel <- coerced$refVariants # The index rides along on the join copy only: the restore path below - # re-reads `targetData`, and a sentinel column there would bind_rows its + # re-reads `target`, and a sentinel column there would bind_rows its # way into the returned frame. - matchResult <- .harmonizeJoin(.haIndexTargets(targetData), refVariants) - if (nrow(matchResult) == 0) { - return(.harmonizeEmptyResult(matchResult)) + joined <- .harmonizeJoin(.haIndexTargets(target), panel) + if (nrow(joined) == 0) { + return(.harmonizeEmptyResult(joined)) } matchResult <- .harmonizeDecideMatches( - matchResult, + joined, colToFlip, colToComplement, flipStrand, @@ -490,20 +519,18 @@ harmonizeAlleles <- function( removeStrandAmbiguous ) qcCounts <- .harmonizeQcCounts(matchResult) - qcSummary <- matchResult - result <- .harmonizeCleanResult(matchResult) - if (removeDups) { - result <- .harmonizeRemoveDups(result) - } - if (!removeUnmatched) { - restored <- .harmonizeRestoreUnmatched(result, matchResult, targetData) - result <- restored$result - qcSummary <- restored$qcSummary + cleaned <- .harmonizeCleanResult(matchResult) + deduped <- if (removeDups) .harmonizeRemoveDups(cleaned) else cleaned + # Putting the unmatched rows back also re-derives the QC summary over + # them, so the two travel together. + final <- if (removeUnmatched) { + list(result = deduped, qcSummary = matchResult) + } else { + .harmonizeRestoreUnmatched(deduped, matchResult, target) } - .harmonizeFinalChecks(result, refVariants, matchMinProp) - out <- list(harmonizedData = result, qcSummary = qcSummary) - attr(out, "qcCounts") <- qcCounts - out + .harmonizeFinalChecks(final$result, panel, matchMinProp) + out <- list(harmonizedData = final$result, qcSummary = final$qcSummary) + `attr<-`(out, "qcCounts", qcCounts) } # Turn the raw (chrom, pos) join into a decided match table: classify each @@ -520,15 +547,12 @@ harmonizeAlleles <- function( removeIndels, removeStrandAmbiguous ) { - matchResult <- .harmonizeFlags(matchResult) - matchResult <- .harmonizeResolveAmbiguity( - matchResult, - removeStrandAmbiguous - ) - matchResult <- .harmonizeKeepRule(matchResult, removeIndels) - matchResult <- .harmonizeResolveTargets(matchResult) + decided <- .harmonizeFlags(matchResult) |> + .harmonizeResolveAmbiguity(removeStrandAmbiguous) |> + .harmonizeKeepRule(removeIndels) |> + .harmonizeResolveTargets() .harmonizeApplyFlips( - matchResult, + decided, colToFlip, colToComplement, flipStrand @@ -544,8 +568,7 @@ harmonizeAlleles <- function( # a frame carrying an NA or empty column name. # @noRd .haIndexTargets <- function(targetData) { - targetData[[.haTargetIdx]] <- seq_len(nrow(targetData)) - targetData + `[[<-`(targetData, .haTargetIdx, value = seq_len(nrow(targetData))) } # QC / flag columns stripped from the harmonized result before it is returned. @@ -567,7 +590,7 @@ harmonizeAlleles <- function( # QC'd alleles below; leaving it in collides on the final rename). # @noRd .harmonizeCoerceInputs <- function(targetData, refVariants) { - if ( + parsedTarget <- if ( is.data.frame(targetData) && ncol(targetData) > 4 && all(is_in(c("chrom", "pos", "A2", "A1"), names(targetData))) @@ -575,23 +598,30 @@ harmonizeAlleles <- function( variantCols <- c("chrom", "pos", "A2", "A1") variantDf <- targetData |> select(all_of(variantCols)) otherCols <- targetData |> select(-all_of(variantCols)) - targetData <- bind_cols( + bind_cols( parseVariantId(variantDf), otherCols, .name_repair = "minimal" ) } else { - targetData <- parseVariantId(targetData) + parseVariantId(targetData) } - refVariants <- parseVariantId(refVariants) + parsedRef <- parseVariantId(refVariants) dropCols <- c("chromosome", "position", "ref", "alt", "variant_id") - if (any(is_in(dropCols, colnames(targetData)))) { - targetData <- select(targetData, -any_of(dropCols)) + # select() rejects a frame with an empty column name, which a passthrough + # column legitimately has, so only touch a frame that has something to + # drop. + trimmedTarget <- if (any(is_in(dropCols, colnames(parsedTarget)))) { + select(parsedTarget, -any_of(dropCols)) + } else { + parsedTarget } - if (is_in("variant_id", colnames(refVariants))) { - refVariants <- select(refVariants, -any_of("variant_id")) + trimmedRef <- if (is_in("variant_id", colnames(parsedRef))) { + select(parsedRef, -any_of("variant_id")) + } else { + parsedRef } - list(targetData = targetData, refVariants = refVariants) + list(targetData = trimmedTarget, refVariants = trimmedRef) } # Inner-join target + reference on (chrom, pos). @@ -616,17 +646,20 @@ harmonizeAlleles <- function( ) warn(msg) emptyOut <- list(harmonizedData = matchResult, qcSummary = matchResult) - attr(emptyOut, "qcCounts") <- list( - considered = 0L, - signFlip = 0L, - strandFlip = 0L, - kept = 0L, - dropped = 0L, - droppedIndel = 0L, - droppedAmbiguous = 0L, - droppedOther = 0L + `attr<-`( + emptyOut, + "qcCounts", + list( + considered = 0L, + signFlip = 0L, + strandFlip = 0L, + kept = 0L, + dropped = 0L, + droppedIndel = 0L, + droppedAmbiguous = 0L, + droppedOther = 0L + ) ) - emptyOut } # Per-variant harmonization flags: original/QC'd ids, uppercased alleles, strand @@ -712,20 +745,22 @@ harmonizeAlleles <- function( # fall through as exact / sign-flip cases rather than being dropped). # @noRd .harmonizeResolveAmbiguity <- function(matchResult, removeStrandAmbiguous) { - if (!removeStrandAmbiguous) { - matchResult$strand_unambiguous <- TRUE + relaxed <- if (removeStrandAmbiguous) { + matchResult + } else { + mutate(matchResult, strand_unambiguous = TRUE) } - if (!any(matchResult$strand_flip & matchResult$strand_unambiguous)) { - matchResult$strand_unambiguous <- TRUE + if (any(relaxed$strand_flip & relaxed$strand_unambiguous)) { + return(relaxed) } - matchResult + mutate(relaxed, strand_unambiguous = TRUE) } # Compute the keep flag (strand-flip vs non-strand-flip rules); drop indels when # requested. # @noRd .harmonizeKeepRule <- function(matchResult, removeIndels) { - matchResult <- matchResult |> + ruled <- matchResult |> mutate( keep = if_else( .data$strand_flip, @@ -737,11 +772,10 @@ harmonizeAlleles <- function( .data$ID_match ) ) - if (removeIndels) { - matchResult <- matchResult |> - mutate(keep = if_else(.data$INDEL, FALSE, .data$keep)) + if (!removeIndels) { + return(ruled) } - matchResult + mutate(ruled, keep = if_else(.data$INDEL, FALSE, .data$keep)) } # Reduce the join to at most one reference row per TARGET variant. @@ -782,8 +816,7 @@ harmonizeAlleles <- function( ] # Named apart from the column it replaces: `keep = keep` inside mutate() # reads the column, not this vector, and silently changes nothing. - resolvedKeep <- rep(FALSE, nrow(matchResult)) - resolvedKeep[resolved] <- TRUE + resolvedKeep <- replace(rep(FALSE, nrow(matchResult)), resolved, TRUE) mutate(matchResult, keep = resolvedKeep) } @@ -821,26 +854,30 @@ harmonizeAlleles <- function( flipStrand ) { signFlip <- matchResult$sign_flip - if (!is.null(colToFlip)) { + negated <- if (is.null(colToFlip)) { + matchResult + } else { .harmonizeCheckCols(colToFlip, matchResult) - matchResult <- matchResult |> + matchResult |> mutate(across( all_of(colToFlip), partial(.negateWhere, flip = signFlip) )) } - if (length(colToComplement) > 0L) { - .harmonizeCheckCols(colToComplement, matchResult) - matchResult <- matchResult |> + complemented <- if (length(colToComplement) == 0L) { + negated + } else { + .harmonizeCheckCols(colToComplement, negated) + negated |> mutate(across( all_of(colToComplement), partial(.complementWhere, flip = signFlip) )) } - if (flipStrand) { - matchResult <- .harmonizeFlipStrandCols(matchResult) + if (!flipStrand) { + return(complemented) } - matchResult + .harmonizeFlipStrandCols(complemented) } # Assert the named columns exist in matchResult. @@ -886,17 +923,20 @@ harmonizeAlleles <- function( 0L } ) - qcCounts$droppedAmbiguous <- sum( + droppedAmbiguous <- sum( !matchResult$keep & matchResult$strand_flip & !matchResult$strand_unambiguous & if (hasIndel) !matchResult$INDEL else TRUE, na.rm = TRUE ) - qcCounts$droppedOther <- qcCounts$dropped - - qcCounts$droppedIndel - - qcCounts$droppedAmbiguous - qcCounts + list_assign( + qcCounts, + droppedAmbiguous = droppedAmbiguous, + droppedOther = qcCounts$dropped - + qcCounts$droppedIndel - + droppedAmbiguous + ) } # Kept rows with QC/flag + target-allele columns stripped and ref alleles / @@ -966,14 +1006,16 @@ harmonizeAlleles <- function( return(list(result = result, qcSummary = qcSummary)) } unmatchData <- targetData |> filter(!is_in(.data$variant_id, matchVariant)) - result <- bind_rows( + withUnmatched <- bind_rows( result, unmatchData |> mutate(variants_id_original = .data$variant_id) ) - result <- result |> + # Restore the caller's input order, which bind_rows put the unmatched + # rows behind. + restored <- withUnmatched |> slice(match(targetData$variant_id, .data$variants_id_original)) |> select(-any_of("variants_id_original")) - list(result = result, qcSummary = qcSummary) + list(result = restored, qcSummary = qcSummary) } # Final guards: enough variants matched, and no duplicate ids remain. @@ -1108,12 +1150,11 @@ matchVariants <- function( # Inject sentinel index/sign columns so the matched pairs and the swap sign # can be read straight back out of harmonizeAlleles without re-deriving # them. - dfA$.mvTidx <- seq_len(nrow(dfA)) - dfA$.mvSign <- 1 - dfB$.mvRidx <- seq_len(nrow(dfB)) + tagA <- mutate(dfA, .mvTidx = seq_len(nrow(dfA)), .mvSign = 1) + tagB <- mutate(dfB, .mvRidx = seq_len(nrow(dfB))) res <- suppressWarnings(harmonizeAlleles( - targetData = dfA, - refVariants = dfB, + targetData = tagA, + refVariants = tagB, colToFlip = ".mvSign", matchMinProp = 0, removeDups = TRUE, @@ -1179,11 +1220,18 @@ parseRegion <- function(region) { #' \code{colnames}: a normalized character chromosome plus integer start/end. #' @examples #' regionToDf(c("1_100_200", "2_300_400")) +#' @importFrom checkmate assertCharacter #' @export regionToDf <- function(ldRegionId, colnames = c("chrom", "start", "end")) { + # @param says "A string", but the function is vectorised and callers pass + # a character vector -- assert what it actually accepts, not the prose. + assertCharacter(ldRegionId, any.missing = FALSE) + assertCharacter(colnames, len = 3L, any.missing = FALSE) parts <- str_split(ldRegionId, "[_:-]", simplify = TRUE) - regionOfInterest <- as_tibble(parts, .name_repair = "minimal") - colnames(regionOfInterest) <- colnames + regionOfInterest <- `colnames<-`( + as_tibble(parts, .name_repair = "minimal"), + colnames + ) regionOfInterest |> mutate( across(all_of(colnames[1]), canonChrom), @@ -1222,9 +1270,11 @@ asGranges <- function(regions) { abort(msg) } # GRanges expects character seqnames; prefix with "chr" if numeric - seqnames <- as.character(df$chrom) - if (!any(str_detect(seqnames, "^chr"))) { - seqnames <- str_c("chr", seqnames) + rawChrom <- as.character(df$chrom) + seqnames <- if (any(str_detect(rawChrom, "^chr"))) { + rawChrom + } else { + str_c("chr", rawChrom) } GenomicRanges::GRanges( seqnames = seqnames, @@ -1306,10 +1356,12 @@ classifyVariantType <- function(ids) { .variantIdsToGRanges <- function(ids, what = "variant ids") { ids <- as.character(ids) if (length(ids) == 0L) { - gr <- GenomicRanges::GRanges() - mcols(gr) <- S4Vectors::DataFrame( - A1 = character(0), - A2 = character(0) + gr <- S4Vectors::`mcols<-`( + GenomicRanges::GRanges(), + value = S4Vectors::DataFrame( + A1 = character(0), + A2 = character(0) + ) ) return(gr) } @@ -1326,13 +1378,15 @@ classifyVariantType <- function(ids) { ) abort(msg) } - gr <- GenomicRanges::GRanges( - withChrPrefix(parsed$chrom), - IRanges::IRanges(start = parsed$pos, width = 1L) - ) - mcols(gr) <- S4Vectors::DataFrame( - A1 = as.character(parsed$A1), - A2 = as.character(parsed$A2) + gr <- S4Vectors::`mcols<-`( + GenomicRanges::GRanges( + withChrPrefix(parsed$chrom), + IRanges::IRanges(start = parsed$pos, width = 1L) + ), + value = S4Vectors::DataFrame( + A1 = as.character(parsed$A1), + A2 = as.character(parsed$A2) + ) ) gr } diff --git a/R/vcfWriter.R b/R/vcfWriter.R index 31441f70d..0db61260b 100644 --- a/R/vcfWriter.R +++ b/R/vcfWriter.R @@ -14,7 +14,7 @@ NULL setMethod( "writeSumStatsVcf", signature("GwasSumStats"), - function(x, outputPath, sampleName = NULL, study = NULL, ...) { + function(x, outputPath, sampleName = NULL, study = NULL) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort( "Package 'VariantAnnotation' is required for writeSumStatsVcf" @@ -57,17 +57,13 @@ setMethod( # Per-sample geno matrices (ES / SS / AF) for the fields present in the mcols. # @noRd .vcfSumstatsGeno <- function(mc, nSnps) { - geno <- list() - if (is_in("Z", colnames(mc))) { - geno[["ES"]] <- matrix(mc$Z, nSnps) - } - if (is_in("N", colnames(mc))) { - geno[["SS"]] <- matrix(as.integer(mc$N), nSnps) - } - if (is_in("MAF", colnames(mc))) { - geno[["AF"]] <- matrix(mc$MAF, nSnps) - } - geno + compact(list( + ES = if (is_in("Z", colnames(mc))) matrix(mc$Z, nSnps), + SS = if (is_in("N", colnames(mc))) { + matrix(as.integer(mc$N), nSnps) + }, + AF = if (is_in("MAF", colnames(mc))) matrix(mc$MAF, nSnps) + )) } # The fixed FORMAT header for the sumstats geno fields (ES / SS / AF). @@ -99,8 +95,7 @@ setMethod( trait = NULL, method = NULL, splitByContext = FALSE, - splitByTrait = FALSE, - ... + splitByTrait = FALSE ) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort( @@ -120,22 +115,45 @@ setMethod( splitByContext = splitByContext, splitByTrait = splitByTrait ) - out <- character(length(rowSpecs)) - for (i in seq_along(rowSpecs)) { - spec <- rowSpecs[[i]] - out[[i]] <- .writeFineMappingVcf( - x, - spec, - outputPath = outputPath, - sampleName = sampleName, - splitByContext = splitByContext, - splitByTrait = splitByTrait - ) - } - invisible(out) + invisible(map_chr( + rowSpecs, + .writeFineMappingVcfSpec, + x = x, + outputPath = outputPath, + sampleName = sampleName, + splitByContext = splitByContext, + splitByTrait = splitByTrait + )) } ) +# @noRd +.writeFineMappingVcfSpec <- function( + spec, + x, + outputPath, + sampleName, + splitByContext, + splitByTrait +) { + .writeFineMappingVcf( + x, + spec, + outputPath = outputPath, + sampleName = sampleName, + splitByContext = splitByContext, + splitByTrait = splitByTrait + ) +} + +# Narrow a row-index vector to those rows whose `axis` column equals the +# caller's requested value. `.tupleColumn()` not `[[`: on a RangedTupleList +# `[[` extracts an ELEMENT, while the identity axes live in mcols. +# @noRd +.vcfNarrowRows <- function(rows, axis, x, selectors) { + rows[as.character(.tupleColumn(x, axis))[rows] == selectors[[axis]]] +} + # Resolve which (study, context, trait, method) rows to write. Without # the split flags this returns a single spec; with `splitByContext` or # `splitByTrait` the collection's rows are walked and one spec is emitted @@ -153,19 +171,19 @@ setMethod( cols <- .tupleColumnNames(x) hasContextSlot <- is_in("context", cols) hasTraitSlot <- is_in("trait", cols) - rows <- seq_len(nrow(x)) - if (!is.null(study)) { - rows <- rows[as.character(x$study)[rows] == study] - } - if (hasContextSlot && !is.null(context)) { - rows <- rows[as.character(x$context)[rows] == context] - } - if (hasTraitSlot && !is.null(trait)) { - rows <- rows[as.character(x$trait)[rows] == trait] - } - if (!is.null(method)) { - rows <- rows[as.character(x$method)[rows] == method] - } + selectors <- compact(list( + study = study, + context = if (hasContextSlot) context, + trait = if (hasTraitSlot) trait, + method = method + )) + rows <- reduce( + names(selectors), + .vcfNarrowRows, + x = x, + selectors = selectors, + .init = seq_len(nrow(x)) + ) if (length(rows) == 0L) { abort("writeSumStatsVcf: no rows match the supplied selectors.") } @@ -223,14 +241,15 @@ setMethod( # empty (all-NA) ones are dropped downstream. # @noRd .vcfCoreSpecs <- function(base, m, nSnps) { - es <- .vcfCol(base, "conditional_effect", nSnps) - if (all(is.na(es))) { - es <- .vcfCol(m, "beta", nSnps) - } - af <- .vcfCol(base, "af", nSnps) - if (all(is.na(af))) { - af <- .vcfCol(m, "af", nSnps) + # The conditional effect when the fit reported one, else the marginal. + conditional <- .vcfCol(base, "conditional_effect", nSnps) + es <- if (all(is.na(conditional))) { + .vcfCol(m, "beta", nSnps) + } else { + conditional } + baseAf <- .vcfCol(base, "af", nSnps) + af <- if (all(is.na(baseAf))) .vcfCol(m, "af", nSnps) else baseAf p <- .vcfCol(m, "p", nSnps) lp <- if_else(is.na(p) | p <= 0, NA_real_, -log10(p)) list( @@ -324,13 +343,13 @@ setMethod( # marginal ES=beta / SE / LP / AF on top. Returns list(base, m, hasPost). # @noRd .vcfResolveBody <- function(entry, sn) { - post <- tryCatch( + post <- try_fetch( as_tibble(getTopLoci(entry, signalCutoff = 0)), - error = function(e) NULL + error = function(cnd) NULL ) - marg <- tryCatch( + marg <- try_fetch( as_tibble(getMarginalEffects(entry)), - error = function(e) NULL + error = function(cnd) NULL ) hasPost <- !is.null(post) && nrow(post) > 0L hasMarg <- !is.null(marg) && nrow(marg) > 0L @@ -449,23 +468,24 @@ setMethod( str_length(base) + 1L, str_length(outputPath) ) - tags <- character(0) - if ( - isTRUE(splitByContext) && - !is.null(spec$context) && - !is.na(spec$context) && - str_length(spec$context) > 0L - ) { - tags <- c(tags, spec$context) - } - if ( - isTRUE(splitByTrait) && - !is.null(spec$trait) && - !is.na(spec$trait) && - str_length(spec$trait) > 0L - ) { - tags <- c(tags, spec$trait) - } + tags <- c( + if ( + isTRUE(splitByContext) && + !is.null(spec$context) && + !is.na(spec$context) && + str_length(spec$context) > 0L + ) { + spec$context + }, + if ( + isTRUE(splitByTrait) && + !is.null(spec$trait) && + !is.na(spec$trait) && + str_length(spec$trait) > 0L + ) { + spec$trait + } + ) if (length(tags) == 0L) { return(outputPath) } @@ -518,12 +538,14 @@ setMethod( ), sample = sampleName ) - VariantAnnotation::geno(hdr) <- genoHeader[ - is_in(rownames(genoHeader), names(geno)), - , - drop = FALSE - ] - hdr + VariantAnnotation::`geno<-`( + hdr, + value = genoHeader[ + is_in(rownames(genoHeader), names(geno)), + , + drop = FALSE + ] + ) } # Assemble + finalize the VCF object (ref / alt / FILTER, sorted). @@ -535,10 +557,19 @@ setMethod( exptData = list(header = hdr), geno = SimpleList(geno) ) - VariantAnnotation::ref(vcf) <- DNAStringSet(ref) - VariantAnnotation::alt(vcf) <- DNAStringSetList(as.list(alt)) - VariantAnnotation::fixed(vcf)$FILTER <- "PASS" - sort(vcf) + alleled <- VariantAnnotation::`alt<-`( + VariantAnnotation::`ref<-`(vcf, value = DNAStringSet(ref)), + value = DNAStringSetList(as.list(alt)) + ) + filtered <- VariantAnnotation::`fixed<-`( + alleled, + value = `[[<-`( + VariantAnnotation::fixed(alleled), + "FILTER", + value = "PASS" + ) + ) + sort(filtered) } # Write the VCF in the format implied by the output extension. writeVcf appends @@ -558,6 +589,7 @@ setMethod( # BCF path: write a temporary bgzipped VCF, then convert to BCF via asBcf. # @noRd +#' @importFrom rlang try_fetch .vcfWriteBcf <- function(vcf, outputPath, chrom) { tmpVcfStem <- tempfile(fileext = ".vcf") tmpVcfBgz <- str_c(tmpVcfStem, ".bgz") @@ -570,20 +602,20 @@ setMethod( # Rsamtools disabled asBcf() (>= 2.26 raises "temporarily disabled"), so # the bare upstream error is translated into something actionable rather # than surfacing as an opaque failure from a documented output format. - tryCatch( + try_fetch( asBcf( tmpVcfBgz, dictionary = unique(chrom), destination = str_remove(outputPath, "\\.bcf$") ), - error = function(e) { + error = function(cnd) { msg <- glue( "writeSumStatsVcf: BCF output needs a working ", "Rsamtools::asBcf(), which the installed Rsamtools does not ", - "provide (\"{conditionMessage(e)}\"). Write a bgzipped VCF ", - "instead by giving the output path a .vcf.bgz extension." + "provide. Write a bgzipped VCF instead by giving the output ", + "path a .vcf.bgz extension." ) - abort(msg) + abort(msg, parent = cnd) } ) } @@ -610,11 +642,12 @@ setMethod( # @noRd .vcfCsColSpecs <- function(cc, base) { cov <- str_remove(cc, "^cs_") - idx <- suppressWarnings(as.integer(str_remove( + raw <- suppressWarnings(as.integer(str_remove( as.character(base[[cc]]), ".*_" ))) - idx[is.na(idx)] <- 0L + # 0 = the variant is in no credible set at this coverage. + idx <- replace(raw, is.na(raw), 0L) csSpec <- .vcfSpec( str_c("CS", cov), idx, diff --git a/_pkgdown.yml b/_pkgdown.yml index 653509b19..10805b0e1 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -169,6 +169,86 @@ reference: - TwasWeights - twasWeightsRow + - title: "Engine options and method parameters" + desc: > + Two disjoint families of argument record. An `*Options()` bundle + carries arguments bound for an external engine and is validated + against that engine's own formals, so an unknown name is refused at + construction. A `*Param()` record is pecotmr-internal and typed, + built on the `MethodParam` virtual base, and reports only the + fields that have actually been set. + contents: + - MethodOptions + - MethodParam + + - subtitle: "Engine options" + contents: + - AspuOptions + - ColocOptions + - ColocboostOptions + - CorShrinkOptions + - CovCanonicalOptions + - CovEdOptions + - CovFlashOptions + - CovMcdOptions + - CovPcaOptions + - CovUdrOptions + - CtwasOptions + - fineMappingMethodOptions + - GbjOptions + - GbjOmniOptions + - KrigingOptions + - LdPruningOptions + - MashCorEmOptions + - MashCorSimpleOptions + - MashDataOptions + - MashOptions + - MashPosteriorOptions + - MrmashCanonicalCovsOptions + - MrmashExpandCovsOptions + - PlinkQcOptions + - PoolrOptions + - QvalueOptions + - RmaOptions + - SusieRssControlOptions + - twasEngineOptions + - UdFitOptions + - UdInitOptions + + - subtitle: "Method parameters" + contents: + - BoundaryMergeParam + - ColocLbfFilterParam + - ColocPriorParam + - CredibleSetParam + - CrossValidationParam + - CtwasPriorParam + - DentistParam + - EnsembleParam + - FineMappingMethodsParam + - GenotypeFilterParam + - GwasFineMappingParam + - MashComponentParam + - MashPriorParam + - MethodsSelectionParam-class + - MrmashPriorParam + - MrParam + - PanelFilterParam + - PvalMethodsParam + - QtlEnrichmentParam + - RaissParam + - RelatednessColumnsParam + - RelatednessPruningParam + - ResidualizationParam + - SignalScreenParam + - SlalomParam + - SumstatsCleaningParam + - SumstatsFilterParam + - SusieRssParam + - TwasWeightsMethodsParam + - VariantPruningParam + - WeightSelectionParam + - title: "Manifest loaders" desc: > Build the individual-level and summary-statistic containers from a @@ -332,7 +412,7 @@ reference: - subtitle: "CtwasResult / CtwasResultEntry" contents: - getContexts - - getCtwasParam + - getCtwasGroupPriors - getFinemap - getMethodNames - getStudy @@ -436,14 +516,15 @@ reference: - title: "cTWAS" desc: > The four chainable steps that `ctwasPipeline` is built from: - `assembleCtwasInputs` → `estCtwasParam` → `screenCtwasRegions` - → `finemapCtwasRegions`. Use the steps directly when you want - to override the estimated priors (e.g. fall back to the prefit - EM values after an accurate-EM divergence), inspect the assembled - region data, or run only part of the pipeline. + `assembleCtwasInputs` → `estCtwasGroupPriors` → + `screenCtwasRegions` → `finemapCtwasRegions`. Use the steps + directly when you want to override the estimated priors (e.g. + fall back to the prefit EM values after an accurate-EM + divergence), inspect the assembled region data, or run only + part of the pipeline. contents: - assembleCtwasInputs - - estCtwasParam + - estCtwasGroupPriors - screenCtwasRegions - finemapCtwasRegions - mergeCtwasBoundaryRegions @@ -512,6 +593,7 @@ reference: results is documented under \code{FineMappingResultBase} in the Class methods section above. contents: + - serWeights - susieWeights - susieRssWeights - susieInfWeights @@ -589,7 +671,6 @@ reference: - buildMrmashPriorMatrices - computeCoefficientsGlasso - computeCovDiag - - computeCovFlash - subtitle: "Ensembling / cross-validation / prediction" contents: @@ -663,6 +744,7 @@ reference: - metaSldscRandom - sldscSubsetMeta - qtlEnrichment + - enlocClusterProbabilities - title: "Bundled example datasets" desc: > diff --git a/data/ctwasEstExample.rda b/data/ctwasEstExample.rda index 656d1143d..58021fa7d 100644 Binary files a/data/ctwasEstExample.rda and b/data/ctwasEstExample.rda differ diff --git a/data/ctwasFinemapExample.rda b/data/ctwasFinemapExample.rda index 252043c0d..24c5200c6 100644 Binary files a/data/ctwasFinemapExample.rda and b/data/ctwasFinemapExample.rda differ diff --git a/data/ctwasInputsExample.rda b/data/ctwasInputsExample.rda index 316c8d79b..6369485d4 100644 Binary files a/data/ctwasInputsExample.rda and b/data/ctwasInputsExample.rda differ diff --git a/inst/prototype/ensemble_twas_weights.ipynb b/inst/prototype/ensemble_twas_weights.ipynb index b9c223c29..eafff31a1 100644 --- a/inst/prototype/ensemble_twas_weights.ipynb +++ b/inst/prototype/ensemble_twas_weights.ipynb @@ -494,6 +494,7 @@ "\n", " library(pecotmr)\n", " library(simxQTL)\n", + " library(purrr)\n", " set.seed(${_replicates['seed']})\n", " cat(\"Replicate: ${_replicates['rep_id']}\\n\")\n", " cat(\"Seed: ${_replicates['seed']}\\n\")\n", @@ -656,10 +657,15 @@ " rsq_y = rsq_y)\n", " }\n", "\n", - " method_metrics <- sapply(names(res$twas_weights), function(wname) {\n", - " compute_metrics(res$twas_weights[[wname]])\n", - " })\n", - " colnames(method_metrics) <- gsub(\"_weights$\", \"\", colnames(method_metrics))\n", + " # cbind over a NAMED list carries the method names as colnames, so the\n", + " # suffix is stripped once here instead of in a second colnames() pass.\n", + " method_metrics <- exec(\n", + " cbind,\n", + " !!!set_names(\n", + " map(res$twas_weights, compute_metrics),\n", + " gsub(\"_weights$\", \"\", names(res$twas_weights))\n", + " )\n", + " )\n", "\n", " ensemble_metrics <- c(mse_w = NA, mse_pred_truth = NA, mse_y = NA, rsq_y = NA)\n", " if (!is.null(ens) && !is.null(ens$ensemble_twas_weights)) {\n", @@ -735,6 +741,7 @@ " library(ggplot2)\n", " library(tidyr)\n", " library(dplyr)\n", + " library(purrr)\n", "\n", " results_dir <- \"${results_dir}\"\n", "\n", @@ -743,17 +750,17 @@ " recursive = TRUE, full.names = TRUE)\n", " cat(sprintf(\"Found %d RDS files\\n\", length(rds_files)))\n", "\n", - " all_data <- lapply(rds_files, function(f) {\n", + " all_data <- map(rds_files, function(f) {\n", " tryCatch(readRDS(f), error = function(e) NULL)\n", " })\n", - " all_data <- all_data[!sapply(all_data, is.null)]\n", - " all_data <- all_data[!sapply(all_data, function(x) isTRUE(x$truth$error))]\n", + " all_data <- compact(all_data)\n", + " all_data <- discard(all_data, function(x) isTRUE(x$truth$error))\n", " cat(sprintf(\"%d successful replicates\\n\", length(all_data)))\n", "\n", " if (length(all_data) == 0) stop(\"No valid results found\")\n", "\n", " # ── 2. Extract metrics ───────────────────────────────────\n", - " metrics_list <- lapply(seq_along(all_data), function(i) {\n", + " metrics_list <- map(seq_along(all_data), function(i) {\n", " x <- all_data[[i]]\n", " coefs <- if (!is.null(x$ensemble)) x$ensemble$method_coef else NULL\n", " list(\n", @@ -766,7 +773,7 @@ "\n", " # ── 3. Tidy data frames ──────────────────────────────────\n", " build_metric_df <- function(metric_name) {\n", - " do.call(rbind, lapply(metrics_list, function(m) {\n", + " exec(rbind, !!!map(metrics_list, function(m) {\n", " if (is.null(m$method_metrics)) return(NULL)\n", " if (!(metric_name %in% rownames(m$method_metrics))) return(NULL)\n", " methods <- colnames(m$method_metrics)\n", @@ -787,16 +794,18 @@ " mse_y_df <- build_metric_df(\"mse_y\")\n", " rsq_y_df <- build_metric_df(\"rsq_y\")\n", "\n", - " coef_mat <- do.call(rbind, lapply(metrics_list, function(m) {\n", + " coef_mat <- exec(rbind, !!!map(metrics_list, function(m) {\n", " if (is.null(m$method_coef)) return(NULL)\n", " m$method_coef\n", " }))\n", " if (!is.null(coef_mat)) {\n", - " rownames(coef_mat) <- sapply(metrics_list[!sapply(metrics_list,\n", - " function(m) is.null(m$method_coef))], function(m) m$rep_id)\n", + " rownames(coef_mat) <- map_chr(\n", + " keep(metrics_list, function(m) !is.null(m$method_coef)),\n", + " function(m) m$rep_id\n", + " )\n", " }\n", "\n", - " scatter_df <- do.call(rbind, lapply(metrics_list, function(m) {\n", + " scatter_df <- exec(rbind, !!!map(metrics_list, function(m) {\n", " if (is.null(m$method_metrics)) return(NULL)\n", " if (!(\"rsq_y\" %in% rownames(m$method_metrics))) return(NULL)\n", " rsq_vals <- m$method_metrics[\"rsq_y\", ]\n", @@ -881,7 +890,7 @@ "\n", " # ── 5. Summary table ─────────────────────────────────────\n", " metric_rows <- c(\"mse_w\", \"mse_pred_truth\", \"mse_y\", \"rsq_y\")\n", - " summary_rows <- lapply(metrics_list, function(m) {\n", + " summary_rows <- map(metrics_list, function(m) {\n", " row <- data.frame(\n", " rep_id = m$rep_id, region = m$region, seed = m$seed,\n", " stringsAsFactors = FALSE\n", diff --git a/inst/prototype/generate_test_for_prs_cs.R b/inst/prototype/generate_test_for_prs_cs.R index 95d927ae7..d8d5f8327 100644 --- a/inst/prototype/generate_test_for_prs_cs.R +++ b/inst/prototype/generate_test_for_prs_cs.R @@ -22,10 +22,10 @@ sigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005) omega0 <- rep(1 / K, K) # Calculate summary statistics -b.hat <- sapply(1:p, function(j) { +b.hat <- purrr::map_dbl(1:p, function(j) { summary(lm(y ~ X[, j]))$coefficients[-1, 1] }) -s.hat <- sapply(1:p, function(j) { +s.hat <- purrr::map_dbl(1:p, function(j) { summary(lm(y ~ X[, j]))$coefficients[-1, 2] }) R.hat <- cor(X) diff --git a/inst/scripts/build_ctwas_examples.R b/inst/scripts/build_ctwas_examples.R index 1ddb0372f..c0c11040c 100644 --- a/inst/scripts/build_ctwas_examples.R +++ b/inst/scripts/build_ctwas_examples.R @@ -25,6 +25,7 @@ # ============================================================================= devtools::load_all(".", quiet = TRUE) +library(purrr) # ----------------------------------------------------------------------------- # 1. Inputs: the bundled chr22 LD panel, GWAS sumstats, and TWAS weights. @@ -71,15 +72,17 @@ ctwasEstExample <- estCtwasParam( thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - fallbackToPrefit = TRUE + fallbackToPrefit = TRUE, + methodArgs = ctwasArgs(min_group_size = 1, min_p_single_effect = 0) ) # The toy GWAS carries no genome-wide-significant signal, so the default # screen (min_nonSNP_PIP = 0.5) selects nothing and the example would be an # empty result. Keep every region so the finemap payload is populated. -screened <- screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) +screened <- screenCtwasRegions( + ctwasEstExample, + methodArgs = ctwasArgs(min_nonSNP_PIP = 0) +) ctwasFinemapExample <- finemapCtwasRegions(screened) # ----------------------------------------------------------------------------- @@ -99,7 +102,7 @@ repointLd <- function(payload) { return(payload) } stored <- as.character(payload$LD_map$LD_file) - portable <- vapply(stored, asResource, character(1), USE.NAMES = FALSE) + portable <- map_chr(stored, asResource) keyMap <- setNames(portable, stored) payload$LD_map$LD_file <- portable payload$LD_map$SNP_file <- portable @@ -127,12 +130,14 @@ invisible(estCtwasParam( thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - fallbackToPrefit = TRUE + fallbackToPrefit = TRUE, + methodArgs = ctwasArgs(min_group_size = 1, min_p_single_effect = 0) )) invisible(finemapCtwasRegions( - screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) + screenCtwasRegions( + ctwasEstExample, + methodArgs = ctwasArgs(min_nonSNP_PIP = 0) + ) )) invisible(asCtwasResult(ctwasFinemapExample)) invisible(mergeCtwasBoundaryRegions(ctwasFinemapExample)) diff --git a/inst/scripts/build_examples.R b/inst/scripts/build_examples.R index 73971cc4b..4d6864308 100644 --- a/inst/scripts/build_examples.R +++ b/inst/scripts/build_examples.R @@ -17,6 +17,7 @@ # ============================================================================= devtools::load_all(".") +library(purrr) set.seed(20260620L) @@ -249,7 +250,7 @@ multiCtxBetas <- list( } ) -multiCtxEntries <- lapply(multiCtxNames, function(ctx) { +multiCtxEntries <- map(multiCtxNames, function(ctx) { bj <- multiCtxBetas[[ctx]] yCtx <- as.numeric(X %*% bj + stats::rnorm(nSample, sd = 1)) zc <- numeric(nVar) diff --git a/inst/scripts/build_h2_examples.R b/inst/scripts/build_h2_examples.R index b5621baf0..2c88e01c5 100644 --- a/inst/scripts/build_h2_examples.R +++ b/inst/scripts/build_h2_examples.R @@ -18,6 +18,7 @@ # ============================================================================= devtools::load_all(".", quiet = TRUE) +library(purrr) mweDir <- Sys.getenv( "MWE_DIR", @@ -46,10 +47,10 @@ message("Loading ", length(regions), " chr22 LD blocks...") # One LdData per block: buildLd*() takes the list and gives one LD block per # element. Loading the whole span at once would instead return a single dense # matrix, i.e. one block, which no jackknife can work with. -ldList <- lapply(regions, function(r) loadLdMatrix(metaPath, region = r)) +ldList <- map(regions, function(r) loadLdMatrix(metaPath, region = r)) message( " ", - sum(vapply(ldList, length, integer(1))), + sum(map_int(ldList, length)), " variants across ", length(ldList), " blocks" diff --git a/inst/scripts/build_sldsc_upstream_z.R b/inst/scripts/build_sldsc_upstream_z.R index 222b02e41..0d31f45b5 100644 --- a/inst/scripts/build_sldsc_upstream_z.R +++ b/inst/scripts/build_sldsc_upstream_z.R @@ -20,6 +20,7 @@ # ============================================================================= suppressMessages(devtools::load_all(".", quiet = TRUE, export_all = FALSE)) +library(purrr) data(ldScoreExample) # EXACT copy of the in-test generator, so the captured z is the one the @@ -43,11 +44,15 @@ simZ <- function(ref, h2, n, seed) { # entry is a hard error there, not a silent re-simulation. cases <- c( list( - c(0.4, 1e4, 42), c(0.15, 4e3, 7), c(0.6, 2.5e4, 99), - c(0.3, 1e4, 5), c(0.6, 5e4, 9), c(0.4, 5e4, 3) + c(0.4, 1e4, 42), + c(0.15, 4e3, 7), + c(0.6, 2.5e4, 99), + c(0.3, 1e4, 5), + c(0.6, 5e4, 9), + c(0.4, 5e4, 3) ), # the HDL recovery test sweeps seeds 1:5 at (h2 = 0.4, n = 1e5) - lapply(1:5, function(s) c(0.4, 1e5, s)) + map(1:5, function(s) c(0.4, 1e5, s)) ) out <- list() for (cs in cases) { @@ -57,5 +62,8 @@ for (cs in cases) { saveRDS(out, "tests/testthat/test_data/sldscUpstreamZ.rds", compress = "xz") cat("keys:", paste(names(out), collapse = " | "), "\n") cat("length each:", unique(lengths(out)), "\n") -cat("file size:", - file.size("tests/testthat/test_data/sldscUpstreamZ.rds"), "bytes\n") +cat( + "file size:", + file.size("tests/testthat/test_data/sldscUpstreamZ.rds"), + "bytes\n" +) diff --git a/man/AspuOptions.Rd b/man/AspuOptions.Rd new file mode 100644 index 000000000..be440bd70 --- /dev/null +++ b/man/AspuOptions.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pvalCombineWrappers.R +\name{AspuOptions} +\alias{AspuOptions} +\title{Options for the aSPU Combination Test} +\usage{ +AspuOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{aSPU::aSPUs()}: \code{pow} (the SPU powers +the omnibus minimises over), \code{n.perm} (permutation count -- aSPU's +p-value resolution is bounded by it), \code{Ps} and \code{prune}. +\code{Zs} and \code{corSNP} are supplied by pecotmr and refused.} +} +\value{ +A \code{MethodOptions} record for + \code{\link{PvalMethodsParam}}. +} +\description{ +Build a checked record of extra arguments for + \code{aSPU::aSPUs()}, the engine behind \code{\link{combinePValues}} + method \code{"aspu"}. +} +\examples{ +AspuOptions(n.perm = 5000) +} +\seealso{ +\code{\link{combinePValues}} +} diff --git a/man/BoundaryMergeParam.Rd b/man/BoundaryMergeParam.Rd new file mode 100644 index 000000000..0344f36ae --- /dev/null +++ b/man/BoundaryMergeParam.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasPipeline.R +\docType{class} +\name{BoundaryMergeParam-class} +\alias{BoundaryMergeParam-class} +\alias{BoundaryMergeParam} +\title{Boundary-Region Merge Settings} +\usage{ +BoundaryMergeParam( + enabled = FALSE, + pipThreshold = 0.5, + filterCs = FALSE, + maxSnp = Inf +) +} +\arguments{ +\item{enabled}{Logical. Run the merge step. Default \code{FALSE}; the +other three fields are read only when this is \code{TRUE}.} + +\item{pipThreshold}{Numeric. PIP threshold for selecting which boundary +genes to merge. Default \code{0.5}.} + +\item{filterCs}{Logical. Require the boundary gene to be in a credible set +to be selected. Default \code{FALSE}.} + +\item{maxSnp}{Numeric. Per-merged-region SNP cap. Default \code{Inf}.} +} +\value{ +A \code{BoundaryMergeParam} object, a \code{\link{MethodParam}}. +} +\description{ +Whether a high-PIP gene whose cis window straddles an + LD-block boundary has its adjacent regions merged and re-fine-mapped + after each run (\code{\link{mergeCtwasBoundaryRegions}}). +} +\examples{ +BoundaryMergeParam(enabled = TRUE, pipThreshold = 0.8) +} diff --git a/man/ColocLbfFilterParam.Rd b/man/ColocLbfFilterParam.Rd new file mode 100644 index 000000000..af8840e52 --- /dev/null +++ b/man/ColocLbfFilterParam.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colocPipeline.R +\docType{class} +\name{ColocLbfFilterParam-class} +\alias{ColocLbfFilterParam-class} +\alias{ColocLbfFilterParam} +\title{Credible-Set Filtering For Colocalisation} +\usage{ +ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5, + priorTol = 1e-09 +) +} +\arguments{ +\item{filterLbfCs}{Logical. Restrict to credible-set variants. Default +\code{FALSE}.} + +\item{secondary}{Optional secondary coverage levels used when selecting +credible sets. \code{NULL} (default) uses the primary sets only.} + +\item{concentration}{Minimum share of the credible set's posterior mass a +variant must carry to be kept. Default \code{0.5}.} + +\item{priorTol}{Prior-variance cutoff for the default filter: effects with +\code{V <= priorTol} are dropped. Default \code{1e-9}. This is the +default filter's own parameter, which is why it lives here rather than +beside it --- \code{filterLbfCs} and \code{secondary} select a +different filter, and then it does not apply.} +} +\value{ +A \code{ColocLbfFilterParam} object, a \code{\link{MethodParam}}. +} +\description{ +Whether and how to restrict each fine-mapping result to its + credible sets before scoring, using the log Bayes factors. +} +\examples{ +ColocLbfFilterParam(filterLbfCs = TRUE) +} diff --git a/man/ColocOptions.Rd b/man/ColocOptions.Rd new file mode 100644 index 000000000..0b810bb02 --- /dev/null +++ b/man/ColocOptions.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colocPipeline.R +\name{ColocOptions} +\alias{ColocOptions} +\title{Arguments For coloc's Bayes-Factor Scorer} +\usage{ +ColocOptions(overlap.min = NULL, trim_by_posterior = NULL, ...) +} +\arguments{ +\item{overlap.min}{Minimum overlap between the two variant sets.} + +\item{trim_by_posterior}{Logical; trim by posterior before scoring.} + +\item{...}{Any other \code{coloc::coloc.bf_bf} argument.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to \code{coloc::coloc.bf_bf}. The prior + probabilities are \emph{not} settable here --- pecotmr derives them from + \code{\link{ColocPriorParam}}, which its enrichment adjustment also + reads --- and the two Bayes-factor matrices are supplied by the pipeline. +} +\examples{ +ColocOptions(trim_by_posterior = FALSE) +} diff --git a/man/ColocPriorParam.Rd b/man/ColocPriorParam.Rd new file mode 100644 index 000000000..3c7b8cd0f --- /dev/null +++ b/man/ColocPriorParam.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colocPipeline.R +\docType{class} +\name{ColocPriorParam-class} +\alias{ColocPriorParam-class} +\alias{ColocPriorParam} +\title{Prior Probabilities For Colocalisation} +\usage{ +ColocPriorParam(p1 = 1e-04, p2 = 1e-04, p12 = 5e-06) +} +\arguments{ +\item{p1}{Prior probability a variant is causal for the QTL trait. +Default \code{1e-4}.} + +\item{p2}{Prior probability a variant is causal for the GWAS trait. +Default \code{1e-4}.} + +\item{p12}{Prior probability a variant is causal for both. Default +\code{5e-6}.} +} +\value{ +A \code{ColocPriorParam} object, a \code{\link{MethodParam}}. +} +\description{ +The per-variant prior probabilities coloc scores with, all + three forwarded to \code{coloc::coloc.bf_bf}. + + These describe the baseline analysis only. When \code{enrichment} is + supplied to \code{\link{colocPipeline}} the priors are \emph{derived} + from the enrichment estimate instead, the way enloc derives them, and + supplying both is an error rather than a silent precedence rule. +} +\examples{ +ColocPriorParam(p12 = 1e-5) +} diff --git a/man/ColocboostOptions.Rd b/man/ColocboostOptions.Rd new file mode 100644 index 000000000..2ff4b5fe7 --- /dev/null +++ b/man/ColocboostOptions.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colocboostPipeline.R +\name{ColocboostOptions} +\alias{ColocboostOptions} +\title{colocboost Engine Settings} +\usage{ +ColocboostOptions(...) +} +\arguments{ +\item{...}{Named \code{colocboost::colocboost} arguments.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Additional arguments forwarded to + \code{colocboost::colocboost}. Names are checked against that + function's own formals, so a misspelled option is an error here rather + than a setting silently dropped inside the run. + + The data arguments \code{colocboostPipeline} assembles itself --- + \code{X}, \code{Y}, \code{sumstat}, \code{LD}, \code{X_ref}, + \code{focal_outcome_idx} --- are not settable here. +} +\examples{ +ColocboostOptions(M = 5) +} diff --git a/man/CorShrinkOptions.Rd b/man/CorShrinkOptions.Rd new file mode 100644 index 000000000..35be7a290 --- /dev/null +++ b/man/CorShrinkOptions.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{CorShrinkOptions} +\alias{CorShrinkOptions} +\title{Settings For The CorShrink Null-Correlation Estimator} +\usage{ +CorShrinkOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{CorShrinkData}, under its own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to \code{CorShrink::CorShrinkData}, the + \code{method = "corshrink"} estimator. \code{data} is refused: it is + the null z-matrix pecotmr assembles. + + \code{ash.control} and \code{image} default to what pecotmr has always + passed, so they are settings now rather than literals. +} +\examples{ +CorShrinkOptions(nboot = 100) +} diff --git a/man/CovCanonicalOptions.Rd b/man/CovCanonicalOptions.Rd new file mode 100644 index 000000000..c3dbff971 --- /dev/null +++ b/man/CovCanonicalOptions.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{CovCanonicalOptions} +\alias{CovCanonicalOptions} +\title{Arguments For mashr's Canonical Covariance Components} +\usage{ +CovCanonicalOptions(cov_methods = NULL, ...) +} +\arguments{ +\item{cov_methods}{Which canonical components to build. \code{NULL} +(default) leaves mashr's own selection in place.} + +\item{...}{Any other \code{mashr::cov_canonical} argument.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options for \code{mashr::cov_canonical}, which builds the + fixed structural hypotheses (identity, singletons, equal effects, simple + heterogeneity) from the condition count. These are hypotheses about + shape, so they go to the mash fit unrefined. +} +\examples{ +CovCanonicalOptions(cov_methods = c("identity", "equal_effects")) +} diff --git a/man/CovEdOptions.Rd b/man/CovEdOptions.Rd new file mode 100644 index 000000000..a2fe653f7 --- /dev/null +++ b/man/CovEdOptions.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{CovEdOptions} +\alias{CovEdOptions} +\title{Arguments For Extreme Deconvolution Refinement} +\usage{ +CovEdOptions(subset = NULL, algorithm = "bovy", ...) +} +\arguments{ +\item{subset}{Rows of the data to use. \code{NULL} (default) uses all.} + +\item{algorithm}{Deconvolution algorithm, \code{"bovy"} (default) or +\code{"teem"}.} + +\item{...}{Any other argument \code{mashr::cov_ed} forwards.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options for \code{mashr::cov_ed}, which refines the + data-driven components by Extreme Deconvolution. The components to refine + are not settable here -- they are whatever \code{components} produced. + + \code{mashr::cov_ed} takes \code{...}, so argument names \strong{cannot + be checked} against it; see \code{\link{MethodOptions}}. +} +\examples{ +CovEdOptions(algorithm = "teem") +} diff --git a/man/CovFlashOptions.Rd b/man/CovFlashOptions.Rd new file mode 100644 index 000000000..1da461fd4 --- /dev/null +++ b/man/CovFlashOptions.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{CovFlashOptions} +\alias{CovFlashOptions} +\title{Arguments For mashr's FLASH Covariance Components} +\usage{ +CovFlashOptions( + subset = NULL, + remove_singleton = FALSE, + tag = NULL, + output_model = NULL, + greedy_args = list(), + backfit_args = list(), + ... +) +} +\arguments{ +\item{subset}{Rows of the data to use. \code{NULL} (default) uses all.} + +\item{remove_singleton}{Drop singleton effect vectors. Default +\code{FALSE}.} + +\item{tag, output_model}{Passed through to \code{mashr::cov_flash}.} + +\item{greedy_args, backfit_args}{Option lists forwarded to flashier's greedy +and backfit stages; mashr nests these itself.} + +\item{...}{Any other \code{mashr::cov_flash} argument.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options for \code{mashr::cov_flash}, a data-driven generator. + \code{factors} is not settable here: pecotmr sets it to distinguish the + \code{"flash"} and \code{"flashNonneg"} components. +} +\examples{ +CovFlashOptions(remove_singleton = TRUE) +} diff --git a/man/CovMcdOptions.Rd b/man/CovMcdOptions.Rd new file mode 100644 index 000000000..173289143 --- /dev/null +++ b/man/CovMcdOptions.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/QtlDataset.R +\name{CovMcdOptions} +\alias{CovMcdOptions} +\title{Options for the Robust Outlier Covariance Estimator} +\usage{ +CovMcdOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{robustbase::covMcd()} -- in practice +\code{alpha} (the subset fraction the determinant is minimised over, +which sets the breakdown point), \code{nsamp}, \code{use.correction} +and \code{nmini} / \code{kmini}. \code{x} is the trait matrix pecotmr +assembles and is refused, as is \code{seed}: pecotmr owns RNG +reproducibility, and \code{covMcd()}'s \code{seed} restores the ambient +\code{.Random.seed} on exit, which would silently undo the caller's +stream.} +} +\value{ +A \code{MethodOptions} record for the \code{outlierArgs} argument. +} +\description{ +Build a checked record of extra arguments for + \code{robustbase::covMcd()}, the minimum-covariance-determinant + estimator behind \code{outlierAction = "drop"} on + \code{\link{getPhenotypes}} and + \code{\link{getResidualizedPhenotypes}}. +} +\examples{ +CovMcdOptions(alpha = 0.75) +} +\seealso{ +\code{\link{getPhenotypes}}, + \code{\link{getResidualizedPhenotypes}} +} diff --git a/man/CovPcaOptions.Rd b/man/CovPcaOptions.Rd new file mode 100644 index 000000000..fac5095d7 --- /dev/null +++ b/man/CovPcaOptions.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{CovPcaOptions} +\alias{CovPcaOptions} +\title{Arguments For mashr's PCA Covariance Components} +\usage{ +CovPcaOptions(subset = NULL, ...) +} +\arguments{ +\item{subset}{Rows of the data to use. \code{NULL} (default) uses all.} + +\item{...}{Any other \code{mashr::cov_pca} argument.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options for \code{mashr::cov_pca}, a data-driven generator. + The number of components is not settable here: it comes from + \code{mashPriorCovariances(nPcs = )}, which the caller also reports on. +} +\examples{ +CovPcaOptions(subset = 1:50) +} diff --git a/man/CovUdrOptions.Rd b/man/CovUdrOptions.Rd new file mode 100644 index 000000000..2bb26b84a --- /dev/null +++ b/man/CovUdrOptions.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{CovUdrOptions} +\alias{CovUdrOptions} +\title{Arguments For Unconstrained Deconvolution Refinement} +\usage{ +CovUdrOptions(init = UdInitOptions(), fit = UdFitOptions()) +} +\arguments{ +\item{init}{Arguments for \code{udr::ud_init()}, built with +\code{\link{UdInitOptions}}.} + +\item{fit}{Arguments for \code{udr::ud_fit()}'s control list, built with +\code{\link{UdFitOptions}}.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Refining the data-driven components with \code{udr}. + + The engine is two functions, so each one's arguments travel in their + own bundle and are checked against their own live source: + \code{init} against \code{udr::ud_init()}'s formals, \code{fit} + against \code{udr::ud_fit_control_default()}'s names. Splitting them + also retired two pecotmr spellings --- \code{unconstrainedUpdate} and + \code{nUnconstrained} --- that had to be translated back to + \code{unconstrained.update} and \code{n_unconstrained} on the way out. +} +\examples{ +CovUdrOptions( + fit = UdFitOptions(unconstrained.update = "ted", maxiter = 500) +) +} diff --git a/man/CredibleSetParam.Rd b/man/CredibleSetParam.Rd new file mode 100644 index 000000000..17890b59e --- /dev/null +++ b/man/CredibleSetParam.Rd @@ -0,0 +1,174 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/fineMappingPipeline.R +\docType{class} +\name{getCoverage} +\alias{getCoverage} +\alias{setCoverage} +\alias{getSecondaryCoverage} +\alias{setSecondaryCoverage} +\alias{getSignalCutoff} +\alias{setSignalCutoff} +\alias{getMinAbsCorr} +\alias{setMinAbsCorr} +\alias{getMedianAbsCorr} +\alias{setMedianAbsCorr} +\alias{getIncludeAllCs} +\alias{setIncludeAllCs} +\alias{getPerCsColumns} +\alias{setPerCsColumns} +\alias{getL} +\alias{getLgreedy} +\alias{getCoverage,CredibleSetParam-method} +\alias{setCoverage,CredibleSetParam-method} +\alias{getSecondaryCoverage,CredibleSetParam-method} +\alias{setSecondaryCoverage,CredibleSetParam-method} +\alias{getSignalCutoff,CredibleSetParam-method} +\alias{setSignalCutoff,CredibleSetParam-method} +\alias{getMinAbsCorr,CredibleSetParam-method} +\alias{setMinAbsCorr,CredibleSetParam-method} +\alias{getMedianAbsCorr,CredibleSetParam-method} +\alias{setMedianAbsCorr,CredibleSetParam-method} +\alias{getIncludeAllCs,CredibleSetParam-method} +\alias{setIncludeAllCs,CredibleSetParam-method} +\alias{getPerCsColumns,CredibleSetParam-method} +\alias{setPerCsColumns,CredibleSetParam-method} +\alias{getL,CredibleSetParam-method} +\alias{getLgreedy,CredibleSetParam-method} +\alias{CredibleSetParam-class} +\alias{CredibleSetParam} +\title{Credible-Set Construction And Reporting} +\usage{ +getCoverage(x, ...) + +setCoverage(x, value, ...) + +getSecondaryCoverage(x, ...) + +setSecondaryCoverage(x, value, ...) + +getSignalCutoff(x, ...) + +setSignalCutoff(x, value, ...) + +getMinAbsCorr(x, ...) + +setMinAbsCorr(x, value, ...) + +getMedianAbsCorr(x, ...) + +setMedianAbsCorr(x, value, ...) + +getIncludeAllCs(x, ...) + +setIncludeAllCs(x, value, ...) + +getPerCsColumns(x, ...) + +setPerCsColumns(x, value, ...) + +getL(x, ...) + +getLgreedy(x, ...) + +\S4method{getCoverage}{CredibleSetParam}(x) + +\S4method{setCoverage}{CredibleSetParam}(x, value) + +\S4method{getSecondaryCoverage}{CredibleSetParam}(x) + +\S4method{setSecondaryCoverage}{CredibleSetParam}(x, value) + +\S4method{getSignalCutoff}{CredibleSetParam}(x) + +\S4method{setSignalCutoff}{CredibleSetParam}(x, value) + +\S4method{getMinAbsCorr}{CredibleSetParam}(x) + +\S4method{setMinAbsCorr}{CredibleSetParam}(x, value) + +\S4method{getMedianAbsCorr}{CredibleSetParam}(x) + +\S4method{setMedianAbsCorr}{CredibleSetParam}(x, value) + +\S4method{getIncludeAllCs}{CredibleSetParam}(x) + +\S4method{setIncludeAllCs}{CredibleSetParam}(x, value) + +\S4method{getPerCsColumns}{CredibleSetParam}(x) + +\S4method{setPerCsColumns}{CredibleSetParam}(x, value) + +\S4method{getL}{CredibleSetParam}(x) + +\S4method{getLgreedy}{CredibleSetParam}(x) + +CredibleSetParam( + coverage = 0.95, + secondaryCoverage = c(0.7, 0.5), + signalCutoff = 0.025, + minAbsCorr = 0.8, + medianAbsCorr = NULL, + includeAllCs = FALSE, + perCsColumns = c("none", "alpha", "full"), + L = 10L, + Lgreedy = NULL +) +} +\arguments{ +\item{x}{A \code{CredibleSetParam}.} + +\item{...}{Unused, present for generic consistency.} + +\item{value}{The replacement value for that setting.} + +\item{coverage}{Primary credible-set coverage. Default \code{0.95}.} + +\item{secondaryCoverage}{Additional coverages to report credible sets at. +Default \code{c(0.7, 0.5)}.} + +\item{signalCutoff}{PIP cutoff for including a non-credible-set variant in +the top-loci table. Default \code{0.025}.} + +\item{minAbsCorr}{Minimum absolute within-set correlation for purity. +Default \code{0.8}.} + +\item{medianAbsCorr}{Median absolute within-set correlation threshold, or +\code{NULL} (default) to judge purity on \code{minAbsCorr} alone.} + +\item{includeAllCs}{Logical. Report every credible set rather than only the +top one. Default \code{FALSE}.} + +\item{perCsColumns}{Which per-credible-set variant-level columns are added +to the \code{topLoci} table. \code{"none"} (default) adds only the +always-on scalar \code{within_cs_pip}; \code{"alpha"} also widens +\code{alpha} into one \code{within_cs_pip_} column per set; +\code{"full"} additionally widens \code{cs_logbf_}, \code{cs_effect_} +and \code{cs_effect_var_}. \code{includeAllCs} decides the \code{} +in those names. This governs the \emph{table}; the stored fit is +governed by \code{fitRetention}.} + +\item{L}{Integer. Maximum number of single effects the fit may carry, and +so the maximum number of credible sets that can exist. Default +\code{10}. Seeded onto every SuSiE-family token in \code{methods} that +did not set it through \code{\link{FineMappingMethodsParam}}.} + +\item{Lgreedy}{Integer or \code{NULL}. Maximum number of single effects +for the greedy initialization stage, where the engine has one. +\code{NULL} (the default) leaves the engine's own default in place.} +} +\value{ +\code{CredibleSetParam} returns a \code{CredibleSetParam} + object, a \code{\link{MethodParam}}. Each \code{get*} returns that + setting's value; each \code{set*} returns a modified copy. \code{L} + and \code{Lgreedy} have no setter: they are seeded onto the fitting + tokens, so changing one needs a refit rather than a re-summary. +} +\description{ +How credible sets are built from a fit and which of them are + reported. Every field is read by + \code{\link{postprocessFinemappingFits}}, so these can be changed and a + stored fit re-summarized without refitting. +} +\examples{ +CredibleSetParam(coverage = 0.9, includeAllCs = TRUE) +} diff --git a/man/CrossValidationParam.Rd b/man/CrossValidationParam.Rd new file mode 100644 index 000000000..7dbdaf8cd --- /dev/null +++ b/man/CrossValidationParam.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/crossValidation.R +\docType{class} +\name{CrossValidationParam-class} +\alias{CrossValidationParam-class} +\alias{CrossValidationParam} +\title{Cross-Validation Settings} +\usage{ +CrossValidationParam( + folds = 0, + numThreads = 1, + samplePartition = NULL, + maxVariants = NULL, + weightMethods = NULL +) +} +\arguments{ +\item{folds}{Integer. Number of folds; \code{0} (the default) or +\code{1} skips cross-validation. The same value in both pipelines --- +\code{twasWeightsPipeline} used to default to \code{5}, which made an +unspecified setting mean two different things.} + +\item{numThreads}{Integer. Parallel workers for the per-fold refits. +\code{1} (default) is serial; \code{-1} uses all cores. Only consulted +when \code{folds > 1}.} + +\item{samplePartition}{Optional pre-defined partition \code{data.frame} +with columns \code{Sample} and \code{Fold}. When supplied, every method +reuses this exact partition instead of generating a fresh one.} + +\item{maxVariants}{Integer. Cap on the number of variants used for CV; +unset means no limit. \strong{\code{twasWeightsPipeline} only} --- +\code{fineMappingPipeline} ignores it, because it does not use the +\code{twasWeightsCv} engine this configures.} + +\item{weightMethods}{Optional override of which methods are +cross-validated, as a character vector of tokens or a named method list. +Unset cross-validates every method that produced non-zero weights. +\strong{\code{twasWeightsPipeline} only} --- +\code{fineMappingPipeline} ignores it, because its \code{methods=} are +fine-mapping methods and its CV refits all of them.} +} +\value{ +A \code{CrossValidationParam} object, a \code{\link{MethodParam}}. +} +\description{ +How cross-validation runs, shared by + \code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}. + + \code{folds}, \code{numThreads} and \code{samplePartition} mean the same + thing in both. \code{maxVariants} and \code{weightMethods} are honoured + by \code{\link{twasWeightsPipeline}} only and are \strong{ignored} by + \code{\link{fineMappingPipeline}}, so one bundle can be handed to + either pipeline unchanged. +} +\examples{ +CrossValidationParam(folds = 10, numThreads = 4) +} diff --git a/man/CtwasOptions.Rd b/man/CtwasOptions.Rd new file mode 100644 index 000000000..2488d130b --- /dev/null +++ b/man/CtwasOptions.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasOptions} +\alias{CtwasOptions} +\title{Arguments For The ctwas Fitting Steps} +\usage{ +CtwasOptions(...) +} +\arguments{ +\item{...}{Any argument accepted by one of the ctwas steps, under ctwas's +own names (\code{niter}, \code{min_gene}, \code{min_nonSNP_PIP}, +\code{numThreads}, ...). Note that settings pecotmr exposes as its own +parameters --- \code{thin}, \code{L}, \code{numThreads} on the pipeline --- +are passed there, not here.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to ctwas. \code{ctwasPipeline} runs seven + ctwas functions in sequence and hands this one bundle to each, forwarding + only the arguments that step actually accepts -- so a setting meant for + the screening step does not disturb the fitting step. Names are therefore + checked against what those seven functions accept \emph{between them}. + + The interface is deliberately flat, matching ctwas's own + \code{ctwas_sumstats}, which takes forty arguments in one signature and + distributes them to its internal steps itself. +} +\examples{ +CtwasOptions(min_group_size = 1, min_gene = 1) +} diff --git a/man/CtwasPriorParam.Rd b/man/CtwasPriorParam.Rd new file mode 100644 index 000000000..77a91996e --- /dev/null +++ b/man/CtwasPriorParam.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasPipeline.R +\docType{class} +\name{CtwasPriorParam-class} +\alias{CtwasPriorParam-class} +\alias{CtwasPriorParam} +\title{cTWAS Prior-Estimation Settings} +\usage{ +CtwasPriorParam( + thin = 0.1, + niterPrefit = 3L, + niter = 30L, + varStructure = c("shared_type", "shared_context", "shared_nonSNP", "shared_all", + "independent"), + fallbackToPrefit = FALSE +) +} +\arguments{ +\item{thin}{Numeric. Proportion of SNPs retained when assembling region +data for the EM. Default \code{0.1}. This is stochastic thinning for +speed, unrelated to \code{\link{VariantPruningParam}}, which decides +which variants enter a gene's weight matrix.} + +\item{niterPrefit}{Integer. Iterations for the prefit EM. Default +\code{3}.} + +\item{niter}{Integer. Iterations for the accurate EM. Default \code{30}.} + +\item{varStructure}{How the prior variance is shared across groups; one of +\code{"shared_type"} (default), \code{"shared_context"}, +\code{"shared_nonSNP"}, \code{"shared_all"} or \code{"independent"}.} + +\item{fallbackToPrefit}{Logical. When the accurate EM returns NaN on +underpowered data, fall back to the prefit estimates rather than failing. +Default \code{FALSE}. A pecotmr recovery step, not a cTWAS argument.} +} +\value{ +A \code{CtwasPriorParam} object, a \code{\link{MethodParam}}. +} +\description{ +The EM stage that estimates cTWAS's group priors + (\code{group_prior} / \code{group_prior_var}). These are exactly the + settings \code{\link{estCtwasGroupPriors}} takes, so the bundle travels + from \code{\link{ctwasPipeline}} to that function whole. +} +\examples{ +CtwasPriorParam(thin = 1, niter = 10, fallbackToPrefit = TRUE) +} diff --git a/man/CtwasResultEntry-class.Rd b/man/CtwasResultEntry-class.Rd index a83a5756f..91f29e251 100644 --- a/man/CtwasResultEntry-class.Rd +++ b/man/CtwasResultEntry-class.Rd @@ -22,7 +22,8 @@ or \code{NULL}.} fuller cTWAS output retained so the raw run is reconstructable, or \code{NULL}.} -\item{\code{param}}{The estimated \code{group_prior} / \code{group_prior_var} for +\item{\code{groupPriors}}{The estimated \code{group_prior} / +\code{group_prior_var} for this run, or \code{NULL}.} \item{\code{regionInfo}}{Per-region metadata, or \code{NULL}.} diff --git a/man/CtwasResultEntry.Rd b/man/CtwasResultEntry.Rd index 793850bd9..25c807cea 100644 --- a/man/CtwasResultEntry.Rd +++ b/man/CtwasResultEntry.Rd @@ -7,7 +7,7 @@ CtwasResultEntry( finemap = NULL, susieAlpha = NULL, - param = NULL, + groupPriors = NULL, regionInfo = NULL ) } @@ -20,7 +20,8 @@ summary table (\code{ctwas::finemap_regions} \code{finemap_res} shape), or (\code{ctwas::finemap_regions} \code{susie_alpha_res} shape) -- the fuller cTWAS output retained so the raw run is reconstructable, or \code{NULL}.} -\item{param}{The estimated \code{group_prior} / \code{group_prior_var} for +\item{groupPriors}{The estimated \code{group_prior} / +\code{group_prior_var} for this run, or \code{NULL}.} \item{regionInfo}{Per-region metadata, or \code{NULL}.} diff --git a/man/DentistParam.Rd b/man/DentistParam.Rd new file mode 100644 index 000000000..d152f77df --- /dev/null +++ b/man/DentistParam.Rd @@ -0,0 +1,56 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sumstatsQc.R +\docType{class} +\name{DentistParam-class} +\alias{DentistParam-class} +\alias{DentistParam} +\title{Arguments For The DENTIST LD-Mismatch Check} +\usage{ +DentistParam( + pValueThreshold = 5e-08, + propSVD = 0.4, + gcControl = FALSE, + nIter = 10, + gPvalueThreshold = 0.05, + duprThreshold = 0.99, + numThreads = 1, + correctChenEtAlBug = TRUE, + seed = NULL +) +} +\arguments{ +\item{pValueThreshold}{Significance threshold for the DENTIST statistic. +Default \code{5e-8}.} + +\item{propSVD}{Proportion of the singular value decomposition retained. +Default \code{0.4}.} + +\item{gcControl}{Logical; apply genomic control. Default \code{FALSE}.} + +\item{nIter}{Number of DENTIST iterations. Default \code{10}.} + +\item{gPvalueThreshold}{Grouping p-value threshold. Default \code{0.05}.} + +\item{duprThreshold}{Duplicate r-squared threshold. Default \code{0.99}.} + +\item{numThreads}{Number of CPU cores. Default \code{1}.} + +\item{correctChenEtAlBug}{Logical; apply the Chen et al. correction. +Default \code{TRUE}.} + +\item{seed}{Integer or \code{NULL}. Random seed for the iteration.} +} +\value{ +A \code{DentistParam} object, a \code{\link{MethodParam}}. +} +\description{ +Options for \code{\link{dentistSingleWindow}}, pecotmr's + DENTIST implementation. Every field is a formal of that function, so an + unknown name is rejected by R as an unused argument; there is no + \code{...} because the contract is complete. Pass the result as + \code{ldMismatchQc(method = )} or + \code{summaryStatsQc(ldMismatchQcMethod = )}. +} +\examples{ +DentistParam(propSVD = 0.5) +} diff --git a/man/EnsembleParam.Rd b/man/EnsembleParam.Rd new file mode 100644 index 000000000..7d0fdfe3d --- /dev/null +++ b/man/EnsembleParam.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/twasWeightsPipeline.R +\docType{class} +\name{EnsembleParam-class} +\alias{EnsembleParam-class} +\alias{EnsembleParam} +\title{SR-TWAS Ensemble Settings} +\usage{ +EnsembleParam( + enabled = FALSE, + r2Threshold = 0.01, + solver = c("quadprog", "glmnet"), + alpha = 1 +) +} +\arguments{ +\item{enabled}{Logical. Compute SR-TWAS ensemble weights. Default +\code{FALSE}.} + +\item{r2Threshold}{Minimum cross-validated \eqn{R^2} for a method to enter +the stack. Default \code{0.01}. Stacking needs at least two methods to +clear it.} + +\item{solver}{Stacking solver, \code{"quadprog"} (default) or +\code{"glmnet"}.} + +\item{alpha}{Elastic-net mixing parameter, used only when +\code{solver = "glmnet"}. Default \code{1}.} +} +\value{ +A \code{EnsembleParam} object, a \code{\link{MethodParam}}. +} +\description{ +Whether and how \code{\link{twasWeightsPipeline}} stacks its + per-method weights into an SR-TWAS ensemble. +} +\section{Requires cross-validation}{ + + Stacking combines each method's \strong{out-of-fold} predictions, so it + cannot run without cross-validation. \code{enabled = TRUE} together with + \code{CrossValidationParam(folds < 2)} is an error. It used to be + neither: the ensemble row was simply absent from the result, with + \code{ensemble = TRUE} still reading as on. + + \code{enabled} defaults to \code{FALSE} because + \code{\link{CrossValidationParam}} defaults to no folds. To get an + ensemble, ask for both. +} + +\examples{ +EnsembleParam(enabled = TRUE, r2Threshold = 0.05) +} +\seealso{ +\code{\link{CrossValidationParam}} +} diff --git a/man/FineMappingMethodsParam.Rd b/man/FineMappingMethodsParam.Rd new file mode 100644 index 000000000..82dd72896 --- /dev/null +++ b/man/FineMappingMethodsParam.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fineMappingPipeline.R +\docType{class} +\name{FineMappingMethodsParam-class} +\alias{FineMappingMethodsParam-class} +\alias{FineMappingMethodsParam} +\title{Which Fine-Mapping Methods To Run, And How} +\usage{ +FineMappingMethodsParam( + methods = NULL, + qtlDatasetMethods = NULL, + qtlSumStatsMethods = NULL +) +} +\arguments{ +\item{methods}{Named list of per-method options whose input path need not +be stated. Each entry is that method's \code{*Options()} record, or +\code{list()} to run it with its defaults.} + +\item{qtlDatasetMethods}{Named list of per-method options for the +individual-level path.} + +\item{qtlSumStatsMethods}{Named list of per-method options for the +summary-statistics path.} +} +\value{ +A \code{FineMappingMethodsParam} object, a \code{\link{MethodParam}}. +} +\description{ +Selects the methods \code{\link{fineMappingPipeline}} runs and + carries each one's engine arguments. + + A method that runs on both individual-level and summary-statistic data + reaches a different engine on each path, so for a + \code{MultiStudyQtlDataset} carrying both there is no single set of + arguments per method. Name such a method under + \code{qtlDatasetMethods} or \code{qtlSumStatsMethods} to say which + path its options are for; name it under \code{methods} when the path + need not be stated --- a single-type run, or a method with nothing + path-specific to configure. + + Naming a method selects it. A method belongs in exactly one of the + three slots. +} +\examples{ +FineMappingMethodsParam(methods = "susie") +FineMappingMethodsParam(methods = list(susie = SusieOptions(L = 20))) +FineMappingMethodsParam( + qtlDatasetMethods = list(susie = SusieOptions(L = 20)), + qtlSumStatsMethods = list(susie = SusieRssOptions(L = 20)) +) +} diff --git a/man/GbjOmniOptions.Rd b/man/GbjOmniOptions.Rd new file mode 100644 index 000000000..8b9210ad7 --- /dev/null +++ b/man/GbjOmniOptions.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pvalCombineWrappers.R +\name{GbjOmniOptions} +\alias{GbjOmniOptions} +\title{Options for the GBJ Omnibus Combination Test} +\usage{ +GbjOmniOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{GBJ::OMNI_ss()} -- in practice +\code{num_boots}, the bootstrap count the omnibus null is built from. +\code{test_stats} and \code{cor_mat} are supplied by pecotmr and refused.} +} +\value{ +A \code{MethodOptions} record for + \code{\link{PvalMethodsParam}}. +} +\description{ +Build a checked record of extra arguments for + \code{GBJ::OMNI_ss()}, the engine behind \code{\link{combinePValues}} + method \code{"gbj_omni"}. It takes a different option from its siblings + (\code{num_boots} rather than \code{pairwise_cors}), so it has its own + constructor. +} +\examples{ +GbjOmniOptions(num_boots = 200) +} +\seealso{ +\code{\link{combinePValues}}, \code{\link{GbjOptions}} +} diff --git a/man/GbjOptions.Rd b/man/GbjOptions.Rd new file mode 100644 index 000000000..fde8f6aa0 --- /dev/null +++ b/man/GbjOptions.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pvalCombineWrappers.R +\name{GbjOptions} +\alias{GbjOptions} +\title{Options for the GBJ Family of Combination Tests} +\usage{ +GbjOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{GBJ::GBJ()} and its siblings -- in practice +\code{pairwise_cors}, the vector of pairwise correlations the test would +otherwise derive from \code{cor_mat}. Names are checked against the +engine's formals, so a misspelling is an error rather than a silent drop. +\code{test_stats} and \code{cor_mat} are supplied by pecotmr and refused.} +} +\value{ +A \code{MethodOptions} record for + \code{\link{PvalMethodsParam}}. +} +\description{ +Build a checked record of extra arguments for the \pkg{GBJ} + set-based tests behind \code{\link{combinePValues}} methods + \code{"gbj"}, \code{"bj"}, \code{"hc"}, \code{"ghc"} and \code{"minp"}. + All five share one signature, so one constructor covers them. +} +\examples{ +GbjOptions(pairwise_cors = rep(0.1, 3)) +} +\seealso{ +\code{\link{combinePValues}}, \code{\link{GbjOmniOptions}} +} diff --git a/man/GenotypeFilterParam.Rd b/man/GenotypeFilterParam.Rd new file mode 100644 index 000000000..175f51f6a --- /dev/null +++ b/man/GenotypeFilterParam.Rd @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/QtlDataset.R +\docType{class} +\name{GenotypeFilterParam-class} +\alias{GenotypeFilterParam-class} +\alias{GenotypeFilterParam} +\title{Genotype Filtering Options} +\usage{ +GenotypeFilterParam( + mafCutoff = NULL, + macCutoff = NULL, + xvarCutoff = NULL, + imissCutoff = NULL, + keepSamples = NULL, + keepVariants = NULL, + keepIndel = NULL +) +} +\arguments{ +\item{mafCutoff}{Minor-allele-frequency floor.} + +\item{macCutoff}{Minor-allele-count floor; the stricter of this and +\code{mafCutoff} applies.} + +\item{xvarCutoff}{Genotype-variance floor.} + +\item{imissCutoff}{Per-variant missingness ceiling.} + +\item{keepSamples}{Sample ids to restrict to; \code{character(0)} keeps +all samples.} + +\item{keepVariants}{Variant ids to restrict to; \code{character(0)} keeps +all variants.} + +\item{keepIndel}{Logical. Retain insertions and deletions.} +} +\value{ +A \code{GenotypeFilterParam} object, a \code{\link{MethodParam}}. +} +\description{ +Which variants and samples survive when a genotype matrix is + assembled, as one checked bundle. Used by \code{\link{QtlDataset}}, the + manifest loaders, and the pipelines that build a dataset. +} +\section{Unset versus set}{ + + Every field defaults to \code{NULL}, meaning \strong{not set}, and an + unset field is absent from the result rather than carried as \code{NULL}. + That is what lets one bundle serve two roles: + \itemize{ + \item to \code{\link{QtlDataset}} it is a \emph{specification}, and + an unset field takes that constructor's own default --- \code{0} for + each cutoff, \code{character(0)} for each \code{keep}, \code{TRUE} + for \code{keepIndel}. + \item to a pipeline it is an \emph{override}, and an unset field + leaves the dataset's construct-time value alone. + } + So \code{GenotypeFilterParam(mafCutoff = 0)} and + \code{GenotypeFilterParam()} differ: the first pins the cutoff at zero, + the second defers. \code{\link{PanelFilterParam}} needs no such + distinction and keeps ordinary defaults. +} + +\examples{ +GenotypeFilterParam(mafCutoff = 0.01, keepIndel = FALSE) +} +\seealso{ +\code{\link{PanelFilterParam}}, \code{\link{SumstatsFilterParam}} +} diff --git a/man/GenotypeHandle.Rd b/man/GenotypeHandle.Rd index d11af48b9..4562e8be8 100644 --- a/man/GenotypeHandle.Rd +++ b/man/GenotypeHandle.Rd @@ -18,7 +18,8 @@ GenotypeHandle( region = NULL, genoMeta = NULL, chroms = NULL, - ... + format = NULL, + vcfArgs = list() ) } \arguments{ @@ -62,7 +63,8 @@ shard is read (so the caller's own absence check can report the mismatch). Only meaningful with \code{genoMeta}; supplying it with any other source is an error (a single-file panel has no per-chromosome shards to skip).} -\item{...}{Additional arguments forwarded to the format-specific reader.} +\item{vcfArgs}{Optional named list of arguments forwarded to +\code{VariantAnnotation::readVcf} when the source is a VCF.} } \value{ A \code{GenotypeHandle} object. diff --git a/man/GwasFineMappingParam.Rd b/man/GwasFineMappingParam.Rd new file mode 100644 index 000000000..f29fbef83 --- /dev/null +++ b/man/GwasFineMappingParam.Rd @@ -0,0 +1,144 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/colocPipeline.R +\docType{class} +\name{getFineMappingMethods} +\alias{getFineMappingMethods} +\alias{setFineMappingMethods} +\alias{getCredibleSetArgs} +\alias{setCredibleSetArgs} +\alias{getRssArgs} +\alias{setRssArgs} +\alias{getPanelFilterArgs} +\alias{setPanelFilterArgs} +\alias{getAddSusieInf} +\alias{setAddSusieInf} +\alias{getFitRetention} +\alias{setFitRetention} +\alias{GwasFineMappingParam-class} +\alias{GwasFineMappingParam} +\alias{getFineMappingMethods,GwasFineMappingParam-method} +\alias{setFineMappingMethods,GwasFineMappingParam-method} +\alias{getCredibleSetArgs,GwasFineMappingParam-method} +\alias{setCredibleSetArgs,GwasFineMappingParam-method} +\alias{getRssArgs,GwasFineMappingParam-method} +\alias{setRssArgs,GwasFineMappingParam-method} +\alias{getPanelFilterArgs,GwasFineMappingParam-method} +\alias{setPanelFilterArgs,GwasFineMappingParam-method} +\alias{getAddSusieInf,GwasFineMappingParam-method} +\alias{setAddSusieInf,GwasFineMappingParam-method} +\alias{getFitRetention,GwasFineMappingParam-method} +\alias{setFitRetention,GwasFineMappingParam-method} +\title{Inline GWAS Fine-Mapping Settings} +\usage{ +getFineMappingMethods(x, ...) + +setFineMappingMethods(x, value, ...) + +getCredibleSetArgs(x, ...) + +setCredibleSetArgs(x, value, ...) + +getRssArgs(x, ...) + +setRssArgs(x, value, ...) + +getPanelFilterArgs(x, ...) + +setPanelFilterArgs(x, value, ...) + +getAddSusieInf(x, ...) + +setAddSusieInf(x, value, ...) + +getFitRetention(x, ...) + +setFitRetention(x, value, ...) + +GwasFineMappingParam( + methods = "susie", + credibleSetArgs = CredibleSetParam(), + rssArgs = SusieRssParam(), + panelFilterArgs = PanelFilterParam(), + addSusieInf = TRUE, + fitRetention = c("slim", "full") +) + +\S4method{getFineMappingMethods}{GwasFineMappingParam}(x) + +\S4method{setFineMappingMethods}{GwasFineMappingParam}(x, value) + +\S4method{getCredibleSetArgs}{GwasFineMappingParam}(x) + +\S4method{setCredibleSetArgs}{GwasFineMappingParam}(x, value) + +\S4method{getRssArgs}{GwasFineMappingParam}(x) + +\S4method{setRssArgs}{GwasFineMappingParam}(x, value) + +\S4method{getPanelFilterArgs}{GwasFineMappingParam}(x) + +\S4method{setPanelFilterArgs}{GwasFineMappingParam}(x, value) + +\S4method{getAddSusieInf}{GwasFineMappingParam}(x) + +\S4method{setAddSusieInf}{GwasFineMappingParam}(x, value) + +\S4method{getFitRetention}{GwasFineMappingParam}(x) + +\S4method{setFitRetention}{GwasFineMappingParam}(x, value) +} +\arguments{ +\item{x}{A \code{GwasFineMappingParam}.} + +\item{...}{Unused, present for generic consistency.} + +\item{value}{The replacement value for that setting.} + +\item{methods}{Fine-mapping methods, as a character vector or a +\code{\link{FineMappingMethodsParam}} record. Default \code{"susie"}.} + +\item{credibleSetArgs}{How credible sets are built, built with +\code{\link{CredibleSetParam}}. \code{coverage} and \code{L} matter +most here: they decide the sets whose log Bayes factors coloc scores, so +leaving them at the defaults while the QTL side used something else +compares two differently-built sets.} + +\item{rssArgs}{The summary-statistics solver, built with +\code{\link{SusieRssParam}} --- \code{serFallback}, \code{rMismatch}, +\code{rFinite} and the \code{susie_rss} control list. What a GWAS block +with an imperfect LD panel needs.} + +\item{panelFilterArgs}{LD-reference-panel filters, built with +\code{\link{PanelFilterParam}}.} + +\item{addSusieInf}{Logical. Chain a SuSiE-inf fit, when \code{methods} +asks for \code{susieInf} alongside \code{susie}. Default \code{TRUE}.} + +\item{fitRetention}{How much of each fit is kept: \code{"slim"} (default) +or \code{"full"}. Only observable when +\code{returnGwasFineMapping = TRUE}, which is when the fine-mapping +result is handed back for other uses.} +} +\value{ +\code{GwasFineMappingParam} returns a + \code{GwasFineMappingParam} object, a \code{\link{MethodParam}}. + Each \code{get*} returns that setting's value --- for the three + nested bundles, the \code{MethodParam} itself --- and each + \code{set*} returns a modified copy. +} +\description{ +How \code{\link{colocPipeline}} fine-maps \code{gwasInput} + when it is summary statistics rather than an existing fine-mapping + result. Every field is forwarded to + \code{\link{fineMappingPipeline}}; the settings that pipeline exposes + but that cannot apply here are deliberately absent: + \code{fineMappingResult} (the pipeline is being asked to produce one), + \code{crossValidation} (refused on summary statistics) and + \code{residualization} (nothing to regress out). + + The whole bundle is inert when \code{gwasInput} is already a + fine-mapping result, since no fit is run. +} +\examples{ +GwasFineMappingParam(credibleSet = CredibleSetParam(coverage = 0.9)) +} diff --git a/man/GwasSumStats.Rd b/man/GwasSumStats.Rd index d3ab4fdcc..1eef67857 100644 --- a/man/GwasSumStats.Rd +++ b/man/GwasSumStats.Rd @@ -16,7 +16,7 @@ GwasSumStats( qcInfo = list(), ldBlocks = NULL, blockId = NULL, - ... + extraCols = list() ) } \arguments{ @@ -74,7 +74,11 @@ it to carry existing keys through a rebuild; without it a rebuild would re-derive them as seqnames and collapse distinct blocks onto one key. Mutually exclusive with \code{ldBlocks}.} -\item{...}{Additional per-study columns to attach to the collection.} +\item{extraCols}{Optional named list of additional per-study columns to +attach to the collection's \code{mcols}. Named rather than variadic +because the base class's own constructor, \code{GRangesList(...)}, uses +\code{...} for its \emph{elements}: a bare \code{...} here would read +as adding an entry rather than a metadata column.} } \value{ A \code{GwasSumStats} object. diff --git a/man/KrigingOptions.Rd b/man/KrigingOptions.Rd new file mode 100644 index 000000000..87e55dd0f --- /dev/null +++ b/man/KrigingOptions.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fineMappingWrappers.R +\name{KrigingOptions} +\alias{KrigingOptions} +\title{Options for the susieR Kriging RSS Diagnostic} +\usage{ +KrigingOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{susieR::kriging_rss()}: \code{r_tol} (the +eigenvalue tolerance below which an LD eigenvalue is treated as zero) and +\code{s} (the estimated proportion of LD/sumstats mismatch, which +defaults to \code{susieR::estimate_s_rss()}). \code{z}, \code{R} and +\code{n} are supplied by pecotmr and refused.} +} +\value{ +A \code{MethodOptions} record for + \code{krigingOutlierQc(methodArgs =)}. +} +\description{ +Build a checked record of extra arguments for + \code{susieR::kriging_rss()}, the engine behind + \code{\link{krigingOutlierQc}}. +} +\examples{ +KrigingOptions(r_tol = 1e-06) +} +\seealso{ +\code{\link{krigingOutlierQc}} +} diff --git a/man/LdData-class.Rd b/man/LdData-class.Rd index 28fd9614f..7990cb4e5 100644 --- a/man/LdData-class.Rd +++ b/man/LdData-class.Rd @@ -57,8 +57,13 @@ it is unwrapped to its handle.} \code{snpInfo}. NULL when correlation is pre-computed, or when the source is a matrix (which is already the subset).} -\item{\code{blockMetadata}}{A \code{GRanges} of blocks or a \code{data.frame} with -block boundary information.} +\item{\code{blockMetadata}}{A \code{GRanges} with one range per block: its +\code{seqnames} and range are the block's chromosome and genomic span, +and \code{mcols} carry \code{blockId}, \code{size}, \code{startIdx} +and \code{endIdx} -- the index range into the correlation matrix the +block addresses. Extra columns the caller supplied are kept as mcols. +A block whose index range is out of bounds has no span to derive and +gets a width-0 range.} \item{\code{nRef}}{Integer, reference panel sample size.} diff --git a/man/LdData.Rd b/man/LdData.Rd index e64bf64fa..817006657 100644 --- a/man/LdData.Rd +++ b/man/LdData.Rd @@ -26,7 +26,12 @@ a matrix of already-extracted dosages, or NULL.} \item{variants}{A GRanges with variant metadata (must have variant_id in mcols, plus A1, A2).} -\item{blockMetadata}{GRanges of blocks, or data.frame with block info.} +\item{blockMetadata}{Block boundaries: a \code{GRanges}, a +\code{data.frame} or a \code{DataFrame}. Whatever is absent for a +single block is derived from \code{variants}, so a bare genomic span +-- or nothing at all -- is enough; with several blocks either the index +columns or \code{size} must be supplied. Normalised on the way in and +stored as a \code{GRanges} (see the \code{blockMetadata} slot).} \item{nRef}{Integer, reference panel sample size.} diff --git a/man/LdPruningOptions.Rd b/man/LdPruningOptions.Rd new file mode 100644 index 000000000..35bb6a86d --- /dev/null +++ b/man/LdPruningOptions.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ld.R +\name{LdPruningOptions} +\alias{LdPruningOptions} +\title{Options for the SNPRelate LD-Pruning Backend} +\usage{ +LdPruningOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{SNPRelate::snpgdsLDpruning()} -- in +practice the window controls \code{slide.max.bp} and +\code{slide.max.n} (pruning is greedy within a window, so the window +bounds which pairs are ever compared), \code{maf}, +\code{missing.rate}, \code{remove.monosnp} and \code{num.thread}. +\code{gdsobj}, \code{method}, \code{ld.threshold} and \code{verbose} +are supplied by pecotmr and refused. The temporary GDS pecotmr writes +holds every sample and variant of \code{X} on one synthetic chromosome, +so \code{sample.id}, \code{snp.id} and \code{autosome.only} are not +meaningful selectors here.} +} +\value{ +A \code{MethodOptions} record for + \code{ldPruneByCorrelation(methodArgs =)}. +} +\description{ +Build a checked record of extra arguments for + \code{SNPRelate::snpgdsLDpruning()}, the engine behind + \code{ldPruneByCorrelation(backend = "snprelate")}. +} +\examples{ +LdPruningOptions(slide.max.bp = 1e6) +} +\seealso{ +\code{\link{ldPruneByCorrelation}} +} diff --git a/man/MashComponentParam.Rd b/man/MashComponentParam.Rd new file mode 100644 index 000000000..71d24c9ce --- /dev/null +++ b/man/MashComponentParam.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\docType{class} +\name{MashComponentParam-class} +\alias{MashComponentParam-class} +\alias{MashComponentParam} +\title{Per-Component Arguments For mashPriorCovariances} +\usage{ +MashComponentParam( + canonical = NULL, + pca = NULL, + flash = NULL, + flashNonneg = NULL +) +} +\arguments{ +\item{canonical}{Options for \code{\link{CovCanonicalOptions}}.} + +\item{pca}{Options for \code{\link{CovPcaOptions}}.} + +\item{flash, flashNonneg}{Options for \code{\link{CovFlashOptions}}.} +} +\value{ +A \code{MashComponentParam} object, a \code{\link{MethodParam}}. + \code{names()} lists the components that were named, which is also the + set that was selected. +} +\description{ +Options for each prior-covariance component, keyed by + component name. Each entry may be a plain list or the matching + constructor -- a plain list is spliced into that constructor, so it gets + the same defaults and the same checking either way. + + Naming a component here also selects it, so \code{components} need not + be given separately. +} +\examples{ +MashComponentParam( + pca = list(subset = 1:50), + canonical = CovCanonicalOptions() +) +} diff --git a/man/MashCorEmOptions.Rd b/man/MashCorEmOptions.Rd new file mode 100644 index 000000000..3f40b290e --- /dev/null +++ b/man/MashCorEmOptions.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{MashCorEmOptions} +\alias{MashCorEmOptions} +\title{Settings For The EM Null-Correlation Estimator} +\usage{ +MashCorEmOptions(...) +} +\arguments{ +\item{...}{Arguments for the estimator, under its own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to \code{mashr::mash_estimate_corr_em}, the + \code{method = "mle"} estimator. + + \code{data}, \code{Ulist} and \code{max_iter} are refused: the first + two are what pecotmr assembles, and \code{max_iter} is the caller's + \code{maxIter}. + + Not checkable: \code{mash_estimate_corr_em} ends in \code{...}, so any + name is legal there and nothing can be rejected. +} +\examples{ +MashCorEmOptions(tol = 1e-5) +} diff --git a/man/MashCorSimpleOptions.Rd b/man/MashCorSimpleOptions.Rd new file mode 100644 index 000000000..67c6e4adf --- /dev/null +++ b/man/MashCorSimpleOptions.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{MashCorSimpleOptions} +\alias{MashCorSimpleOptions} +\title{Settings For The Simple Null-Correlation Estimator} +\usage{ +MashCorSimpleOptions(...) +} +\arguments{ +\item{...}{Arguments for the estimator, under its own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to + \code{mashr::estimate_null_correlation_simple}. \code{data} is refused: + it is the null-partition data object pecotmr assembles. +} +\examples{ +MashCorSimpleOptions(z_thresh = 3) +} diff --git a/man/MashDataOptions.Rd b/man/MashDataOptions.Rd new file mode 100644 index 000000000..0e27b11b9 --- /dev/null +++ b/man/MashDataOptions.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{MashDataOptions} +\alias{MashDataOptions} +\title{Settings For mashr Data Assembly} +\usage{ +MashDataOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{mashr::mash_set_data}, under its own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to \code{mashr::mash_set_data}, which turns + the effect-size and standard-error matrices into mashr's data object. + + \code{Bhat}, \code{Shat}, \code{alpha} and \code{V} are refused: the + first two are the matrices pecotmr builds, and the last two are the + caller's own \code{alpha} / \code{vhat} arguments. + + \code{zero_Bhat_Shat_reset} defaults to \code{1000} here because that + is the value pecotmr has always passed; it is now a setting rather than + a literal. +} +\examples{ +MashDataOptions(zero_Bhat_Shat_reset = 500) +} diff --git a/man/MashOptions.Rd b/man/MashOptions.Rd new file mode 100644 index 000000000..8f3cb7246 --- /dev/null +++ b/man/MashOptions.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{MashOptions} +\alias{MashOptions} +\title{Settings For The mash Mixture-Weight Fit} +\usage{ +MashOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{mashr::mash}, under its own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to \code{mashr::mash}, the fit that + estimates the mixture weights over the prior covariances. Checked + against that function's live formals. + + \code{data}, \code{Ulist} and \code{outputlevel} are refused: they are + the inputs pecotmr assembles and the output level it needs. + \code{seed} is refused too --- use the caller's \code{setSeed}, so one + setting governs the whole run. +} +\examples{ +MashOptions(nullweight = 10, optmethod = "mixSQP") +} diff --git a/man/MashPosteriorOptions.Rd b/man/MashPosteriorOptions.Rd new file mode 100644 index 000000000..df811df4c --- /dev/null +++ b/man/MashPosteriorOptions.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{MashPosteriorOptions} +\alias{MashPosteriorOptions} +\title{Settings For mashr Posterior Computation} +\usage{ +MashPosteriorOptions(...) +} +\arguments{ +\item{...}{Arguments for the posterior computation, under its own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to + \code{mashr::mash_compute_posterior_matrices}. + + \code{g}, \code{data} and \code{output_posterior_cov} are refused: the + first two are the fitted model and the data pecotmr assembles, and the + third is the caller's \code{outputPosteriorCov}. \code{A} is refused as + well --- the contrast matrix follows from \code{excludeCondition}. + \code{seed} is refused; use \code{setSeed}. +} +\examples{ +MashPosteriorOptions(pi_thresh = 1e-8) +} diff --git a/man/MashPriorParam.Rd b/man/MashPriorParam.Rd new file mode 100644 index 000000000..191e00eaf --- /dev/null +++ b/man/MashPriorParam.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\docType{class} +\name{MashPriorParam-class} +\alias{MashPriorParam-class} +\alias{MashPriorParam} +\title{mash Prior-Covariance Settings} +\usage{ +MashPriorParam( + priorCovariances = NULL, + components = c("canonical", "pca", "flash", "flashNonneg"), + engine = c("covEd", "covUdr", "none"), + nPcs = NULL +) +} +\arguments{ +\item{priorCovariances}{Optional named list of square covariance matrices, +or a \code{\link{MashPrior}}. \code{NULL} (default) builds them.} + +\item{components}{Which prior-covariance components to build: any of +\code{"canonical"}, \code{"pca"}, \code{"flash"}, +\code{"flashNonneg"}, or a \code{\link{MashComponentParam}} record to +configure them. Ignored when \code{priorCovariances} is supplied.} + +\item{engine}{How the data-driven components are refined: +\code{"covEd"} (default), \code{"covUdr"} or \code{"none"}, or the +matching constructor --- \code{\link{CovEdOptions}} / +\code{\link{CovUdrOptions}} --- to configure it at the same time. +Ignored when \code{priorCovariances} is supplied.} + +\item{nPcs}{Optional integer; principal components seeded into +\code{mashr::cov_pca()}. Defaults to \code{ncol} of the data. Read +only when \code{components} includes \code{"pca"}.} +} +\value{ +A \code{MashPriorParam} object, a \code{\link{MethodParam}}. +} +\description{ +How the prior covariance matrices (the \code{Ulist} mash + consumes) are obtained: supplied outright, or built from components and + refined by an engine. Exactly the arguments + \code{\link{mashPriorCovariances}} takes for that job, so the bundle + travels there whole. + + Supplying \code{priorCovariances} short-circuits the rest: the + components are not built and the engine does not run. +} +\examples{ +MashPriorParam(components = c("canonical", "pca"), nPcs = 3) +} diff --git a/man/MethodOptions-class.Rd b/man/MethodOptions-class.Rd new file mode 100644 index 000000000..49ddd619e --- /dev/null +++ b/man/MethodOptions-class.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/MethodOptions.R +\docType{class} +\name{MethodOptions-class} +\alias{MethodOptions-class} +\alias{MethodOptions} +\alias{show,MethodOptions-method} +\title{Arguments For One Fitting Engine} +\usage{ +\S4method{show}{MethodOptions}(object) +} +\arguments{ +\item{object}{A \code{MethodOptions} object.} +} +\value{ +\code{show} is called for its side effect and returns + \code{invisible(NULL)}. +} +\description{ +A validated bundle of arguments destined for one external + fitting engine, produced by an engine constructor such as + \code{SusieOptions()} or \code{MrmashOptions()} rather than written as a + bare list. Names are checked against the engine's own formals at + construction, so a misspelled option fails immediately instead of being + silently dropped. + + It \strong{is} a \code{\link[S4Vectors]{SimpleList}}: \code{$}, + \code{[[}, \code{names()} and \code{length()} behave as on a list, it + splices into a call with \code{!!!}, and subsetting returns a + \code{MethodOptions} rather than degrading to a plain list. The engine name + and the callee it forwards to travel in \code{metadata()}. +} +\section{Whether argument names are checked}{ + + A constructor checks the names you give it against the \emph{live} + formals of the function it forwards to, so the check can never drift from + the version of that package you have installed. Printing a + \code{MethodOptions} says which applies to it. + + Names cannot be checked in two situations, and in both the arguments are + forwarded unchecked rather than rejected: + \itemize{ + \item \strong{The engine takes \code{...}}, so any name is legal as + far as it is concerned. As of writing this applies to + \code{mvsusieR::mvsusie_rss}, \code{mvsusieR::create_mixture_prior}, + \code{ncvreg::ncvreg}, \code{ncvreg::cv.ncvreg}, + \code{RcppDPR::fit_model}, \code{mashr::cov_ed}, + \code{ctwas::finemap_regions} and + \code{ctwas::postprocess_region_merging}. A misspelling here reaches + the engine, which may ignore it silently. + \item \strong{The engine's package is not installed}, so its formals + cannot be read. Building the arguments still works -- it is not + running the engine -- and the engine's own requirement check reports + the missing package when you actually run it. + } + + Every other engine enumerates its arguments, so a misspelling is an error + at the call site naming the accepted set. Constructors for pecotmr's own + engines take no \code{...} at all, so R itself rejects an unknown name as + an unused argument. +} + diff --git a/man/MethodParam-class.Rd b/man/MethodParam-class.Rd new file mode 100644 index 000000000..cbcca80d4 --- /dev/null +++ b/man/MethodParam-class.Rd @@ -0,0 +1,88 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/MethodParam.R +\docType{class} +\name{MethodParam-class} +\alias{MethodParam-class} +\alias{MethodParam} +\alias{$,MethodParam-method} +\alias{[[,MethodParam,ANY,ANY-method} +\alias{names,MethodParam-method} +\alias{length,MethodParam-method} +\alias{as.list,MethodParam-method} +\alias{show,MethodParam-method} +\title{Typed Settings For One Pipeline Stage} +\usage{ +\S4method{$}{MethodParam}(x, name) + +\S4method{[[}{MethodParam,ANY,ANY}(x, i, j, ...) + +\S4method{names}{MethodParam}(x) + +\S4method{length}{MethodParam}(x) + +\S4method{as.list}{MethodParam}(x, ...) + +\S4method{show}{MethodParam}(object) +} +\arguments{ +\item{x}{A \code{MethodParam} object.} + +\item{name}{The name of a setting.} + +\item{i}{A setting's name, or its position among the settings that are +set.} + +\item{j}{Unused, for consistency with the generic.} + +\item{...}{Unused, for consistency with the generic.} + +\item{object}{A \code{MethodParam} object.} +} +\value{ +\code{$} returns that setting's value, \code{NULL} when it is + unset. + +\code{[[} returns that setting's value. + +\code{names} returns the settings that are set. + +\code{length} returns how many settings are set. + +\code{as.list} returns the settings that are set, as a named list. + +\code{show} is called for its side effect and returns + \code{invisible(NULL)}. +} +\description{ +The virtual base of pecotmr's \code{*Param()} records -- + \code{\link{CredibleSetParam}}, \code{\link{SusieRssParam}}, + \code{\link{PanelFilterParam}} and the rest. Each one holds settings + \strong{pecotmr itself reads}, declared as typed slots and checked when + the record is built. + + This is the counterpart to \code{\link{MethodOptions}}, which carries + arguments bound for an \emph{external} engine. The distinction is + deliberate and visible in the name: a \code{*Param()} is a pecotmr + setting whose meaning and type pecotmr defines, so pecotmr validates it; + a \code{*Options()} is somebody else's argument list, so pecotmr checks + only that each name exists in that engine's live formals and otherwise + does not attempt to mirror its semantics. +} +\section{List interface}{ + + A \code{MethodParam} reads like a list: \code{$} and \code{[[} fetch a + field, and \code{names()}, \code{length()} and \code{as.list()} describe + it. + + Those last three report only the fields that are \strong{set}. A slot + holding \code{NULL} is absent from all three, while \code{$} and + \code{[[} still return \code{NULL} for it. This is not cosmetic: + \code{as.list()} on one of these records is spliced into an engine call, + and an engine that distinguishes an explicit \code{NULL} argument from an + omitted one would otherwise see a different call. + + Unlike a list, \code{$} on a name that is not a field is an error rather + than \code{NULL}. Silently reading a misspelled setting as "unset" is the + failure these classes exist to prevent. +} + diff --git a/man/MethodsSelectionParam-class.Rd b/man/MethodsSelectionParam-class.Rd new file mode 100644 index 000000000..4ec963825 --- /dev/null +++ b/man/MethodsSelectionParam-class.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/MethodParam.R +\docType{class} +\name{MethodsSelectionParam-class} +\alias{MethodsSelectionParam-class} +\title{Which Methods A Pipeline Runs, And How} +\description{ +The virtual base of + \code{\link{FineMappingMethodsParam}} and + \code{\link{TwasWeightsMethodsParam}}: which methods a pipeline runs, + and each one's engine arguments. + + Three slots rather than one because a method running on both data paths + reaches a different engine on each --- lasso is glmnet on + individual-level data and lassosum on summary statistics --- so one bag + of arguments per method cannot serve a \code{MultiStudyQtlDataset} + carrying both. \code{methods} holds entries whose input path need not + be stated; \code{qtlDatasetMethods} and \code{qtlSumStatsMethods} hold + the ones that must state it. Naming a method selects it. +} +\section{Slots}{ + +\describe{ +\item{\code{methods}}{Named list of per-method options whose input path need not +be stated.} + +\item{\code{qtlDatasetMethods}}{Named list of per-method options for the +individual-level path.} + +\item{\code{qtlSumStatsMethods}}{Named list of per-method options for the +summary-statistics path.} +}} + +\seealso{ +\code{\link{FineMappingMethodsParam}}, + \code{\link{TwasWeightsMethodsParam}} +} diff --git a/man/MrParam.Rd b/man/MrParam.Rd new file mode 100644 index 000000000..46085d93b --- /dev/null +++ b/man/MrParam.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/causalInferencePipeline.R +\docType{class} +\name{MrParam-class} +\alias{MrParam-class} +\alias{MrParam} +\title{Mendelian-Randomization Settings} +\usage{ +MrParam( + method = c("ivwPerVariant", "csAware"), + pipCutoff = 0.5, + cpipCutoff = 0.5, + pvalCutoff = 1 +) +} +\arguments{ +\item{method}{\code{"ivwPerVariant"} (default) filters \code{topLoci} +variants by \code{pip > pipCutoff} and IVW-pools their Wald ratios. +\code{"csAware"} groups variants by credible set and computes a +PIP-weighted composite Wald ratio per set, using \code{cpipCutoff}.} + +\item{pipCutoff}{Numeric. PIP threshold for a variant to be used as an +instrument. Default \code{0.5}. Used only by \code{"ivwPerVariant"}.} + +\item{cpipCutoff}{Numeric. Cumulative-PIP cutoff for retaining a credible +set. Default \code{0.5}. Used only by \code{"csAware"}.} + +\item{pvalCutoff}{Numeric. MR runs for a \code{(qtl tuple, gwas)} pair +only when its \code{twasPval} is below this; otherwise the MR columns +are \code{NA}. Default \code{1} (no gate).} +} +\value{ +A \code{MrParam} object, a \code{\link{MethodParam}}. +} +\description{ +How \code{\link{causalInferencePipeline}} runs MR from a + tuple's \code{topLoci} table. +} +\examples{ +MrParam(method = "csAware", cpipCutoff = 0.8) +} diff --git a/man/MrmashCanonicalCovsOptions.Rd b/man/MrmashCanonicalCovsOptions.Rd new file mode 100644 index 000000000..3d0f484b8 --- /dev/null +++ b/man/MrmashCanonicalCovsOptions.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{MrmashCanonicalCovsOptions} +\alias{MrmashCanonicalCovsOptions} +\title{Arguments For mr.mashr's Canonical-Covariance Builder} +\usage{ +MrmashCanonicalCovsOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{mr.mashr::compute_canonical_covs()}, such +as \code{singletons} and \code{hetgrid}.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{mr.mashr::compute_canonical_covs()}, the + function that builds the canonical prior mixture. \code{r} (the number + of conditions) is pecotmr's to supply, so it is refused here; every + other name is checked against that function's live formals. + + No defaults: pecotmr used to carry \code{singletons = TRUE} and + \code{hetgrid = c(0, 0.25, 0.5, 0.75, 1)}, which are character for + character the engine's own defaults. Transcribing them bought nothing + and would silently go stale if mr.mashr changed them. +} +\examples{ +MrmashCanonicalCovsOptions(singletons = FALSE) +} diff --git a/man/MrmashExpandCovsOptions.Rd b/man/MrmashExpandCovsOptions.Rd new file mode 100644 index 000000000..791c0eabd --- /dev/null +++ b/man/MrmashExpandCovsOptions.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{MrmashExpandCovsOptions} +\alias{MrmashExpandCovsOptions} +\title{Arguments For mr.mashr's Covariance Expansion} +\usage{ +MrmashExpandCovsOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{mr.mashr::expand_covs()}, such as +\code{zeromat}.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{mr.mashr::expand_covs()}, which expands + the prior covariances over the scaling grid. The covariance list and the + grid are both pecotmr's to supply, so they are refused here; every other + name is checked against that function's live formals. +} +\examples{ +MrmashExpandCovsOptions(zeromat = FALSE) +} diff --git a/man/MrmashPriorParam.Rd b/man/MrmashPriorParam.Rd new file mode 100644 index 000000000..1f9f679c4 --- /dev/null +++ b/man/MrmashPriorParam.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\docType{class} +\name{MrmashPriorParam-class} +\alias{MrmashPriorParam-class} +\alias{MrmashPriorParam} +\title{Prior-Covariance Arguments For mr.mash} +\usage{ +MrmashPriorParam( + canonicalPriorMatrices = FALSE, + priorGrid = NULL, + canonicalCovs = MrmashCanonicalCovsOptions(), + expandCovs = MrmashExpandCovsOptions() +) +} +\arguments{ +\item{canonicalPriorMatrices}{Logical. Include the canonical mixture from +\code{mr.mashr::compute_canonical_covs()}. Default \code{FALSE}.} + +\item{priorGrid}{Optional pre-computed scaling grid (numeric vector). +\code{NULL} (default) derives one from the summary statistics via +\code{computeGrid()}.} + +\item{canonicalCovs}{Arguments for +\code{mr.mashr::compute_canonical_covs()}, built with +\code{\link{MrmashCanonicalCovsOptions}}. Only consulted when +\code{canonicalPriorMatrices} is \code{TRUE}.} + +\item{expandCovs}{Arguments for \code{mr.mashr::expand_covs()}, built +with \code{\link{MrmashExpandCovsOptions}}.} +} +\value{ +A \code{MrmashPriorParam} object, a \code{\link{MethodParam}}. +} +\description{ +Settings for \code{\link{buildMrmashPriorMatrices}}, the + shared prior-covariance builder behind \code{\link{mrmashWrapper}} and + \code{\link{mrmashRssWeights}}. + + The builder reaches two mr.mashr functions, so the arguments bound for + each travel in their own nested bundle --- \code{canonicalCovs} for + \code{compute_canonical_covs()} and \code{expandCovs} for + \code{expand_covs()} --- and each is checked against that function's + live formals. The two fields pecotmr itself reads stay flat. + + \code{dataDrivenPriorMatrices} is \emph{not} set here: it is an input + computed upstream (typically by \code{\link{mashPriorCovariances}}), + not a tuning choice, so it stays a parameter of the caller. +} +\examples{ +MrmashPriorParam(canonicalPriorMatrices = TRUE) +MrmashPriorParam( + canonicalCovs = MrmashCanonicalCovsOptions(singletons = FALSE) +) +} diff --git a/man/PanelFilterParam.Rd b/man/PanelFilterParam.Rd new file mode 100644 index 000000000..9617a26b0 --- /dev/null +++ b/man/PanelFilterParam.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ld.R +\docType{class} +\name{PanelFilterParam-class} +\alias{PanelFilterParam-class} +\alias{PanelFilterParam} +\title{LD Reference Panel Filtering Options} +\usage{ +PanelFilterParam(mafCutoff = 0, macCutoff = 0, imissCutoff = 1) +} +\arguments{ +\item{mafCutoff}{Minor-allele-frequency floor. Default \code{0}.} + +\item{macCutoff}{Minor-allele-count floor; the stricter of this and +\code{mafCutoff} applies, using the panel's own sample count. Default +\code{0}.} + +\item{imissCutoff}{Per-variant missingness ceiling. Default \code{1}, which +filters nothing and lets the allele-frequency sidecar be read instead of +materializing dosage.} +} +\value{ +A \code{PanelFilterParam} object, a \code{\link{MethodParam}}. +} +\description{ +Which of an LD panel's variants are kept before the panel is + used, as one checked bundle. Narrower than + \code{\link{GenotypeFilterParam}}: a panel is not a study's genotypes, so + there is no sample restriction and no variance cutoff, and the + missingness default is \code{1} (no filter) rather than \code{0}. +} +\examples{ +PanelFilterParam(mafCutoff = 0.001) +} +\seealso{ +\code{\link{GenotypeFilterParam}}, + \code{\link{SumstatsFilterParam}} +} diff --git a/man/PlinkQcOptions.Rd b/man/PlinkQcOptions.Rd new file mode 100644 index 000000000..851b56ad8 --- /dev/null +++ b/man/PlinkQcOptions.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/relatednessQc.R +\name{PlinkQcOptions} +\alias{PlinkQcOptions} +\title{Additional Arguments For plinkQC::relatednessFilter} +\usage{ +PlinkQcOptions( + otherCriterion = NULL, + otherCriterionTh = NULL, + otherCriterionThDirection = "ge", + otherCriterionIID = "IID", + otherCriterionMeasure = NULL, + ... +) +} +\arguments{ +\item{otherCriterion}{Optional data frame of additional filtering criteria.} + +\item{otherCriterionTh}{Threshold for the additional criterion.} + +\item{otherCriterionThDirection}{Direction of the threshold comparison. +Default \code{"ge"}.} + +\item{otherCriterionIID}{Column name for the individual ID in +\code{otherCriterion}. Default \code{"IID"}.} + +\item{otherCriterionMeasure}{Column name for the criterion measure.} + +\item{...}{Any other \code{plinkQC::relatednessFilter} argument.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +The secondary-criterion settings \code{filterRelatedness} + forwards to \code{plinkQC::relatednessFilter}, plus anything else that + function accepts. Names are plinkQC's own and \strong{are checked} + against \code{plinkQC::relatednessFilter}'s live formals, so the check + cannot drift from the upstream signature. See + \code{\link{MethodOptions}} for when checking is not possible. + + The pair identifiers, the relatedness column and the threshold are + \emph{not} settable here: \code{filterRelatedness} derives those from + its own \code{columns} and \code{relatednessThreshold} arguments, which + its graph pre-pruning uses as well, and injects them. +} +\examples{ +PlinkQcOptions(otherCriterionThDirection = "le") +} diff --git a/man/PoolrOptions.Rd b/man/PoolrOptions.Rd new file mode 100644 index 000000000..3a033b936 --- /dev/null +++ b/man/PoolrOptions.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pvalCombineWrappers.R +\name{PoolrOptions} +\alias{PoolrOptions} +\title{Options for the poolr Combination Tests} +\usage{ +PoolrOptions(...) +} +\arguments{ +\item{...}{Arguments for the chosen \pkg{poolr} test: \code{adjust} (the +correlation adjustment; pecotmr defaults it to \code{"generalized"}), +\code{m}, \code{size}, \code{threshold}, \code{side}, \code{batchsize} +and \code{nearpd}. The \pkg{poolr} signatures end in \code{...}, so +names cannot be checked here and a misspelling is passed through. +\code{p} and \code{R} are supplied by pecotmr and refused.} +} +\value{ +A \code{MethodOptions} record for + \code{\link{PvalMethodsParam}}. +} +\description{ +Build a record of extra arguments for \code{poolr::fisher()}, + \code{poolr::stouffer()} and \code{poolr::invchisq()} -- the engines + behind \code{\link{combinePValues}} methods \code{"fisher"}, + \code{"stouffer"} and \code{"invchisq"}. All three share one signature. +} +\examples{ +PoolrOptions(adjust = "empirical", side = 1) +} +\seealso{ +\code{\link{combinePValues}} +} diff --git a/man/PvalMethodsParam.Rd b/man/PvalMethodsParam.Rd new file mode 100644 index 000000000..675a7e6f1 --- /dev/null +++ b/man/PvalMethodsParam.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pvalCombineWrappers.R +\docType{class} +\name{PvalMethodsParam-class} +\alias{PvalMethodsParam-class} +\alias{PvalMethodsParam} +\title{Per-Method Options for combinePValues} +\usage{ +PvalMethodsParam( + fisher = NULL, + stouffer = NULL, + invchisq = NULL, + gbj = NULL, + bj = NULL, + hc = NULL, + ghc = NULL, + minp = NULL, + gbj_omni = NULL, + aspu = NULL +) +} +\arguments{ +\item{fisher, stouffer, invchisq}{Options for those poolr tests, built with +\code{\link{PoolrOptions}}.} + +\item{gbj, bj, hc, ghc, minp}{Options for those GBJ tests, built with +\code{\link{GbjOptions}}.} + +\item{gbj_omni}{Options for the GBJ omnibus test, built with +\code{\link{GbjOmniOptions}}.} + +\item{aspu}{Options for aSPU, built with \code{\link{AspuOptions}}.} +} +\value{ +A \code{PvalMethodsParam} object, a \code{\link{MethodParam}}, + for \code{combinePValues(methodArgs =)}. \code{names()} lists the + methods that were configured. +} +\description{ +Bundle per-method engine options for + \code{\link{combinePValues}}. Each entry is named for the method it + configures and built with that method's constructor, so an option meant + for one engine cannot silently reach another. +} +\details{ +Each entry may be given as a plain named list instead, which is + spliced into that method's constructor and so gets the same defaults and + the same checking. + + \code{acat}, \code{hmp}, \code{bonferroni} and \code{gates} are valid + \code{combinePValues} methods but take no options, so they are not + arguments here --- naming one is an unused-argument error. +} +\examples{ +PvalMethodsParam(aspu = AspuOptions(n.perm = 5000)) +} +\seealso{ +\code{\link{combinePValues}} +} diff --git a/man/QtlDataset.Rd b/man/QtlDataset.Rd index 9d4c8e48a..ebbf3c881 100644 --- a/man/QtlDataset.Rd +++ b/man/QtlDataset.Rd @@ -10,13 +10,7 @@ QtlDataset( phenotypes, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0), scaleResiduals = TRUE, - mafCutoff = 0, - macCutoff = 0, - xvarCutoff = 0, - imissCutoff = 0, - keepSamples = character(0), - keepVariants = character(0), - keepIndel = TRUE + genotypeFilterArgs = GenotypeFilterParam() ) } \arguments{ @@ -35,35 +29,31 @@ genotype experiment.} \item{scaleResiduals}{Logical (length 1). Default \code{TRUE}.} -\item{mafCutoff}{Numeric (length 1). Minor allele frequency threshold; -variants with \code{MAF < mafCutoff} are dropped at extraction time inside -\code{getGenotypes()} / \code{getResidualizedGenotypes()}. Default 0 (no -filter).} - -\item{macCutoff}{Numeric (length 1). Minor allele count threshold; converted -to a MAF threshold using \code{max(mafCutoff, macCutoff / (2 * n))} where -\code{n} is the post-narrowing sample count of the extracted block. Default -0 (no filter).} - -\item{xvarCutoff}{Numeric (length 1). Per-variant genotype variance -threshold; variants with column variance below this are dropped at -extraction time. Default 0 (no filter).} - -\item{imissCutoff}{Numeric (length 1). Per-sample genotype-missingness -threshold; samples with a missing-genotype rate above this are dropped at -extraction time. Default 0 (no filter).} - -\item{keepSamples}{Character vector of sample identifiers to retain. The -dataset is subset to them, narrowing \code{colData} and -\code{sampleMap} together, so the sample set has one home rather than -two. Length 0 means no restriction.} - -\item{keepVariants}{Character vector of variant identifiers to retain prior -to per-block QC. Length 0 means no restriction.} - -\item{keepIndel}{Logical (length 1). When \code{FALSE}, variants whose -alleles are not single nucleotides (indels) are dropped at extraction. -Default \code{TRUE} (keep all variants).} +\item{genotypeFilterArgs}{Which variants and samples to keep, built with +\code{\link{GenotypeFilterParam}}. A bare list is refused, since it +cannot be checked. Each field is recorded on the object and applied +lazily, at extraction time inside \code{getGenotypes()} / +\code{getResidualizedGenotypes()}: +\itemize{ + \item \code{mafCutoff} --- drop variants with + \code{MAF < mafCutoff}. Unset means 0 (no filter). + \item \code{macCutoff} --- a minor-allele-count threshold, converted + to a MAF threshold as \code{max(mafCutoff, macCutoff / (2 * n))} + with \code{n} the post-narrowing sample count of the extracted + block. Unset means 0. + \item \code{xvarCutoff} --- drop variants whose column variance is + below this. Unset means 0. + \item \code{imissCutoff} --- drop samples whose missing-genotype rate + exceeds this. Unset means 0. + \item \code{keepSamples} --- subset the dataset to these samples, + narrowing \code{colData} and \code{sampleMap} together so the + sample set has one home rather than two. Unset, or + \code{character(0)}, means no restriction. + \item \code{keepVariants} --- retain only these variants, before + per-block QC. Unset, or \code{character(0)}, means no restriction. + \item \code{keepIndel} --- when \code{FALSE}, drop variants whose + alleles are not single nucleotides. Unset means \code{TRUE}. +}} } \value{ A \code{QtlDataset} object. diff --git a/man/QtlEnrichmentParam.Rd b/man/QtlEnrichmentParam.Rd new file mode 100644 index 000000000..62fa2d137 --- /dev/null +++ b/man/QtlEnrichmentParam.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qtlEnrichmentPipeline.R +\docType{class} +\name{QtlEnrichmentParam-class} +\alias{QtlEnrichmentParam-class} +\alias{QtlEnrichmentParam} +\title{Arguments For The QTL Enrichment Estimator} +\usage{ +QtlEnrichmentParam( + numGwas = NULL, + piQtl = NULL, + lambda = 1, + impN = 25, + doubleShrinkage = FALSE, + besselCorrection = TRUE +) +} +\arguments{ +\item{numGwas}{Number of GWAS variants used to estimate \code{piGwas}. +\code{NULL} (default) estimates it from the data, which is biased unless +the outcome PIP vector really is genome-wide.} + +\item{piQtl}{Per-variant prior of being a causal QTL variant. \code{NULL} +(default) estimates it from the data.} + +\item{lambda}{Shrinkage parameter, shrinking the enrichment estimate +towards zero as in ridge regression. \code{0} applies no shrinkage. +Default \code{1.0}.} + +\item{impN}{Rounds of multiple imputation to draw QTL from. Default +\code{25}.} + +\item{doubleShrinkage}{Logical. Apply the double-shrinkage correction to +the enrichment estimate. Default \code{FALSE}.} + +\item{besselCorrection}{Logical. Apply Bessel's correction when estimating +the sampling variance. Default \code{TRUE}.} +} +\value{ +A \code{QtlEnrichmentParam} object, a \code{\link{MethodParam}}. +} +\description{ +The algorithmic settings \code{\link{qtlEnrichment}} takes, + as one checked bundle. Everything else that function accepts --- the two + data arguments, \code{numThreads}, \code{seed}, \code{verbose}, and the + \code{alignNames} switch --- is the pipeline's own business and is not + settable here. +} +\examples{ +QtlEnrichmentParam(lambda = 0, impN = 50) +} diff --git a/man/QtlSumStats.Rd b/man/QtlSumStats.Rd index 72a961392..d3fb4ea08 100644 --- a/man/QtlSumStats.Rd +++ b/man/QtlSumStats.Rd @@ -15,7 +15,7 @@ QtlSumStats( nSample = NULL, qcInfo = list(), traitPos = NULL, - ... + extraCols = list() ) } \arguments{ @@ -55,7 +55,11 @@ record. Fine-mapping / TWAS pipelines reject inputs where \code{NULL}), carried forward as provenance; not part of the identity key. \code{NULL} (default) omits the column.} -\item{...}{Additional per-tuple columns to attach to the collection.} +\item{extraCols}{Optional named list of additional per-tuple columns to +attach to the collection's \code{mcols}. Named rather than variadic +because the base class's own constructor, \code{GRangesList(...)}, uses +\code{...} for its \emph{elements}: a bare \code{...} here would read +as adding an entry rather than a metadata column.} } \value{ A \code{QtlSumStats} object. diff --git a/man/QvalueOptions.Rd b/man/QvalueOptions.Rd new file mode 100644 index 000000000..83b3770ce --- /dev/null +++ b/man/QvalueOptions.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qtlAssociationPostprocess.R +\name{QvalueOptions} +\alias{QvalueOptions} +\title{Options for Storey q-value Estimation} +\usage{ +QvalueOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{qvalue::qvalue()}: \code{pi0}, the + \code{pi0.method} / \code{lambda} pair that sets how the null + proportion is estimated, \code{pfdr}, \code{fdr.level} and + \code{lfdr.out}. \code{qvalue()}'s signature ends in \code{...}, so + names cannot be checked here and a misspelling is passed through. + \code{p} is the p-value vector pecotmr assembles and is refused. + + pecotmr retries \code{qvalue()} on its two documented degenerate cases + ("missing or infinite" with \code{lambda = 0}, "pi0 <= 0" with a + bootstrap \code{pi0}); setting \code{lambda} or \code{pi0.method} + here replaces the first attempt, and the retries still override them + when that attempt fails.} +} +\value{ +A \code{MethodOptions} record for + \code{qtlAssociationPostprocess(qvalueArgs =)}. +} +\description{ +Build a record of extra arguments for + \code{qvalue::qvalue()}, the Storey q-value engine behind + \code{\link{qtlAssociationPostprocess}}. +} +\examples{ +QvalueOptions(pi0.method = "bootstrap") +} +\seealso{ +\code{\link{qtlAssociationPostprocess}} +} diff --git a/man/RaissParam.Rd b/man/RaissParam.Rd new file mode 100644 index 000000000..f8e26f9a7 --- /dev/null +++ b/man/RaissParam.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sumstatsQc.R +\docType{class} +\name{RaissParam-class} +\alias{RaissParam-class} +\alias{RaissParam} +\title{Arguments For RAISS Imputation During Summary-Statistic QC} +\usage{ +RaissParam( + lamb = 0.01, + svdTol = 1e-12, + r2Threshold = 0.6, + minimumLd = 5, + mafCutoff = 0, + macCutoff = 0, + imissCutoff = 1, + flank = 0 +) +} +\arguments{ +\item{lamb}{Regularization term added to the LD diagonal. Default +\code{0.01}.} + +\item{svdTol}{Singular-value cutoff for the pseudo-inverse. Default +\code{1e-12}. Note this is tighter than \code{\link{raiss}}'s own +\code{1e-8} default.} + +\item{r2Threshold}{Imputation \eqn{R^2} below which a variant is dropped +from the output. Default \code{0.6}.} + +\item{minimumLd}{Minimum LD score for retaining an imputed variant. +Default \code{5}.} + +\item{mafCutoff}{Minor-allele-frequency floor for a variant to be an +imputation TARGET. Default \code{0}.} + +\item{macCutoff}{Minor-allele-count floor for a target; the stricter of +this and \code{mafCutoff} applies. Default \code{0}.} + +\item{imissCutoff}{Missingness ceiling for a target. Default \code{1}.} + +\item{flank}{Base pairs by which to widen the analysis-region window on +each side, retaining LD context for edge variants. Default \code{0}.} +} +\value{ +A \code{RaissParam} object, a \code{\link{MethodParam}}. +} +\description{ +The settings \code{\link{summaryStatsQc}} uses when + \code{impute = TRUE}. Four are forwarded to \code{\link{raiss}}; the + other four are pecotmr's own, bounding which panel variants RAISS is + asked to impute and how wide a window it reads. + + \code{\link{raiss}} also takes an \code{rcond}, but only on its + LD-matrix path. QC always hands it a genotype matrix, which routes + through the SVD solver and uses \code{svdTol} instead, so \code{rcond} + is not offered here --- naming it is an error rather than a setting that + silently does nothing. +} +\examples{ +RaissParam(mafCutoff = 0.01, flank = 5e5) +} +\seealso{ +\code{\link{summaryStatsQc}}, \code{\link{raiss}} +} diff --git a/man/RelatednessColumnsParam.Rd b/man/RelatednessColumnsParam.Rd new file mode 100644 index 000000000..600ed694b --- /dev/null +++ b/man/RelatednessColumnsParam.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/relatednessQc.R +\docType{class} +\name{RelatednessColumnsParam-class} +\alias{RelatednessColumnsParam-class} +\alias{RelatednessColumnsParam} +\title{Column Names In A Relatedness Table} +\usage{ +RelatednessColumnsParam( + iid1 = "IID1", + iid2 = "IID2", + fid1 = NULL, + fid2 = NULL, + value = "PI_HAT" +) +} +\arguments{ +\item{iid1, iid2}{Column names for the first and second individual ID. +Defaults \code{"IID1"} and \code{"IID2"}.} + +\item{fid1, fid2}{Column names for the first and second family ID, or +\code{NULL} (default) when the table has none.} + +\item{value}{Column name for the relatedness measure. Default +\code{"PI_HAT"}.} +} +\value{ +A \code{RelatednessColumnsParam} object, a \code{\link{MethodParam}}. +} +\description{ +Which columns of the \code{relatedness} data frame hold the + pair identifiers and the relatedness measure. Built by this constructor + rather than passed as a bare list so a misspelled field fails at the call + site instead of silently leaving the default in place. +} +\examples{ +RelatednessColumnsParam(value = "KINSHIP") +} diff --git a/man/RelatednessPruningParam.Rd b/man/RelatednessPruningParam.Rd new file mode 100644 index 000000000..e2fa34cb1 --- /dev/null +++ b/man/RelatednessPruningParam.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/relatednessQc.R +\docType{class} +\name{RelatednessPruningParam-class} +\alias{RelatednessPruningParam-class} +\alias{RelatednessPruningParam} +\title{Graph Pre-Pruning Controls For filterRelatedness} +\usage{ +RelatednessPruningParam( + maxComponentSize = 20L, + reduceFraction = 0.05, + maxIterations = 20L +) +} +\arguments{ +\item{maxComponentSize}{Largest connected component left untouched by +pre-pruning. Default \code{20}.} + +\item{reduceFraction}{Fraction of highest-degree nodes removed per +pre-pruning iteration. Default \code{0.05}.} + +\item{maxIterations}{Maximum plinkQC iterations used to resolve any +remaining related pairs. Default \code{20}.} +} +\value{ +A \code{RelatednessPruningParam} object, a \code{\link{MethodParam}}. +} +\description{ +Bounds on the graph-based pre-pruning that runs before + plinkQC, and on the iterative cleanup that runs after it. +} +\examples{ +RelatednessPruningParam(maxComponentSize = 50L) +} diff --git a/man/ResidualizationParam.Rd b/man/ResidualizationParam.Rd new file mode 100644 index 000000000..bfce5fa0e --- /dev/null +++ b/man/ResidualizationParam.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/QtlDataset.R +\docType{class} +\name{ResidualizationParam-class} +\alias{ResidualizationParam-class} +\alias{ResidualizationParam} +\title{Covariate Residualization Settings} +\usage{ +ResidualizationParam( + phenotypeCovariates = NULL, + genotypeCovariates = NULL, + residualizePhenotype = NULL, + residualizeGenotype = NULL, + covariateNaAction = NULL +) +} +\arguments{ +\item{phenotypeCovariates}{Covariates to residualize the phenotype on, or +\code{NULL} (default) for the dataset's own.} + +\item{genotypeCovariates}{Covariates to residualize the genotype on, or +\code{NULL} (default) for the dataset's own.} + +\item{residualizePhenotype}{Logical. Residualize on the phenotype +covariates. \code{NULL} (default) means unset, which the accessors +read as \code{TRUE}.} + +\item{residualizeGenotype}{Logical. Residualize on the genotype +covariates. \code{NULL} (default) means unset, read as \code{TRUE}.} + +\item{covariateNaAction}{How missing covariate values are handled when the +design is assembled: \code{"impute"} or \code{"drop"}. \code{NULL} +(default) leaves the accessor's own default in place.} +} +\value{ +A \code{ResidualizationParam} object, a \code{\link{MethodParam}}. +} +\description{ +What is regressed out of the phenotype and genotype before + fitting. Shared by \code{\link{fineMappingPipeline}} and + \code{\link{twasWeightsPipeline}}, which hold the same four settings. + + \code{fineMappingPipeline}'s \code{usePCA} / \code{nPCs} are + \strong{not} here. They do not residualize anything: they PCA-reduce a + multi-trait context's phenotype matrix and fine-map each top principal + component \emph{as a trait}. That is an analysis mode, a sibling of the + univariate and multivariate dispatch paths, not a covariate setting. +} +\section{Summary-statistics inputs}{ + + A \code{QtlSumStats} / \code{GwasSumStats} input carries no genotypes + or covariates, so nothing here applies and the whole bundle is + \strong{ignored} --- not refused. + + That is the opposite of \code{\link{CrossValidationParam}}, which + \emph{is} refused on those inputs + (\code{fineMappingPipeline(QtlSumStats, crossValidation = ...)} errors). + The difference is the default: CV is off unless asked for + (\code{folds = 0}), so a non-default value on a summary-statistics run + is an explicit request for something impossible. Residualization is on + by default (\code{residualizePhenotype} and \code{residualizeGenotype} + are both \code{TRUE}), so refusing a non-default would reject the + \emph{default} bundle and force every sumstats caller to unset it. + + One bundle therefore travels to either input kind unchanged, the same + way \code{CrossValidationParam}'s \code{weightMethods} / + \code{maxVariants} are carried but ignored by + \code{fineMappingPipeline}. +} + +\examples{ +ResidualizationParam(residualizeGenotype = FALSE) +} diff --git a/man/RmaOptions.Rd b/man/RmaOptions.Rd new file mode 100644 index 000000000..d1f74b147 --- /dev/null +++ b/man/RmaOptions.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/h2EstimationWrappers.R +\name{RmaOptions} +\alias{RmaOptions} +\title{Options for the Random-Effects Meta-Analysis Engine} +\usage{ +RmaOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{metafor::rma()}: \code{test} (the + null-distribution choice -- \code{"knha"} is the small-\eqn{k} + correction, and these meta-analyses often run on few studies), + \code{level}, \code{weighted}, \code{tau2} and \code{control}. + \code{rma()}'s signature ends in \code{...}, so names cannot be + checked here and a misspelling is passed through. \code{yi} and + \code{sei} are the estimate/standard-error pair pecotmr assembles and + are refused, as is \code{method}: that is the caller's + \code{metaMethod}. + + These settings apply to the first fit. pecotmr falls back to the + closed-form DerSimonian-Laird estimator when an iterative one fails, and + the fallback carries them too.} +} +\value{ +A \code{MethodOptions} record for the \code{metaArgs} argument. +} +\description{ +Build a record of extra arguments for + \code{metafor::rma()}, the random-effects meta-analysis engine behind + \code{\link{metaSldscRandom}}, + \code{\link{metaAnalysisPerCondition}} and + \code{\link{calculateFeatureScores}}. +} +\examples{ +RmaOptions(test = "knha") +} +\seealso{ +\code{\link{metaSldscRandom}}, + \code{\link{metaAnalysisPerCondition}} +} diff --git a/man/SignalScreenParam.Rd b/man/SignalScreenParam.Rd new file mode 100644 index 000000000..da214512b --- /dev/null +++ b/man/SignalScreenParam.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fineMappingPipeline.R +\docType{class} +\name{SignalScreenParam-class} +\alias{SignalScreenParam-class} +\alias{SignalScreenParam} +\title{Signal Pre-Screen Settings} +\usage{ +SignalScreenParam(pip = NULL, absZ = NULL, bf = NULL, logBf = NULL) +} +\arguments{ +\item{pip}{Posterior-inclusion-probability cutoff. A negative value uses +the adaptive \code{3 / nVariants} threshold.} + +\item{absZ}{Cutoff on the maximum absolute z-score.} + +\item{bf}{Cutoff on the maximum per-variant Bayes factor.} + +\item{logBf}{Cutoff on the maximum per-variant log Bayes factor.} +} +\value{ +A \code{SignalScreenParam} object, a \code{\link{MethodParam}}. +} +\description{ +Whether to skip a block before fitting it, and on which + metric. Shared by \code{\link{fineMappingPipeline}} and + \code{\link{colocboostPipeline}}. +} +\section{One metric at a time}{ + + The four metrics are mutually exclusive and the constructor enforces it, + so a conflicting pair fails where it is written rather than part-way + into a pipeline run. Leave them all unset (the default) to screen + nothing. +} + +\examples{ +SignalScreenParam(absZ = 5) +} diff --git a/man/SlalomParam.Rd b/man/SlalomParam.Rd new file mode 100644 index 000000000..cc56cc7c6 --- /dev/null +++ b/man/SlalomParam.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sumstatsQc.R +\docType{class} +\name{SlalomParam-class} +\alias{SlalomParam-class} +\alias{SlalomParam} +\title{Arguments For The SLALOM LD-Mismatch Check} +\usage{ +SlalomParam( + standardError = NULL, + abfPriorVariance = 0.04, + nlog10pDentistSThreshold = 4, + r2Threshold = 0.6, + leadVariantChoice = "pvalue" +) +} +\arguments{ +\item{standardError}{Per-variant standard errors. \code{NULL} (default) +leaves \code{\link{slalom}}'s own data-dependent default in place.} + +\item{abfPriorVariance}{Prior variance for the approximate Bayes factor. +Default \code{0.04}.} + +\item{nlog10pDentistSThreshold}{\code{-log10(p)} threshold on the +DENTIST-S statistic above which a variant is an outlier. Default +\code{4.0}.} + +\item{r2Threshold}{Minimum r-squared with the lead variant for a variant to +be tested. Default \code{0.6}.} + +\item{leadVariantChoice}{How the lead variant is chosen. Default +\code{"pvalue"}.} +} +\value{ +A \code{SlalomParam} object, a \code{\link{MethodParam}}. +} +\description{ +Options for \code{\link{slalom}}, pecotmr's SLALOM + implementation. Every field is a formal of that function, so an unknown + name is rejected by R as an unused argument; there is no \code{...} + because the contract is complete. Pass the result as + \code{ldMismatchQc(method = )} or + \code{summaryStatsQc(ldMismatchQcMethod = )}. +} +\examples{ +SlalomParam(r2Threshold = 0.8) +} diff --git a/man/SumstatsCleaningParam.Rd b/man/SumstatsCleaningParam.Rd new file mode 100644 index 000000000..f72ee129d --- /dev/null +++ b/man/SumstatsCleaningParam.Rd @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sumstatsQc.R +\docType{class} +\name{SumstatsCleaningParam-class} +\alias{SumstatsCleaningParam-class} +\alias{SumstatsCleaningParam} +\title{Summary-Statistics Cleaning Settings} +\usage{ +SumstatsCleaningParam( + coerceNumeric = TRUE, + normalizeChr = TRUE, + dropNonstandardChr = TRUE, + dropMissData = TRUE, + dropPOutOfRange = TRUE, + clampSmallP = TRUE, + smallPFloor = 4.94065645841247e-324, + dropZeroEffect = TRUE, + dropNonpositiveSe = TRUE +) +} +\arguments{ +\item{coerceNumeric}{Logical. Coerce the signed columns +(Z/BETA/SE/OR/LOG_ODDS/SIGNED_SUMSTAT/P/MAF/FRQ/INFO/N) to numeric. +Default \code{TRUE}.} + +\item{normalizeChr}{Logical. Strip the \code{"chr"} prefix, uppercase the +chromosome label, and map 23->X, 24->Y, M->MT. Default \code{TRUE}.} + +\item{dropNonstandardChr}{Logical. Drop variants whose CHR (after +normalization) is outside 1..22, X, Y, MT. Default \code{TRUE}.} + +\item{dropMissData}{Logical. Drop rows with NA in any vital column (chrom, +pos, A1, A2, and at least one of Z / BETA). Default \code{TRUE}.} + +\item{dropPOutOfRange}{Logical. Drop rows where \code{P < 0} or +\code{P > 1}. Default \code{TRUE}.} + +\item{clampSmallP}{Logical. Floor non-negative P values below +\code{smallPFloor} to \code{smallPFloor}, so \code{-log10(P)} stays +finite. Applied to both input and Z-derived P values. Default +\code{TRUE}.} + +\item{smallPFloor}{Numeric (length 1). The floor \code{clampSmallP} +applies. Default \code{5e-324} (R's smallest positive double).} + +\item{dropZeroEffect}{Logical. Drop rows where any effect column is exactly +0 (\code{BETA}, \code{LOG_ODDS}, \code{SIGNED_SUMSTAT}) or \code{OR} +is exactly 1. Default \code{TRUE}.} + +\item{dropNonpositiveSe}{Logical. Drop rows where \code{SE <= 0}. Default +\code{TRUE}.} +} +\value{ +A \code{SumstatsCleaningParam} object, a \code{\link{MethodParam}}. +} +\description{ +What makes a summary-statistics row a well-formed record: + type coercion, chromosome-label normalization, dropping malformed or + impossible rows, and flooring underflowed p-values. + + Separate from \code{\link{SumstatsFilterParam}} on purpose. That one + applies quality thresholds to \emph{valid} records (INFO, N, indels, + strand-ambiguous variants); this one decides whether a row is a valid + record at all. All of it is applied by \code{\link{summaryStatsQc}} + before any filter or screen runs. +} +\examples{ +SumstatsCleaningParam(clampSmallP = FALSE, dropZeroEffect = FALSE) +} diff --git a/man/SumstatsFilterParam.Rd b/man/SumstatsFilterParam.Rd new file mode 100644 index 000000000..d95b27a9f --- /dev/null +++ b/man/SumstatsFilterParam.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sumstatsQc.R +\docType{class} +\name{SumstatsFilterParam-class} +\alias{SumstatsFilterParam-class} +\alias{SumstatsFilterParam} +\title{Summary-Statistic Row Filtering Options} +\usage{ +SumstatsFilterParam( + removeIndels = FALSE, + removeStrandAmbiguous = TRUE, + infoCutoff = 0, + nCutoff = 5 +) +} +\arguments{ +\item{removeIndels}{Logical. Drop insertions and deletions. Default +\code{FALSE}.} + +\item{removeStrandAmbiguous}{Logical. Drop strand-ambiguous variants (A/T +and C/G). Default \code{TRUE}.} + +\item{infoCutoff}{Imputation-INFO floor. Default \code{0}.} + +\item{nCutoff}{Per-variant sample-size floor. Default \code{5}.} +} +\value{ +A \code{SumstatsFilterParam} object, a \code{\link{MethodParam}}. +} +\description{ +Which rows of a summary-statistics table survive QC, as one + checked bundle. These act on the sumstats themselves, not on any genotype + matrix, which is why they are separate from + \code{\link{GenotypeFilterParam}}. +} +\examples{ +SumstatsFilterParam(removeIndels = TRUE, infoCutoff = 0.8) +} +\seealso{ +\code{\link{GenotypeFilterParam}}, \code{\link{PanelFilterParam}} +} diff --git a/man/SusieRssControlOptions.Rd b/man/SusieRssControlOptions.Rd new file mode 100644 index 000000000..ec512220b --- /dev/null +++ b/man/SusieRssControlOptions.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fineMappingWrappers.R +\name{SusieRssControlOptions} +\alias{SusieRssControlOptions} +\title{Arguments For susieR's RSS Control Block} +\usage{ +SusieRssControlOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{susieR::susie_rss_control()}, under its own +names (\code{check_prior}, \code{mismatch_estimator}, ...).} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to \code{susieR::susie_rss_control()} and + from there to \code{susie_rss()}'s \code{control} argument. Names are + checked against that function's live formals, so a misspelling fails at + the call site rather than being dropped into an ignored list --- which is + what a bare named list here used to do. +} +\examples{ +SusieRssControlOptions(check_prior = TRUE) +} diff --git a/man/SusieRssParam.Rd b/man/SusieRssParam.Rd new file mode 100644 index 000000000..5cd00995f --- /dev/null +++ b/man/SusieRssParam.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fineMappingPipeline.R +\docType{class} +\name{SusieRssParam-class} +\alias{SusieRssParam-class} +\alias{SusieRssParam} +\title{SuSiE-RSS Solver Settings} +\usage{ +SusieRssParam( + serFallback = FALSE, + keepFullFit = c("fallback", "all", "none"), + rFinite = NULL, + rMismatch = "none", + control = NULL +) +} +\arguments{ +\item{serFallback}{Logical. Fall back to a single-effect fit when the +multi-effect fit is judged unreliable. Default \code{FALSE}.} + +\item{keepFullFit}{Which pre-fallback multi-effect fits to retain: +\code{"fallback"} (default) keeps them only for regions that fell back, +\code{"all"} for every region, \code{"none"} for none. Only meaningful +when \code{serFallback} is \code{TRUE}.} + +\item{rFinite}{Sample size used for the LD matrix's finiteness check, or +\code{NULL} (default) to use the panel's own.} + +\item{rMismatch}{How to treat an LD / z-score mismatch. Default +\code{"none"}.} + +\item{control}{Options for \code{susieR::susie_rss_control()}, forwarded as +\code{susie_rss()}'s \code{control} argument. Built with +\code{\link{SusieRssControlOptions}}; \code{NULL} (default) leaves that +function's own defaults in place.} +} +\value{ +A \code{SusieRssParam} object, a \code{\link{MethodParam}}. +} +\description{ +How the SuSiE-RSS fit is conditioned and what it falls back + to, on \code{QtlSumStats} / \code{GwasSumStats} input. + + SuSiE-family only, which is what the name says: every field is a + \code{susieR} concept --- \code{serFallback} drops to + \code{susie_ser}, \code{rFinite} / \code{rMismatch} are + \code{susie_rss}'s \code{R_finite} / \code{R_mismatch}, and + \code{control} is \code{susie_rss_control}. The other + summary-statistics engine, \code{mvsusieR::mvsusie_rss}, has none of + these formals and is not configured by this. +} +\examples{ +SusieRssParam(serFallback = TRUE, keepFullFit = "all") +} diff --git a/man/TwasWeightsMethodsParam.Rd b/man/TwasWeightsMethodsParam.Rd new file mode 100644 index 000000000..6834f8cec --- /dev/null +++ b/man/TwasWeightsMethodsParam.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/twasWeightsPipeline.R +\docType{class} +\name{TwasWeightsMethodsParam-class} +\alias{TwasWeightsMethodsParam-class} +\alias{TwasWeightsMethodsParam} +\title{Which TWAS Weight Methods To Run, And How} +\usage{ +TwasWeightsMethodsParam( + methods = NULL, + qtlDatasetMethods = NULL, + qtlSumStatsMethods = NULL +) +} +\arguments{ +\item{methods}{Named list of per-method options whose input path need not +be stated. Each entry is that method's \code{*Options()} record, or +\code{list()} to run it with its defaults.} + +\item{qtlDatasetMethods}{Named list of per-method options for the +individual-level path.} + +\item{qtlSumStatsMethods}{Named list of per-method options for the +summary-statistics path.} +} +\value{ +A \code{TwasWeightsMethodsParam} object, a \code{\link{MethodParam}}. +} +\description{ +Selects the methods \code{\link{twasWeightsPipeline}} runs and + carries each one's engine arguments. + + A method that runs on both individual-level and summary-statistic data + reaches a different engine on each path, so for a + \code{MultiStudyQtlDataset} carrying both there is no single set of + arguments per method. Name such a method under + \code{qtlDatasetMethods} or \code{qtlSumStatsMethods} to say which + path its options are for; name it under \code{methods} when the path + need not be stated --- a single-type run, or a method with nothing + path-specific to configure. + + Naming a method selects it. A method belongs in exactly one of the + three slots. +} +\examples{ +TwasWeightsMethodsParam(methods = list(lasso = list(), susie = list())) +TwasWeightsMethodsParam( + methods = list(susie = list()), + qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), + qtlSumStatsMethods = list(lasso = LassosumOptions()) +) +} diff --git a/man/UdFitOptions.Rd b/man/UdFitOptions.Rd new file mode 100644 index 000000000..ea8a57e87 --- /dev/null +++ b/man/UdFitOptions.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{UdFitOptions} +\alias{UdFitOptions} +\title{Arguments For udr's Fitting Step} +\usage{ +UdFitOptions(...) +} +\arguments{ +\item{...}{Any \code{udr} control field: \code{unconstrained.update}, +\code{maxiter}, \code{tol}, \code{tol.lik}, \code{penalty.type}, and +the rest of \code{udr::ud_fit_control_default()}.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{udr::ud_fit()}'s \code{control} list. + udr's tunables do not live in \code{ud_fit}'s formals --- it takes an + opaque \code{control} --- so the valid names come from + \code{udr::ud_fit_control_default()} instead. Still a live source, not + a transcription. +} +\examples{ +UdFitOptions(unconstrained.update = "ted", maxiter = 500) +} diff --git a/man/UdInitOptions.Rd b/man/UdInitOptions.Rd new file mode 100644 index 000000000..e942203b9 --- /dev/null +++ b/man/UdInitOptions.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{UdInitOptions} +\alias{UdInitOptions} +\title{Arguments For udr's Initialisation Step} +\usage{ +UdInitOptions(...) +} +\arguments{ +\item{...}{Arguments for \code{udr::ud_init()}.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{udr::ud_init()}, which sets up the + mixture before \code{udr::ud_fit()} refines it. The data and the + component matrices are pecotmr's to supply and are refused here; the + remaining names --- \code{n_unconstrained}, \code{n_rank1} --- are + checked against that function's live formals. + + udr's own spellings, not pecotmr's: this is somebody else's signature, + so \code{n_unconstrained} is written the way udr writes it. +} +\examples{ +UdInitOptions(n_unconstrained = 20L) +} diff --git a/man/VariantPruningParam.Rd b/man/VariantPruningParam.Rd new file mode 100644 index 000000000..ffdbc6d86 --- /dev/null +++ b/man/VariantPruningParam.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasPipeline.R +\docType{class} +\name{VariantPruningParam-class} +\alias{VariantPruningParam-class} +\alias{VariantPruningParam} +\title{Per-Gene Variant-Pruning Settings} +\usage{ +VariantPruningParam( + weightCutoff = 0, + csMinCor = 0.8, + pipRescue = 0, + maxVariants = Inf +) +} +\arguments{ +\item{weightCutoff}{Numeric. Drop variants with +\code{|weight| < weightCutoff}. Default \code{0} (no filter).} + +\item{csMinCor}{Numeric. Variants in a 95\% credible set whose purity +(\code{min_abs_corr}) is at least this are must-keep. Default +\code{0.8}. Requires a \code{fineMappingResult}; ignored without one.} + +\item{pipRescue}{Numeric. Variants with PIP above this are must-keep. +Default \code{0} (no PIP rescue). Requires a \code{fineMappingResult}.} + +\item{maxVariants}{Numeric. Cap on the per-gene variant count. Above it, +all must-keep variants are retained and the remaining slots filled by +descending PIP (when available) or descending \code{|weight|}. Default +\code{Inf} (no cap).} +} +\value{ +A \code{VariantPruningParam} object, a \code{\link{MethodParam}}. +} +\description{ +Which variants survive into each gene's weight matrix before + cTWAS sees it. \code{maxVariants} caps the count; \code{csMinCor} and + \code{pipRescue} mark variants as must-keep so they survive the cap. +} +\examples{ +VariantPruningParam(weightCutoff = 1e-4, maxVariants = 5000) +} diff --git a/man/WeightSelectionParam.Rd b/man/WeightSelectionParam.Rd new file mode 100644 index 000000000..935bbd299 --- /dev/null +++ b/man/WeightSelectionParam.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/causalInferencePipeline.R +\docType{class} +\name{WeightSelectionParam-class} +\alias{WeightSelectionParam-class} +\alias{WeightSelectionParam} +\title{TWAS Weight-Selection Settings} +\usage{ +WeightSelectionParam( + cutoff = 0, + pvalCutoff = Inf, + metric = "rsq", + pvalMetric = c("adj_rsq_pval", "pval") +) +} +\arguments{ +\item{cutoff}{Numeric. Minimum cross-validated r-squared a method must +reach to be eligible. Default \code{0} (no r-squared gate).} + +\item{pvalCutoff}{Numeric. A method is eligible only when its +\code{cvResult} p-value metric is below this. Default \code{Inf} (no +gate). A finite value activates selection even when \code{cutoff = 0}.} + +\item{metric}{Character. Which \code{cvResult} metric is the r-squared +used for the cutoff and for ranking; typically \code{"rsq"} or +\code{"adj_rsq"}. Default \code{"rsq"}.} + +\item{pvalMetric}{Character vector of candidate \code{cvResult} metric +names for the p-value gate; the first one present in a tuple's metrics +is used. Default \code{c("adj_rsq_pval", "pval")}.} +} +\value{ +A \code{WeightSelectionParam} object, a \code{\link{MethodParam}}. +} +\description{ +How \code{\link{causalInferencePipeline}} picks which TWAS + method's weights to use for each \code{(study, context, trait, + gwasStudy)} tuple, from the cross-validation metrics on the + \code{cvResult}. Selection runs when \code{cutoff > 0} or + \code{pvalCutoff} is finite; otherwise every method is carried through. +} +\examples{ +WeightSelectionParam(cutoff = 0.01, metric = "adj_rsq") +} diff --git a/man/asCtwasResult.Rd b/man/asCtwasResult.Rd index 741963611..0db925ff2 100644 --- a/man/asCtwasResult.Rd +++ b/man/asCtwasResult.Rd @@ -23,7 +23,7 @@ Decompose the raw list returned by \code{\link{mergeCtwasBoundaryRegions}}) into the structured, per-(study, context) \code{\link{CtwasResult}} -- the same decomposition \code{\link{ctwasPipeline}} applies to its one-shot output, exposed for the - granular \code{assembleCtwasInputs} \eqn{\to} \code{estCtwasParam} + granular \code{assembleCtwasInputs} \eqn{\to} \code{estCtwasGroupPriors} \eqn{\to} \code{screenCtwasRegions} \eqn{\to} \code{finemapCtwasRegions} path. The GWAS study is read from \code{z_snp$study} and the (single) weight method from the gene ids. diff --git a/man/assembleCtwasInputs.Rd b/man/assembleCtwasInputs.Rd index 551f04ee7..3889b6793 100644 --- a/man/assembleCtwasInputs.Rd +++ b/man/assembleCtwasInputs.Rd @@ -10,10 +10,7 @@ assembleCtwasInputs( twasZ = NULL, fineMappingResult = NULL, method = NULL, - twasWeightCutoff = 0, - csMinCor = 0.8, - minPipCutoff = 0, - maxNumVariants = Inf + variantPruningArgs = VariantPruningParam() ) } \arguments{ @@ -56,25 +53,12 @@ present; otherwise run \strong{every} method as an independent cTWAS run (one \code{CtwasResult} row-set per method). Passing the name explicitly (e.g. \code{"mrash"}) restricts the run to that single method.} -\item{twasWeightCutoff}{Numeric (length 1). Drop variants with \code{|weight| -< twasWeightCutoff} from each gene's weight matrix before ctwas sees it. -Default \code{0} (no filter).} - -\item{csMinCor}{Numeric (length 1). When \code{fineMappingResult} is -provided, variants belonging to any 95\% credible set with purity -(\code{min_abs_corr}) \code{>= csMinCor} are marked as must-keep and -survive the per-gene cap. Default \code{0.8}. Ignored without a -\code{fineMappingResult}.} - -\item{minPipCutoff}{Numeric (length 1). When \code{fineMappingResult} is -provided, variants with PIP greater than \code{minPipCutoff} are marked as -must-keep and survive the per-gene cap. Default \code{0} (no PIP rescue). -Ignored without a \code{fineMappingResult}.} - -\item{maxNumVariants}{Numeric (length 1). Cap on per-gene variant count. When -the gene has more variants than this, keep all must-keep variants and fill -remaining slots by descending PIP (when available) or descending -\code{|weight|}. Default \code{Inf} (no cap).} +\item{variantPruningArgs}{Which variants survive into each gene's weight +matrix, built with \code{\link{VariantPruningParam}}: +\code{weightCutoff}, \code{csMinCor}, \code{pipRescue} and +\code{maxVariants}. Handed whole to +\code{\link{assembleCtwasInputs}}. The \code{csMinCor} / +\code{pipRescue} rescues need a \code{fineMappingResult}.} } \value{ A list with elements \code{z_snp}, \code{z_gene} (NULL when no @@ -91,7 +75,7 @@ Builds the per-block ctwas-shape input set (\code{z_snp}, } \details{ The returned list is the SHARED STATE threaded through - \code{\link{estCtwasParam}} -> \code{\link{screenCtwasRegions}} -> + \code{\link{estCtwasGroupPriors}} -> \code{\link{screenCtwasRegions}} -> \code{\link{finemapCtwasRegions}}. Callers can short-circuit at any step (e.g. override the estimated priors before fine-mapping) or call \code{ctwasPipeline()} for the one-shot path. @@ -109,7 +93,8 @@ blocks <- GenomicRanges::GRanges("chr22", blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) -gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) +gwasByRegion <- summaryStatsQc(gss, + panelFilter = PanelFilterParam(mafCutoff = 0.0025)) assembleCtwasInputs(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample)) } diff --git a/man/bLassoWeights.Rd b/man/bLassoWeights.Rd index 977edd0bc..aae8611ce 100644 --- a/man/bLassoWeights.Rd +++ b/man/bLassoWeights.Rd @@ -4,7 +4,14 @@ \alias{bLassoWeights} \title{Compute Weights Using the Bayesian LASSO (BGLR)} \usage{ -bLassoWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) +bLassoWeights( + X, + y, + nIter = 10000, + burnIn = 2000, + thin = 5, + methodArgs = BglrOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -17,7 +24,10 @@ bLassoWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) \item{thin}{Thinning interval. Default is 5.} -\item{...}{Additional arguments passed through to `BGLR::BGLR`.} +\item{methodArgs}{Options forwarded to \code{BGLR::BGLR}, built +with \code{\link{BglrOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/bayesAWeights.Rd b/man/bayesAWeights.Rd index 83476a18a..ec52cd310 100644 --- a/man/bayesAWeights.Rd +++ b/man/bayesAWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesAWeights} \title{BayesA TWAS weights (t-distribution prior)} \usage{ -bayesAWeights(X, y, Z = NULL, ...) +bayesAWeights(X, y, Z = NULL, methodArgs = QggOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,8 +13,10 @@ bayesAWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / -\code{qgg}.} +\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built +with \code{\link{QggOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of effect-size weights, one per variant (column of diff --git a/man/bayesAlphabetWeights.Rd b/man/bayesAlphabetWeights.Rd index cf122ad04..24d71fb26 100644 --- a/man/bayesAlphabetWeights.Rd +++ b/man/bayesAlphabetWeights.Rd @@ -13,7 +13,7 @@ bayesAlphabetWeights( nit = 5000, nburn = 1000, nthin = 5, - ... + methodArgs = QggOptions() ) } \arguments{ @@ -37,7 +37,10 @@ Options are bayesN, bayesL, bayesA, bayesC, or bayesR.} \item{nthin}{Integer. Thinning interval for retained MCMC samples. Default \code{5}.} -\item{...}{Additional arguments forwarded to \code{qgg::gbayes}.} +\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built +with \code{\link{QggOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A vector containing the weights to be applied to each genotype in diff --git a/man/bayesBWeights.Rd b/man/bayesBWeights.Rd index fae5845ac..e5f0c1b3a 100644 --- a/man/bayesBWeights.Rd +++ b/man/bayesBWeights.Rd @@ -4,7 +4,15 @@ \alias{bayesBWeights} \title{Compute Weights Using BayesB} \usage{ -bayesBWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, probIn = 0.2, ...) +bayesBWeights( + X, + y, + nIter = 10000, + burnIn = 2000, + thin = 5, + probIn = 0.2, + methodArgs = BglrOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -19,7 +27,10 @@ bayesBWeights(X, y, nIter = 10000, burnIn = 2000, thin = 5, probIn = 0.2, ...) \item{probIn}{Prior inclusion probability for each marker. Default is 0.2.} -\item{...}{Additional arguments passed through to `BGLR::BGLR`.} +\item{methodArgs}{Options forwarded to \code{BGLR::BGLR}, built +with \code{\link{BglrOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/bayesCWeights.Rd b/man/bayesCWeights.Rd index 3dea01a0b..7150b95b2 100644 --- a/man/bayesCWeights.Rd +++ b/man/bayesCWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesCWeights} \title{BayesC TWAS weights (rounded-spike prior)} \usage{ -bayesCWeights(X, y, Z = NULL, pi = 0.1, ...) +bayesCWeights(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -16,8 +16,10 @@ bayesCWeights(X, y, Z = NULL, pi = 0.1, ...) \item{pi}{Numeric in (0, 1). Prior proportion of non-null effects for the BayesC mixture. Default \code{0.1}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / -\code{qgg}.} +\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built +with \code{\link{QggOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of effect-size weights, one per variant (column of diff --git a/man/bayesLWeights.Rd b/man/bayesLWeights.Rd index a0cc3e890..b94e320f8 100644 --- a/man/bayesLWeights.Rd +++ b/man/bayesLWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesLWeights} \title{BayesL TWAS weights (Laplace prior, LASSO-equivalent)} \usage{ -bayesLWeights(X, y, Z = NULL, ...) +bayesLWeights(X, y, Z = NULL, methodArgs = QggOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,8 +13,10 @@ bayesLWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / -\code{qgg}.} +\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built +with \code{\link{QggOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of effect-size weights, one per variant (column of diff --git a/man/bayesNWeights.Rd b/man/bayesNWeights.Rd index c2d37d9ec..1f5bd7a7d 100644 --- a/man/bayesNWeights.Rd +++ b/man/bayesNWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesNWeights} \title{BayesN TWAS weights (Gaussian prior, ridge-equivalent)} \usage{ -bayesNWeights(X, y, Z = NULL, ...) +bayesNWeights(X, y, Z = NULL, methodArgs = QggOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,8 +13,10 @@ bayesNWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / -\code{qgg}.} +\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built +with \code{\link{QggOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of effect-size weights, one per variant (column of diff --git a/man/bayesRWeights.Rd b/man/bayesRWeights.Rd index 4a4df34f4..10ecaab68 100644 --- a/man/bayesRWeights.Rd +++ b/man/bayesRWeights.Rd @@ -4,7 +4,7 @@ \alias{bayesRWeights} \title{BayesR TWAS weights (hierarchical mixture prior)} \usage{ -bayesRWeights(X, y, Z = NULL, ...) +bayesRWeights(X, y, Z = NULL, methodArgs = QggOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,8 +13,10 @@ bayesRWeights(X, y, Z = NULL, ...) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} -\item{...}{Additional arguments forwarded to \code{bayesAlphabetWeights} / -\code{qgg}.} +\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built +with \code{\link{QggOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of effect-size weights, one per variant (column of diff --git a/man/bglrWeights.Rd b/man/bglrWeights.Rd index 336aff2de..7e6233a1f 100644 --- a/man/bglrWeights.Rd +++ b/man/bglrWeights.Rd @@ -4,7 +4,16 @@ \alias{bglrWeights} \title{Compute Weights Using a BGLR Linear Regression Model} \usage{ -bglrWeights(X, y, model, nIter, burnIn, thin, etaArgs = list(), ...) +bglrWeights( + X, + y, + model, + nIter, + burnIn, + thin, + etaArgs = list(), + methodArgs = BglrOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -22,7 +31,10 @@ bglrWeights(X, y, model, nIter, burnIn, thin, etaArgs = list(), ...) \item{etaArgs}{Optional named list of additional arguments included in the `ETA` linear-term specification (e.g. `list(probIn = 0.05)` for BayesB).} -\item{...}{Additional arguments passed through to `BGLR::BGLR`.} +\item{methodArgs}{Options forwarded to \code{BGLR::BGLR}, built +with \code{\link{BglrOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/buildMrmashPriorMatrices.Rd b/man/buildMrmashPriorMatrices.Rd index a156b13ee..63e9f12a5 100644 --- a/man/buildMrmashPriorMatrices.Rd +++ b/man/buildMrmashPriorMatrices.Rd @@ -11,8 +11,8 @@ buildMrmashPriorMatrices( dataDrivenPriorMatrices = NULL, canonicalPriorMatrices = TRUE, priorGrid = NULL, - hetgrid = c(0, 0.25, 0.5, 0.75, 1), - singletons = TRUE + canonicalCovs = MrmashCanonicalCovsOptions(), + expandCovs = MrmashExpandCovsOptions() ) } \arguments{ @@ -23,8 +23,9 @@ buildMrmashPriorMatrices( \item{K}{Number of conditions. When NULL, inferred from \code{ncol(Bhat)}.} \item{dataDrivenPriorMatrices}{Optional list with element \code{U} (list of -raw covariance matrices) computed e.g. by \code{\link{computeCovFlash}} / -\code{\link{computeCovDiag}}.} +raw covariance matrices) computed e.g. by +\code{\link{computeCovDiag}}, or by \code{mashr::cov_flash}, which +returns such a list directly.} \item{canonicalPriorMatrices}{Logical. When TRUE (default for RSS), include the standard canonical mixture from @@ -34,12 +35,15 @@ the standard canonical mixture from \item{priorGrid}{Optional pre-computed scaling grid (numeric vector). When NULL, derived from \code{Bhat}, \code{Shat} via \code{computeGrid()}.} -\item{hetgrid}{Heterogeneity grid passed to -\code{mr.mashr::compute_canonical_covs()}. Default \code{c(0, 0.25, 0.5, -0.75, 1)}, matching the individual-level wrapper.} +\item{canonicalCovs}{Arguments for +\code{mr.mashr::compute_canonical_covs()} --- \code{singletons}, +\code{hetgrid} --- built with +\code{\link{MrmashCanonicalCovsOptions}}. Empty by default, which +leaves that function's own defaults in place.} -\item{singletons}{Whether to include single-condition prior components. -Default TRUE.} +\item{expandCovs}{Arguments for \code{mr.mashr::expand_covs()} --- +\code{zeromat} --- built with \code{\link{MrmashExpandCovsOptions}}. +Empty by default, which leaves that function's own defaults in place.} } \value{ A list with components \code{S0} (the expanded list of prior diff --git a/man/buildTopLoci.Rd b/man/buildTopLoci.Rd index b90c38044..77f37ff3b 100644 --- a/man/buildTopLoci.Rd +++ b/man/buildTopLoci.Rd @@ -17,9 +17,7 @@ buildTopLoci( otherQuantities = NULL, region = NULL, conditionIdx = NULL, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE + credibleSetArgs = CredibleSetParam(includeAllCs = FALSE) ) } \arguments{ @@ -63,14 +61,10 @@ carries no sample count: \code{n} is left \code{NA} for the per-variant \item{conditionIdx}{Integer or \code{NULL}. Index of the conditioned effect (per-condition output); \code{NULL} for the unconditioned fit.} -\item{fullFit}{Logical. Retain the full fit object on each entry. Default -\code{FALSE}.} - -\item{fullFitAlphaOnly}{Logical. When retaining the full fit, keep only the -per-effect alpha matrix. Default \code{TRUE}.} - -\item{includeAllCs}{Logical. Include all credible sets rather than only the -top one. Default \code{FALSE}.} +\item{credibleSetArgs}{How credible sets are built and reported, built with +\code{\link{CredibleSetParam}}. \code{perCsColumns} decides which +per-credible-set variant-level columns this table carries, and +\code{includeAllCs} their labels.} } \value{ A data frame in the fixed 22-column shape for this fit and method, or diff --git a/man/calculateFeatureScores.Rd b/man/calculateFeatureScores.Rd index d350507b7..1ac450297 100644 --- a/man/calculateFeatureScores.Rd +++ b/man/calculateFeatureScores.Rd @@ -4,7 +4,11 @@ \alias{calculateFeatureScores} \title{Feature score from deviation contrasts (random-effects meta per condition)} \usage{ -calculateFeatureScores(contrastResult, metaMethod = "REML") +calculateFeatureScores( + contrastResult, + metaMethod = "REML", + metaArgs = RmaOptions() +) } \arguments{ \item{contrastResult}{A contrast table from @@ -14,6 +18,10 @@ columns.} \item{metaMethod}{Between-study variance estimator forwarded to \code{metafor::rma} (default \code{"REML"}).} + +\item{metaArgs}{Extra arguments for \code{metafor::rma()}, built with +\code{\link{RmaOptions}} -- \code{test = "knha"} in particular, the +small-study correction.} } \value{ A \code{data.frame} with \code{condition} and \code{zScore}. diff --git a/man/causalInferencePipeline.Rd b/man/causalInferencePipeline.Rd index e192f20ba..0d629c377 100644 --- a/man/causalInferencePipeline.Rd +++ b/man/causalInferencePipeline.Rd @@ -8,17 +8,10 @@ causalInferencePipeline( gwasSumStats, twasWeights = NULL, fineMappingResult = NULL, - rsqCutoff = 0, - rsqPvalCutoff = Inf, - rsqOption = "rsq", - rsqPvalOption = c("adj_rsq_pval", "pval"), - mrPipCutoff = 0.5, - mrMethod = c("ivwPerVariant", "csAware"), - mrCpipCutoff = 0.5, - mrPvalCutoff = 1, + weightSelectionArgs = WeightSelectionParam(), + mrArgs = MrParam(), combineMethods = NULL, - alleleFlip = TRUE, - ... + alleleFlip = TRUE ) } \arguments{ @@ -34,55 +27,24 @@ supplied, drives the MR computation and (when \code{twasWeights = NULL}) the TWAS-Z weights via the SuSiE-style coefficients on each entry's \code{topLoci}.} -\item{rsqCutoff}{Numeric (length 1). When \code{> 0}, performs CV weight -selection (ports the legacy \code{twas_pipeline} \code{pick_best_model} + -\code{update_twas_method}): per \code{(study, context, trait, gwasStudy)} -keep only the method whose \code{cvResult} \code{rsqOption} metric is -highest among methods that clear both \code{rsqCutoff} and the -\code{rsqPvalCutoff} gate AND that produced a finite TWAS Z (the NA/Inf -re-selection); groups where no method clears the cutoffs are dropped. A -group whose methods carry no usable \code{cvResult} (the SS-TWAS path) -keeps all methods. Needs the \code{twasWeights} \code{cvResult}, so -selection is a no-op on the fineMappingResult-only path. Default \code{0} -(no selection; score every method).} - -\item{rsqPvalCutoff}{Numeric (length 1). CV-p-value gate for weight selection -(ports legacy \code{rsq_pval_cutoff}): a method is eligible only when its -\code{cvResult} \code{rsqPvalOption} metric is \code{< rsqPvalCutoff}. -Default \code{Inf} (no p-value gate). A finite value activates selection -even when \code{rsqCutoff = 0}.} - -\item{rsqOption}{Character. Which \code{cvResult} metric is the "r-squared" -used for the cutoff and ranking (ports legacy \code{rsq_option}); typically -\code{"rsq"} or \code{"adj_rsq"}. Default \code{"rsq"}.} - -\item{rsqPvalOption}{Character vector of candidate \code{cvResult} metric -names for the p-value gate (ports legacy \code{rsq_pval_option}); the first -one present in a tuple's metrics is used. Default \code{c("adj_rsq_pval", -"pval")}.} - -\item{mrPipCutoff}{Numeric (length 1). PIP threshold for a \code{topLoci} -variant to be used as an instrumental variable. Used only when -\code{mrMethod = "ivwPerVariant"}. Default \code{0.5}.} - -\item{mrMethod}{One of \code{"ivwPerVariant"} (default) or \code{"csAware"}. -The IVW-per-variant method filters topLoci variants by \code{pip > -mrPipCutoff} and IVW-pools Wald ratios across variants. The CS-aware method -groups variants by credible set (column \code{cs} in topLoci), computes a -PIP-weighted composite Wald ratio per CS using \code{mrCpipCutoff} on the -per-CS cumulative PIP, then IVW-pools across CSs and reports Cochran's Q + -I-squared in the output columns \code{Q}, \code{I2}.} - -\item{mrCpipCutoff}{Numeric (length 1). Cumulative-PIP cutoff for retaining a -credible set. Used only when \code{mrMethod = "csAware"}. Default -\code{0.5}.} - -\item{mrPvalCutoff}{Numeric (length 1). TWAS-p-value gate for running MR -(ports the legacy \code{twas_pipeline} \code{mr_pval_cutoff}): MR is -computed for a \code{(qtl tuple, gwas)} only when its \code{twasPval < -mrPvalCutoff}; otherwise the MR output columns are \code{NA}. Default -\code{1} (no gate; MR runs wherever a \code{fineMappingResult} entry -exists).} +\item{weightSelectionArgs}{How one TWAS method's weights are picked per +\code{(study, context, trait, gwasStudy)} tuple, built with +\code{\link{WeightSelectionParam}}: \code{cutoff} (minimum +cross-validated r-squared, default \code{0}), \code{pvalCutoff} (the +CV-p-value gate, default \code{Inf}), and \code{metric} / +\code{pvalMetric} naming which \code{cvResult} metrics those two read. +Selection runs when \code{cutoff > 0} or \code{pvalCutoff} is finite; +it keeps the highest-\code{metric} method among those clearing both +gates that also produced a finite TWAS Z. Otherwise every method is +carried through. Ports the legacy \code{twas_pipeline} +\code{pick_best_model} / \code{update_twas_method}.} + +\item{mrArgs}{How Mendelian randomization is run, built with +\code{\link{MrParam}}: \code{method} (\code{"ivwPerVariant"}, the +default, or \code{"csAware"}), the PIP threshold that method reads +(\code{pipCutoff} or \code{cpipCutoff}), and \code{pvalCutoff}, the +TWAS-p-value gate below which MR runs at all (default \code{1}, no +gate; otherwise the MR columns are \code{NA}).} \item{combineMethods}{Optional character vector forwarded to \code{\link{combinePValues}} for cross-method combination per @@ -93,8 +55,6 @@ skips combination.} to the GWAS by (chrom, pos) with ref/alt swaps recognized and the exposure effect / weight sign-flipped accordingly; when FALSE, match on exact alleles only, so a ref/alt swap is treated as a distinct variant.} - -\item{...}{Reserved.} } \value{ A \code{GRanges} as described above. diff --git a/man/colocPipeline.Rd b/man/colocPipeline.Rd index 7ffb7062a..ed095391a 100644 --- a/man/colocPipeline.Rd +++ b/man/colocPipeline.Rd @@ -7,20 +7,14 @@ colocPipeline( qtlFineMappingResult, gwasInput, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-09, - p1 = 1e-04, - p2 = 1e-04, - p12 = 5e-06, - finemappingMethods = "susie", + priors = ColocPriorParam(), + lbfFilterArgs = ColocLbfFilterParam(), + gwasFineMappingArgs = GwasFineMappingParam(), returnGwasFineMapping = FALSE, enrichment = NULL, - p12Max = 0.001, adjustPips = TRUE, alleleFlip = TRUE, - ... + methodArgs = ColocOptions() ) } \arguments{ @@ -33,37 +27,32 @@ colocPipeline( fine-map inline (\code{\link{QtlSumStats}} or \code{\link{GwasSumStats}}).} -\item{filterLbfCs}{Logical. When \code{TRUE} (and \code{filterLbfCsSecondary} -is \code{NULL}), keep only effects that produced a credible set -(\code{trimmedFit$sets$cs_index}). Default \code{FALSE}.} - -\item{filterLbfCsSecondary}{Optional secondary coverage (numeric in \eqn{(0, -1)}). When supplied, run a credible-set concentration filter at this -coverage level instead of \code{filterLbfCs}: each L-effect's credible set -must span fewer than \code{nVariants * filterLbfCsSecondary * -filterLbfCsConcentration} variants to be kept. Effects with diffuse -credible sets are dropped before the LBF matrix is passed to -\code{coloc::coloc.bf_bf}. Overrides \code{filterLbfCs} when set.} - -\item{filterLbfCsConcentration}{Numeric in \eqn{(0, 1)}; the concentration -factor in the cutoff above. With the default \code{0.5} a 50\% credible set -is kept only if it spans fewer than 25\% of the locus's variants. Only -consulted when \code{filterLbfCsSecondary} is non-NULL. Default \code{0.5}.} - -\item{priorTol}{Prior-variance cutoff for the default filter: effects with -\code{V <= priorTol} are dropped. Ignored when either \code{filterLbfCs} or -\code{filterLbfCsSecondary} is in use. Default \code{1e-9}.} - -\item{p1}{Prior probability of QTL signal per variant. Default \code{1e-4}.} - -\item{p2}{Prior probability of GWAS signal per variant. Default \code{1e-4}.} - -\item{p12}{Prior probability of shared signal per variant. Default -\code{5e-6}.} - -\item{finemappingMethods}{Character vector forwarded to -\code{\link{fineMappingPipeline}} when \code{gwasInput} is summary -statistics rather than a fine-mapping result. Default \code{"susie"}.} +\item{priors}{Per-variant prior probabilities, built with +\code{\link{ColocPriorParam}}: \code{p1} (QTL signal), \code{p2} (GWAS +signal) and \code{p12} (shared). Mutually exclusive with +\code{enrichment}, which derives the same three.} + +\item{lbfFilterArgs}{Credible-set filtering applied before scoring, +built with +\code{\link{ColocLbfFilterParam}}. \code{filterLbfCs} keeps only effects +that produced a credible set; supplying \code{secondary} instead runs a +concentration filter at that coverage, where an effect is kept only if +its credible set spans fewer than +\code{nVariants * secondary * concentration} variants. Diffuse effects +are dropped before the LBF matrix reaches +\code{coloc::coloc.bf_bf}. \code{priorTol} is the default filter's own +cutoff (effects with \code{V <= priorTol} are dropped) and does not +apply once \code{filterLbfCs} or \code{secondary} selects another.} + +\item{gwasFineMappingArgs}{How \code{gwasInput} is fine-mapped when it is +summary statistics rather than a fine-mapping result, built with +\code{\link{GwasFineMappingParam}}: \code{methods}, +\code{credibleSet}, \code{rss}, \code{panelFilter}, +\code{addSusieInf} and \code{fitRetention}. Inert when +\code{gwasInput} is already fine-mapped. \code{credibleSet} is the one +to check: its \code{coverage} / \code{L} decide the sets whose LBFs are +scored, so defaults here against a differently-built QTL side compare +two different things.} \item{returnGwasFineMapping}{Logical. When \code{TRUE}, attach the fine-mapping result computed from \code{gwasInput} on the returned object @@ -74,15 +63,12 @@ columns \code{gwasStudy}, \code{qtlStudy}, \code{qtlContext}, \code{enrichment}, and optionally \code{gwasContext} / \code{gwasTrait} (which the join uses when present, and which \code{\link{qtlEnrichmentPipeline}} emits for a QTL outcome side). Output -of \code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL}, each pair's -\code{p12} prior is scaled to \code{min(p12 * (1 + enrichment), p12Max)} -(the enrichment-informed colocalization variant, "enloc"). Pairs without a -matching enrichment row fall back to the baseline \code{p12} with a -warning. Default \code{NULL} (baseline coloc).} - -\item{p12Max}{Numeric scalar. Maximum value for the enrichment-adjusted -\code{p12} prior. Default \code{1e-3}. Ignored when \code{enrichment = -NULL}.} +of \code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL} the pair is +scored by enloc rather than coloc: the priors come from that table's +\code{colocP1} / \code{colocP2} / \code{colocP12} columns, and the +report gains \code{RCP} and \code{LCP}. Pairs without a matching +enrichment row fall back to the baseline priors with a warning. Default +\code{NULL} (baseline coloc).} \item{adjustPips}{Logical, default \code{TRUE}. When TRUE, before any per-pair inference the QTL and GWAS fine-mapping result collections are @@ -106,7 +92,10 @@ between the QTL and GWAS by (chrom, pos) with ref/alt swaps recognized (LBF is coding-invariant, so no sign change is needed); when FALSE, match on exact alleles only, so a ref/alt swap is treated as a distinct variant.} -\item{...}{Additional arguments forwarded to \code{coloc::coloc.bf_bf}.} +\item{methodArgs}{Additional arguments forwarded to +\code{coloc::coloc.bf_bf}, built with \code{\link{ColocOptions}}. The +prior probabilities are set through \code{priors} instead, since the +enrichment adjustment reads them too.} } \value{ A \code{\linkS4class{ColocResult}}: one element per tested @@ -119,10 +108,14 @@ A \code{\linkS4class{ColocResult}}: one element per tested standard coloc fields (\code{idx1}, \code{idx2}, \code{nSnps}, \code{hit1}, \code{hit2}, \code{PP.H0.abf} \ldots \code{PP.H4.abf}) and the reconciliation diagnostics \code{qtlRetainedMass} / - \code{gwasRetainedMass}. When \code{enrichment} is supplied, two - additional columns \code{enrichment} and \code{p12Used} report the - per-pair factor and the prior actually passed to - \code{coloc::coloc.bf_bf}. + \code{gwasRetainedMass}. When \code{enrichment} is supplied the pair is + scored by enloc instead, and four further columns appear: + \code{enrichment} and \code{p12Used} report the per-pair factor and the + shared-signal prior enloc derived, while \code{RCP} and \code{LCP} are + enloc's regional and locus colocalisation probabilities. Those two are + the same numbers as \code{PP.H4.abf} and + \code{PP.H3.abf + PP.H4.abf}, reported under enloc's names because that + is what readers of enloc output expect to find. Project it with \code{\link{getColocPairs}} (the flat table this pipeline used to return, also available as \code{as.data.frame}), @@ -160,11 +153,11 @@ directly. That choice carries three behaviours that \item \strong{fSuSiE support}: the LBF matrix lives at a different slot for fSuSiE fits (\code{fsusie_result$lBF}) and gets stacked into a single matrix. - \item \strong{Effect filtering}: \code{filterLbfCs} keeps only - effects that produced a credible set; \code{filterLbfCsSecondary} - keeps effects at a secondary coverage; otherwise the default - filter drops effects whose prior variance is below - \code{priorTol}. + \item \strong{Effect filtering}: \code{lbfFilter}'s + \code{filterLbfCs} keeps only effects that produced a credible + set, its \code{secondary} keeps effects at a secondary coverage; + otherwise the default filter drops effects whose prior variance is + below \code{priorTol}. \item \strong{Per-tuple LBF reuse}: each second-side tuple's LBF matrix is extracted once and scored against every first-side tuple, so the filtering above is applied once per tuple rather @@ -177,7 +170,7 @@ This pipeline preserves all three. \item \code{gwasInput} is a \code{\link{QtlSumStats}} or a \code{\link{GwasSumStats}}: it is fine-mapped inline by \code{\link{fineMappingPipeline}} with the supplied - \code{finemappingMethods} (default \code{"susie"}). + \code{GwasFineMappingParam()} (methods default \code{"susie"}). \item \code{gwasInput} is a fine-mapping result: used directly; no inline fine-mapping. } diff --git a/man/colocViews.Rd b/man/colocViews.Rd index f0d48c2cc..6bff247ce 100644 --- a/man/colocViews.Rd +++ b/man/colocViews.Rd @@ -23,24 +23,23 @@ getColocCredibleSets(x, coverage = 0.95, minPp4 = NULL, minAbsCorr = 0.8, ...) getColocGenes(x, ...) -\S4method{getColocPairs}{ColocResult}(x, ...) +\S4method{getColocPairs}{ColocResult}(x) -\S4method{getColocVariants}{ColocResult}(x, pooled = FALSE, ...) +\S4method{getColocVariants}{ColocResult}(x, pooled = FALSE) -\S4method{getColocGenes}{ColocResult}(x, ...) +\S4method{getColocGenes}{ColocResult}(x) \S4method{getColocCredibleSets}{ColocResult}( x, coverage = 0.95, minPp4 = NULL, minAbsCorr = 0.8, - requireMaxH4 = FALSE, - ... + requireMaxH4 = FALSE ) -\S4method{getColocPairs}{ColocBoostResult}(x, ...) +\S4method{getColocPairs}{ColocBoostResult}(x) -\S4method{getColocVariants}{ColocBoostResult}(x, pooled = FALSE, ...) +\S4method{getColocVariants}{ColocBoostResult}(x, pooled = FALSE) } \arguments{ \item{x}{A \code{ColocResult}.} diff --git a/man/colocboostPipeline.Rd b/man/colocboostPipeline.Rd index f1ca6ec3f..f57f0165d 100644 --- a/man/colocboostPipeline.Rd +++ b/man/colocboostPipeline.Rd @@ -5,7 +5,6 @@ \alias{colocboostPipeline,QtlDataset-method} \alias{colocboostPipeline,QtlSumStats-method} \alias{colocboostPipeline,MultiStudyQtlDataset-method} -\alias{colocboostPipeline,ANY-method} \title{ColocBoost multi-trait colocalization pipeline (S4)} \usage{ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) @@ -22,15 +21,10 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, + panelFilterArgs = PanelFilterParam(), + signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, - ... + methodArgs = ColocboostOptions() ) \S4method{colocboostPipeline}{QtlSumStats}( @@ -38,17 +32,13 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) gwasSumStats = NULL, contexts = NULL, traitId = NULL, - region = NULL, - cisWindow = NULL, focalTrait = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, alleleFlip = TRUE, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + panelFilterArgs = PanelFilterParam(), + methodArgs = ColocboostOptions() ) \S4method{colocboostPipeline}{MultiStudyQtlDataset}( @@ -63,18 +53,11 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, + panelFilterArgs = PanelFilterParam(), + signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, - ... + methodArgs = ColocboostOptions() ) - -\S4method{colocboostPipeline}{ANY}(qtlData, gwasSumStats = NULL, ...) } \arguments{ \item{qtlData}{One of \code{QtlDataset}, \code{QtlSumStats}, or @@ -83,9 +66,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) \item{gwasSumStats}{Optional \code{GwasSumStats} with the GWAS studies to colocalize against. \code{NULL} to skip GWAS colocalization.} -\item{...}{Additional arguments forwarded to -\code{\link[colocboost]{colocboost}} (e.g., \code{M}, \code{L}, -\code{output_level}).} +\item{...}{Required by the generic; the methods take no further arguments.} \item{contexts}{Optional character vector of context names to restrict the individual-level / QtlSumStats QTL analysis to. When \code{NULL} (default), @@ -99,10 +80,14 @@ variant-window selection).} \item{region}{Optional single-range \code{GRanges} describing the analysis window. Mutually exclusive with \code{traitId} (see the \code{QtlDataset} -accessors).} +accessors). Individual-level input only: summary statistics carry no +genotypes to window, so the \code{QtlSumStats} method does not take it +--- matching \code{\link{fineMappingPipeline}} and +\code{\link{twasWeightsPipeline}}.} \item{cisWindow}{Optional cis window in basepairs; required with -\code{traitId}, optional with \code{region}.} +\code{traitId}, optional with \code{region}. Individual-level input +only, as for \code{region}.} \item{focalTrait}{Optional trait name; when supplied and present in the assembled outcome list, the colocboost xQTL-only run uses it as the focal @@ -116,36 +101,46 @@ colocboost variants to run.} \item{samples}{Optional character vector of sample IDs to restrict the analysis to; \code{NULL} (default) uses all samples.} -\item{mafCutoff, macCutoff, imissCutoff}{Analysis-time filters applied to the -summary-statistic sides against the LD reference panel: a variant whose -panel genotypes fall below the cutoffs is dropped before the LD matrix is -built. Defaults (\code{0}, \code{0}, \code{1}) filter nothing. See the -Details section for how these relate to the individual-level cutoffs -recorded on a \code{QtlDataset}.} - -\item{pipCutoffToSkip}{Individual-level pre-filter (ports the legacy -\code{pip_cutoff_to_skip_ind}). Scalar (applied to every context) or a -context-named numeric vector. For each context, every outcome is fit with a -single-effect SuSiE (\code{L = 1}) and dropped unless some variant's PIP -exceeds the cutoff; a context with no surviving outcome is skipped. -\code{0} (default) disables it; a negative value uses \code{3 / -n_variants}. (Summary-statistic skipping is handled upstream by -\code{\link{summaryStatsQc}}'s own \code{pipCutoffToSkip}.)} - -\item{absZCutoffToSkip, bfCutoffToSkip, logBfCutoffToSkip}{Alternative -individual-level pre-filter metrics used in place of -\code{pipCutoffToSkip}: drop an outcome unless its maximum marginal -\code{|z|} (\code{absZCutoffToSkip}), or its maximum per-variant -single-effect Bayes factor (\code{bfCutoffToSkip}) / log Bayes factor -(\code{logBfCutoffToSkip}) from the \code{L = 1} fit, exceeds the cutoff. -Scalars, each defaulting to 0 (off). Exactly one screening metric may be -enabled: setting any of these requires \code{pipCutoffToSkip = 0}.} +\item{panelFilterArgs}{Analysis-time filters applied to the summary-statistic +sides against the LD reference panel, built with +\code{\link{PanelFilterParam}}: a variant whose panel genotypes fall +below its cutoffs is dropped before the LD matrix is built. The defaults +filter nothing. See the Details section for how these relate to the +individual-level cutoffs recorded on a \code{QtlDataset}.} + +\item{signalScreenArgs}{Individual-level pre-filter (ports the legacy +\code{pip_cutoff_to_skip_ind}), built with +\code{\link{SignalScreenParam}}. For each context every outcome is fit +with a single-effect SuSiE (\code{L = 1}) and dropped unless the chosen +metric exceeds its cutoff; a context with no surviving outcome is +skipped: +\itemize{ + \item \code{pip} --- the maximum PIP. A negative cutoff uses + \code{3 / n_variants}. Uniquely here it may also be a + \strong{context-named} numeric vector rather than a scalar, + applying a different cutoff per context. + \item \code{absZ} --- the maximum marginal \code{|z|}. + \item \code{bf} / \code{logBf} --- the maximum per-variant Bayes + factor or log Bayes factor from the \code{L = 1} fit. +} +Only one metric may be enabled, which +\code{\link{SignalScreenParam}} enforces when you build it. Unset (the +default) screens nothing. Summary-statistic skipping is handled upstream +by \code{\link{summaryStatsQc}}.} \item{alleleFlip}{Logical, default \code{TRUE}. When TRUE, harmonize variants across the individual X, sumstats, and LD by (chrom, pos) with ref/alt swaps recognized (flipping z / residualized dosage / LD to a shared coding); when FALSE, match on exact alleles only (names-only), so a ref/alt swap is treated as a distinct variant.} + +\item{methodArgs}{Additional arguments forwarded to +\code{colocboost::colocboost}, built with +\code{\link{ColocboostOptions}}. Names are checked against that +function's formals, so a misspelled option errors instead of being +dropped inside the run. The data slots the pipeline assembles itself +(\code{X}, \code{Y}, \code{sumstat}, \code{LD}, \code{X_ref}, +\code{focal_outcome_idx}) are refused.} } \value{ A \code{\linkS4class{ColocBoostResult}}: one element per @@ -196,15 +191,14 @@ for either side; colocboost has its own variable-selection algorithm. \code{getGenotypes()} / \code{getResidualizedGenotypes()}. The pipeline does \emph{not} run a separate individual-level QC pass. - \item \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} act - at ANALYSIS time on the sumstat sides, measured against the - \strong{LD reference panel}: a variant whose panel genotypes fall - below the cutoffs is dropped before the LD matrix is built. They - apply to a \code{QtlSumStats} QTL side and to a - \code{GwasSumStats} GWAS side (so they still bite when the QTL - side is individual-level). Defaults (\code{0}, \code{0}, - \code{1}) filter nothing. Unlike - \code{summaryStatsQc(imputeOpts = ...)}, which only bounds what + \item \code{panelFilter} acts at ANALYSIS time on the sumstat + sides, measured against the \strong{LD reference panel}: a + variant whose panel genotypes fall below its cutoffs is dropped + before the LD matrix is built. It applies to a + \code{QtlSumStats} QTL side and to a \code{GwasSumStats} GWAS + side (so it still bites when the QTL side is + individual-level). Its defaults filter nothing. Unlike + \code{summaryStatsQc(imputeArgs = ...)}, which only bounds what RAISS will impute, these discard \emph{observed} variants. \item All summary-statistic QC (variant filters, harmonization against the \code{ldSketch}, LD-mismatch detection, RAISS diff --git a/man/combinePValues.Rd b/man/combinePValues.Rd index 63fde59d4..d1147a3c4 100644 --- a/man/combinePValues.Rd +++ b/man/combinePValues.Rd @@ -1,10 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pvalCombine.R +% Please edit documentation in R/pvalCombineWrappers.R \name{combinePValues} \alias{combinePValues} \title{Combine P-values via Any of a Menu of Methods} \usage{ -combinePValues(pvals = NULL, zScores = NULL, methods, R = NULL, naRm = TRUE) +combinePValues( + pvals = NULL, + zScores = NULL, + methods, + R = NULL, + naRm = TRUE, + methodArgs = PvalMethodsParam() +) } \arguments{ \item{pvals}{Optional numeric vector of p-values. Required for methods that @@ -20,6 +27,13 @@ the menu (lowercase).} \item{naRm}{Logical; if \code{TRUE} (default), drop NA p-values before combination.} + +\item{methodArgs}{Per-method engine options, built with +\code{\link{PvalMethodsParam}} -- for example +\code{PvalMethodsParam(aspu = AspuOptions(n.perm = 5000))}. Configuring +a method that \code{methods} does not request is an error rather than a +silent no-op. \code{acat}, \code{hmp}, \code{bonferroni} and +\code{gates} take no options.} } \value{ A list with two elements: diff --git a/man/computeCoefficientsGlasso.Rd b/man/computeCoefficientsGlasso.Rd index 18d7e3e38..9a7473af8 100644 --- a/man/computeCoefficientsGlasso.Rd +++ b/man/computeCoefficientsGlasso.Rd @@ -4,7 +4,7 @@ \alias{computeCoefficientsGlasso} \title{Compute initial mr.mash coefficients via group-lasso} \usage{ -computeCoefficientsGlasso(X, Y, standardize, nthreads, Xnew = NULL) +computeCoefficientsGlasso(X, Y, standardize, numThreads, Xnew = NULL) } \arguments{ \item{X}{Numeric design matrix (samples x variants).} @@ -14,7 +14,7 @@ computeCoefficientsGlasso(X, Y, standardize, nthreads, Xnew = NULL) \item{standardize}{Logical; standardize the columns of \code{X} before fitting.} -\item{nthreads}{Integer; number of threads for the group-lasso fit.} +\item{numThreads}{Integer; number of threads for the group-lasso fit.} \item{Xnew}{Optional new design matrix for prediction; \code{NULL} returns in-sample coefficients.} @@ -32,5 +32,5 @@ data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] Y <- matrix(rnorm(nrow(X) * 3), nrow(X), 3) computeCoefficientsGlasso(X = X, Y = Y, standardize = TRUE, - nthreads = 1L, Xnew = NULL) + numThreads = 1L, Xnew = NULL) } diff --git a/man/computeCovFlash.Rd b/man/computeCovFlash.Rd deleted file mode 100644 index c6456fa75..000000000 --- a/man/computeCovFlash.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/regularizedRegressionWrappers.R -\name{computeCovFlash} -\alias{computeCovFlash} -\title{Compute covariance matrix using FLASH} -\usage{ -computeCovFlash(Y) -} -\arguments{ -\item{Y}{Numeric matrix (samples x conditions).} -} -\value{ -A covariance matrix of dimension ncol(Y) x ncol(Y), rescaled by the - column standard deviations of Y. -} -\description{ -Estimates a covariance matrix from a data matrix Y using empirical Bayes -matrix factorization (\code{flashier::flash}). When the FLASH fit finds no -shared factors, the returned covariance is diagonal with entries -\code{residuals_sd^2}; otherwise the factor contribution is added. FLASH -errors are not caught; callers should handle them explicitly or supply a -pre-computed prior covariance instead. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:30] -Y <- matrix(rnorm(nrow(X) * 3), nrow(X), 3) -computeCovFlash(Y = Y) -} diff --git a/man/computeCsCorrelation.Rd b/man/computeCsCorrelation.Rd index 89a058711..1fcb58936 100644 --- a/man/computeCsCorrelation.Rd +++ b/man/computeCsCorrelation.Rd @@ -4,16 +4,13 @@ \alias{computeCsCorrelation} \alias{computeCsCorrelation,FineMappingResultBase,SumStatsBase-method} \alias{computeCsCorrelation,FineMappingResultBase,QtlDataset-method} -\alias{computeCsCorrelation,FineMappingResultBase,ANY-method} \title{Compute Between-Credible-Set Correlation On Demand} \usage{ computeCsCorrelation(x, ldSource, ...) -\S4method{computeCsCorrelation}{FineMappingResultBase,SumStatsBase}(x, ldSource, ...) +\S4method{computeCsCorrelation}{FineMappingResultBase,SumStatsBase}(x, ldSource) -\S4method{computeCsCorrelation}{FineMappingResultBase,QtlDataset}(x, ldSource, ...) - -\S4method{computeCsCorrelation}{FineMappingResultBase,ANY}(x, ldSource, ...) +\S4method{computeCsCorrelation}{FineMappingResultBase,QtlDataset}(x, ldSource) } \arguments{ \item{x}{A \code{\link{fineMappingRow}} carrying the fit (credible-set diff --git a/man/computeLdScores.Rd b/man/computeLdScores.Rd index 477017dc5..ff2bd3cc6 100644 --- a/man/computeLdScores.Rd +++ b/man/computeLdScores.Rd @@ -8,9 +8,9 @@ \usage{ computeLdScores(ldRef, annotations = NULL, ...) -\S4method{computeLdScores}{LdEigen}(ldRef, annotations = NULL, ...) +\S4method{computeLdScores}{LdEigen}(ldRef, annotations = NULL) -\S4method{computeLdScores}{LdScore}(ldRef, annotations = NULL, ...) +\S4method{computeLdScores}{LdScore}(ldRef, annotations = NULL) } \arguments{ \item{ldRef}{An \code{LdStatistic} object.} diff --git a/man/ctwasEstExample.Rd b/man/ctwasEstExample.Rd index 225f10d7d..bda027732 100644 --- a/man/ctwasEstExample.Rd +++ b/man/ctwasEstExample.Rd @@ -11,7 +11,7 @@ A list carrying the \code{\link{ctwasInputsExample}} components plus } \description{ The augmented cTWAS state returned by -\code{\link{estCtwasParam}} (the assembled inputs plus estimated +\code{\link{estCtwasGroupPriors}} (the assembled inputs plus estimated group priors and per-region data), ready for \code{\link{screenCtwasRegions}}. Derived from the de-identified \code{protocol_example} toy data; all identifiers are synthetic. diff --git a/man/ctwasInputsExample.Rd b/man/ctwasInputsExample.Rd index 371b2baad..77ec6c070 100644 --- a/man/ctwasInputsExample.Rd +++ b/man/ctwasInputsExample.Rd @@ -12,9 +12,10 @@ A list with the cTWAS input components \code{z_snp}, \code{z_gene}, \description{ The assembled cTWAS input list produced by \code{\link{assembleCtwasInputs}} over a two-LD-block chr22 grid with one -gene, ready for \code{\link{estCtwasParam}}. Self-contained (no external LD -files needed for parameter estimation). Derived from the de-identified -\code{protocol_example} toy data; all identifiers are synthetic. +gene, ready for \code{\link{estCtwasGroupPriors}}. Self-contained (no +external LD files needed for parameter estimation). Derived from the +de-identified \code{protocol_example} toy data; all identifiers are +synthetic. } \examples{ data(ctwasInputsExample) diff --git a/man/ctwasPipeline.Rd b/man/ctwasPipeline.Rd index bacb53fbb..2788dc241 100644 --- a/man/ctwasPipeline.Rd +++ b/man/ctwasPipeline.Rd @@ -10,24 +10,13 @@ ctwasPipeline( twasZ = NULL, fineMappingResult = NULL, method = NULL, - thin = 0.1, - niterPrefit = 3L, - niter = 30L, L = 5L, - groupPriorVarStructure = c("shared_type", "shared_context", "shared_nonSNP", - "shared_all", "independent"), - ncore = 1L, - twasWeightCutoff = 0, - csMinCor = 0.8, - minPipCutoff = 0, - maxNumVariants = Inf, - fallbackToPrefit = FALSE, + numThreads = 1L, + ctwasPriorArgs = CtwasPriorParam(), + variantPruningArgs = VariantPruningParam(), + boundaryMergeArgs = BoundaryMergeParam(), keepSnps = FALSE, - mergeBoundary = FALSE, - mergePipThresh = 0.5, - mergeFilterCs = FALSE, - mergeMaxSNP = Inf, - ... + methodArgs = CtwasOptions() ) } \arguments{ @@ -70,37 +59,28 @@ present; otherwise run \strong{every} method as an independent cTWAS run (one \code{CtwasResult} row-set per method). Passing the name explicitly (e.g. \code{"mrash"}) restricts the run to that single method.} -\item{thin, niterPrefit, niter, L}{Pass-throughs to -\code{ctwas::ctwas_sumstats}.} +\item{L}{Integer. Max number of single effects in cTWAS fine-mapping. +Default \code{5}. Pass-through to \code{ctwas::ctwas_sumstats}.} -\item{groupPriorVarStructure}{Pass-through (defaults \code{"shared_type"}).} +\item{numThreads}{Number of cores. Default \code{1}.} -\item{ncore}{Number of cores. Default \code{1}.} +\item{ctwasPriorArgs}{The EM stage that estimates cTWAS's group priors, built +with \code{\link{CtwasPriorParam}}: \code{thin}, \code{niterPrefit}, +\code{niter}, \code{varStructure} and \code{fallbackToPrefit}. Handed +whole to \code{\link{estCtwasGroupPriors}}.} -\item{twasWeightCutoff}{Numeric (length 1). Drop variants with \code{|weight| -< twasWeightCutoff} from each gene's weight matrix before ctwas sees it. -Default \code{0} (no filter).} +\item{variantPruningArgs}{Which variants survive into each gene's weight +matrix, built with \code{\link{VariantPruningParam}}: +\code{weightCutoff}, \code{csMinCor}, \code{pipRescue} and +\code{maxVariants}. Handed whole to +\code{\link{assembleCtwasInputs}}. The \code{csMinCor} / +\code{pipRescue} rescues need a \code{fineMappingResult}.} -\item{csMinCor}{Numeric (length 1). When \code{fineMappingResult} is -provided, variants belonging to any 95\% credible set with purity -(\code{min_abs_corr}) \code{>= csMinCor} are marked as must-keep and -survive the per-gene cap. Default \code{0.8}. Ignored without a -\code{fineMappingResult}.} - -\item{minPipCutoff}{Numeric (length 1). When \code{fineMappingResult} is -provided, variants with PIP greater than \code{minPipCutoff} are marked as -must-keep and survive the per-gene cap. Default \code{0} (no PIP rescue). -Ignored without a \code{fineMappingResult}.} - -\item{maxNumVariants}{Numeric (length 1). Cap on per-gene variant count. When -the gene has more variants than this, keep all must-keep variants and fill -remaining slots by descending PIP (when available) or descending -\code{|weight|}. Default \code{Inf} (no cap).} - -\item{fallbackToPrefit}{Logical (length 1). Forwarded to -\code{\link{estCtwasParam}}. When \code{TRUE}, ctwas's accurate-EM NaN -failure is recovered by falling back to the prefit estimates (mirrors the -legacy ctwas_2 workaround on underpowered data). Default \code{FALSE}.} +\item{boundaryMergeArgs}{Whether a high-PIP gene straddling an LD-block +boundary has its regions merged and re-fine-mapped, built with +\code{\link{BoundaryMergeParam}}: \code{enabled} (default +\code{FALSE}), \code{pipThreshold}, \code{filterCs} and +\code{maxSnp}.} \item{keepSnps}{Logical (length 1). When \code{TRUE}, retain the context-agnostic SNP background of each run as one extra \code{CtwasResult} @@ -110,25 +90,9 @@ group) so the full ctwas output is reconstructable from the SNP rows are the null background and are dropped from the structured gene-level result.} -\item{mergeBoundary}{Logical (length 1). When \code{TRUE}, run -\code{\link{mergeCtwasBoundaryRegions}} after fine-mapping each run: a -high-PIP gene whose cis window straddles an LD-block boundary has its -adjacent regions merged and re-fine-mapped (the legacy default-off -\code{ctwas_3} post-processing). Default \code{FALSE}.} - -\item{mergePipThresh}{Numeric (length 1). PIP threshold for selecting which -boundary genes to merge (\code{\link{mergeCtwasBoundaryRegions}} -\code{pipThresh}). Default \code{0.5}. Ignored unless \code{mergeBoundary = -TRUE}.} - -\item{mergeFilterCs}{Logical (length 1). Require the boundary gene to be in a -credible set to be selected. Default \code{FALSE}. Ignored unless -\code{mergeBoundary = TRUE}.} - -\item{mergeMaxSNP}{Numeric (length 1). Per-merged-region SNP cap. Default -\code{Inf}. Ignored unless \code{mergeBoundary = TRUE}.} - -\item{...}{Additional arguments forwarded to \code{ctwas::ctwas_sumstats}.} +\item{methodArgs}{Additional arguments forwarded to ctwas, built +with \code{\link{CtwasOptions}}. Names are checked against what +the ctwas steps accept between them.} } \value{ A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, @@ -139,8 +103,9 @@ A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, fine-mapping posteriors (\code{finemap}), the run's \code{param}, and its \code{regionInfo}. For the raw \code{ctwas::finemap_regions} list (e.g. to feed \code{\link{mergeCtwasBoundaryRegions}}), call the granular - \code{\link{assembleCtwasInputs}} \eqn{\to} \code{\link{estCtwasParam}} - \eqn{\to} \code{\link{screenCtwasRegions}} \eqn{\to} + \code{\link{assembleCtwasInputs}} \eqn{\to} + \code{\link{estCtwasGroupPriors}} \eqn{\to} + \code{\link{screenCtwasRegions}} \eqn{\to} \code{\link{finemapCtwasRegions}} path instead. } \description{ @@ -187,9 +152,11 @@ blocks <- GenomicRanges::GRanges("chr22", blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) -gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) +gwasByRegion <- summaryStatsQc(gss, + panelFilter = PanelFilterParam(mafCutoff = 0.0025)) ctwasPipeline(gwasSumStats = gwasByRegion, - twasWeights = list(ctwasWeightsExample), thin = 1, niterPrefit = 3, - niter = 10, min_group_size = 1, min_p_single_effect = 0, - fallbackToPrefit = TRUE) + twasWeights = list(ctwasWeightsExample), + ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, + fallbackToPrefit = TRUE), + methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) } diff --git a/man/dentist.Rd b/man/dentist.Rd index ea1570895..77d74942b 100644 --- a/man/dentist.Rd +++ b/man/dentist.Rd @@ -11,17 +11,9 @@ dentist( nSample = NULL, windowSize = 2e+06, windowMode = c("distance", "count"), - pValueThreshold = 5.0369e-08, - propSVD = 0.4, - gcControl = FALSE, - nIter = 10, - gPvalueThreshold = 0.05, - duprThreshold = 0.99, - ncpus = 1, - correctChenEtAlBug = TRUE, minDim = 2000, ldMethod = "sample", - seed = NULL + methodArgs = DentistParam() ) } \arguments{ @@ -47,30 +39,6 @@ distance mode (base pairs). Default is 2000000 (2 Mb). Only used when \code{segmentByDist} (C++ \code{--wind-dist}), and \code{"count"} creates windows by variant count using \code{segmentByCount} (C++ \code{--wind}).} -\item{pValueThreshold}{The p-value threshold for significance. Default is -5e-8.} - -\item{propSVD}{The proportion of singular value decomposition (SVD) to use. -Default is 0.4.} - -\item{gcControl}{Logical indicating whether genomic control should be -applied. Default is FALSE.} - -\item{nIter}{The number of iterations for the Dentist algorithm. Default is -10.} - -\item{gPvalueThreshold}{The genomic p-value threshold for significance. -Default is 0.05.} - -\item{duprThreshold}{The absolute correlation r value threshold to be -considered duplicate. Default is 0.99.} - -\item{ncpus}{The number of CPU cores to use for parallel processing. Default -is 1.} - -\item{correctChenEtAlBug}{Logical indicating whether to correct the Chen et -al. bug. Default is TRUE.} - \item{minDim}{In distance mode: minimum number of SNPs per block (default 2000). In count mode: the number of variants per window (i.e., the window size).} @@ -80,12 +48,14 @@ size).} (default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is provided directly.} -\item{seed}{Integer or \code{NULL}. Random seed for the iterative -variant-partitioning RNG. \code{NULL} (default) preserves the original -DENTIST hard-coded seeds (\code{10} for the initial partition, -\code{20000 + t * 20000} per iteration) for exact fidelity with the -reference binary; a provided seed makes the partitioning reproducible under -a value of your choosing.} +\item{methodArgs}{The DENTIST algorithm settings, built with +\code{\link{DentistParam}}: \code{pValueThreshold}, \code{propSVD}, +\code{gcControl}, \code{nIter}, \code{gPvalueThreshold}, +\code{duprThreshold}, \code{numThreads}, \code{correctChenEtAlBug} +and \code{seed}. This is the same record +\code{\link{ldMismatchQc}} takes as +\code{method = DentistParam(...)}, so a setting means the same thing +and carries the same default whichever entry point reaches it.} } \value{ A data frame containing the imputed result and detected outliers. diff --git a/man/dentistSingleWindow.Rd b/man/dentistSingleWindow.Rd index ce488a046..55a80f9e0 100644 --- a/man/dentistSingleWindow.Rd +++ b/man/dentistSingleWindow.Rd @@ -15,7 +15,7 @@ dentistSingleWindow( nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - ncpus = 1, + numThreads = 1, correctChenEtAlBug = TRUE, ldMethod = "sample", seed = NULL @@ -46,7 +46,7 @@ provided; inferred from \code{X} when \code{X} is provided.} \item{duprThreshold}{Duplicate r-squared threshold. Default is 0.99.} -\item{ncpus}{Number of CPU cores. Default is 1.} +\item{numThreads}{Number of CPU cores. Default is 1.} \item{correctChenEtAlBug}{Correct the original DENTIST operator! bug. Default is TRUE.} diff --git a/man/dot-penalizedRssWeights.Rd b/man/dot-penalizedRssWeights.Rd index a89ec0995..e892039cf 100644 --- a/man/dot-penalizedRssWeights.Rd +++ b/man/dot-penalizedRssWeights.Rd @@ -14,12 +14,15 @@ lambda0 = 0, lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = PenalizedRssOptions() ) } \arguments{ -\item{stat, LD, s, selection, penalty, gamma, alpha, lambda0, lambda2, ...}{See the +\item{stat, LD, s, selection, penalty, gamma, alpha, lambda0, lambda2}{See the public wrappers for details.} + +\item{methodArgs}{Options forwarded to \code{penalizedRss}, built with +\code{\link{PenalizedRssOptions}}.} } \value{ Numeric weight vector of length \code{nrow(LD)}. diff --git a/man/dprWeights.Rd b/man/dprWeights.Rd index ef818c067..534ed90ea 100644 --- a/man/dprWeights.Rd +++ b/man/dprWeights.Rd @@ -7,13 +7,36 @@ \alias{dprAdaptiveGibbsWeights} \title{Compute Weights Using Dirichlet Process Regression (RcppDPR)} \usage{ -dprWeights(X, y, fittingMethod = "VB", retainFit = FALSE, ...) +dprWeights( + X, + y, + fittingMethod = "VB", + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) -dprVbWeights(X, y, nK = 8, retainFit = FALSE, ...) +dprVbWeights( + X, + y, + nK = 8, + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) -dprGibbsWeights(X, y, sStep = 5000, retainFit = FALSE, ...) +dprGibbsWeights( + X, + y, + sStep = 5000, + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) -dprAdaptiveGibbsWeights(X, y, retainFit = FALSE, ...) +dprAdaptiveGibbsWeights( + X, + y, + fitRetention = c("none", "slim", "full"), + methodArgs = DprOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -23,10 +46,17 @@ dprAdaptiveGibbsWeights(X, y, retainFit = FALSE, ...) \item{fittingMethod}{One of "VB", "Gibbs", or "Adaptive_Gibbs". Default is "VB".} -\item{retainFit}{Logical. Attach the full fitted-model object to the result. +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the fitted model. This +engine keeps no trimmable intermediates, so the two retaining levels +behave alike here. Default \code{FALSE}.} -\item{...}{Additional arguments passed through to `RcppDPR::fit_model`.} +\item{methodArgs}{Options forwarded to \code{RcppDPR::fit_model}, built +with \code{\link{DprOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} \item{nK}{Integer. Number of variational mixture components for the VB fit (\code{dprVbWeights}). Default \code{8}.} diff --git a/man/enetWeights.Rd b/man/enetWeights.Rd index 8788fe880..d983cd16f 100644 --- a/man/enetWeights.Rd +++ b/man/enetWeights.Rd @@ -4,12 +4,16 @@ \alias{enetWeights} \title{Compute TWAS weights via elastic net (glmnet, alpha = 0.5)} \usage{ -enetWeights(X, y) +enetWeights(X, y, methodArgs = GlmnetOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} \item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} + +\item{methodArgs}{Additional arguments forwarded to +\code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare +list is refused, since it cannot be checked against the engine's formals.} } \value{ Numeric vector of length \code{ncol(X)} of per-variant weights. diff --git a/man/enlocClusterProbabilities.Rd b/man/enlocClusterProbabilities.Rd new file mode 100644 index 000000000..17b0e1e66 --- /dev/null +++ b/man/enlocClusterProbabilities.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/enloc.R +\name{enlocClusterProbabilities} +\alias{enlocClusterProbabilities} +\title{enloc Colocalisation Probabilities For One Signal Cluster} +\usage{ +enlocClusterProbabilities( + gwasLog10Bf, + qtlPip, + pi1e, + pi1ne, + p12 = 0, + applyFloor = FALSE +) +} +\arguments{ +\item{gwasLog10Bf}{Numeric vector of per-variant GWAS log10 Bayes factors.} + +\item{qtlPip}{Numeric vector of per-variant eQTL PIPs, same length and +order.} + +\item{pi1e}{Prior probability of GWAS causality for a variant that is a +causal eQTL, \code{expit(a0 + a1)}.} + +\item{pi1ne}{The same for a variant that is not, \code{expit(a0)}.} + +\item{p12}{Prior probability of colocalisation, used only for the +small-probability floor fastenloc applies to each SNP-level term.} + +\item{applyFloor}{Logical. Apply that floor. fastenloc skips it on the +summary-statistics path, where not all variants are present.} +} +\value{ +A list with \code{ppH0} to \code{ppH4}, \code{rcp}, \code{lcp} and + \code{scp} (the per-variant colocalisation probabilities whose sum is + \code{rcp}). +} +\description{ +The quantities fastenloc reports for a single eQTL signal + cluster, given the GWAS Bayes factors and the eQTL PIPs over the same + variants. + + Both parameterisations are returned because they come from one + computation: \code{rcp} is \code{ppH4} and \code{lcp} is + \code{ppH3 + ppH4}. +} +\examples{ +enlocClusterProbabilities( + gwasLog10Bf = c(2, 0.1, 0.1), + qtlPip = c(0.7, 0.2, 0.05), + pi1e = 0.02, + pi1ne = 0.001 +) +} diff --git a/man/estCtwasGroupPriors.Rd b/man/estCtwasGroupPriors.Rd new file mode 100644 index 000000000..01b6876a8 --- /dev/null +++ b/man/estCtwasGroupPriors.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasPipeline.R +\name{estCtwasGroupPriors} +\alias{estCtwasGroupPriors} +\title{Estimate cTWAS group prior + prior variance} +\usage{ +estCtwasGroupPriors( + inputs, + ctwasPriorArgs = CtwasPriorParam(), + numThreads = 1L, + methodArgs = CtwasOptions() +) +} +\arguments{ +\item{inputs}{A list returned by \code{\link{assembleCtwasInputs}}.} + +\item{ctwasPriorArgs}{The EM settings, built with +\code{\link{CtwasPriorParam}}: \code{thin} (SNP thinning when +assembling region data), \code{niterPrefit} and \code{niter} (prefit / +accurate EM iterations), \code{varStructure}, and +\code{fallbackToPrefit} -- when \code{TRUE}, an accurate EM that fails +on a degenerate input is recovered by re-running only the prefit step +and returning those (typically finite) priors.} + +\item{numThreads}{Number of cores.} + +\item{methodArgs}{Additional arguments forwarded to ctwas, built +with \code{\link{CtwasOptions}}. Names are checked against what +the ctwas steps accept between them.} +} +\value{ +The \code{inputs} list augmented with \code{region_data}, + \code{boundary_genes}, \code{z_gene}, and \code{param}. +} +\description{ +Step 2 of the three-step \code{\link{ctwasPipeline}}: assembles + \code{region_data} from the inputs and runs \code{ctwas::est_param} (prefit + EM + accurate EM) to estimate the group prior probabilities and prior + variances. Returns the input state plus \code{region_data}, + \code{boundary_genes}, \code{z_gene}, and \code{param}. +} +\examples{ +data(ctwasInputsExample) +estCtwasGroupPriors(ctwasInputsExample, + ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, + fallbackToPrefit = TRUE), + methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) +} diff --git a/man/estCtwasParam.Rd b/man/estCtwasParam.Rd deleted file mode 100644 index ac08d7ffc..000000000 --- a/man/estCtwasParam.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ctwasPipeline.R -\name{estCtwasParam} -\alias{estCtwasParam} -\title{Estimate cTWAS group prior + prior variance} -\usage{ -estCtwasParam( - inputs, - thin = 0.1, - niterPrefit = 3L, - niter = 30L, - groupPriorVarStructure = c("shared_type", "shared_context", "shared_nonSNP", - "shared_all", "independent"), - ncore = 1L, - fallbackToPrefit = FALSE, - ... -) -} -\arguments{ -\item{inputs}{A list returned by \code{\link{assembleCtwasInputs}}.} - -\item{thin, niterPrefit, niter}{Pass-throughs to -\code{ctwas::assemble_region_data} / \code{ctwas::est_param}.} - -\item{groupPriorVarStructure}{Pass-through.} - -\item{ncore}{Number of cores.} - -\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 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 -deliberately broad; a genuinely broken input still surfaces because the -prefit re-run will itself error. Mirrors the legacy ctwas_2 workaround on -toy data where the accurate EM cannot be estimated.} - -\item{...}{Additional arguments forwarded to \code{ctwas::est_param} (e.g. -\code{min_p_single_effect}, \code{min_group_size}).} -} -\value{ -The \code{inputs} list augmented with \code{region_data}, - \code{boundary_genes}, \code{z_gene}, and \code{param}. -} -\description{ -Step 2 of the three-step \code{\link{ctwasPipeline}}: assembles - \code{region_data} from the inputs and runs \code{ctwas::est_param} (prefit - EM + accurate EM) to estimate the group prior probabilities and prior - variances. Returns the input state plus \code{region_data}, - \code{boundary_genes}, \code{z_gene}, and \code{param}. -} -\examples{ -data(ctwasInputsExample) -estCtwasParam(ctwasInputsExample, thin = 1, niterPrefit = 3, - niter = 10, min_group_size = 1, min_p_single_effect = 0, - fallbackToPrefit = TRUE) -} diff --git a/man/estimateH2.Rd b/man/estimateH2.Rd index a75f61017..da43e5925 100644 --- a/man/estimateH2.Rd +++ b/man/estimateH2.Rd @@ -21,7 +21,7 @@ estimateH2( annotations = NULL, local = FALSE, study = NULL, - ... + estimatorArgs = list() ) } \arguments{ @@ -58,6 +58,9 @@ unstratified estimation.} \item{study}{Character (length 1) or \code{NULL}. Restrict the selection to this study; \code{NULL} matches all studies.} + +\item{estimatorArgs}{Optional named list of estimator-specific options +(\code{lambda} for lder / gldsc / hdl, \code{nIter} for sldsc).} } \value{ An \code{H2Estimate} object. diff --git a/man/estimateSparsity.Rd b/man/estimateSparsity.Rd index fd3d77436..1b114d280 100644 --- a/man/estimateSparsity.Rd +++ b/man/estimateSparsity.Rd @@ -10,7 +10,8 @@ estimateSparsity(weightResults) \item{weightResults}{Named list of weight vectors or matrices as returned by \code{\link{learnTwasWeights}}. The mr.ash element should have a \code{"fit"} attribute containing the model fit object (set -\code{retainFits = TRUE} in \code{learnTwasWeights} to obtain this).} +\code{fitRetention = "slim"} in \code{learnTwasWeights} to obtain +this).} } \value{ A scalar sparsity estimate (proportion of non-zero effects). diff --git a/man/extractCsInfo.Rd b/man/extractCsInfo.Rd index 3661559b1..e7fb0fdb9 100644 --- a/man/extractCsInfo.Rd +++ b/man/extractCsInfo.Rd @@ -7,8 +7,10 @@ extractCsInfo(fmRow, csNames, topLociTable, ldSource) } \arguments{ -\item{fmRow}{A \code{\link{fineMappingRow}} carrying the SuSiE -fit and variant ids (e.g. from \code{\link{getFineMappingResult}}).} +\item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row +fine-mapping collection as returned by +\code{\link{getFineMappingResult}}, carrying the SuSiE fit and +variant ids.} \item{csNames}{Character vector. Names of the Credible Sets, usually in the format "L_".} diff --git a/man/extractTopPipInfo.Rd b/man/extractTopPipInfo.Rd index 6851486ed..8358ae3ab 100644 --- a/man/extractTopPipInfo.Rd +++ b/man/extractTopPipInfo.Rd @@ -7,8 +7,10 @@ extractTopPipInfo(fmRow, sumstats) } \arguments{ -\item{fmRow}{A \code{\link{fineMappingRow}} carrying the SuSiE -fit and variant ids (e.g. from \code{\link{getFineMappingResult}}).} +\item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row +fine-mapping collection as returned by +\code{\link{getFineMappingResult}}, carrying the SuSiE fit and +variant ids.} \item{sumstats}{A list or data frame carrying a \code{z} element aligned to the fit's variants (\code{sumstats$z}).} diff --git a/man/filterInvalidSummaryStat.Rd b/man/filterInvalidSummaryStat.Rd index bb5926eeb..24cc63190 100644 --- a/man/filterInvalidSummaryStat.Rd +++ b/man/filterInvalidSummaryStat.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashWrapper.R +% Please edit documentation in R/mashPipeline.R \name{filterInvalidSummaryStat} \alias{filterInvalidSummaryStat} \title{Filter invalid summary statistics for mash input} diff --git a/man/filterMixtureComponents.Rd b/man/filterMixtureComponents.Rd index 195fbf88e..8407923ec 100644 --- a/man/filterMixtureComponents.Rd +++ b/man/filterMixtureComponents.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashWrapper.R +% Please edit documentation in R/mashPipeline.R \name{filterMixtureComponents} \alias{filterMixtureComponents} \title{Filter conditions from mash prior mixture components} diff --git a/man/filterRelatedness.Rd b/man/filterRelatedness.Rd index 0db8f7f40..64c4e9b8c 100644 --- a/man/filterRelatedness.Rd +++ b/man/filterRelatedness.Rd @@ -8,21 +8,11 @@ filterRelatedness( relatedness, relatednessThreshold = 0.0625, analysisType = c("maximizeUnrelated", "maximizeCases"), - relatednessIid1 = "IID1", - relatednessIid2 = "IID2", - relatednessFid1 = NULL, - relatednessFid2 = NULL, - relatednessValue = "PI_HAT", + columns = RelatednessColumnsParam(), phenoData = NULL, phenoCol = "pheno", - otherCriterion = NULL, - otherCriterionThreshold = NULL, - otherCriterionDirection = "ge", - otherCriterionIid = "IID", - otherCriterionMeasure = NULL, - maxComponentSize = 20L, - reduceFraction = 0.05, - maxIterations = 20L, + pruning = RelatednessPruningParam(), + plinkQcArgs = PlinkQcOptions(), verbose = FALSE ) } @@ -37,16 +27,9 @@ considered related (default 0.0625, i.e. 2nd degree).} \code{"maximizeCases"}. The latter preserves cases in case-control studies.} -\item{relatednessIid1}{Column name for first individual ID (default "IID1").} - -\item{relatednessIid2}{Column name for second individual ID (default "IID2").} - -\item{relatednessFid1}{Column name for first family ID (default NULL).} - -\item{relatednessFid2}{Column name for second family ID (default NULL).} - -\item{relatednessValue}{Column name for the relatedness measure (default -"PI_HAT").} +\item{columns}{Which columns of \code{relatedness} hold the pair +identifiers and the relatedness measure. Build with +\code{\link{RelatednessColumnsParam}}.} \item{phenoData}{A data.frame with columns \code{IID} and the column named by \code{phenoCol}. Required when \code{analysisType = "maximizeCases"}.} @@ -54,27 +37,12 @@ studies.} \item{phenoCol}{Column name for the phenotype (default "pheno"). Expected to be binary (1 = case, 0 = control).} -\item{otherCriterion}{Optional data.frame with additional filtering criteria -(passed to \code{plinkQC::relatednessFilter}).} - -\item{otherCriterionThreshold}{Threshold for additional criterion.} - -\item{otherCriterionDirection}{Direction for threshold comparison (default -"ge").} - -\item{otherCriterionIid}{Column name for individual ID in criterion data -(default "IID").} - -\item{otherCriterionMeasure}{Column name for the criterion measure.} - -\item{maxComponentSize}{Maximum component size before graph-based pre-pruning -(default 20).} - -\item{reduceFraction}{Fraction of highest-degree nodes to remove per -iteration during pre-pruning (default 0.05).} +\item{pruning}{Bounds on the graph pre-pruning and the iterative cleanup. +Build with \code{\link{RelatednessPruningParam}}.} -\item{maxIterations}{Maximum plinkQC iterations for resolving remaining -related pairs (default 20).} +\item{plinkQcArgs}{Additional arguments forwarded to +\code{plinkQC::relatednessFilter}. Build with +\code{\link{PlinkQcOptions}}.} \item{verbose}{Logical, print progress messages (default FALSE).} } @@ -90,6 +58,6 @@ pruning (removing highest-degree nodes), then applies \examples{ rel <- data.frame(IID1 = c("s1", "s2"), IID2 = c("s2", "s3"), value = c(0.5, 0.1)) -filterRelatedness(rel, relatednessIid1 = "IID1", relatednessIid2 = "IID2", - relatednessValue = "value", relatednessThreshold = 0.2) +filterRelatedness(rel, relatednessThreshold = 0.2, + columns = RelatednessColumnsParam(value = "value")) } diff --git a/man/fineMappingMethodOptions.Rd b/man/fineMappingMethodOptions.Rd new file mode 100644 index 000000000..d81c6b9aa --- /dev/null +++ b/man/fineMappingMethodOptions.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fineMappingPipeline.R, R/fineMappingWrappers.R +\name{fineMappingMethodOptions} +\alias{fineMappingMethodOptions} +\alias{SusieOptions} +\alias{SusieRssOptions} +\alias{SusieInfOptions} +\alias{SusieInfRssOptions} +\alias{SusieAshOptions} +\alias{SusieAshRssOptions} +\alias{SerOptions} +\alias{MvsusieOptions} +\alias{MvsusieRssOptions} +\alias{FsusieOptions} +\title{Arguments For A Fine-Mapping Engine} +\usage{ +SusieOptions(...) + +SusieRssOptions(...) + +SusieInfOptions(...) + +SusieInfRssOptions(...) + +SusieAshOptions(...) + +SusieAshRssOptions(...) + +SerOptions(...) + +MvsusieOptions(...) + +MvsusieRssOptions(...) + +FsusieOptions(...) +} +\arguments{ +\item{...}{Arguments for the engine, under its own names (\code{L}, +\code{coverage}, \code{max_iter}, ...).} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to one fine-mapping engine, checked + against that engine's live formals. + + There is one constructor per ENGINE, not per method. A method whose + individual-level and summary-statistic paths run different functions + has one for each --- \code{SusieOptions} for \code{susieR::susie} and + \code{SusieRssOptions} for \code{susieR::susie_rss}, \code{MvsusieOptions} + and \code{MvsusieRssOptions} likewise. Checking the union of the two + instead would accept an \code{susie_rss}-only name on an + individual-level run and then silently drop it, and would leave + mvsusie unchecked entirely, since \code{mvsusie_rss} takes \code{...} + and a union containing it accepts any name at all. + + \code{SerOptions} and \code{FsusieOptions} have no sibling: SER is + summary-statistics-only and fSuSiE individual-only. + + Pass the result as an element of \code{\link{FineMappingMethodsParam}}, + or directly to the matching single-engine function. In the aggregator a + method accepts either of its engines' constructors, since the input + class is not known at that point. A plain list works there too and + stays checked against both; the exact engine is checked once the run's + input class is known. +} +\examples{ +SusieOptions(L = 5) +SusieRssOptions(maf_thresh = 0.01) +MvsusieOptions(prior_tol = 1e-9) +} diff --git a/man/fineMappingPipeline.Rd b/man/fineMappingPipeline.Rd index d335f6ab2..3c92657f3 100644 --- a/man/fineMappingPipeline.Rd +++ b/man/fineMappingPipeline.Rd @@ -6,7 +6,6 @@ \alias{fineMappingPipeline,MultiStudyQtlDataset-method} \alias{fineMappingPipeline,QtlSumStats-method} \alias{fineMappingPipeline,GwasSumStats-method} -\alias{fineMappingPipeline,ANY-method} \title{Fine-Mapping Pipeline} \usage{ fineMappingPipeline(data, ...) @@ -18,47 +17,23 @@ fineMappingPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, - mafCutoff = NULL, - macCutoff = NULL, - xvarCutoff = NULL, - imissCutoff = NULL, - keepIndel = NULL, - keepSamples = NULL, - keepVariants = NULL, + genotypeFilterArgs = GenotypeFilterParam(), jointRegions = FALSE, jointSpecification = NULL, addSusieInf = TRUE, - L = 10L, - Lgreedy = NULL, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, + credibleSetArgs = CredibleSetParam(), fineMappingResult = NULL, - cvFolds = 0, - cvThreads = 1, - samplePartition = NULL, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam(), + signalScreenArgs = SignalScreenParam(), usePCA = FALSE, nPCs = 10L, seed = NULL, - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, naAction = c("drop", "impute"), verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - ... + fitRetention = c("slim", "full") ) \S4method{fineMappingPipeline}{MultiStudyQtlDataset}( @@ -68,36 +43,25 @@ fineMappingPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, + genotypeFilterArgs = GenotypeFilterParam(), + panelFilterArgs = PanelFilterParam(), jointRegions = FALSE, jointSpecification = NULL, addSusieInf = TRUE, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, + credibleSetArgs = CredibleSetParam(), fineMappingResult = NULL, - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - cvFolds = 0, - cvThreads = 1, - samplePartition = NULL, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam(), + signalScreenArgs = SignalScreenParam(), + rssArgs = SusieRssParam(), + usePCA = FALSE, + nPCs = 10L, seed = NULL, naAction = c("drop", "impute"), verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - ... + fitRetention = c("slim", "full") ) \S4method{fineMappingPipeline}{QtlSumStats}( @@ -107,59 +71,31 @@ fineMappingPipeline(data, ...) traitId = NULL, jointSpecification = NULL, addSusieInf = TRUE, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, + credibleSetArgs = CredibleSetParam(), fineMappingResult = NULL, - twasWeights = NULL, + mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - serFallback = FALSE, - rFinite = NULL, - rMismatch = "none", - rssControl = NULL, - keepFullFit = "fallback", - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + fitRetention = c("slim", "full"), + rssArgs = SusieRssParam(), + panelFilterArgs = PanelFilterParam(), + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam() ) \S4method{fineMappingPipeline}{GwasSumStats}( data, methods, addSusieInf = TRUE, - L = 10L, - Lgreedy = NULL, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, - medianAbsCorr = NULL, + credibleSetArgs = CredibleSetParam(), fineMappingResult = NULL, verbose = 1, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE, - serFallback = FALSE, - rFinite = NULL, - rMismatch = "none", - rssControl = NULL, - keepFullFit = "fallback", - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + fitRetention = c("slim", "full"), + rssArgs = SusieRssParam(), + panelFilterArgs = PanelFilterParam(), + crossValidationArgs = CrossValidationParam(), + residualizationArgs = ResidualizationParam() ) - -\S4method{fineMappingPipeline}{ANY}(data, ...) } \arguments{ \item{data}{A \code{QtlDataset}, \code{MultiStudyQtlDataset}, @@ -173,11 +109,12 @@ fineMappingPipeline(data, ...) \code{c("susie", "susieInf", "mvsusie")} (any subset of \code{c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie")}, subject to per-class compatibility). - \item A named list keyed by method token, where each value is a - list of per-method kwargs to splice into the underlying - fitter, e.g. - \code{list(susie = list(L = 1, refine = FALSE), - mvsusie = list(max_iter = 500))}. Mirrors the + \item A \code{\link{FineMappingMethodsParam}} record keyed by method + token, where each value is a list of per-method kwargs to + splice into the underlying fitter, e.g. + \code{FineMappingMethodsParam(susie = list(L = 1, refine = + FALSE), mvsusie = list(max_iter = 500))}. Each + entry is checked against the engine that receives it. Mirrors the convention of \code{\link{twasWeightsPipeline}}'s \code{methods} argument. User-supplied kwargs override the capability-table defaults and any base / chained args set @@ -200,33 +137,12 @@ with \code{chrom}/\code{start}/\code{end}. Mutually exclusive with position when extracting variants. Required when \code{traitId} is supplied. Mutually exclusive with \code{region}.} -\item{mafCutoff}{Numeric or \code{NULL}. Per-call override of the -\code{QtlDataset} minor-allele-frequency filter; \code{NULL} uses the -dataset's stored value.} - -\item{macCutoff}{Numeric or \code{NULL}. Per-call override of the -\code{QtlDataset} minor-allele-count filter; \code{NULL} uses the dataset's -stored value.} - -\item{xvarCutoff}{Numeric or \code{NULL}. Per-call override of the -\code{QtlDataset} per-variant variance filter; \code{NULL} uses the -dataset's stored value.} - -\item{imissCutoff}{Numeric or \code{NULL}. Per-call override of the -\code{QtlDataset} per-sample missingness filter; \code{NULL} uses the -dataset's stored value.} - -\item{keepIndel}{Logical or \code{NULL}. Per-call override of the -\code{QtlDataset} indel-retention flag; \code{NULL} uses the dataset's -stored value.} - -\item{keepSamples}{Character vector or \code{NULL}. Per-call override of the -\code{QtlDataset} sample allow-list; \code{NULL} uses the dataset's stored -value.} - -\item{keepVariants}{Character vector or \code{NULL}. Per-call override of the -\code{QtlDataset} variant allow-list; \code{NULL} uses the dataset's stored -value.} +\item{genotypeFilterArgs}{Per-call overrides of the \code{QtlDataset}'s own +filters, built with \code{\link{GenotypeFilterParam}}. A field left unset +keeps the dataset's construct-time value, so +\code{GenotypeFilterParam(mafCutoff = 0)} pins the cutoff at zero while +\code{GenotypeFilterParam()} changes nothing. Applies to the +\code{QtlDataset} method only.} \item{jointRegions}{For QtlDataset with a multi-range \code{region}: \code{FALSE} (default) fits each range independently and merges the @@ -247,71 +163,83 @@ informative message. See the design notes in \code{R/jointSpecification.R} for the accepted grammar.} \item{addSusieInf}{Logical. When \code{susieInf} is in \code{methods} -alongside \code{susie} and/or \code{susieAsh}, controls whether the -SuSiE-inf fit initialises the chained downstream method(s). Default -\code{TRUE}.} - -\item{L}{Integer. Maximum number of SuSiE single effects. Default \code{10}.} - -\item{Lgreedy}{Integer or \code{NULL}. Number of greedily-added effects in -the SuSiE-inf refinement (the greedy-L loop). \code{NULL} (default) -disables the greedy loop and fits \code{L} directly.} - -\item{coverage}{Primary credible-set coverage (numeric, length 1). Default -\code{0.95}.} - -\item{secondaryCoverage}{Secondary coverages forwarded to -\code{postprocessFinemappingFits}. Default \code{c(0.7, 0.5)}.} - -\item{signalCutoff}{PIP cutoff for top-loci selection. Default \code{0.025}.} - -\item{minAbsCorr}{Minimum absolute correlation for credible-set purity. -Default \code{0.8}.} - -\item{medianAbsCorr}{Optional median absolute correlation for credible-set -purity, routed to \code{susieR::susie_get_cs}. A set is kept if it passes -either \code{minAbsCorr} or \code{medianAbsCorr} (OR-logic). Default -\code{NULL} (off).} +alongside \code{susie} and/or \code{susieAsh}, whether the SuSiE-inf +fit initialises the chained downstream method(s). Default \code{TRUE}. +A choice between methods rather than a property of the credible sets, +which is why it stands alone.} + +\item{credibleSetArgs}{How credible sets are built and reported, built with + \code{\link{CredibleSetParam}}: \code{coverage} (default \code{0.95}), + \code{secondaryCoverage} (\code{c(0.7, 0.5)}), \code{signalCutoff} + (the PIP cutoff for top-loci selection, \code{0.025}), + \code{minAbsCorr} (\code{0.8}) and \code{medianAbsCorr} + (\code{NULL}) for purity --- a set is kept if it passes either, OR-logic + --- and \code{includeAllCs}. \code{perCsColumns} adds the per-set + variant-level columns to \code{topLoci}. \code{L} bounds how many + credible sets can exist (default \code{10}) and \code{Lgreedy} the + greedy-L loop of the SuSiE-inf refinement. + + Most fields are read by \code{\link{postprocessFinemappingFits}}, so a + stored fit can be re-summarized under different settings without + refitting. \code{L} / \code{Lgreedy} are the exception: they are seeded + onto each SuSiE-family token's own arguments, so changing them needs a + refit.} \item{fineMappingResult}{Optional existing \code{FineMappingResult} to use as a resume cache; tuples already present are not refit.} -\item{cvFolds}{Integer. Number of cross-validation folds. Default \code{0} -(no CV). When \code{> 1}, each method is refit on the training samples of -every fold and used to predict the held-out samples; the fold partition -plus per-fold out-of-fold predictions and metrics are stored on each -\code{FineMappingRow}'s \code{cvResult} slot (see -\code{\link{getCvResult}}). \code{twasWeightsPipeline} reuses this -partition and feeds these predictions into the SR-TWAS ensemble. -Individual-level (\code{QtlDataset} / \code{MultiStudyQtlDataset}) input -only; ignored for sumstat inputs.} - -\item{cvThreads}{Integer. Number of parallel workers for the cross-validation -fold refits (passed to the shared CV engine's \code{numThreads}). Default -\code{1} (serial); \code{-1} uses all cores. Only consulted when -\code{cvFolds > 1}.} - -\item{samplePartition}{Optional pre-defined CV partition \code{data.frame} -with columns \code{Sample} and \code{Fold}. When supplied (and -\code{cvFolds > 1}), every method reuses this exact partition; otherwise a -fresh partition is generated per \code{(study, context, trait)}.} - -\item{pipCutoffToSkip}{Numeric (length 1). Individual-level single-effect -(SER) pre-screen applied to each residualized \code{(X, y)} block before a -full fit: a susie model with \code{L = 1} is fit and the block is skipped -when no PIP exceeds the cutoff (no potentially significant variant). The -summary-statistics analog lives in \code{summaryStatsQc()}. \code{0} -(default) disables the screen; a negative value uses the adaptive \code{3 / -nVariants} threshold.} - -\item{absZCutoffToSkip, bfCutoffToSkip, logBfCutoffToSkip}{Numeric (length 1). -Alternative individual-level pre-screen metrics, in place of -\code{pipCutoffToSkip}: skip a block unless its maximum marginal \code{|z|} -(\code{absZCutoffToSkip}), or its maximum per-variant single-effect Bayes -factor (\code{bfCutoffToSkip}) / log Bayes factor -(\code{logBfCutoffToSkip}) from the \code{L = 1} fit, exceeds the cutoff. -Each defaults to 0 (off). Exactly one of the four \code{*CutoffToSkip} -arguments may be non-zero (one screening metric at a time).} +\item{crossValidationArgs}{Cross-validation settings, built with + \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no + CV), \code{numThreads} for the per-fold refits, and \code{samplePartition} + to reuse a fixed partition across methods. When \code{folds > 1} each + method is refit on every fold's training samples and used to predict the + held-out ones; the partition, the out-of-fold predictions and the metrics + are stored on each \code{FineMappingRow}'s \code{cvResult} slot. + + Cross-validation holds out \strong{samples}, so it is not possible on + \code{QtlSumStats} / \code{GwasSumStats} input. Those methods accept + the argument and \strong{error} if it is set, rather than accepting it + and quietly returning results that were never cross-validated. + + \code{maxVariants} and \code{weightMethods} are honoured by + \code{\link{twasWeightsPipeline}} only and are ignored here.} + +\item{residualizationArgs}{Covariate residualization settings, built with + \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and + \code{genotypeCovariates} name which covariates to regress out + (\code{NULL}, the default, uses every available one), and + \code{residualizePhenotype} / \code{residualizeGenotype} turn each side + off. + + Only meaningful for \code{QtlDataset} / \code{MultiStudyQtlDataset} + input. A \code{QtlSumStats} / \code{GwasSumStats} run has no covariates + to regress out, so the bundle is \strong{ignored} there rather than + refused --- unlike \code{crossValidation}, which errors. Residualization + is on by default, so refusing a non-default value would reject the + default bundle; CV is off by default, so a non-default value there is an + explicit request for something the input cannot do. + + The marginal univariate effects stored on each \code{FineMappingRow} + obey the same choice as the SuSiE fit itself --- they are computed + against the same residualized \code{X} / \code{Y}.} + +\item{signalScreenArgs}{Individual-level single-effect (SER) pre-screen +applied to each residualized \code{(X, y)} block before a full fit, +built with \code{\link{SignalScreenParam}}. A susie model with +\code{L = 1} is fit and the block is skipped unless the chosen metric +exceeds its cutoff: +\itemize{ + \item \code{pip} --- the maximum PIP. A negative cutoff uses the + adaptive \code{3 / nVariants} threshold. + \item \code{absZ} --- the maximum marginal \code{|z|}, which needs + no fit. + \item \code{bf} / \code{logBf} --- the maximum per-variant Bayes + factor or log Bayes factor from the \code{L = 1} fit. +} +Only one metric may be enabled, which +\code{\link{SignalScreenParam}} enforces when you build it. Unset (the +default) screens nothing. The summary-statistics analog lives in +\code{\link{summaryStatsQc}}.} \item{usePCA}{Logical (length 1). \code{QtlDataset} only. When \code{TRUE} (default \code{FALSE}), each multi-trait context's PCA-reduced phenotype is @@ -331,8 +259,11 @@ reproducible fits; the global RNG state is restored on return. Default \code{NULL} (no seeding).} -\item{twasWeights}{Optional \code{\link{TwasWeights}} resume cache to reuse -previously fitted weights; \code{NULL} fits fresh.} +\item{mrmashPrior}{Optional \code{\link{TwasWeights}} from a previous +mr.mash \code{\link{twasWeightsPipeline}} run, mined for the mvSuSiE +data-driven prior: the retained \code{mrmash} fits supply the prior +mixture, and their cross-validation payload supplies honest per-fold +priors. \code{NULL} uses the canonical prior instead.} \item{dataDrivenPriorWeightsCutoff}{Numeric or \code{NULL}. Cutoff below which data-driven prior weights are zeroed; \code{NULL} disables the @@ -343,93 +274,47 @@ phenotype/genotype data.} \item{verbose}{Verbosity (0 silent, 1 default). Default \code{1}.} -\item{trim}{Logical (length 1). When \code{TRUE} (default) the -\code{susieFit} slot on each output \code{FineMappingRow} carries a -trimmed view of the SuSiE fit (the minimal subset needed by downstream -pipelines). When \code{FALSE} the full untrimmed \code{susie()} return is -retained so accessors like \code{getSusieFit()} and non-default-coverage -queries through \code{getCs()} can read the full posterior matrices -(\code{lbf_variable}, \code{mu}, \code{mu2}, \code{V}). The 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. Only meaningful when the input is -a \code{QtlDataset} / \code{MultiStudyQtlDataset} (ignored for sumstat -inputs).} - -\item{genotypeCovariatesToResidualize}{Character vector (or \code{NULL}) of -genotype-covariate column names to residualize against. \code{NULL} uses -every available genotype covariate.} - -\item{residualizePhenotypeCovariates}{Logical (length 1). When \code{TRUE} -(default) residualize against the phenotype-side covariates listed in -\code{phenotypeCovariatesToResidualize}. Set \code{FALSE} to disable -phenotype-covariate residualization entirely. The marginal univariate -effects stored on each \code{FineMappingRow} obey the same -residualization choice as the SuSiE fit itself -- they are computed against -the same residualized \code{X} / \code{Y}.} - -\item{residualizeGenotypeCovariates}{Logical (length 1). When \code{TRUE} -(default) residualize against the genotype-side covariates listed in -\code{genotypeCovariatesToResidualize}. Set \code{FALSE} to disable.} - -\item{serFallback}{Logical (length 1, default \code{FALSE}). -\code{QtlSumStats} / \code{GwasSumStats} (summary-statistics SuSiE-RSS -paths) only. When \code{TRUE}, after each standard multi-effect SuSiE-RSS -fit (\code{susie} / \code{susieAsh}) the pipeline reads susieR's -finite-sample R diagnostics and, if -\code{fit$R_finite_diagnostics$R_reliability_flag} is \code{TRUE}, reports -the single-effect (\code{ser_model}) result for that region instead of the -multi-effect fit. Defaults \code{FALSE} so existing callers are unchanged. -See \code{keepFullFit} for retaining the multi-effect fit.} - -\item{rFinite}{\code{QtlSumStats} / \code{GwasSumStats} only. Finite-sample -size for susieR's \code{R_finite} correction, forwarded to -\code{susieR::susie_rss()}. \code{NULL} (default) uses susieR's default, -except when a finite/EB mode is active (\code{serFallback=TRUE} or -\code{rMismatch != "none"}) and \code{rFinite} is \code{NULL}, in which -case it defaults to the LD-panel sample size \code{getNSamples(ldSketch)}.} - -\item{rMismatch}{\code{QtlSumStats} / \code{GwasSumStats} only. LD-mismatch -correction mode forwarded to \code{susieR::susie_rss()} as -\code{R_mismatch}: \code{"none"} (default), \code{"eb"} (empirical Bayes), -or \code{"eb_mix"} (residual-mixture EB).} - -\item{rssControl}{\code{QtlSumStats} / \code{GwasSumStats} only. Optional -named list of \code{susieR::susie_rss_control()} settings (e.g. -\code{check_prior}, \code{mismatch_estimator}), forwarded as -\code{susie_rss()}'s \code{control} argument. Default \code{NULL} leaves -the \code{susie_rss_control()} defaults in place.} - -\item{keepFullFit}{\code{QtlSumStats} / \code{GwasSumStats} only. Controls -retention of the pre-fallback multi-effect SuSiE-RSS fit when -\code{serFallback=TRUE}: \code{"fallback"} (default) keeps it only for -regions that fell back to SER; \code{"all"} keeps it for every region; -\code{"none"} keeps none. The retained fit and the decision are stored on -the entry's SuSiE fit and read via \code{getSusieFit(res)$multiEffectFit}, -\code{getSusieFit(res)$R_reliability_flag}, and -\code{getSusieFit(res)$serFallbackUsed}.} +\item{fitRetention}{How much of each fit the \code{susieFit} slot keeps: +\code{"slim"} (default) a trimmed view, or \code{"full"} the whole +\code{susie()} return, so \code{getSusieFit()} and +non-default-coverage \code{getCs()} queries can read the full posterior +matrices. The per-variant \code{topLoci} table is fully populated +either way --- its per-credible-set columns are governed by +\code{credibleSet}'s \code{perCsColumns}, not by this.} + +\item{panelFilterArgs}{LD-reference-panel filters for the summary-statistics +and GWAS methods, built with \code{\link{PanelFilterParam}}. See +\emph{Panel filters on the RSS path} above.} + +\item{rssArgs}{Summary-statistics solver settings for \code{QtlSumStats} / +\code{GwasSumStats} input, built with \code{\link{SusieRssParam}}: +\itemize{ + \item \code{serFallback} (default \code{FALSE}) --- after each + multi-effect SuSiE-RSS fit, read susieR's finite-sample R + diagnostics and, when + \code{fit$R_finite_diagnostics$R_reliability_flag} is \code{TRUE}, + report the single-effect (\code{ser_model}) result for that region + instead. + \item \code{keepFullFit} (default \code{"fallback"}) --- which + pre-fallback multi-effect fits to retain: only the regions that fell + back, \code{"all"}, or \code{"none"}. Meaningful only with + \code{serFallback}. The retained fit and the decision are read via + \code{getSusieFit(res)$multiEffectFit}, + \code{$R_reliability_flag} and \code{$serFallbackUsed}. + \item \code{rFinite} --- finite-sample size for susieR's + \code{R_finite} correction. \code{NULL} (default) uses susieR's + own, except when a finite/EB mode is active (\code{serFallback} or + \code{rMismatch != "none"}), where it falls back to the LD panel's + \code{getNSamples(ldSketch)}. + \item \code{rMismatch} (default \code{"none"}) --- LD-mismatch + correction forwarded as \code{R_mismatch}: also \code{"eb"} or + \code{"eb_mix"}. + \item \code{control} --- options for + \code{susieR::susie_rss_control()}, built with + \code{\link{SusieRssControlOptions}}. This was a bare named list, + which meant a misspelled option was dropped silently; the + constructor checks the names against that function's live formals. +}} } \value{ A \code{FineMappingResult} collection keyed by \code{(study, context, @@ -492,8 +377,9 @@ S4-dispatched per-region fine-mapping entry point that } \section{Chained initialisation}{ When \code{susieInf} is requested alongside - \code{susie} and/or \code{susieAsh} and \code{addSusieInf = TRUE} - (default), the SuSiE-inf fit is computed first and used as initialisation + \code{susie} and/or \code{susieAsh} and + \code{addSusieInf = TRUE} (the default), the SuSiE-inf fit is computed + first and used as initialisation for the SuSiE / SuSiE-ash fits, mirroring the legacy \code{univariateAnalysisPipeline} / \code{susieRssPipeline} chained init behaviour. SuSiE-inf is dropped from the final result when the caller did @@ -526,8 +412,8 @@ deliberately not ported here: \itemize{ \item TWAS weights computation (\code{twasWeights = TRUE} path): lives in \code{\link{twasWeightsPipeline}} now. - \item Filtering knobs (\code{mafCutoff}, \code{imissCutoff}, - \code{xvarCutoff}, \code{ldReferenceMetaFile}): individual- + \item Filtering knobs (now \code{genotypeFilter} / + \code{panelFilter}, \code{ldReferenceMetaFile}): individual- level QC lives on the \code{QtlDataset} constructor; sumstat QC lives in \code{summaryStatsQc()}. No filtering happens inside this pipeline. @@ -536,7 +422,7 @@ deliberately not ported here: reanalysis on the RSS path): these are not exposed as dedicated method tokens. Callers who want a single-effect fit can request it via per-method kwargs, e.g. - \code{methods = list(susie = list(L = 1))} (see the + \code{methods = FineMappingMethodsParam(susie = list(L = 1))} \code{methods} parameter). \item \code{loadRssData} and explicit \code{ldReferenceMetaFile} arguments: the new @@ -559,16 +445,17 @@ deliberately not ported here: \section{Panel filters on the RSS path}{ On \code{QtlSumStats} / \code{GwasSumStats} input there is no genotype matrix to filter, so - \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured - against the \strong{LD reference panel} instead: a variant whose panel - genotypes fall below the cutoffs is dropped before the z-scores and LD - matrix are built. The thresholds mean the same thing as on the - \code{QtlDataset} path (MAC is converted to a MAF equivalent and the - stricter of the two applies), so one number carries across input types. - Defaults (\code{0}, \code{0}, \code{1}) filter nothing. + \code{panelFilter}'s \code{mafCutoff} / \code{macCutoff} / + \code{imissCutoff} are measured against the \strong{LD reference panel} + instead: a variant whose panel genotypes fall below the cutoffs is + dropped before the z-scores and LD matrix are built. The thresholds mean + the same thing as \code{genotypeFilter}'s on the \code{QtlDataset} path + (MAC is converted to a MAF equivalent and the stricter of the two + applies), so one number carries across input types. The defaults filter + nothing. This discards \emph{observed} variants, unlike - \code{summaryStatsQc(imputeOpts = ...)}, which only bounds which variants + \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants RAISS will impute. Use it when the panel cannot support the LD estimate a rare variant would need. } diff --git a/man/finemapCtwasRegions.Rd b/man/finemapCtwasRegions.Rd index d056869f6..e42528c89 100644 --- a/man/finemapCtwasRegions.Rd +++ b/man/finemapCtwasRegions.Rd @@ -4,16 +4,23 @@ \alias{finemapCtwasRegions} \title{Fine-map cTWAS regions} \usage{ -finemapCtwasRegions(screenResult, L = 5L, ncore = 1L, ...) +finemapCtwasRegions( + screenResult, + L = 5L, + numThreads = 1L, + methodArgs = CtwasOptions() +) } \arguments{ \item{screenResult}{A list returned by \code{\link{screenCtwasRegions}}.} \item{L}{Pass-through.} -\item{ncore}{Number of cores.} +\item{numThreads}{Number of cores.} -\item{...}{Additional arguments forwarded to \code{ctwas::finemap_regions}.} +\item{methodArgs}{Additional arguments forwarded to ctwas, built +with \code{\link{CtwasOptions}}. Names are checked against what +the ctwas steps accept between them.} } \value{ A list mirroring \code{ctwas::ctwas_sumstats}'s output: @@ -41,11 +48,14 @@ blocks <- GenomicRanges::GRanges("chr22", blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) -gwasByRegion <- summaryStatsQc(gss, mafCutoff = 0.0025) +gwasByRegion <- summaryStatsQc(gss, + panelFilter = PanelFilterParam(mafCutoff = 0.0025)) inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample)) -est <- estCtwasParam(inp, thin = 1, niterPrefit = 3, niter = 10, - min_group_size = 1, min_p_single_effect = 0, fallbackToPrefit = TRUE) -screened <- screenCtwasRegions(est, L = 5L) +est <- estCtwasGroupPriors(inp, + ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, + fallbackToPrefit = TRUE), + methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) +screened <- screenCtwasRegions(est) finemapCtwasRegions(screened, L = 5L) } diff --git a/man/fitFsusie.Rd b/man/fitFsusie.Rd index bffdf235b..057185d89 100644 --- a/man/fitFsusie.Rd +++ b/man/fitFsusie.Rd @@ -4,7 +4,7 @@ \alias{fitFsusie} \title{Fit fSuSiE on individual-level (X, Y, pos) data} \usage{ -fitFsusie(X, Y, pos, ...) +fitFsusie(X, Y, pos, methodArgs = FsusieOptions()) } \arguments{ \item{X}{Numeric matrix of genotypes (samples x variants).} @@ -13,7 +13,9 @@ fitFsusie(X, Y, pos, ...) \item{pos}{Numeric vector of trait positions (length \code{ncol(Y)}).} -\item{...}{Additional arguments forwarded to \code{fsusieR::susiF}.} +\item{methodArgs}{Options forwarded to \code{fsusieR::susiF}, built with +\code{\link{FsusieOptions}}. A bare list is refused: it cannot be checked +against the engine, so a misspelled option would be silently ignored.} } \value{ The fit object returned by \code{fsusieR::susiF}. @@ -30,5 +32,5 @@ base <- sin(seq(0, 2 * pi, length.out = nPos)) Y <- matrix(rep(base, each = n), n, nPos) + X[, 1] \%o\% (0.5 * cos(seq(0, pi, length.out = nPos))) pos <- seq_len(nPos) -fitFsusie(X, Y, pos = pos, L = 2) +fitFsusie(X, Y, pos = pos, methodArgs = FsusieOptions(L = 2)) } diff --git a/man/fitMvsusie.Rd b/man/fitMvsusie.Rd index 306d39f00..3f35d87a9 100644 --- a/man/fitMvsusie.Rd +++ b/man/fitMvsusie.Rd @@ -4,7 +4,13 @@ \alias{fitMvsusie} \title{Fit mvSuSiE on individual-level (X, Y) data} \usage{ -fitMvsusie(X, Y, prior_variance, coverage = 0.95, ...) +fitMvsusie( + X, + Y, + prior_variance, + coverage = 0.95, + methodArgs = MvsusieOptions() +) } \arguments{ \item{X}{Numeric matrix of genotypes (samples x variants).} @@ -18,7 +24,10 @@ domain-specific prior.} \item{coverage}{Credible set coverage (default 0.95).} -\item{...}{Additional arguments forwarded to \code{mvsusieR::mvsusie}.} +\item{methodArgs}{Options forwarded to \code{mvsusieR::mvsusie}, built +with \code{\link{MvsusieOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be silently +ignored.} } \value{ The fit object returned by \code{mvsusieR::mvsusie}. diff --git a/man/fitMvsusieRss.Rd b/man/fitMvsusieRss.Rd index 8fb8aa55f..8f9d891dc 100644 --- a/man/fitMvsusieRss.Rd +++ b/man/fitMvsusieRss.Rd @@ -4,7 +4,14 @@ \alias{fitMvsusieRss} \title{Fit mvSuSiE-RSS on summary-statistic (Z, R, N) data} \usage{ -fitMvsusieRss(Z, R, N, prior_variance, coverage = 0.95, ...) +fitMvsusieRss( + Z, + R, + N, + prior_variance, + coverage = 0.95, + methodArgs = MvsusieRssOptions() +) } \arguments{ \item{Z}{Numeric matrix of Z-scores (variants x conditions).} @@ -17,7 +24,10 @@ fitMvsusieRss(Z, R, N, prior_variance, coverage = 0.95, ...) \item{coverage}{Credible set coverage (default 0.95).} -\item{...}{Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}.} +\item{methodArgs}{Options forwarded to \code{mvsusieR::mvsusie_rss}, +built with \code{\link{MvsusieRssOptions}} --- the RSS entry point has +its own constructor, since it is a different function from +\code{mvsusie} with different arguments.} } \value{ The fit object returned by \code{mvsusieR::mvsusie_rss}. diff --git a/man/fitSusieInfThenSusieRss.Rd b/man/fitSusieInfThenSusieRss.Rd index fe6ad5c81..9162e1b82 100644 --- a/man/fitSusieInfThenSusieRss.Rd +++ b/man/fitSusieInfThenSusieRss.Rd @@ -9,8 +9,8 @@ fitSusieInfThenSusieRss( R, n, args = list(), - susieInfArgs = list(), - susieArgs = list(), + SusieInfOptions = list(), + SusieOptions = list(), fittedModels = NULL ) } @@ -21,11 +21,15 @@ fitSusieInfThenSusieRss( \item{n}{Sample size (scalar).} -\item{args}{Default arguments forwarded to both fits.} +\item{args}{Defaults forwarded to both fits, built with +\code{\link{SusieOptions}}. A bare list is refused, since it cannot be +checked; \code{list()} (the default) means no options.} -\item{susieInfArgs}{SuSiE-inf-specific overrides.} +\item{SusieInfOptions}{SuSiE-inf-specific overrides, built with +\code{\link{SusieInfOptions}}; they take precedence over \code{args}.} -\item{susieArgs}{Standard SuSiE-RSS-specific overrides.} +\item{SusieOptions}{Standard SuSiE-RSS-specific overrides, built with +\code{\link{SusieOptions}}; they take precedence over \code{args}.} \item{fittedModels}{Optional list with pre-fitted \code{$susie} and/or \code{$susieInf} objects to skip re-fitting.} diff --git a/man/fsusieAffectedRegions.Rd b/man/fsusieAffectedRegions.Rd index cf93dc1e0..9a3ebb28b 100644 --- a/man/fsusieAffectedRegions.Rd +++ b/man/fsusieAffectedRegions.Rd @@ -7,7 +7,7 @@ \usage{ fsusieAffectedRegions(x, ...) -\S4method{fsusieAffectedRegions}{FineMappingResultBase}(x, ...) +\S4method{fsusieAffectedRegions}{FineMappingResultBase}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} diff --git a/man/fsusieCredibleBand.Rd b/man/fsusieCredibleBand.Rd index 038f6d295..20a698bf1 100644 --- a/man/fsusieCredibleBand.Rd +++ b/man/fsusieCredibleBand.Rd @@ -7,7 +7,7 @@ \usage{ fsusieCredibleBand(x, ...) -\S4method{fsusieCredibleBand}{FineMappingResultBase}(x, ...) +\S4method{fsusieCredibleBand}{FineMappingResultBase}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} diff --git a/man/fsusieWeights.Rd b/man/fsusieWeights.Rd index 1937ec293..67e274041 100644 --- a/man/fsusieWeights.Rd +++ b/man/fsusieWeights.Rd @@ -10,7 +10,7 @@ fsusieWeights( Y = NULL, variantIds = NULL, featureNames = NULL, - retainFit = FALSE + fitRetention = c("none", "slim", "full") ) } \arguments{ @@ -32,7 +32,10 @@ of SNPs in the fit) for the matrix row names. Defaults to \item{featureNames}{Optional character vector of feature (outcome) names for the matrix column names. Defaults to the fit's \code{outing_grid}.} -\item{retainFit}{If TRUE, stores the fit as an attribute on the result.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ A numeric matrix of variant (rows) by feature (columns) weights. diff --git a/man/fsusieWrapper.Rd b/man/fsusieWrapper.Rd index 0329eb1a5..420e1632b 100644 --- a/man/fsusieWrapper.Rd +++ b/man/fsusieWrapper.Rd @@ -4,7 +4,18 @@ \alias{fsusieWrapper} \title{Wrapper for fsusie Function with Automatic Post-Processing} \usage{ -fsusieWrapper(X, Y, pos, L, prior, maxSnpEm, covLev, minPurity, maxScale, ...) +fsusieWrapper( + X, + Y, + pos, + L, + prior, + maxSnpEm, + covLev, + minPurity, + maxScale, + methodArgs = FsusieOptions() +) } \arguments{ \item{X}{Residual genotype matrix.} @@ -27,7 +38,9 @@ model.} \item{maxScale}{numeric, define the maximum of wavelet coefficients used in the analysis (2^maxScale). Set 10 true by default.} -\item{...}{Additional arguments passed to the fsusie function.} +\item{methodArgs}{Options forwarded to \code{fsusieR::susiF}, built with +\code{\link{FsusieOptions}}. A bare list is refused: it cannot be checked +against the engine, so a misspelled option would be silently ignored.} } \value{ A modified fsusie object with the susie sets list, correlations for diff --git a/man/getAf.Rd b/man/getAf.Rd index 2c641dc12..ee757e108 100644 --- a/man/getAf.Rd +++ b/man/getAf.Rd @@ -7,7 +7,7 @@ \usage{ getAf(x, ...) -\S4method{getAf}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL, ...) +\S4method{getAf}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) } \arguments{ \item{x}{A \code{QtlDataset} object.} diff --git a/man/getBeta.Rd b/man/getBeta.Rd index d93d097e2..6008fa99e 100644 --- a/man/getBeta.Rd +++ b/man/getBeta.Rd @@ -7,12 +7,34 @@ \usage{ getBeta(x, ...) -\S4method{getBeta}{SumStatsBase}(x, ...) +\S4method{getBeta}{SumStatsBase}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} \item{...}{Class-specific selection arguments.} + +\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to +this study; \code{NULL} matches all studies.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of effect sizes, or \code{NULL} if not available. diff --git a/man/getChromPaths.Rd b/man/getChromPaths.Rd index f8a373a99..c3cff69d1 100644 --- a/man/getChromPaths.Rd +++ b/man/getChromPaths.Rd @@ -7,7 +7,7 @@ \usage{ getChromPaths(x, ...) -\S4method{getChromPaths}{GenotypeHandle}(x, ...) +\S4method{getChromPaths}{GenotypeHandle}(x) } \arguments{ \item{x}{A \code{GenotypeHandle}.} diff --git a/man/getColocBoostOutcomes.Rd b/man/getColocBoostOutcomes.Rd index 546a37f0b..420ada9a5 100644 --- a/man/getColocBoostOutcomes.Rd +++ b/man/getColocBoostOutcomes.Rd @@ -7,7 +7,7 @@ \usage{ getColocBoostOutcomes(x, ...) -\S4method{getColocBoostOutcomes}{ColocBoostResult}(x, ...) +\S4method{getColocBoostOutcomes}{ColocBoostResult}(x) } \arguments{ \item{x}{A \code{\linkS4class{ColocBoostResult}}.} diff --git a/man/getComputingTime.Rd b/man/getComputingTime.Rd index ff39cbbd3..3f8a3f648 100644 --- a/man/getComputingTime.Rd +++ b/man/getComputingTime.Rd @@ -7,7 +7,7 @@ \usage{ getComputingTime(x, ...) -\S4method{getComputingTime}{ColocBoostResult}(x, ...) +\S4method{getComputingTime}{ColocBoostResult}(x) } \arguments{ \item{x}{A \code{\linkS4class{ColocBoostResult}}.} diff --git a/man/getCredibleSetSummary.Rd b/man/getCredibleSetSummary.Rd index 500f5970b..b09d15891 100644 --- a/man/getCredibleSetSummary.Rd +++ b/man/getCredibleSetSummary.Rd @@ -7,7 +7,7 @@ \usage{ getCredibleSetSummary(x, ...) -\S4method{getCredibleSetSummary}{FineMappingResultBase}(x, coverage = 0.95, ...) +\S4method{getCredibleSetSummary}{FineMappingResultBase}(x, coverage = 0.95) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} diff --git a/man/getCs.Rd b/man/getCs.Rd index 5ca5887d9..7b9905ef5 100644 --- a/man/getCs.Rd +++ b/man/getCs.Rd @@ -15,8 +15,7 @@ getCs(x, ...) method = NULL, region = NULL, coverage = 0.95, - minPurity = NULL, - ... + minPurity = NULL ) } \arguments{ diff --git a/man/getCtwasParam.Rd b/man/getCtwasGroupPriors.Rd similarity index 74% rename from man/getCtwasParam.Rd rename to man/getCtwasGroupPriors.Rd index 1f055edec..dfc6a2502 100644 --- a/man/getCtwasParam.Rd +++ b/man/getCtwasGroupPriors.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/CtwasResultEntry.R -\name{getCtwasParam} -\alias{getCtwasParam} -\alias{getCtwasParam,CtwasResultEntry-method} +\name{getCtwasGroupPriors} +\alias{getCtwasGroupPriors} +\alias{getCtwasGroupPriors,CtwasResultEntry-method} \title{Get cTWAS Group Prior Parameters} \usage{ -getCtwasParam(x, ...) +getCtwasGroupPriors(x, ...) -\S4method{getCtwasParam}{CtwasResultEntry}(x, ...) +\S4method{getCtwasGroupPriors}{CtwasResultEntry}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry}.} @@ -25,5 +25,5 @@ Return the estimated \code{group_prior} / \code{group_prior_var} cre <- CtwasResultEntry( finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), susieAlpha = data.frame(id = c("g1", "g2"), alpha = c(0.9, 0.1))) -getCtwasParam(cre) +getCtwasGroupPriors(cre) } diff --git a/man/getCvFits.Rd b/man/getCvFits.Rd index 6bb53c7e4..fe287c746 100644 --- a/man/getCvFits.Rd +++ b/man/getCvFits.Rd @@ -7,7 +7,7 @@ \usage{ getCvFits(x, ...) -\S4method{getCvFits}{MashPrior}(x, ...) +\S4method{getCvFits}{MashPrior}(x) } \arguments{ \item{x}{A \code{MashPrior} object.} diff --git a/man/getCvResult.Rd b/man/getCvResult.Rd index 27e51c22a..c30f943cf 100644 --- a/man/getCvResult.Rd +++ b/man/getCvResult.Rd @@ -11,13 +11,13 @@ \usage{ getCvResult(x, ...) -\S4method{getCvResult}{QtlFineMappingResult}(x, study = NULL, context = NULL, trait = NULL, method = NULL, ...) +\S4method{getCvResult}{QtlFineMappingResult}(x, study = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getCvResult}{FineMappingRow}(x, ...) +\S4method{getCvResult}{FineMappingRow}(x) -\S4method{getCvResult}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL, ...) +\S4method{getCvResult}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getCvResult}{TwasWeightsRow}(x, ...) +\S4method{getCvResult}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} diff --git a/man/getDataType.Rd b/man/getDataType.Rd index 75284f914..4a015c916 100644 --- a/man/getDataType.Rd +++ b/man/getDataType.Rd @@ -11,7 +11,7 @@ getDataType(x, ...) \S4method{getDataType}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getDataType}{TwasWeightsRow}(x, ...) +\S4method{getDataType}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} diff --git a/man/getFinemap.Rd b/man/getFinemap.Rd index 9a663ad33..792a3e547 100644 --- a/man/getFinemap.Rd +++ b/man/getFinemap.Rd @@ -9,9 +9,9 @@ \usage{ getFinemap(x, ...) -\S4method{getFinemap}{CtwasResult}(x, ...) +\S4method{getFinemap}{CtwasResult}(x) -\S4method{getFinemap}{CtwasResultEntry}(x, ...) +\S4method{getFinemap}{CtwasResultEntry}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry} or \code{CtwasResult}.} diff --git a/man/getFits.Rd b/man/getFits.Rd index 919389210..7174016be 100644 --- a/man/getFits.Rd +++ b/man/getFits.Rd @@ -9,9 +9,9 @@ \usage{ getFits(x, ...) -\S4method{getFits}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL, ...) +\S4method{getFits}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getFits}{TwasWeightsRow}(x, ...) +\S4method{getFits}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} @@ -38,6 +38,6 @@ Extract fitted model objects. } \examples{ data(ctwasWeightsExample) -# NULL unless the pipeline was run with `retainFit = TRUE` +# NULL unless the pipeline kept fits (fitRetention != "none") getFits(ctwasWeightsExample) } diff --git a/man/getFullFit.Rd b/man/getFullFit.Rd index ed785360e..6c866e656 100644 --- a/man/getFullFit.Rd +++ b/man/getFullFit.Rd @@ -7,7 +7,7 @@ \usage{ getFullFit(x, ...) -\S4method{getFullFit}{MashPrior}(x, ...) +\S4method{getFullFit}{MashPrior}(x) } \arguments{ \item{x}{A \code{MashPrior} object.} diff --git a/man/getGenome.Rd b/man/getGenome.Rd index 2a0216691..962f5c72e 100644 --- a/man/getGenome.Rd +++ b/man/getGenome.Rd @@ -10,11 +10,11 @@ \usage{ getGenome(x, ...) -\S4method{getGenome}{SumStatsBase}(x, ...) +\S4method{getGenome}{SumStatsBase}(x) -\S4method{getGenome}{AnnotationMatrix}(x, ...) +\S4method{getGenome}{AnnotationMatrix}(x) -\S4method{getGenome}{LdStatistic}(x, ...) +\S4method{getGenome}{LdStatistic}(x) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/getGenotypes.Rd b/man/getGenotypes.Rd index 19d6fe010..a8b75c0e7 100644 --- a/man/getGenotypes.Rd +++ b/man/getGenotypes.Rd @@ -8,15 +8,14 @@ \usage{ getGenotypes(x, ...) -\S4method{getGenotypes}{LdData}(x, ...) +\S4method{getGenotypes}{LdData}(x) \S4method{getGenotypes}{QtlDataset}( x, traitId = NULL, region = NULL, cisWindow = NULL, - samples = NULL, - ... + samples = NULL ) } \arguments{ diff --git a/man/getLbf.Rd b/man/getLbf.Rd index 1e6a54a6e..94d752b97 100644 --- a/man/getLbf.Rd +++ b/man/getLbf.Rd @@ -7,7 +7,7 @@ \usage{ getLbf(x, ...) -\S4method{getLbf}{FineMappingResultBase}(x, ...) +\S4method{getLbf}{FineMappingResultBase}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} diff --git a/man/getLdSketch.Rd b/man/getLdSketch.Rd index 82fd6c1e8..7dbecf626 100644 --- a/man/getLdSketch.Rd +++ b/man/getLdSketch.Rd @@ -11,13 +11,13 @@ \usage{ getLdSketch(x, ...) -\S4method{getLdSketch}{SumStatsBase}(x, ...) +\S4method{getLdSketch}{SumStatsBase}(x) -\S4method{getLdSketch}{FineMappingResultBase}(x, ...) +\S4method{getLdSketch}{FineMappingResultBase}(x) -\S4method{getLdSketch}{ColocResultBase}(x, ...) +\S4method{getLdSketch}{ColocResultBase}(x) -\S4method{getLdSketch}{TwasWeights}(x, ...) +\S4method{getLdSketch}{TwasWeights}(x) } \arguments{ \item{x}{An S4 object that carries an \code{ldSketch} slot.} diff --git a/man/getMaf.Rd b/man/getMaf.Rd index a77b02e9e..5899410e5 100644 --- a/man/getMaf.Rd +++ b/man/getMaf.Rd @@ -8,9 +8,16 @@ \usage{ getMaf(x, ...) -\S4method{getMaf}{SumStatsBase}(x, ...) +\S4method{getMaf}{SumStatsBase}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) -\S4method{getMaf}{QtlDataset}(x, region = NULL, cisWindow = NULL, samples = NULL, ...) +\S4method{getMaf}{QtlDataset}(x, region = NULL, cisWindow = NULL, samples = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlDataset} object.} @@ -18,6 +25,21 @@ getMaf(x, ...) \item{...}{Class-specific selection arguments (e.g., \code{region}, \code{cisWindow} for \code{QtlDataset}).} +\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to +this study; \code{NULL} matches all studies.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} + \item{region}{Character (length 1, \code{"chr:start-end"}) or \code{NULL}. Restrict variants to this region; \code{NULL} uses the full cis window / all regions.} diff --git a/man/getMarginalEffects.Rd b/man/getMarginalEffects.Rd index a53bc250f..b1539b3ae 100644 --- a/man/getMarginalEffects.Rd +++ b/man/getMarginalEffects.Rd @@ -14,8 +14,7 @@ getMarginalEffects(x, maxPval = NULL, ...) context = NULL, trait = NULL, method = NULL, - region = NULL, - ... + region = NULL ) } \arguments{ diff --git a/man/getN.Rd b/man/getN.Rd index 538a3ae34..1f8af3dae 100644 --- a/man/getN.Rd +++ b/man/getN.Rd @@ -7,12 +7,34 @@ \usage{ getN(x, ...) -\S4method{getN}{SumStatsBase}(x, ...) +\S4method{getN}{SumStatsBase}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} \item{...}{Class-specific selection arguments.} + +\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to +this study; \code{NULL} matches all studies.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of sample sizes. diff --git a/man/getP.Rd b/man/getP.Rd index efa7f33e4..1765bae43 100644 --- a/man/getP.Rd +++ b/man/getP.Rd @@ -7,12 +7,34 @@ \usage{ getP(x, ...) -\S4method{getP}{SumStatsBase}(x, ...) +\S4method{getP}{SumStatsBase}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} \item{...}{Class-specific selection arguments.} + +\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to +this study; \code{NULL} matches all studies.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of p-values, or \code{NULL} if not available. diff --git a/man/getPhenotypes.Rd b/man/getPhenotypes.Rd index 949a12826..ffb3e76a8 100644 --- a/man/getPhenotypes.Rd +++ b/man/getPhenotypes.Rd @@ -15,7 +15,7 @@ getPhenotypes(x, ...) naAction = c("keep", "drop", "impute"), outlierAction = c("keep", "drop"), outlierPvalThreshold = 0.001, - ... + outlierArgs = CovMcdOptions() ) } \arguments{ @@ -41,6 +41,11 @@ all regions.} \item{outlierPvalThreshold}{Numeric. Two-sided p-value threshold for flagging phenotype outliers. Default \code{1e-3}.} + +\item{outlierArgs}{Extra arguments for \code{robustbase::covMcd()}, the +robust covariance estimator the outlier rule is built on, supplied with +\code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only +consulted when \code{outlierAction = "drop"}.} } \value{ A named list of phenotype matrices or \code{SummarizedExperiment} diff --git a/man/getPip.Rd b/man/getPip.Rd index c80157886..43eee3034 100644 --- a/man/getPip.Rd +++ b/man/getPip.Rd @@ -16,8 +16,7 @@ getPip(x, ...) trait = NULL, method = NULL, region = NULL, - returnList = FALSE, - ... + returnList = FALSE ) \S4method{getPip}{QtlFineMappingResult}( @@ -26,8 +25,7 @@ getPip(x, ...) context = NULL, trait = NULL, method = NULL, - returnList = FALSE, - ... + returnList = FALSE ) } \arguments{ diff --git a/man/getQcDiagnostics.Rd b/man/getQcDiagnostics.Rd index c7a8bef75..bb398f7ca 100644 --- a/man/getQcDiagnostics.Rd +++ b/man/getQcDiagnostics.Rd @@ -7,7 +7,7 @@ \usage{ getQcDiagnostics(x, entry = 1L, ...) -\S4method{getQcDiagnostics}{SumStatsBase}(x, entry = 1L, ...) +\S4method{getQcDiagnostics}{SumStatsBase}(x, entry = 1L) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -27,7 +27,8 @@ A \code{data.frame} of per-variant diagnostics (columns include \description{ Return the per-variant LD-mismatch diagnostics table (SLALOM or DENTIST output) attached to a sumstats entry by - \code{\link{summaryStatsQc}} when \code{zMismatchQc} was not \code{"none"}. + \code{\link{summaryStatsQc}} when \code{ldMismatchQcMethod} was not + \code{"none"}. Convenience accessor over \code{getQcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. } diff --git a/man/getQcInfo.Rd b/man/getQcInfo.Rd index d73a3c122..0dfab611b 100644 --- a/man/getQcInfo.Rd +++ b/man/getQcInfo.Rd @@ -7,7 +7,7 @@ \usage{ getQcInfo(x, ...) -\S4method{getQcInfo}{SumStatsBase}(x, ...) +\S4method{getQcInfo}{SumStatsBase}(x) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/getRegion.Rd b/man/getRegion.Rd index 16f7cfede..b094ad798 100644 --- a/man/getRegion.Rd +++ b/man/getRegion.Rd @@ -8,9 +8,9 @@ \usage{ getRegion(x, ...) -\S4method{getRegion}{FineMappingResultBase}(x, ...) +\S4method{getRegion}{FineMappingResultBase}(x) -\S4method{getRegion}{TwasWeights}(x, ...) +\S4method{getRegion}{TwasWeights}(x) } \arguments{ \item{x}{The object.} diff --git a/man/getRegionVcp.Rd b/man/getRegionVcp.Rd index 189590667..c940c5fe9 100644 --- a/man/getRegionVcp.Rd +++ b/man/getRegionVcp.Rd @@ -7,7 +7,7 @@ \usage{ getRegionVcp(x, ...) -\S4method{getRegionVcp}{ColocBoostResult}(x, ...) +\S4method{getRegionVcp}{ColocBoostResult}(x) } \arguments{ \item{x}{A \code{\linkS4class{ColocBoostResult}}.} diff --git a/man/getResidualizedGenotypes.Rd b/man/getResidualizedGenotypes.Rd index 1a8cb404f..1a8c6393f 100644 --- a/man/getResidualizedGenotypes.Rd +++ b/man/getResidualizedGenotypes.Rd @@ -14,14 +14,7 @@ getResidualizedGenotypes(x, ...) region = NULL, cisWindow = NULL, samples = NULL, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - residualizePhenotypeCovariatesFromGenotypes = NULL, - residualizeGenotypeCovariatesFromGenotypes = NULL, - covariateNaAction = c("impute", "drop"), - ... + residualizationArgs = ResidualizationParam() ) } \arguments{ @@ -48,29 +41,13 @@ around the trait; \code{NULL} uses the dataset default.} \item{samples}{Character vector or \code{NULL}. Restrict to these sample IDs; \code{NULL} uses all samples.} -\item{phenotypeCovariatesToResidualize}{Character vector or \code{NULL}. -Phenotype covariate names to residualize; \code{NULL} uses the dataset -default set.} - -\item{genotypeCovariatesToResidualize}{Character vector or \code{NULL}. -Genotype covariate names to residualize; \code{NULL} uses the dataset -default set.} - -\item{residualizePhenotypeCovariates}{Logical. Whether to residualize the -phenotype covariates. Default \code{TRUE}.} - -\item{residualizeGenotypeCovariates}{Logical. Whether to residualize the -genotype covariates. Default \code{TRUE}.} - -\item{residualizePhenotypeCovariatesFromGenotypes}{Logical or \code{NULL}. -Whether to residualize phenotype covariates out of the genotype design; -\code{NULL} uses the default.} - -\item{residualizeGenotypeCovariatesFromGenotypes}{Logical or \code{NULL}. -Whether to residualize genotype covariates out of the genotype design; -\code{NULL} uses the default.} - -\item{covariateNaAction}{Character. How to handle missing covariate values.} +\item{residualizationArgs}{What the data is residualized on, built with +\code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and +\code{genotypeCovariates} choose the covariate sets, +\code{residualizePhenotype} / \code{residualizeGenotype} turn each +side on or off, and \code{covariateNaAction} says how missing +covariate values are handled. The same record the pipelines take, so a +setting means the same thing by either route.} } \value{ A numeric matrix (samples x variants). diff --git a/man/getResidualizedPhenotypes.Rd b/man/getResidualizedPhenotypes.Rd index bc7fe901a..6e582be47 100644 --- a/man/getResidualizedPhenotypes.Rd +++ b/man/getResidualizedPhenotypes.Rd @@ -12,17 +12,11 @@ getResidualizedPhenotypes(x, ...) contexts, traitId = NULL, region = NULL, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - residualizePhenotypeCovariatesFromPhenotypes = NULL, - residualizeGenotypeCovariatesFromPhenotypes = NULL, naAction = c("keep", "drop", "impute"), - covariateNaAction = c("impute", "drop"), outlierAction = c("keep", "drop"), outlierPvalThreshold = 0.001, - ... + outlierArgs = CovMcdOptions(), + residualizationArgs = ResidualizationParam() ) } \arguments{ @@ -43,38 +37,27 @@ to select; \code{NULL} matches all traits in the dataset.} Restrict variants to this region; \code{NULL} uses the full cis window / all regions.} -\item{phenotypeCovariatesToResidualize}{Character vector or \code{NULL}. -Phenotype covariate names to residualize; \code{NULL} uses the dataset -default set.} - -\item{genotypeCovariatesToResidualize}{Character vector or \code{NULL}. -Genotype covariate names to residualize; \code{NULL} uses the dataset -default set.} - -\item{residualizePhenotypeCovariates}{Logical. Whether to residualize the -phenotype covariates. Default \code{TRUE}.} - -\item{residualizeGenotypeCovariates}{Logical. Whether to residualize the -genotype covariates. Default \code{TRUE}.} - -\item{residualizePhenotypeCovariatesFromPhenotypes}{Logical or \code{NULL}. -Whether to residualize phenotype covariates out of the phenotype; -\code{NULL} uses the default.} - -\item{residualizeGenotypeCovariatesFromPhenotypes}{Logical or \code{NULL}. -Whether to residualize genotype covariates out of the phenotype; -\code{NULL} uses the default.} - \item{naAction}{Character. How to handle missing phenotype values: one of \code{"keep"}, \code{"drop"}, or \code{"impute"}.} -\item{covariateNaAction}{Character. How to handle missing covariate values.} - \item{outlierAction}{Character. How to handle phenotype outliers: one of \code{"keep"} or \code{"drop"}.} \item{outlierPvalThreshold}{Numeric. Two-sided p-value threshold for flagging phenotype outliers. Default \code{1e-3}.} + +\item{outlierArgs}{Extra arguments for \code{robustbase::covMcd()}, the +robust covariance estimator the outlier rule is built on, supplied with +\code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only +consulted when \code{outlierAction = "drop"}.} + +\item{residualizationArgs}{What the data is residualized on, built with +\code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and +\code{genotypeCovariates} choose the covariate sets, +\code{residualizePhenotype} / \code{residualizeGenotype} turn each +side on or off, and \code{covariateNaAction} says how missing +covariate values are handled. The same record the pipelines take, so a +setting means the same thing by either route.} } \value{ A named list of numeric matrices keyed by context. diff --git a/man/getRetainedMass.Rd b/man/getRetainedMass.Rd index 5627b3505..7ee8036b9 100644 --- a/man/getRetainedMass.Rd +++ b/man/getRetainedMass.Rd @@ -7,7 +7,7 @@ \usage{ getRetainedMass(x, ...) -\S4method{getRetainedMass}{FineMappingResultBase}(x, ...) +\S4method{getRetainedMass}{FineMappingResultBase}(x) } \arguments{ \item{x}{A fine-mapping collection.} diff --git a/man/getSe.Rd b/man/getSe.Rd index 9e129c248..12c3ba670 100644 --- a/man/getSe.Rd +++ b/man/getSe.Rd @@ -7,12 +7,34 @@ \usage{ getSe(x, ...) -\S4method{getSe}{SumStatsBase}(x, ...) +\S4method{getSe}{SumStatsBase}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} \item{...}{Class-specific selection arguments.} + +\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to +this study; \code{NULL} matches all studies.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of standard errors, or \code{NULL} if not available. diff --git a/man/getSignificantQtls.Rd b/man/getSignificantQtls.Rd index e3fba9140..cf69a0c21 100644 --- a/man/getSignificantQtls.Rd +++ b/man/getSignificantQtls.Rd @@ -50,8 +50,9 @@ entries <- lapply(seq_len(G), function(i) { }) qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", - n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), - p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G)) + extraCols = list( + n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), + p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G))) pp <- qtlAssociationPostprocess(qss) getSignificantQtls(pp) } diff --git a/man/getStandardized.Rd b/man/getStandardized.Rd index e7dd1a7d5..f7a2008b9 100644 --- a/man/getStandardized.Rd +++ b/man/getStandardized.Rd @@ -11,7 +11,7 @@ getStandardized(x, ...) \S4method{getStandardized}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getStandardized}{TwasWeightsRow}(x, ...) +\S4method{getStandardized}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} diff --git a/man/getSumStats-GwasSumStats-method.Rd b/man/getSumStats-GwasSumStats-method.Rd index cdf3f0784..f8884e6bb 100644 --- a/man/getSumStats-GwasSumStats-method.Rd +++ b/man/getSumStats-GwasSumStats-method.Rd @@ -4,7 +4,14 @@ \alias{getSumStats,GwasSumStats-method} \title{Get a GWAS Study's Summary-Statistic GRanges} \usage{ -\S4method{getSumStats}{GwasSumStats}(x, study = NULL, ranges = NULL, ...) +\S4method{getSumStats}{GwasSumStats}( + x, + study = NULL, + ranges = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL +) } \arguments{ \item{x}{A \code{GwasSumStats} object.} @@ -15,7 +22,10 @@ collection has a single row.} \item{ranges}{Optional \code{GRanges} restricting the returned variants to those it overlaps. \code{NULL} (default) returns the study's full set.} -\item{...}{Additional arguments (currently unused).} +\item{context, trait, annotateSignificance}{QTL-only selectors, named here so +that supplying one is an error rather than a silently ignored request. A +GWAS has no context or trait axis and carries no significance annotation; +leave them \code{NULL}.} } \value{ A \code{GRanges} object. diff --git a/man/getSumStats.Rd b/man/getSumStats.Rd index 516cf2a86..395231d13 100644 --- a/man/getSumStats.Rd +++ b/man/getSumStats.Rd @@ -9,7 +9,7 @@ \usage{ getSumStats(x, ...) -\S4method{getSumStats}{MultiStudyQtlDataset}(x, ...) +\S4method{getSumStats}{MultiStudyQtlDataset}(x) \S4method{getSumStats}{QtlSumStats}( x, @@ -17,8 +17,7 @@ getSumStats(x, ...) context = NULL, trait = NULL, annotateSignificance = NULL, - ranges = NULL, - ... + ranges = NULL ) } \arguments{ diff --git a/man/getSumStatsDf.Rd b/man/getSumStatsDf.Rd index 762f7ceb0..ec3c51ea6 100644 --- a/man/getSumStatsDf.Rd +++ b/man/getSumStatsDf.Rd @@ -1,27 +1,27 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/qtlSumStats.R, -% R/gwasSumStats.R +% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, +% R/qtlSumStats.R \name{getSumStatsDf} \alias{getSumStatsDf} -\alias{getSumStatsDf,QtlSumStats-method} \alias{getSumStatsDf,GwasSumStats-method} +\alias{getSumStatsDf,QtlSumStats-method} \title{Get Standardized Sumstat Data Frame for One Tuple} \usage{ getSumStatsDf(x, ...) -\S4method{getSumStatsDf}{QtlSumStats}( +\S4method{getSumStatsDf}{GwasSumStats}( x, study = NULL, - context = NULL, - trait = NULL, require = character(0), derive = c("none", "zFromBetaSe"), keepChrPrefix = TRUE ) -\S4method{getSumStatsDf}{GwasSumStats}( +\S4method{getSumStatsDf}{QtlSumStats}( x, study = NULL, + context = NULL, + trait = NULL, require = character(0), derive = c("none", "zFromBetaSe"), keepChrPrefix = TRUE @@ -38,12 +38,6 @@ to the underlying unpacker.} \item{study}{Character (length 1) or \code{NULL}. Restrict the selection to this study; \code{NULL} matches all studies.} -\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to -this context; \code{NULL} matches all contexts.} - -\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to -this trait; \code{NULL} matches all traits.} - \item{require}{Character vector. Columns that must be present (derived if necessary) in the returned summary-statistics data frame.} @@ -52,6 +46,12 @@ BETA, SE) from the available ones.} \item{keepChrPrefix}{Logical. If \code{TRUE}, keep the \code{chr} prefix on chromosome names; otherwise strip it.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} } \value{ A \code{data.frame}. diff --git a/man/getSusieAlpha.Rd b/man/getSusieAlpha.Rd index a29ec01fb..3e64385d0 100644 --- a/man/getSusieAlpha.Rd +++ b/man/getSusieAlpha.Rd @@ -9,9 +9,9 @@ \usage{ getSusieAlpha(x, ...) -\S4method{getSusieAlpha}{CtwasResult}(x, ...) +\S4method{getSusieAlpha}{CtwasResult}(x) -\S4method{getSusieAlpha}{CtwasResultEntry}(x, ...) +\S4method{getSusieAlpha}{CtwasResultEntry}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry} or \code{CtwasResult}.} diff --git a/man/getSusieFit.Rd b/man/getSusieFit.Rd index 84a6dea6b..3d93df2c8 100644 --- a/man/getSusieFit.Rd +++ b/man/getSusieFit.Rd @@ -15,11 +15,10 @@ getSusieFit(x, ...) context = NULL, trait = NULL, method = NULL, - region = NULL, - ... + region = NULL ) -\S4method{getSusieFit}{FineMappingRow}(x, ...) +\S4method{getSusieFit}{FineMappingRow}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} diff --git a/man/getTopLoci.Rd b/man/getTopLoci.Rd index 8a5679114..1dd621f0d 100644 --- a/man/getTopLoci.Rd +++ b/man/getTopLoci.Rd @@ -17,7 +17,7 @@ getTopLoci(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) method = NULL, region = NULL, minPurity = NULL, - ... + raw = FALSE ) } \arguments{ @@ -49,6 +49,11 @@ all regions.} \item{minPurity}{Numeric or \code{NULL}. Minimum credible-set purity to retain; \code{NULL} applies no purity filter.} + +\item{raw}{Logical (length 1). \code{FALSE} (default) returns the posterior +view described above. \code{TRUE} hands back the stored canonical table +verbatim, so neither the projection nor \code{signalCutoff} applies and +\code{type = "GRanges"} is an error.} } \value{ A \code{data.frame} or a \code{GRanges}. diff --git a/man/getTraitPosition.Rd b/man/getTraitPosition.Rd index ecd53ede5..0515e459b 100644 --- a/man/getTraitPosition.Rd +++ b/man/getTraitPosition.Rd @@ -11,13 +11,13 @@ \usage{ getTraitPosition(x, ...) -\S4method{getTraitPosition}{FineMappingResultBase}(x, ...) +\S4method{getTraitPosition}{FineMappingResultBase}(x) -\S4method{getTraitPosition}{QtlDataset}(x, traitId = NULL, ...) +\S4method{getTraitPosition}{QtlDataset}(x, traitId = NULL) -\S4method{getTraitPosition}{QtlSumStats}(x, traitId = NULL, ...) +\S4method{getTraitPosition}{QtlSumStats}(x, traitId = NULL) -\S4method{getTraitPosition}{TwasWeights}(x, ...) +\S4method{getTraitPosition}{TwasWeights}(x) } \arguments{ \item{x}{The object.} diff --git a/man/getVarY.Rd b/man/getVarY.Rd index e691e7bb7..500340201 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/qtlSumStats.R, -% R/gwasSumStats.R +% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, +% R/qtlSumStats.R \name{getVarY} \alias{getVarY} -\alias{getVarY,QtlSumStats-method} \alias{getVarY,GwasSumStats-method} +\alias{getVarY,QtlSumStats-method} \title{Get Phenotype Variance} \usage{ getVarY(x, ...) -\S4method{getVarY}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL) - \S4method{getVarY}{GwasSumStats}(x, study = NULL) + +\S4method{getVarY}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/getVariantIds.Rd b/man/getVariantIds.Rd index 985069806..97cf284dc 100644 --- a/man/getVariantIds.Rd +++ b/man/getVariantIds.Rd @@ -19,26 +19,25 @@ getVariantIds(x, ...) context = NULL, trait = NULL, method = NULL, - region = NULL, - ... + region = NULL ) -\S4method{getVariantIds}{SumStatsBase}(x, ...) - -\S4method{getVariantIds}{LdData}(x, ...) - -\S4method{getVariantIds}{FineMappingRow}(x, ...) - -\S4method{getVariantIds}{TwasWeights}( +\S4method{getVariantIds}{SumStatsBase}( x, study = NULL, context = NULL, trait = NULL, - method = NULL, - ... + annotateSignificance = NULL, + ranges = NULL ) -\S4method{getVariantIds}{TwasWeightsRow}(x, ...) +\S4method{getVariantIds}{LdData}(x) + +\S4method{getVariantIds}{FineMappingRow}(x) + +\S4method{getVariantIds}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) + +\S4method{getVariantIds}{TwasWeightsRow}(x) } \arguments{ \item{x}{The object.} @@ -60,6 +59,12 @@ this fine-mapping / weight method; \code{NULL} matches all methods.} \item{region}{Character (length 1, \code{"chr:start-end"}) or \code{NULL}. Restrict variants to this region; \code{NULL} uses the full cis window / all regions.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Character vector of variant IDs. diff --git a/man/getWeights.Rd b/man/getWeights.Rd index 8046f0490..93948089d 100644 --- a/man/getWeights.Rd +++ b/man/getWeights.Rd @@ -9,9 +9,9 @@ \usage{ getWeights(x, ...) -\S4method{getWeights}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL, ...) +\S4method{getWeights}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getWeights}{TwasWeightsRow}(x, ...) +\S4method{getWeights}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} diff --git a/man/getZ.Rd b/man/getZ.Rd index c647e7c40..66276017b 100644 --- a/man/getZ.Rd +++ b/man/getZ.Rd @@ -7,7 +7,14 @@ \usage{ getZ(x, ...) -\S4method{getZ}{SumStatsBase}(x, ...) +\S4method{getZ}{SumStatsBase}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -15,6 +22,21 @@ getZ(x, ...) \item{...}{Class-specific selection arguments (e.g., \code{study} for \code{GwasSumStats}; \code{study}, \code{context}, \code{trait} for \code{QtlSumStats}).} + +\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to +this study; \code{NULL} matches all studies.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of z-scores. diff --git a/man/glmnetWeights.Rd b/man/glmnetWeights.Rd index 77cf6d201..6e6d4c962 100644 --- a/man/glmnetWeights.Rd +++ b/man/glmnetWeights.Rd @@ -4,7 +4,7 @@ \alias{glmnetWeights} \title{Compute TWAS weights via penalized regression (glmnet)} \usage{ -glmnetWeights(X, y, alpha) +glmnetWeights(X, y, alpha, methodArgs = GlmnetOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,6 +13,10 @@ glmnetWeights(X, y, alpha) \item{alpha}{Elastic-net mixing parameter in \code{[0, 1]}: \code{1} = lasso, \code{0} = ridge, \code{0.5} = elastic net.} + +\item{methodArgs}{Additional arguments forwarded to +\code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare +list is refused, since it cannot be checked against the engine's formals.} } \value{ Numeric vector of length \code{ncol(X)} of per-variant weights. diff --git a/man/intersectVariants.Rd b/man/intersectVariants.Rd index 48a903f2e..3e6a18f80 100644 --- a/man/intersectVariants.Rd +++ b/man/intersectVariants.Rd @@ -7,7 +7,7 @@ \usage{ intersectVariants(x, y, oneSided = FALSE, ...) -\S4method{intersectVariants}{FineMappingResultBase,FineMappingResultBase}(x, y, oneSided = FALSE, ...) +\S4method{intersectVariants}{FineMappingResultBase,FineMappingResultBase}(x, y, oneSided = FALSE) } \arguments{ \item{x}{A fine-mapping collection to reconcile.} diff --git a/man/krigingOutlierQc.Rd b/man/krigingOutlierQc.Rd index 979d61518..406bfc3a6 100644 --- a/man/krigingOutlierQc.Rd +++ b/man/krigingOutlierQc.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sumstatsQc.R +% Please edit documentation in R/fineMappingWrappers.R \name{krigingOutlierQc} \alias{krigingOutlierQc} \title{Kriging-style LD-consistency outlier QC} @@ -10,7 +10,8 @@ krigingOutlierQc( n, variantIds = NULL, zThreshold = 2, - logLRThreshold = 2 + logLRThreshold = 2, + methodArgs = KrigingOptions() ) } \arguments{ @@ -28,6 +29,9 @@ default \code{s} is \code{susieR::estimate_s_rss()}).} \item{logLRThreshold}{Log-likelihood-ratio cutoff for the allele-switch rule (default \code{2}, matching susieR).} + +\item{methodArgs}{Extra arguments for \code{susieR::kriging_rss()}, built +with \code{\link{KrigingOptions}} -- \code{r_tol} and \code{s}.} } \value{ A list with \code{flip} (logical vector; \code{TRUE} = allele switch, diff --git a/man/l0learnRssWeights.Rd b/man/l0learnRssWeights.Rd index 95719d3d9..ba93c4680 100644 --- a/man/l0learnRssWeights.Rd +++ b/man/l0learnRssWeights.Rd @@ -14,7 +14,7 @@ l0learnRssWeights( lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, - ... + methodArgs = PenalizedRssOptions() ) } \arguments{ @@ -42,7 +42,10 @@ Default \code{"L0"}.} \item{maxSwaps}{Maximum swap rounds per lambda. Default 100.} -\item{...}{Additional arguments passed to \code{penalizedRss()}.} +\item{methodArgs}{Options forwarded to \code{penalizedRss}, built +with \code{\link{PenalizedRssOptions}}. A bare list is refused: it +cannot be checked against the engine, so a misspelled option would +be silently ignored.} } \value{ A numeric vector of SNP coefficient weights. diff --git a/man/l0learnWeights.Rd b/man/l0learnWeights.Rd index 836652d27..05b697a9c 100644 --- a/man/l0learnWeights.Rd +++ b/man/l0learnWeights.Rd @@ -4,7 +4,7 @@ \alias{l0learnWeights} \title{Compute Weights Using L0Learn} \usage{ -l0learnWeights(X, y, penalty = "L0", nFolds = 5, ...) +l0learnWeights(X, y, penalty = "L0", nFolds = 5, methodArgs = L0learnOptions()) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -16,8 +16,10 @@ l0learnWeights(X, y, penalty = "L0", nFolds = 5, ...) \item{nFolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `L0Learn::L0Learn.cvfit` -(e.g. `nGamma`, `gammaMin`, `gammaMax`, `algorithm`, `maxSuppSize`).} +\item{methodArgs}{Options forwarded to \code{L0Learn::L0Learn.cvfit}, built +with \code{\link{L0learnOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/lassoWeights.Rd b/man/lassoWeights.Rd index d99dabc08..55a2a0295 100644 --- a/man/lassoWeights.Rd +++ b/man/lassoWeights.Rd @@ -4,12 +4,16 @@ \alias{lassoWeights} \title{Compute TWAS weights via lasso (glmnet, alpha = 1)} \usage{ -lassoWeights(X, y) +lassoWeights(X, y, methodArgs = GlmnetOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} \item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} + +\item{methodArgs}{Additional arguments forwarded to +\code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare +list is refused, since it cannot be checked against the engine's formals.} } \value{ Numeric vector of length \code{ncol(X)} of per-variant weights. diff --git a/man/lassosumRssWeights.Rd b/man/lassosumRssWeights.Rd index d911d571b..90d995524 100644 --- a/man/lassosumRssWeights.Rd +++ b/man/lassosumRssWeights.Rd @@ -9,7 +9,7 @@ lassosumRssWeights( LD, s = c(0.2, 0.5, 0.9, 1), selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = LassosumOptions() ) } \arguments{ @@ -25,7 +25,10 @@ sample sizes).} \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. \code{"minFbeta"} is retained as an explicit alternative for debugging.} -\item{...}{Additional arguments passed to \code{lassosumRss()}.} +\item{methodArgs}{Options forwarded to \code{lassosumRss}, built +with \code{\link{LassosumOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of the posterior SNP coefficients at the best (s, diff --git a/man/ldMismatchQc.Rd b/man/ldMismatchQc.Rd index 290e6c415..2ca52bb4a 100644 --- a/man/ldMismatchQc.Rd +++ b/man/ldMismatchQc.Rd @@ -10,8 +10,7 @@ ldMismatchQc( X = NULL, nSample = NULL, method = c("slalom", "dentist"), - ldMethod = "sample", - ... + ldMethod = "sample" ) } \arguments{ @@ -26,16 +25,16 @@ ldMismatchQc( \code{R} is provided and \code{method = "dentist"}; inferred from \code{X} when \code{X} is provided.} -\item{method}{Character string specifying the QC method: \code{"slalom"} -(default) or \code{"dentist"}.} +\item{method}{Which QC method to run: \code{"slalom"} (default) or +\code{"dentist"}, or the matching constructor -- +\code{\link{SlalomParam}} / \code{\link{DentistParam}} -- to configure +it at the same time. The constructor carries the choice, so there is no +separate options argument that could disagree with it.} \item{ldMethod}{Character string specifying the LD computation method when \code{X} is provided. One of \code{"sample"} (default), \code{"population"}, or \code{"gcta"}. Ignored when \code{R} is provided directly.} - -\item{...}{Additional arguments passed to the underlying QC method -(\code{\link{dentistSingleWindow}} or \code{\link{slalom}}).} } \value{ A data frame with at least a logical \code{outlier} column indicating diff --git a/man/ldPruneByCorrelation.Rd b/man/ldPruneByCorrelation.Rd index 16122ea04..31481765f 100644 --- a/man/ldPruneByCorrelation.Rd +++ b/man/ldPruneByCorrelation.Rd @@ -8,7 +8,8 @@ ldPruneByCorrelation( X, corThres = 0.8, backend = c("hclust", "snprelate"), - verbose = FALSE + verbose = FALSE, + methodArgs = LdPruningOptions() ) } \arguments{ @@ -30,6 +31,13 @@ group. Default 0.8.} }} \item{verbose}{Logical. If TRUE, print progress messages. Default FALSE.} + +\item{methodArgs}{Extra arguments for +\code{SNPRelate::snpgdsLDpruning()}, built with +\code{\link{LdPruningOptions}} -- the window controls in particular. +Only the \code{"snprelate"} backend has an engine to configure, so +supplying options alongside \code{backend = "hclust"} is an error +rather than a silent no-op.} } \value{ A list with: diff --git a/man/learnTwasWeights.Rd b/man/learnTwasWeights.Rd index f3f2396b9..6194d57f9 100644 --- a/man/learnTwasWeights.Rd +++ b/man/learnTwasWeights.Rd @@ -13,8 +13,7 @@ learnTwasWeights( trait = "", numThreads = 1, fittedModels = NULL, - retainFits = FALSE, - retainFitDetail = c("slim", "full"), + fitRetention = c("none", "slim", "full"), standardized = FALSE, dataType = NULL, ldSketch = NULL, @@ -50,13 +49,18 @@ set to -1, the function uses all available cores. If set to 0 or 1, no parallel processing is performed. If set to 2 or more, parallel processing is enabled with that many threads.} -\item{fittedModels}{Optional named list of fitted SuSiE-family models.} +\item{fittedModels}{Named list of fitted SuSiE-family models, keyed by +token (\code{susie}, \code{susieInf}, \code{mvsusie}, \code{fsusie}). +Required whenever a SuSiE-family weight method is requested: those +methods extract weights from an existing fit and never fine-map, so a +missing fit is an error. Run \code{\link{fineMappingPipeline}} to +produce the fits.} -\item{retainFits}{If TRUE, retain fitted model objects as attributes on -returned weight matrices when supported by the weight method.} - -\item{retainFitDetail}{Character. Level of fit detail to retain: -\code{"slim"} (default) or \code{"full"}.} +\item{fitRetention}{How much of each per-method fit is kept on the result: +\code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed +payload downstream needs, \code{"full"} keeps the whole fitted object. +Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; +for every other method the two behave alike.} \item{standardized}{Logical. Whether the supplied \code{X} / \code{Y} are already standardized. Default \code{FALSE}.} @@ -91,6 +95,10 @@ parallel processing to handle multiple methods. data(multiTraitData) X <- multiTraitData$X[, 1:80] Y <- multiTraitData$Y +# SuSiE-family methods extract weights from an existing fit and never +# fine-map themselves, so the fit is supplied via `fittedModels`. +fit <- susieR::susie(X, Y[, 1], L = 5) learnTwasWeights(X, Y[, 1, drop = FALSE], - weightMethods = list(susie_weights = list())) + weightMethods = list(susie_weights = list()), + fittedModels = list(susie = fit)) } diff --git a/man/loadMultiStudyQtlDatasetFromManifest.Rd b/man/loadMultiStudyQtlDatasetFromManifest.Rd index 39dfca3d3..5cd0a0b2d 100644 --- a/man/loadMultiStudyQtlDatasetFromManifest.Rd +++ b/man/loadMultiStudyQtlDatasetFromManifest.Rd @@ -16,13 +16,7 @@ loadMultiStudyQtlDatasetFromManifest( formatMapping = NULL, transposeCovariates = FALSE, scaleResiduals = TRUE, - mafCutoff = 0, - macCutoff = 0, - xvarCutoff = 0, - imissCutoff = 0, - keepSamples = character(0), - keepVariants = character(0), - keepIndel = TRUE + genotypeFilterArgs = GenotypeFilterParam() ) } \arguments{ @@ -41,11 +35,12 @@ loader for \code{sumStatsManifest}.} \item{transposeCovariates}{Transpose covariate TSVs (QTLtools layout).} -\item{scaleResiduals, mafCutoff, macCutoff, xvarCutoff}{Pass-through -\code{\link{QtlDataset}} arguments applied to every study.} +\item{scaleResiduals}{Pass-through \code{\link{QtlDataset}} argument, +applied to every study.} -\item{imissCutoff, keepSamples, keepVariants, keepIndel}{Pass-through -\code{\link{QtlDataset}} arguments applied to every study.} +\item{genotypeFilterArgs}{Pass-through \code{\link{QtlDataset}} filtering +options, built with \code{\link{GenotypeFilterParam}} and applied to +every study.} } \value{ A \code{MultiStudyQtlDataset} object. diff --git a/man/loadQtlDatasetFromManifest.Rd b/man/loadQtlDatasetFromManifest.Rd index c55b6e0fb..731319b5b 100644 --- a/man/loadQtlDatasetFromManifest.Rd +++ b/man/loadQtlDatasetFromManifest.Rd @@ -10,13 +10,7 @@ loadQtlDatasetFromManifest( genotypes = NULL, genotypeCovariates = NULL, scaleResiduals = TRUE, - mafCutoff = 0, - macCutoff = 0, - xvarCutoff = 0, - imissCutoff = 0, - keepSamples = character(0), - keepVariants = character(0), - keepIndel = TRUE, + genotypeFilterArgs = GenotypeFilterParam(), transposeCovariates = FALSE ) } @@ -36,11 +30,11 @@ a genotype path/prefix; reconciled with a \code{genotypePath} column.} \item{genotypeCovariates}{A numeric matrix (samples x covariates) or a path to a covariate TSV; reconciled with a \code{genotypeCovariatePath} column.} -\item{scaleResiduals, mafCutoff, macCutoff, xvarCutoff}{Pass-through -\code{\link{QtlDataset}} arguments (stored as lazy QC slots).} +\item{scaleResiduals}{Pass-through \code{\link{QtlDataset}} argument.} -\item{imissCutoff, keepSamples, keepVariants, keepIndel}{Pass-through -\code{\link{QtlDataset}} arguments (stored as lazy QC slots).} +\item{genotypeFilterArgs}{Pass-through \code{\link{QtlDataset}} filtering +options, built with \code{\link{GenotypeFilterParam}} and stored as lazy +QC slots.} \item{transposeCovariates}{Transpose covariate TSVs (QTLtools layout) before treating them as samples-as-rows.} diff --git a/man/mashCovarianceComponents.Rd b/man/mashCovarianceComponents.Rd index 455e30953..f077c47d9 100644 --- a/man/mashCovarianceComponents.Rd +++ b/man/mashCovarianceComponents.Rd @@ -11,6 +11,7 @@ mashCovarianceComponents( components = c("canonical", "pca", "flash", "flashNonneg"), nPcs = NULL, inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), setSeed = 999 ) } @@ -29,6 +30,13 @@ least \code{"strong"} (the discovery set the covariances are learned on).} \item{inputScale}{SumStats -> matrix conversion scale.} +\item{mashDataArgs}{Extra arguments for +\code{mashr::mash_set_data()}, built with +\code{\link{MashDataOptions}} -- for example +\code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +\code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +are refused by the constructor.} + \item{setSeed}{Integer seed (\code{cov_flash} is stochastic), or \code{NULL} to leave the ambient RNG untouched.} } diff --git a/man/mashInput.Rd b/man/mashInput.Rd index 03dad5dc4..8eb1a1604 100644 --- a/man/mashInput.Rd +++ b/man/mashInput.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashWrapper.R +% Please edit documentation in R/mashPipeline.R \name{mashInput} \alias{mashInput} \title{Assemble MASH strong / random / null input from S4 objects} diff --git a/man/mashModelFit.Rd b/man/mashModelFit.Rd index baad4d2e6..8894d053f 100644 --- a/man/mashModelFit.Rd +++ b/man/mashModelFit.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashPipeline.R +% Please edit documentation in R/mashWrapper.R \name{mashModelFit} \alias{mashModelFit} \title{Fit a mash Model for Posterior Computation} @@ -12,6 +12,8 @@ mashModelFit( fitOn = c("random", "strong"), outputLevel = 4L, inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + mashArgs = MashOptions(), setSeed = 999 ) } @@ -38,6 +40,19 @@ full model \code{\link{mashPosterior}} consumes).} \item{inputScale}{SumStats -> matrix conversion scale.} +\item{mashDataArgs}{Extra arguments for +\code{mashr::mash_set_data()}, built with +\code{\link{MashDataOptions}} -- for example +\code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +\code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +are refused by the constructor.} + +\item{mashArgs}{Extra arguments for \code{mashr::mash()}, built with +\code{\link{MashOptions}} -- for example \code{nullweight}, +\code{optmethod} or \code{verbose}. \code{data}, \code{Ulist}, +\code{outputlevel} and \code{seed} are owned by pecotmr and are +refused by the constructor.} + \item{setSeed}{Integer seed, or \code{NULL} to leave the ambient RNG untouched.} } diff --git a/man/mashPipeline.Rd b/man/mashPipeline.Rd index 85da4a6fe..05f5733bf 100644 --- a/man/mashPipeline.Rd +++ b/man/mashPipeline.Rd @@ -10,9 +10,10 @@ mashPipeline( residualCorrelation = NULL, residualCorrelationMethod = c("identity", "simple", "simpleSpecific", "corshrink", "mle"), - priorCovariances = NULL, - nPcs = NULL, + prior = MashPriorParam(), inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + mashArgs = MashOptions(), setSeed = 999 ) } @@ -58,19 +59,12 @@ artefact (the legacy MWE pattern).} \code{priorCovariances} to refine against. A named method whose requirement is unmet is a hard error, not a silent fallback.} -\item{priorCovariances}{Optional named list of square covariance matrices -(the \code{Ulist} \code{mashr::mash()} consumes), or a -\code{\link{mashPriorCovariances}} result, which is unwrapped to its -\code{U}. When supplied, replaces -the canonical + PCA + flash + ED chain (\code{cov_canonical} / -\code{cov_pca} / \code{cov_flash} / \code{cov_ed}) entirely; mash sees only -the supplied matrices. Every entry must be a \code{ncol(Bhat) x ncol(Bhat)} -matrix. Useful when \code{U} was learnt on a larger reference and shipped -as a static artefact (the legacy MWE pattern).} - -\item{nPcs}{Optional integer; number of principal components seeded into -\code{mashr::cov_pca()}. Defaults to \code{ncol(Bhat) - 1}. Ignored when -\code{priorCovariances} is supplied.} +\item{prior}{How the prior covariance matrices are obtained, built with +\code{\link{MashPriorParam}}: \code{priorCovariances} supplies them +outright (short-circuiting the rest), otherwise \code{components} +chooses which to build, \code{engine} how the data-driven ones are +refined, and \code{nPcs} parametrises the \code{pca} component. +Forwarded whole to \code{\link{mashPriorCovariances}}.} \item{inputScale}{One of \code{"auto"} (default), \code{"beta"}, \code{"z"}. Controls which (Bhat, Shat) pair is extracted from each @@ -88,6 +82,19 @@ sumstats entry: \code{alpha} should be chosen consistently with the resolved scale: typically \code{alpha = 0} for beta, \code{alpha = 1} for z.} +\item{mashDataArgs}{Extra arguments for +\code{mashr::mash_set_data()}, built with +\code{\link{MashDataOptions}} -- for example +\code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +\code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +are refused by the constructor.} + +\item{mashArgs}{Extra arguments for \code{mashr::mash()}, built with +\code{\link{MashOptions}} -- for example \code{nullweight}, +\code{optmethod} or \code{verbose}. \code{data}, \code{Ulist}, +\code{outputlevel} and \code{seed} are owned by pecotmr and are +refused by the constructor.} + \item{setSeed}{Integer. RNG seed for reproducibility of \code{mashr::cov_flash} and \code{mashr::cov_ed}. Default 999.} } @@ -106,5 +113,5 @@ End-to-end driver: from `(strong, random, null)` sumstats data(qtlSumStatsMulticontextExample) ss <- qtlSumStatsMulticontextExample sumStatsList <- list(strong = ss, random = ss) -mashPipeline(sumStatsList, alpha = 0, nPcs = 2L) +mashPipeline(sumStatsList, alpha = 0, prior = MashPriorParam(nPcs = 2L)) } diff --git a/man/mashPosterior.Rd b/man/mashPosterior.Rd index 15be4664d..f9d580561 100644 --- a/man/mashPosterior.Rd +++ b/man/mashPosterior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashPipeline.R +% Please edit documentation in R/mashWrapper.R \name{mashPosterior} \alias{mashPosterior} \title{Compute mash Posterior Matrices for a Target Set} @@ -11,7 +11,9 @@ mashPosterior( vhat = NULL, excludeCondition = character(0), outputPosteriorCov = TRUE, - inputScale = c("auto", "beta", "z") + inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + posteriorArgs = MashPosteriorOptions() ) } \arguments{ @@ -35,6 +37,20 @@ none.} by \code{\link{fitMashContrast}}). Default \code{TRUE}.} \item{inputScale}{SumStats -> matrix conversion scale.} + +\item{mashDataArgs}{Extra arguments for +\code{mashr::mash_set_data()}, built with +\code{\link{MashDataOptions}} -- for example +\code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +\code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +are refused by the constructor.} + +\item{posteriorArgs}{Extra arguments for +\code{mashr::mash_compute_posterior_matrices()}, built with +\code{\link{MashPosteriorOptions}} -- for example +\code{algorithm.version}. \code{g}, \code{data}, \code{A}, +\code{output_posterior_cov} and \code{seed} are owned by pecotmr +and are refused by the constructor.} } \value{ The \code{mashr::mash_compute_posterior_matrices()} result: a list of diff --git a/man/mashPriorCovariances.Rd b/man/mashPriorCovariances.Rd index 6939227a2..aa595406f 100644 --- a/man/mashPriorCovariances.Rd +++ b/man/mashPriorCovariances.Rd @@ -9,12 +9,13 @@ mashPriorCovariances( alpha, vhat = NULL, components = c("canonical", "pca", "flash", "flashNonneg"), - engine = c("cov_ed", "ud", "ud_ted"), + engine = c("covEd", "covUdr", "none"), nPcs = NULL, priorCovariances = NULL, priorComponents = NULL, - udControl = list(), inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), + mashArgs = MashOptions(), setSeed = 999 ) } @@ -30,15 +31,19 @@ least \code{"strong"} (the discovery set the covariances are learned on).} \item{components}{Data-driven covariance components, any of \code{"canonical"}, \code{"pca"}, \code{"flash"} (default \code{cov_flash}), \code{"flashNonneg"} (\code{cov_flash(factors = -"nonneg")}). Built in that fixed order. Ignored by the \code{"ud"} / -\code{"ud_ted"} engines.} +"nonneg")}). Built in that fixed order. May instead be a +\code{\link{MashComponentParam}} record, which names the components and +carries each one's options.} -\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{engine}{Covariance-refinement engine, either a name or the matching +constructor carrying that engine's settings. \code{"covEd"} (default; +\code{\link{CovEdOptions}} -- 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{"covUdr"} +(\code{\link{CovUdrOptions}} -- \pkg{udr} ED / TED updates, returning +weights directly -- OPT-IN, known numerical issues, so not the default; +\code{UdFitOptions(unconstrained.update = "ted")} additionally needs +i.i.d. (z-scale) data); \code{"none"} to skip refinement.} \item{nPcs}{PCs seeded into \code{cov_pca}. Default \code{ncol(Bhat) - 1}.} @@ -58,14 +63,21 @@ 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{mashDataArgs}{Extra arguments for +\code{mashr::mash_set_data()}, built with +\code{\link{MashDataOptions}} -- for example +\code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +\code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +are refused by the constructor.} + +\item{mashArgs}{Extra arguments for \code{mashr::mash()}, built with +\code{\link{MashOptions}} -- for example \code{nullweight}, +\code{optmethod} or \code{verbose}. \code{data}, \code{Ulist}, +\code{outputlevel} and \code{seed} are owned by pecotmr and are +refused by the constructor.} + \item{setSeed}{Integer seed, or \code{NULL} to leave the ambient RNG untouched.} } diff --git a/man/mashRandNullSample.Rd b/man/mashRandNullSample.Rd index fda944d4d..db7effdc2 100644 --- a/man/mashRandNullSample.Rd +++ b/man/mashRandNullSample.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashWrapper.R +% Please edit documentation in R/mashPipeline.R \name{mashRandNullSample} \alias{mashRandNullSample} \title{Sample random and null variant subsets for mash} diff --git a/man/mashResidualCorrelation.Rd b/man/mashResidualCorrelation.Rd index adb6617a3..2c49a7afa 100644 --- a/man/mashResidualCorrelation.Rd +++ b/man/mashResidualCorrelation.Rd @@ -12,6 +12,7 @@ mashResidualCorrelation( nSubset = 6000L, maxIter = 6L, inputScale = c("auto", "beta", "z"), + mashDataArgs = MashDataOptions(), setSeed = 999 ) } @@ -44,6 +45,13 @@ EM iterations).} \item{inputScale}{SumStats -> matrix conversion scale (\code{"auto"} / \code{"beta"} / \code{"z"}).} +\item{mashDataArgs}{Extra arguments for +\code{mashr::mash_set_data()}, built with +\code{\link{MashDataOptions}} -- for example +\code{zero_Bhat_Shat_reset} or \code{zero_Shat_reset}. \code{Bhat}, +\code{Shat}, \code{alpha} and \code{V} are supplied by pecotmr and +are refused by the constructor.} + \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).} diff --git a/man/mcpRssWeights.Rd b/man/mcpRssWeights.Rd index d1293bb5c..46a519d7f 100644 --- a/man/mcpRssWeights.Rd +++ b/man/mcpRssWeights.Rd @@ -11,7 +11,7 @@ mcpRssWeights( gamma = 3, alpha = 1, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = PenalizedRssOptions() ) } \arguments{ @@ -30,7 +30,10 @@ sample sizes).} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} -\item{...}{Additional arguments passed to \code{penalizedRss()}.} +\item{methodArgs}{Options forwarded to \code{penalizedRss}, built +with \code{\link{PenalizedRssOptions}}. A bare list is refused: it +cannot be checked against the engine, so a misspelled option would +be silently ignored.} } \value{ A numeric vector of SNP coefficient weights. diff --git a/man/mcpWeights.Rd b/man/mcpWeights.Rd index 0b5e4a3f9..66d7cc626 100644 --- a/man/mcpWeights.Rd +++ b/man/mcpWeights.Rd @@ -4,7 +4,7 @@ \alias{mcpWeights} \title{Compute Weights Using MCP-Penalized Regression} \usage{ -mcpWeights(X, y, nfolds = 5, ...) +mcpWeights(X, y, nfolds = 5, methodArgs = NcvregOptions()) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -13,7 +13,10 @@ mcpWeights(X, y, nfolds = 5, ...) \item{nfolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `ncvreg::cv.ncvreg`.} +\item{methodArgs}{Options forwarded to \code{ncvreg::cv.ncvreg}, built +with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/mergeCtwasBoundaryRegions.Rd b/man/mergeCtwasBoundaryRegions.Rd index b5a8cb52d..336b2b2f4 100644 --- a/man/mergeCtwasBoundaryRegions.Rd +++ b/man/mergeCtwasBoundaryRegions.Rd @@ -10,8 +10,8 @@ mergeCtwasBoundaryRegions( filterCs = FALSE, maxSNP = Inf, L = 5L, - ncore = 1L, - ... + numThreads = 1L, + methodArgs = CtwasOptions() ) } \arguments{ @@ -36,9 +36,11 @@ to be selected (\code{select_boundary_genes} \code{filter_cs}). Default \item{L}{Integer. Max number of single effects for the merged-region re-fine-mapping (LD path only). Default \code{5}.} -\item{ncore}{Number of cores. Default \code{1}.} +\item{numThreads}{Number of cores. Default \code{1}.} -\item{...}{Forwarded to the underlying ctwas postprocess function.} +\item{methodArgs}{Additional arguments forwarded to ctwas, built +with \code{\link{CtwasOptions}}. Names are checked against what +the ctwas steps accept between them.} } \value{ The \code{finemapResult} list with \code{finemap_res}, diff --git a/man/mergeMashData.Rd b/man/mergeMashData.Rd index ee0137d04..e5965d38b 100644 --- a/man/mergeMashData.Rd +++ b/man/mergeMashData.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashWrapper.R +% Please edit documentation in R/mashPipeline.R \name{mergeMashData} \alias{mergeMashData} \title{Merge two mash data lists} diff --git a/man/metaAnalysisPerCondition.Rd b/man/metaAnalysisPerCondition.Rd index 80945d531..1d28a91aa 100644 --- a/man/metaAnalysisPerCondition.Rd +++ b/man/metaAnalysisPerCondition.Rd @@ -8,7 +8,8 @@ metaAnalysisPerCondition( effectSizes, seValues, seCutoff = 0, - metaMethod = "DL" + metaMethod = "DL", + metaArgs = RmaOptions() ) } \arguments{ @@ -27,6 +28,10 @@ the meta-analysis for a given feature (default 0).} meta-analysis, forwarded to \code{metafor::rma(method = )}. Default \code{"DL"} (DerSimonian-Laird); other options include \code{"REML"}, \code{"ML"}, \code{"EB"}.} + +\item{metaArgs}{Extra arguments for \code{metafor::rma()}, built with +\code{\link{RmaOptions}} -- \code{test = "knha"} in particular, the +small-study correction.} } \value{ A tibble with columns: diff --git a/man/metaSldscRandom.Rd b/man/metaSldscRandom.Rd index 43a5d5bf4..05a9f38c2 100644 --- a/man/metaSldscRandom.Rd +++ b/man/metaSldscRandom.Rd @@ -7,7 +7,8 @@ metaSldscRandom( perTraitEstimates, category, - quantity = c("tauStar", "enrichment", "enrichstat") + quantity = c("tauStar", "enrichment", "enrichstat"), + metaArgs = RmaOptions() ) } \arguments{ @@ -17,6 +18,10 @@ metaSldscRandom( \item{category}{Character. Annotation name to meta-analyze.} \item{quantity}{Character: `"tauStar"`, `"enrichment"`, or `"enrichstat"`.} + +\item{metaArgs}{Extra arguments for \code{metafor::rma()}, built with +\code{\link{RmaOptions}} -- \code{test = "knha"} in particular, the +small-study correction.} } \value{ List with `mean`, `se`, `p`, `nTraits`, `traitsUsed`, `tau2`. diff --git a/man/mrashRssWeights.Rd b/man/mrashRssWeights.Rd index d943a86b1..a46f6da31 100644 --- a/man/mrashRssWeights.Rd +++ b/man/mrashRssWeights.Rd @@ -4,7 +4,16 @@ \alias{mrashRssWeights} \title{Extract weights from mr.ash.rss (susieR)} \usage{ -mrashRssWeights(stat, LD, varY, sigma2E, s0, w0, z = numeric(0), ...) +mrashRssWeights( + stat, + LD, + varY, + sigma2E, + s0, + w0, + z = numeric(0), + methodArgs = MrashRssOptions() +) } \arguments{ \item{stat}{A list of summary statistics with elements \code{b} (effect @@ -26,7 +35,10 @@ grid).} \item{z}{Optional numeric vector of z-scores; defaults to \code{numeric(0)} (derived from \code{stat}).} -\item{...}{Additional arguments forwarded to \code{mr.ash.rss}.} +\item{methodArgs}{Options forwarded to \code{susieR::mr.ash.rss}, built +with \code{\link{MrashOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of the posterior mean of the coefficients. diff --git a/man/mrashWeights.Rd b/man/mrashWeights.Rd index 60769b453..06419f2ca 100644 --- a/man/mrashWeights.Rd +++ b/man/mrashWeights.Rd @@ -4,7 +4,13 @@ \alias{mrashWeights} \title{Compute Weights Using mr.ash Shrinkage} \usage{ -mrashWeights(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) +mrashWeights( + X, + y, + initPriorSd = TRUE, + fitRetention = c("none", "slim", "full"), + methodArgs = MrashOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -14,15 +20,23 @@ mrashWeights(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) \item{initPriorSd}{Logical. Initialize the prior standard-deviation grid from the data. Default \code{TRUE}.} -\item{retainFit}{Logical. Attach the full fitted-model object to the result. +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} + attribute of the returned weights: \code{"none"} (default) attaches + nothing, \code{"slim"} and \code{"full"} attach the fitted model. This + engine keeps no trimmable intermediates, so the two retaining levels + behave alike here. Default \code{FALSE}.} -\item{...}{Additional arguments forwarded to \code{mr.ash}.} +\item{methodArgs}{Options forwarded to \code{susieR::mr.ash}, built +with \code{\link{MrashOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of weights, one per variant (column of \code{X}); - zero-variance columns receive weight 0. When \code{retainFit = TRUE} the - fitted \code{mr.ash} object is attached as attribute \code{"fit"}. + zero-variance columns receive weight 0. Unless + \code{fitRetention = "none"} the fitted \code{mr.ash} object is + attached as attribute \code{"fit"}. } \description{ This function fits the `mr.ash` model (adaptive shrinkage regression) to diff --git a/man/mrmashRssWeights.Rd b/man/mrmashRssWeights.Rd index 84b40a474..df64a7e48 100644 --- a/man/mrmashRssWeights.Rd +++ b/man/mrmashRssWeights.Rd @@ -14,9 +14,8 @@ mrmashRssWeights( w0 = NULL, V = NULL, covY = NULL, - retainFit = FALSE, - fitDetail = c("slim", "full"), - ... + fitRetention = c("none", "slim", "full"), + methodArgs = MrmashRssOptions() ) } \arguments{ @@ -49,18 +48,20 @@ the identity matrix of size K.} \item{covY}{Optional response covariance matrix (K x K). When NULL, defaults to the identity matrix of size K.} -\item{retainFit}{If TRUE, attaches (as the \code{"fit"} attribute on the -returned weights) the inputs \code{fineMappingPipeline} needs to rebuild -the mvSuSiE reweighted prior: \code{dataDrivenPriorMatrices}, the fitted -\code{w0}, and the fitted \code{V}. Default FALSE.} +\item{fitRetention}{How much of the mr.mash fit is kept as the +\code{"fit"} attribute of the returned weights. \code{"none"} (default) +attaches nothing. \code{"slim"} keeps what \code{fineMappingPipeline} +needs to rebuild the mvSuSiE reweighted mixture prior and residual +variance --- the original \code{dataDrivenPriorMatrices}, the fitted +\code{w0} and \code{V}; the heavy coefficient matrix \code{mu1} is +already returned as the weights, so it is not duplicated. \code{"full"} +additionally retains the complete fit under \code{$fit}, at the cost of +a larger payload.} -\item{fitDetail}{How much to retain when \code{retainFit = TRUE}. -\code{"slim"} (default) keeps only those reconstruction inputs (the -coefficients are already the returned weights); \code{"full"} additionally -keeps the complete \code{mr.mash.rss} fit under \code{$fit}. Mirrors -\code{\link{mrmashWeights}}.} - -\item{...}{Additional arguments forwarded to \code{mr.mashr::mr.mash.rss}.} +\item{methodArgs}{Options forwarded to \code{mr.mashr::mr.mash.rss}, built +with \code{\link{MrmashOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric matrix of per-variant per-context weights (variants x @@ -81,9 +82,9 @@ Prior construction reuses the same infrastructure as the individual-level \code{\link{mrmashWrapper}}: \code{computeGrid} + \code{mr.mashr::compute_canonical_covs()} + \code{mr.mashr::expand_covs()} for \code{S0}, and \code{computeW0} for the mixture weights. Supply -\code{dataDrivenPriorMatrices} (e.g. from \code{\link{computeCovFlash}} / -\code{\link{computeCovDiag}}) to add data-driven covariance components -alongside the canonical mixture. +\code{dataDrivenPriorMatrices} (e.g. from +\code{\link{computeCovDiag}}, or \code{mashr::cov_flash}) to add +data-driven covariance components alongside the canonical mixture. } \examples{ data(eqtlRegionExample) diff --git a/man/mrmashWeights.Rd b/man/mrmashWeights.Rd index 66e204c42..eb807441d 100644 --- a/man/mrmashWeights.Rd +++ b/man/mrmashWeights.Rd @@ -8,9 +8,9 @@ mrmashWeights( mrmashFit = NULL, X = NULL, Y = NULL, - retainFit = FALSE, - fitDetail = c("slim", "full"), - ... + fitRetention = c("none", "slim", "full"), + dataDrivenPriorMatrices = NULL, + methodArgs = MrmashOptions() ) } \arguments{ @@ -20,20 +20,24 @@ mrmashWeights( \item{Y}{Phenotype matrix. Required when `mrmashFit` is NULL.} -\item{retainFit}{If TRUE, attach (as the `"fit"` attribute of the returned -weights) the parts of the mr.mash fit that `fineMappingPipeline` needs to -rebuild the mvSuSiE reweighted mixture prior + residual variance: the -original data-driven prior matrices (`dataDrivenPriorMatrices`), the fitted -mixture weights (`w0`) and the residual covariance (`V`). Default FALSE.} +\item{fitRetention}{How much of the mr.mash fit is kept as the +\code{"fit"} attribute of the returned weights. \code{"none"} (default) +attaches nothing. \code{"slim"} keeps what \code{fineMappingPipeline} +needs to rebuild the mvSuSiE reweighted mixture prior and residual +variance --- the original \code{dataDrivenPriorMatrices}, the fitted +\code{w0} and \code{V}; the heavy coefficient matrix \code{mu1} is +already returned as the weights, so it is not duplicated. \code{"full"} +additionally retains the complete fit under \code{$fit}, at the cost of +a larger payload.} -\item{fitDetail}{How much of the fit to retain when `retainFit = TRUE`. -`"slim"` (default) keeps only the three reconstruction inputs above; the -heavy coefficient matrix (`mu1`) is already returned as the weights, so it -is not duplicated. `"full"` additionally retains the complete mr.mash fit -under `$fit` (consistent with how susie fits are kept), at the cost of a -larger payload.} +\item{dataDrivenPriorMatrices}{Optional list of data-driven prior +covariance matrices; forwarded to \code{mrmashWrapper} when it has to fit, +and retained in the payload for mvSuSiE prior reconstruction.} -\item{...}{Additional arguments passed to `mrmashWrapper()` when fitting.} +\item{methodArgs}{Options forwarded to \code{mr.mashr::mr.mash}, built +with \code{\link{MrmashOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ Matrix of variant weights. @@ -48,6 +52,6 @@ X <- multiTraitData$X[, 1:60] Y <- multiTraitData$Y ddpm <- multiTraitData$priorMatrices fit <- mrmashWrapper(X = X, Y = Y, dataDrivenPriorMatrices = ddpm, - canonicalPriorMatrices = TRUE) + prior = MrmashPriorParam(canonicalPriorMatrices = TRUE)) mrmashWeights(mrmashFit = fit, X = X, Y = Y) } diff --git a/man/mrmashWrapper.Rd b/man/mrmashWrapper.Rd index 74920a3c8..c27bce1db 100644 --- a/man/mrmashWrapper.Rd +++ b/man/mrmashWrapper.Rd @@ -10,19 +10,13 @@ mrmashWrapper( V = NULL, sumstats = NULL, dataDrivenPriorMatrices = NULL, - priorGrid = NULL, - nthreads = 1, - canonicalPriorMatrices = FALSE, - standardize = FALSE, - updateW0 = TRUE, - w0Threshold = 1e-08, + prior = MrmashPriorParam(), + bInitMethod = "enet", updateV = TRUE, updateVMethod = "full", - bInitMethod = "enet", - maxIter = 5000, - tol = 0.01, - verbose = FALSE, - ... + standardize = FALSE, + numThreads = 1, + methodArgs = MrmashOptions() ) } \arguments{ @@ -42,23 +36,11 @@ mr.mash, or \code{NULL} for the individual-data variant.} \item{dataDrivenPriorMatrices}{A list of data-driven covariance matrices. Default is NULL.} -\item{priorGrid}{A vector of scaling factors to be used in fitting the -mr.mash model. Default is NULL.} - -\item{nthreads}{The number of threads to use for parallel computation. -Default is 2.} - -\item{canonicalPriorMatrices}{A logical indicating whether to use canonical -matrices as priors. Default is FALSE.} - -\item{standardize}{A logical indicating whether to standardize the input -data. Default is FALSE.} - -\item{updateW0}{A logical indicating whether to update the prior mixture -weights. Default is TRUE.} +\item{prior}{Prior-covariance construction options, built with +\code{\link{MrmashPriorParam}}.} -\item{w0Threshold}{The threshold for updating prior mixture weights. Default -is 1e-8.} +\item{bInitMethod}{The method for initializing the coefficient matrix. +Default is "enet".} \item{updateV}{A logical indicating whether to update the residual covariance matrix. Default is TRUE.} @@ -66,17 +48,20 @@ matrix. Default is TRUE.} \item{updateVMethod}{The method for updating the residual covariance matrix. Default is "full".} -\item{bInitMethod}{The method for initializing the coefficient matrix. -Default is "enet".} - -\item{maxIter}{The maximum number of iterations. Default is 5000.} - -\item{tol}{The tolerance for convergence. Default is 0.01.} - -\item{verbose}{A logical indicating whether to print verbose output. Default -is FALSE.} - -\item{...}{Additional arguments to be passed to mr.mash.} +\item{standardize}{A logical indicating whether to standardize the input +data. Default is FALSE. Used by the summary-statistic and initialisation +steps as well as the fit, so it is set here rather than in +\code{methodArgs}.} + +\item{numThreads}{The number of threads to use for parallel computation. +Default is 1. Used by the same three steps as \code{standardize}.} + +\item{methodArgs}{Options forwarded to \code{mr.mashr::mr.mash} under its +own names, built with \code{\link{MrmashOptions}} +(\code{update_w0}, \code{max_iter}, \code{tol}, \code{w0_threshold}, +\code{verbose}, ...). Arguments the wrapper derives --- the prior, the +residual covariance, the coefficient initialisation --- cannot be set +here.} } \value{ A mr.mash fit, stored as a list with some or all of the following @@ -117,7 +102,7 @@ data(multiTraitData) res <- mrmashWrapper( X = multiTraitData$X[, 1:60], Y = multiTraitData$Y, dataDrivenPriorMatrices = multiTraitData$priorMatrices, - canonicalPriorMatrices = TRUE + prior = MrmashPriorParam(canonicalPriorMatrices = TRUE) ) } diff --git a/man/mvsusieRssWeights.Rd b/man/mvsusieRssWeights.Rd index b35050801..b36f4fa27 100644 --- a/man/mvsusieRssWeights.Rd +++ b/man/mvsusieRssWeights.Rd @@ -8,38 +8,24 @@ mvsusieRssWeights( stat, LD, mvsusieRssFit = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - retainFit = FALSE, - ... + fitRetention = c("none", "slim", "full") ) } \arguments{ \item{stat}{A list with \code{z} (matrix variants x conditions) and \code{n} -(numeric vector or scalar).} +(numeric vector or scalar), describing the block the fit came from.} -\item{LD}{LD correlation matrix.} +\item{LD}{LD correlation matrix for that block. The fit must cover the +same number of variants; a mismatch is an error, since weights from one +block are not comparable against another's LD.} -\item{mvsusieRssFit}{Optional pre-fitted \code{mvsusieRss} object.} +\item{mvsusieRssFit}{A fitted \code{mvsusieRss} object. Required: this +extracts weights and never runs fine-mapping itself.} -\item{priorVariance}{Optional mvSuSiE prior variance specification. When -NULL, \code{mvsusieR::create_mixture_prior()} is used with \code{R = -ncol(stat$z)}.} - -\item{residualVariance}{Optional residual covariance matrix.} - -\item{L}{Maximum number of single effects. Default \code{10}, matching -\code{mvsusieR::mvsusie}.} - -\item{LGreedy}{Integer or \code{NULL}. Number of greedily-added effects. -\code{NULL} (default) disables the greedy loop and fits \code{L} -directly.} - -\item{retainFit}{If TRUE, attaches the fitted object as an attribute.} - -\item{...}{Additional arguments forwarded to \code{mvsusieR::mvsusie_rss}.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ A numeric matrix of per-variant per-context weights (variants x @@ -47,13 +33,13 @@ A numeric matrix of per-variant per-context weights (variants x } \description{ Multi-context summary-statistics analog of \code{\link{mvsusieWeights}}: -extracts coefficients from an existing \code{mvsusieR::mvsusie_rss} fit, or -fits one from \code{stat$z} (variants x conditions) and \code{LD}. +extracts coefficients from an existing \code{mvsusieR::mvsusie_rss} fit. +It never runs fine-mapping itself --- \code{mvsusieRssFit} is required. } \details{ -Follows the \code{*_rss_weights(stat, LD, ...)} contract. Expects -\code{stat$z} to be a numeric matrix (variants x conditions) and -\code{stat$n} a per-context vector or scalar. +Follows the \code{*_rss_weights(stat, LD, ...)} contract: \code{stat} and +\code{LD} describe the block the fit is being extracted against, and the +fit is checked against them rather than refitted. } \examples{ data(eqtlRegionExample) diff --git a/man/mvsusieWeights.Rd b/man/mvsusieWeights.Rd index b52b2c1c1..39af00d90 100644 --- a/man/mvsusieWeights.Rd +++ b/man/mvsusieWeights.Rd @@ -4,46 +4,18 @@ \alias{mvsusieWeights} \title{Compute mvSuSiE TWAS weights} \usage{ -mvsusieWeights( - mvsusieFit = NULL, - X = NULL, - Y = NULL, - priorVariance = NULL, - residualVariance = NULL, - L = 10, - LGreedy = NULL, - verbose = FALSE, - ... -) +mvsusieWeights(mvsusieFit = NULL) } \arguments{ -\item{mvsusieFit}{Optional fitted mvSuSiE object.} - -\item{X}{Genotype matrix. Required when `mvsusieFit` is NULL.} - -\item{Y}{Phenotype matrix. Required when `mvsusieFit` is NULL.} - -\item{priorVariance}{Optional mvSuSiE prior variance list.} - -\item{residualVariance}{Optional residual variance matrix.} - -\item{L}{Maximum number of components. Default \code{10}, matching -\code{mvsusieR::mvsusie}.} - -\item{LGreedy}{Integer or \code{NULL}. Number of greedily-added components. -\code{NULL} (default) disables the greedy loop and fits \code{L} -directly.} - -\item{verbose}{If TRUE, prints mvSuSiE fitting progress.} - -\item{...}{Additional arguments passed to `fitMvsusie()` when fitting.} +\item{mvsusieFit}{A fitted mvSuSiE object. Required.} } \value{ Matrix of variant weights. } \description{ -Extracts coefficients from an existing mvSuSiE fit or fits `fitMvsusie()` -from `X` and `Y`. +Extracts coefficients from an existing mvSuSiE fit. This never fits +mvSuSiE itself: fine-mapping belongs to \code{fineMappingPipeline()}, and a +missing fit is an error rather than an invitation to refit. } \examples{ \donttest{ @@ -52,6 +24,9 @@ library(susieR) data(multiTraitData) X <- multiTraitData$X[, 1:60] Y <- multiTraitData$Y -mvsusieWeights(X = X, Y = Y, L = 5, LGreedy = 2) +fit <- fitMvsusie(X = X, Y = Y, + prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y)), + methodArgs = MvsusieOptions(L = 5)) +mvsusieWeights(mvsusieFit = fit) } } diff --git a/man/nSnps.Rd b/man/nSnps.Rd index 84c2aec5e..3bac7b011 100644 --- a/man/nSnps.Rd +++ b/man/nSnps.Rd @@ -7,12 +7,34 @@ \usage{ nSnps(x, ...) -\S4method{nSnps}{SumStatsBase}(x, ...) +\S4method{nSnps}{SumStatsBase}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} \item{...}{Class-specific selection arguments.} + +\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to +this study; \code{NULL} matches all studies.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} + +\item{annotateSignificance}{Optional correction-method name passed through to +\code{\link{getSumStats}} (QTL only); \code{NULL} applies none.} + +\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the +variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Integer. diff --git a/man/ncvregWeights.Rd b/man/ncvregWeights.Rd index a67d25f36..0fa18b01a 100644 --- a/man/ncvregWeights.Rd +++ b/man/ncvregWeights.Rd @@ -4,7 +4,7 @@ \alias{ncvregWeights} \title{Compute Weights Using ncvreg with SCAD or MCP Penalty} \usage{ -ncvregWeights(X, y, penalty, nfolds = 5, ...) +ncvregWeights(X, y, penalty, nfolds = 5, methodArgs = NcvregOptions()) } \arguments{ \item{X}{A numeric matrix of predictors (no intercept column; `ncvreg` @@ -16,7 +16,10 @@ standardizes internally and adds its own intercept).} \item{nfolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `ncvreg::cv.ncvreg`.} +\item{methodArgs}{Options forwarded to \code{ncvreg::cv.ncvreg}, built +with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/overlapTopLoci.Rd b/man/overlapTopLoci.Rd index 6e269ae32..50a0b85e2 100644 --- a/man/overlapTopLoci.Rd +++ b/man/overlapTopLoci.Rd @@ -11,8 +11,7 @@ overlapTopLoci(qtl, gwas, ...) qtl, gwas, signalCutoff = 0.025, - type = c("data.frame", "GRanges"), - ... + type = c("data.frame", "GRanges") ) } \arguments{ diff --git a/man/pecotmr-pval-combine.Rd b/man/pecotmr-pval-combine.Rd index bfc12e076..3d267b034 100644 --- a/man/pecotmr-pval-combine.Rd +++ b/man/pecotmr-pval-combine.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pvalCombine.R +% Please edit documentation in R/pvalCombineWrappers.R \name{pecotmr-pval-combine} \alias{pecotmr-pval-combine} \title{P-value Combination Methods} diff --git a/man/postprocessFinemappingFits.Rd b/man/postprocessFinemappingFits.Rd index ffac0d960..a66a1fbba 100644 --- a/man/postprocessFinemappingFits.Rd +++ b/man/postprocessFinemappingFits.Rd @@ -12,20 +12,13 @@ postprocessFinemappingFits( yScalar = 1, af = NULL, n = NULL, - coverage = NULL, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.1, + credibleSetArgs = CredibleSetParam(), + fitRetention = "slim", otherQuantities = NULL, region = NULL, priorEffTol = 1e-09, - minAbsCorr = 0.8, - medianAbsCorr = NULL, csInput = NULL, - conditionIdx = NULL, - trim = TRUE, - fullFit = FALSE, - fullFitAlphaOnly = TRUE, - includeAllCs = FALSE + conditionIdx = NULL ) } \arguments{ @@ -48,41 +41,36 @@ MAF). Default NULL.} \item{n}{Optional per-variant sample size, exported as the \code{N} column. Default NULL -> \code{N} falls back to the fit's own scalar sample size.} -\item{coverage}{Primary credible-set coverage.} +\item{credibleSetArgs}{How credible sets are built and reported, built with +\code{\link{CredibleSetParam}}: \code{coverage}, +\code{secondaryCoverage}, \code{signalCutoff} (the PIP cutoff for +including non-credible-set variants in top loci), \code{minAbsCorr} and +\code{medianAbsCorr} for purity, and \code{includeAllCs}.} -\item{secondaryCoverage}{Additional credible-set coverages.} +\item{fitRetention}{How much of each fit is kept: \code{"slim"} (default) +trims the retained fit to what downstream needs, \code{"full"} keeps the +whole fit object. The \code{topLoci} table's per-credible-set columns +are governed by \code{credibleSet}'s \code{perCsColumns} instead.} -\item{signalCutoff}{PIP cutoff for including non-CS variants in top loci.} +\item{otherQuantities}{Optional named list of extra per-method quantities to +carry on the result untouched (returned as the \code{otherQuantities} +element). Default \code{NULL}.} -\item{otherQuantities}{Optional list carried into each method result.} +\item{region}{Optional \code{"chr:start-end"} string naming the region the +fits cover; recorded on the result. Default \code{NULL}.} -\item{region}{Optional genomic anchor (\code{"chr:start-end"} or -\code{GRanges}) recorded on the result; \code{NULL} to omit.} +\item{priorEffTol}{Numeric (length 1). Effects whose prior variance +\code{V} is at or below this tolerance are dropped as unconverged before +the credible sets are read. Default \code{1e-9}.} -\item{priorEffTol}{Tolerance for retaining effects by prior variance.} +\item{csInput}{One of \code{"X"}, \code{"Xcorr"}, \code{"fsusie"}: how +credible-set purity is computed from \code{dataX}. \code{NULL} (default) +lets each method pick its own -- \code{"Xcorr"} for the RSS methods, +\code{"fsusie"} for fsusie, \code{"X"} otherwise.} -\item{minAbsCorr}{Minimum absolute correlation for credible-set purity.} - -\item{medianAbsCorr}{Numeric or \code{NULL}. Median absolute within-CS -correlation threshold for purity; \code{NULL} uses only \code{minAbsCorr}.} - -\item{csInput}{Optional precomputed credible-set specification, or -\code{NULL} to derive it from the fits.} - -\item{conditionIdx}{Integer or \code{NULL}. Index of the conditioned effect -(per-condition output); \code{NULL} for the unconditioned fit.} - -\item{trim}{Logical. Trim the retained fit to the fields needed downstream. -Default \code{TRUE}.} - -\item{fullFit}{Logical. Retain the full fit object on each entry. Default -\code{FALSE}.} - -\item{fullFitAlphaOnly}{Logical. When retaining the full fit, keep only the -per-effect alpha matrix. Default \code{TRUE}.} - -\item{includeAllCs}{Logical. Include all credible sets rather than only the -top one. Default \code{FALSE}.} +\item{conditionIdx}{Integer or \code{NULL}. For a multi-condition +(3-D) fit, the condition to slice out; \code{NULL} (default) keeps the +unconditioned fit.} } \value{ A list with \code{finemappingResults} (per-method post-processed diff --git a/man/prsCsWeights.Rd b/man/prsCsWeights.Rd index f523a1cce..43257f3ea 100644 --- a/man/prsCsWeights.Rd +++ b/man/prsCsWeights.Rd @@ -4,7 +4,7 @@ \alias{prsCsWeights} \title{Extract weights from prsCs function} \usage{ -prsCsWeights(stat, LD, ...) +prsCsWeights(stat, LD, methodArgs = PrsCsOptions()) } \arguments{ \item{stat}{A list of summary statistics with elements \code{b} (effect @@ -13,7 +13,10 @@ sizes) and \code{n} (per-variant sample sizes).} \item{LD}{Numeric LD (correlation) matrix aligned to the variants in \code{stat}.} -\item{...}{Additional arguments forwarded to \code{prsCs}.} +\item{methodArgs}{Options forwarded to \code{prsCs}, built +with \code{\link{PrsCsOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of the posterior SNP coefficients. @@ -33,5 +36,5 @@ stat <- list( n = rep(nrow(X), ncol(X)) ) LD <- cor(X) -prsCsWeights(stat, LD, maf = rep(0.3, ncol(X))) +prsCsWeights(stat, LD, methodArgs = PrsCsOptions(maf = rep(0.3, ncol(X)))) } diff --git a/man/qtlAssociationPostprocess.Rd b/man/qtlAssociationPostprocess.Rd index 427b494aa..1e91e239a 100644 --- a/man/qtlAssociationPostprocess.Rd +++ b/man/qtlAssociationPostprocess.Rd @@ -14,7 +14,8 @@ qtlAssociationPostprocess(x, ...) cisWindow = 0, methods = c("permutation", "bonferroni"), pvalueCol = "P", - afCol = "af" + afCol = "af", + qvalueArgs = QvalueOptions() ) } \arguments{ @@ -42,6 +43,10 @@ no stored column -- it is a significance query (see \item{pvalueCol, afCol}{Entry mcol names for the per-variant p-value / allele frequency (defaults \code{"P"} / \code{"af"}).} + +\item{qvalueArgs}{Extra arguments for \code{qvalue::qvalue()}, built with +\code{\link{QvalueOptions}} -- the \code{pi0.method} / \code{lambda} +pair in particular, which sets how the null proportion is estimated.} } \value{ The input \code{QtlSumStats} with added correction columns. @@ -69,7 +74,8 @@ entries <- lapply(seq_len(G), function(i) { }) qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", - n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), - p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G)) + extraCols = list( + n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), + p_beta = pBeta, beta_shape1 = rep(1, G), beta_shape2 = rep(200, G))) qtlAssociationPostprocess(qss) } diff --git a/man/qtlDatasetFilters.Rd b/man/qtlDatasetFilters.Rd index f3db96c2e..7343008e3 100644 --- a/man/qtlDatasetFilters.Rd +++ b/man/qtlDatasetFilters.Rd @@ -28,17 +28,17 @@ getKeepVariants(x, ...) getKeepIndel(x, ...) -\S4method{getMafCutoff}{QtlDataset}(x, ...) +\S4method{getMafCutoff}{QtlDataset}(x) -\S4method{getMacCutoff}{QtlDataset}(x, ...) +\S4method{getMacCutoff}{QtlDataset}(x) -\S4method{getXvarCutoff}{QtlDataset}(x, ...) +\S4method{getXvarCutoff}{QtlDataset}(x) -\S4method{getImissCutoff}{QtlDataset}(x, ...) +\S4method{getImissCutoff}{QtlDataset}(x) -\S4method{getKeepVariants}{QtlDataset}(x, ...) +\S4method{getKeepVariants}{QtlDataset}(x) -\S4method{getKeepIndel}{QtlDataset}(x, ...) +\S4method{getKeepIndel}{QtlDataset}(x) } \arguments{ \item{x}{A \code{QtlDataset}.} diff --git a/man/qtlEnrichmentPipeline.Rd b/man/qtlEnrichmentPipeline.Rd index c257aa452..1acf65d90 100644 --- a/man/qtlEnrichmentPipeline.Rd +++ b/man/qtlEnrichmentPipeline.Rd @@ -7,13 +7,10 @@ qtlEnrichmentPipeline( gwasFineMappingResult, qtlFineMappingResult, - numGwas = NULL, - piQtl = NULL, - lambda = 1, - impN = 25, + methodArgs = QtlEnrichmentParam(), numThreads = 1L, seed = NULL, - ... + verbose = TRUE ) } \arguments{ @@ -21,18 +18,11 @@ qtlEnrichmentPipeline( \item{qtlFineMappingResult}{The annotation side; see above.} -\item{numGwas}{Number of GWAS variants used to estimate \code{piGwas}. When -\code{NULL} (default) it is estimated from the data -- bias warning applies -if the input PIP vector is not genome-wide.} - -\item{piQtl}{Per-variant prior of being a QTL causal variant. \code{NULL} -(default) estimates from the data.} - -\item{lambda}{Shrinkage parameter for the enrichment estimator. Default -\code{1.0}.} - -\item{impN}{Number of imputed samples used by the estimator. Default -\code{25}.} +\item{methodArgs}{The estimator's algorithmic settings, built with +\code{\link{QtlEnrichmentParam}}: \code{numGwas}, \code{piQtl}, +\code{lambda}, \code{impN}, \code{doubleShrinkage} and +\code{besselCorrection}. A bare list is refused, since it cannot be +checked.} \item{numThreads}{Number of threads used by \code{qtlEnrichment}. Default \code{1}.} @@ -41,7 +31,7 @@ if the input PIP vector is not genome-wide.} \code{\link{qtlEnrichment}} for reproducible multiple imputation. \code{NULL} (default) draws a nondeterministic seed.} -\item{...}{Additional arguments forwarded to \code{\link{qtlEnrichment}}.} +\item{verbose}{Logical. Print progress messages. Default \code{TRUE}.} } \value{ A tibble with one row per (outcome trait, annotation unit) pair. @@ -55,15 +45,17 @@ A tibble with one row per (outcome trait, annotation unit) pair. The estimates are \code{enrichmentLogOdds}, the enrichment parameter \eqn{a_1} on the log-odds scale, with its standard error \code{enrichmentSe}; \code{enrichment} is the same quantity as a - multiplicative factor, \eqn{e^{a_1} - 1}, which is what - \code{colocPipeline} scales \code{p12} by (so \eqn{a_1 = 0} leaves the - prior untouched). \code{enrichmentLogOddsNoShrinkage} and + multiplicative factor, \eqn{e^{a_1} - 1}, reported for interpretation + (so \eqn{a_1 = 0} means no enrichment). + \code{enrichmentLogOddsNoShrinkage} and \code{enrichmentSeNoShrinkage} are the same estimate before shrinkage, \code{intercept} / \code{interceptSe} are \eqn{a_0}, and \code{colocP1}, - \code{colocP2}, \code{colocP12} are the enrichment-informed coloc priors - the estimator derives from \eqn{(a_0, a_1)} -- an alternative to scaling - a baseline \code{p12}. \code{effectiveMiRounds} is how many - multiple-imputation rounds survived outlier filtering. + \code{colocP2}, \code{colocP12} are the enrichment-informed priors the + estimator derives from \eqn{(a_0, a_1)} exactly as fastenloc's + \code{set_enrich_params} does; those three are what + \code{\link{colocPipeline}} scores with when given this table. + \code{effectiveMiRounds} is how many multiple-imputation rounds survived + outlier filtering. } \description{ Genome-wide pipeline that computes per-pair enrichment diff --git a/man/qtlSumStatsFromBetaMatrix.Rd b/man/qtlSumStatsFromBetaMatrix.Rd index adab60243..c8d77aceb 100644 --- a/man/qtlSumStatsFromBetaMatrix.Rd +++ b/man/qtlSumStatsFromBetaMatrix.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashWrapper.R +% Please edit documentation in R/mashPipeline.R \name{qtlSumStatsFromBetaMatrix} \alias{qtlSumStatsFromBetaMatrix} \title{Build a QtlSumStats from Bhat / Shat (effect-size) Matrices} diff --git a/man/qtlSumStatsFromZMatrix.Rd b/man/qtlSumStatsFromZMatrix.Rd index 352a5d1b7..8c1c40234 100644 --- a/man/qtlSumStatsFromZMatrix.Rd +++ b/man/qtlSumStatsFromZMatrix.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashWrapper.R +% Please edit documentation in R/mashPipeline.R \name{qtlSumStatsFromZMatrix} \alias{qtlSumStatsFromZMatrix} \title{Build a QtlSumStats from a Z-score matrix} diff --git a/man/readAnnotations.Rd b/man/readAnnotations.Rd index 874a8ea6f..54d77acee 100644 --- a/man/readAnnotations.Rd +++ b/man/readAnnotations.Rd @@ -7,7 +7,7 @@ \usage{ readAnnotations(paths, snpRanges, annotationMeta = NULL, genome = "hg19", ...) -\S4method{readAnnotations}{character}(paths, snpRanges, annotationMeta = NULL, genome = "hg19", ...) +\S4method{readAnnotations}{character}(paths, snpRanges, annotationMeta = NULL, genome = "hg19") } \arguments{ \item{paths}{Named character vector of file paths, or a named list of GRanges diff --git a/man/readGenotypes.Rd b/man/readGenotypes.Rd index 56410d8f9..5beefc705 100644 --- a/man/readGenotypes.Rd +++ b/man/readGenotypes.Rd @@ -8,9 +8,25 @@ \usage{ readGenotypes(path, format = NULL, ...) -\S4method{readGenotypes}{character}(path, format = NULL, ...) +\S4method{readGenotypes}{character}(path, format = NULL, vcfArgs = list()) -\S4method{readGenotypes}{missing}(path, format = NULL, ...) +\S4method{readGenotypes}{missing}( + path, + plink1Prefix = NULL, + plink2Prefix = NULL, + bed = NULL, + bim = NULL, + fam = NULL, + pgen = NULL, + pvar = NULL, + psam = NULL, + ldMeta = NULL, + region = NULL, + genoMeta = NULL, + chroms = NULL, + format = NULL, + vcfArgs = list() +) } \arguments{ \item{path}{Character, path to a single self-describing genotype file @@ -23,6 +39,35 @@ inferred from file extension.} \item{...}{The keyword source arguments described above, plus any further arguments forwarded to the format-specific reader.} + +\item{vcfArgs}{Optional named list of arguments forwarded to +\code{VariantAnnotation::readVcf} when the source is a VCF.} + +\item{plink1Prefix, plink2Prefix}{Character. Stem of a plink1 +(\code{.bed}/\code{.bim}/\code{.fam}) or plink2 +(\code{.pgen}/\code{.pvar}/\code{.psam}) triplet, without the extension.} + +\item{bed, bim, fam}{Character. Explicit paths to the three files of a plink1 +triplet, when they do not share a stem.} + +\item{pgen, pvar, psam}{Character. Explicit paths to the three files of a +plink2 triplet, when they do not share a stem.} + +\item{ldMeta}{Path to an LD-meta TSV (columns \code{chrom}, \code{start}, +\code{end}, \code{path}). Requires \code{region}: the row covering it is +resolved and the file it names is read with the matching backend.} + +\item{region}{Region to resolve out of \code{ldMeta}: a +\code{"chr:start-end"} string, or a one-row data.frame with +\code{chrom}, \code{start}, \code{end}.} + +\item{genoMeta}{One-file-per-chromosome specification: a path to a +\code{#chr,path} meta file, or a named character vector (names = +chromosomes, values = payload paths / prefixes).} + +\item{chroms}{Optional character vector of chromosomes. Only the +\code{genoMeta} shards whose chromosome is listed are read; chromosome +labels are compared canonically. Meaningful only with \code{genoMeta}.} } \value{ A \code{RangedSummarizedExperiment} of variants x samples. diff --git a/man/resolveWeights.Rd b/man/resolveWeights.Rd index 1c994bcba..fd6ba5273 100644 --- a/man/resolveWeights.Rd +++ b/man/resolveWeights.Rd @@ -8,16 +8,16 @@ \usage{ resolveWeights(x, ...) -\S4method{resolveWeights}{FineMappingResultBase}(x, ...) - -\S4method{resolveWeights}{TwasWeights}( +\S4method{resolveWeights}{FineMappingResultBase}( x, study = NULL, context = NULL, trait = NULL, method = NULL, - ... + region = NULL ) + +\S4method{resolveWeights}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) } \arguments{ \item{x}{A \code{TwasWeights} or a \code{FineMappingResult}.} @@ -27,6 +27,10 @@ resolveWeights(x, ...) \item{study, context, trait, method}{Optional length-1 selectors pinning one row of a collection, as elsewhere; each \code{NULL} (default) leaves that part of the tuple unconstrained. Ignored when \code{x} is already a row.} + +\item{region}{Character (length 1, \code{"chr:start-end"}) or \code{NULL}. +A further selector for a \code{FineMappingResult}, whose rows also carry +a region; \code{NULL} (default) leaves it unconstrained.} } \value{ A \code{list} with \code{variantIds} (character) and \code{weights} diff --git a/man/scadRssWeights.Rd b/man/scadRssWeights.Rd index 719963b9d..76e3077d8 100644 --- a/man/scadRssWeights.Rd +++ b/man/scadRssWeights.Rd @@ -11,7 +11,7 @@ scadRssWeights( gamma = 3.7, alpha = 1, selection = c("ldQuadratic", "minFbeta"), - ... + methodArgs = PenalizedRssOptions() ) } \arguments{ @@ -30,7 +30,10 @@ sample sizes).} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} -\item{...}{Additional arguments passed to \code{penalizedRss()}.} +\item{methodArgs}{Options forwarded to \code{penalizedRss}, built +with \code{\link{PenalizedRssOptions}}. A bare list is refused: it +cannot be checked against the engine, so a misspelled option would +be silently ignored.} } \value{ A numeric vector of SNP coefficient weights. diff --git a/man/scadWeights.Rd b/man/scadWeights.Rd index 0a200d5ac..976dd6c82 100644 --- a/man/scadWeights.Rd +++ b/man/scadWeights.Rd @@ -4,7 +4,7 @@ \alias{scadWeights} \title{Compute Weights Using SCAD-Penalized Regression} \usage{ -scadWeights(X, y, nfolds = 5, ...) +scadWeights(X, y, nfolds = 5, methodArgs = NcvregOptions()) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -13,7 +13,10 @@ scadWeights(X, y, nfolds = 5, ...) \item{nfolds}{Number of cross-validation folds. Default is 5.} -\item{...}{Additional arguments passed through to `ncvreg::cv.ncvreg`.} +\item{methodArgs}{Options forwarded to \code{ncvreg::cv.ncvreg}, built +with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of length `ncol(X)` of variant weights. diff --git a/man/screenCtwasRegions.Rd b/man/screenCtwasRegions.Rd index 006bb7b5d..d1c2f29a5 100644 --- a/man/screenCtwasRegions.Rd +++ b/man/screenCtwasRegions.Rd @@ -1,24 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ctwasPipeline.R +% Please edit documentation in R/ctwasWrapper.R \name{screenCtwasRegions} \alias{screenCtwasRegions} \title{Screen cTWAS regions} \usage{ -screenCtwasRegions(estResult, L = 5L, ncore = 1L, ...) +screenCtwasRegions(estResult, numThreads = 1L, methodArgs = CtwasOptions()) } \arguments{ -\item{estResult}{A list returned by \code{\link{estCtwasParam}}.} +\item{estResult}{A list returned by \code{\link{estCtwasGroupPriors}}.} -\item{L}{Unused. Retained for call-site compatibility with -\code{\link{ctwasPipeline}}; ctwas's screening always uses the -single-effect (SER) model and ignores L. \code{L} is applied by -\code{\link{finemapCtwasRegions}} downstream.} +\item{numThreads}{Number of cores.} -\item{ncore}{Number of cores.} - -\item{...}{Additional arguments forwarded to \code{ctwas::screen_regions} -(e.g. \code{min_nonSNP_PIP}, \code{min_snp_pval}, \code{min_var}, -\code{min_gene}).} +\item{methodArgs}{Additional arguments forwarded to ctwas, built +with \code{\link{CtwasOptions}}. Names are checked against what +the ctwas steps accept between them.} } \value{ The \code{estResult} list augmented with \code{screen_res} (the full @@ -26,12 +21,13 @@ The \code{estResult} list augmented with \code{screen_res} (the full } \description{ Step 3 of the three-step \code{\link{ctwasPipeline}}: runs - \code{ctwas::screen_regions} on the \code{\link{estCtwasParam}} result and - returns the screened-region set. Use this entry point to substitute - hand-tuned priors for the ones estimated in step 2 (e.g. when the accurate - EM diverges to NaN and you want to recover the prefit values). + \code{ctwas::screen_regions} on the \code{\link{estCtwasGroupPriors}} + result and returns the screened-region set. Use this entry point to + substitute hand-tuned priors for the ones estimated in step 2 (e.g. when + the accurate EM diverges to NaN and you want to recover the prefit + values). } \examples{ data(ctwasEstExample) -screenCtwasRegions(ctwasEstExample, L = 5L) +screenCtwasRegions(ctwasEstExample) } diff --git a/man/sdpr.Rd b/man/sdpr.Rd index 73958b21f..aa46fb4ac 100644 --- a/man/sdpr.Rd +++ b/man/sdpr.Rd @@ -19,7 +19,7 @@ sdpr( iter = 1000, burn = 200, thin = 5, - nThreads = 1, + numThreads = 1, optLlk = 1, verbose = TRUE, seed = NULL @@ -57,7 +57,7 @@ length equal to `bhat`.} \item{thin}{Thinning interval for MCMC. Default is 5.} -\item{nThreads}{Number of threads to use. Default is 1.} +\item{numThreads}{Number of threads to use. Default is 1.} \item{optLlk}{Which likelihood to evaluate. 1 for equation 6 (slightly shrink the correlation of SNPs) and 2 for equation 5 (SNPs genotyped on different diff --git a/man/sdprWeights.Rd b/man/sdprWeights.Rd index 498318a23..d5d7a5378 100644 --- a/man/sdprWeights.Rd +++ b/man/sdprWeights.Rd @@ -4,7 +4,7 @@ \alias{sdprWeights} \title{Extract weights from sdpr function} \usage{ -sdprWeights(stat, LD, ...) +sdprWeights(stat, LD, methodArgs = SdprOptions()) } \arguments{ \item{stat}{A list of summary statistics with elements \code{b} (effect @@ -13,7 +13,10 @@ sizes) and \code{n} (per-variant sample sizes).} \item{LD}{Numeric LD (correlation) matrix aligned to the variants in \code{stat}.} -\item{...}{Additional arguments forwarded to \code{sdpr}.} +\item{methodArgs}{Options forwarded to \code{sdpr}, built +with \code{\link{SdprOptions}}. A bare list is refused: it cannot be +checked against the engine, so a misspelled option would be +silently ignored.} } \value{ A numeric vector of the posterior SNP coefficients. diff --git a/man/serWeights.Rd b/man/serWeights.Rd new file mode 100644 index 000000000..e90cbd28a --- /dev/null +++ b/man/serWeights.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fineMappingWrappers.R +\name{serWeights} +\alias{serWeights} +\title{Compute single-effect (SER) TWAS weights} +\usage{ +serWeights( + X = NULL, + y = NULL, + serFit = NULL, + fitRetention = c("none", "slim", "full") +) +} +\arguments{ +\item{X}{Optional genotype matrix; when supplied it is only used to +check that the fit covers the same number of variants.} + +\item{y}{Unused; retained for signature compatibility.} + +\item{serFit}{Optional fitted SER object.} + +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} +} +\value{ +Numeric vector of variant weights. +} +\description{ +Extracts coefficients from an existing single-effect fit, as produced by +\code{fineMappingPipeline(..., methods = "ser")} on summary statistics. +The SER model carries the same \code{alpha} / \code{mu} / +\code{X_column_scale_factors} structure as a SuSiE fit --- with a single +effect, so \code{alpha} has one row --- so extraction is identical. +} +\details{ +SER fits only exist on the summary-statistics path, because +\code{susieR::susie_ser} is the only implementation +\code{\link{fineMappingPipeline}} has for the \code{"ser"} method. That +does not restrict the weights: a fit is a fit, and weights read off an +RSS fit are as usable for TWAS as any from penalized regression. +} +\examples{ +data(eqtlRegionExample) +X <- eqtlRegionExample$X[, 1:30] +y <- eqtlRegionExample$yRes +z <- apply(X, 2, function(g) summary(stats::lm(y ~ g))$coefficients[2, 3]) +fit <- suppressWarnings(susieR::susie_ser(z = z, n = nrow(X))) +serWeights(serFit = fit) +} diff --git a/man/show-methods.Rd b/man/show-methods.Rd index 63613ad7e..67731abc9 100644 --- a/man/show-methods.Rd +++ b/man/show-methods.Rd @@ -3,8 +3,8 @@ % R/AnnotationMatrix.R, R/ColocResult.R, R/ColocBoostResult.R, % R/CtwasResult.R, R/GwasFineMappingResult.R, R/H2Estimate.R, R/LdData.R, % R/LdEigen.R, R/LdScore.R, R/MashPrior.R, R/QtlDataset.R, -% R/MultiStudyQtlDataset.R, R/QtlFineMappingResult.R, R/qtlSumStats.R, -% R/gwasSumStats.R, R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R +% R/MultiStudyQtlDataset.R, R/QtlFineMappingResult.R, R/gwasSumStats.R, +% R/qtlSumStats.R, R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R \name{show-methods} \alias{show-methods} \alias{show,GenotypeHandle-method} @@ -21,8 +21,8 @@ \alias{show,QtlDataset-method} \alias{show,MultiStudyQtlDataset-method} \alias{show,QtlFineMappingResult-method} -\alias{show,QtlSumStats-method} \alias{show,GwasSumStats-method} +\alias{show,QtlSumStats-method} \alias{show,FineMappingRow-method} \alias{show,TwasWeights-method} \alias{show,TwasWeightsRow-method} @@ -56,10 +56,10 @@ \S4method{show}{QtlFineMappingResult}(object) -\S4method{show}{QtlSumStats}(object) - \S4method{show}{GwasSumStats}(object) +\S4method{show}{QtlSumStats}(object) + \S4method{show}{FineMappingRow}(object) \S4method{show}{TwasWeights}(object) diff --git a/man/subsetRegion.Rd b/man/subsetRegion.Rd index 293930f55..1fccb5fe3 100644 --- a/man/subsetRegion.Rd +++ b/man/subsetRegion.Rd @@ -7,7 +7,7 @@ \usage{ subsetRegion(x, region, ...) -\S4method{subsetRegion}{RangedTupleList}(x, region, ...) +\S4method{subsetRegion}{RangedTupleList}(x, region) } \arguments{ \item{x}{A \code{RangedTupleList} collection.} diff --git a/man/summaryStatsQc.Rd b/man/summaryStatsQc.Rd index 275ea672a..54de9e616 100644 --- a/man/summaryStatsQc.Rd +++ b/man/summaryStatsQc.Rd @@ -6,65 +6,43 @@ \usage{ summaryStatsQc( sumstats, - removeIndels = FALSE, - removeStrandAmbiguous = TRUE, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - infoCutoff = 0, - nCutoff = 5, + sumstatsFilterArgs = SumstatsFilterParam(), + panelFilterArgs = PanelFilterParam(), keepVariants = NULL, skipRegion = NULL, - pipCutoffToSkip = 0, - absZCutoffToSkip = 0, - bfCutoffToSkip = 0, - logBfCutoffToSkip = 0, - zMismatchQc = c("none", "slalom", "dentist"), + signalScreenArgs = SignalScreenParam(), + ldMismatchQcMethod = c("none", "slalom", "dentist"), alleleFlipKriging = FALSE, effectiveN = TRUE, impute = FALSE, - imputeOpts = list(rcond = 0.01, r2Threshold = 0.6, minimumLd = 5, lamb = 0.01), + imputeArgs = RaissParam(), matchMinProp = 0, - coerceNumeric = TRUE, - normalizeChr = TRUE, - dropNonstandardChr = TRUE, - dropMissData = TRUE, - dropPOutOfRange = TRUE, - clampSmallP = TRUE, - smallPFloor = 4.94065645841247e-324, - dropZeroEffect = TRUE, - dropNonpositiveSe = TRUE + sumstatsCleaningArgs = SumstatsCleaningParam() ) } \arguments{ \item{sumstats}{A \code{QtlSumStats} or \code{GwasSumStats} collection.} -\item{removeIndels}{Logical (length 1). When \code{TRUE}, drop indels during -panel harmonization. Default \code{FALSE}.} - -\item{removeStrandAmbiguous}{Logical (length 1). When \code{TRUE}, drop A/T -and C/G strand-ambiguous variants. Default \code{TRUE}.} - -\item{mafCutoff}{Numeric (length 1). Minor-allele-frequency threshold, -measured wherever it can be: against the summary statistics' own -\code{AF} / \code{MAF} / \code{FRQ} column when one is present, and -against the LD reference panel. Default 0 (off). See the panel-filters -section below.} - -\item{macCutoff}{Numeric (length 1). Minor-allele-count threshold for the -LD reference panel, converted to a MAF equivalent using -\code{macCutoff / (2 * nSamples)}; the stricter of it and -\code{mafCutoff} applies. Default 0 (off).} - -\item{imissCutoff}{Numeric (length 1). Per-variant missingness-rate ceiling -for the LD reference panel. Default 1 (off).} - -\item{infoCutoff}{Numeric (length 1). INFO score threshold. Default 0. -Requires \code{INFO} column when non-zero.} - -\item{nCutoff}{Numeric (length 1). Sample-size deviation threshold: drop -variants whose \code{N} is more than \code{nCutoff} -median-absolute-deviations from the median. Set to 0 to disable. Default 5.} +\item{sumstatsFilterArgs}{Row filters applied to the summary statistics +themselves, built with \code{\link{SumstatsFilterParam}}: +\code{removeIndels} drops indels during panel harmonization, +\code{removeStrandAmbiguous} drops A/T and C/G variants, +\code{infoCutoff} is an INFO-score floor (requiring an \code{INFO} +column when non-zero), and \code{nCutoff} drops variants whose \code{N} +is more than that many median-absolute-deviations from the median (0 +disables it).} + +\item{panelFilterArgs}{LD-reference-panel filters, built with + \code{\link{PanelFilterParam}}. \code{macCutoff} is converted to a MAF + equivalent using \code{macCutoff / (2 * nSamples)} and the stricter of + it and \code{mafCutoff} applies; \code{imissCutoff} is a per-variant + missingness ceiling. See the panel-filters section below. + + \code{mafCutoff} is the one setting that reaches past the panel: it is + measured wherever it can be, against the summary statistics' own + \code{AF} / \code{MAF} / \code{FRQ} column when one is present + \emph{and} against the panel. It has always been a single knob, so it + lives here rather than being split into two that could disagree.} \item{keepVariants}{Optional character vector of variant IDs (SNP column) to retain prior to harmonization.} @@ -72,29 +50,24 @@ retain prior to harmonization.} \item{skipRegion}{Optional character vector of \code{"chr:start-end"} strings, or a \code{GRanges}, of regions to drop.} -\item{pipCutoffToSkip}{Numeric (length 1). When \code{!= 0}, run an -LD-independent single-effect SER screen and skip the entry if no PIP -exceeds the cutoff. \code{< 0} resolves to \code{3 / nVariants}. Default 0 -(no screen).} - -\item{absZCutoffToSkip}{Numeric (length 1). Alternative signal screen: skip -the entry when \code{max(abs(Z))} does not exceed the cutoff. No model fit. -Default 0 (off).} - -\item{bfCutoffToSkip}{Numeric (length 1). Alternative signal screen: skip the -entry when the largest per-variant single-effect Bayes factor (from the -same \code{susie_ser} fit as the PIP screen) does not exceed the cutoff. -Compared in log space (\code{maxlogBF > log(cutoff)}). Must be \code{> 0}. -Default 0 (off).} - -\item{logBfCutoffToSkip}{Numeric (length 1). As \code{bfCutoffToSkip} but the -cutoff is on the log Bayes factor scale (\code{maxlogBF > cutoff}). Default -0 (off). Exactly one of \code{pipCutoffToSkip} / \code{absZCutoffToSkip} / -\code{bfCutoffToSkip} / \code{logBfCutoffToSkip} may be non-zero (one -screening metric at a time); enabling more than one is an error.} - -\item{zMismatchQc}{One of \code{"none"} (default), \code{"slalom"}, -\code{"dentist"}.} +\item{signalScreenArgs}{Whether to skip an entry before fitting it, +built with +\code{\link{SignalScreenParam}} --- the same bundle +\code{\link{fineMappingPipeline}} and \code{\link{colocboostPipeline}} +take. \code{pip} runs an LD-independent single-effect SER screen and +skips the entry if no PIP exceeds the cutoff (\code{< 0} resolves to +\code{3 / nVariants}); \code{absZ} skips when \code{max(abs(Z))} does +not exceed the cutoff, with no model fit; \code{bf} and \code{logBf} +screen the largest per-variant single-effect Bayes factor from that same +\code{susie_ser} fit, on the raw and log scales respectively. One metric +at a time --- the constructor rejects a conflicting pair. Unset (the +default) screens nothing.} + +\item{ldMismatchQcMethod}{Which LD-mismatch check to run: \code{"none"} +(default), \code{"slalom"} or \code{"dentist"}, or the matching +constructor -- \code{\link{SlalomParam}} / \code{\link{DentistParam}} -- +to configure it at the same time. Exactly one engine is selected either +way, since the constructor carries the choice.} \item{alleleFlipKriging}{Logical (length 1). Opt-in kriging LD-consistency prefilter run before SLALOM/DENTIST. Default \code{FALSE}.} @@ -118,18 +91,20 @@ records the setting and each entry's \code{nSource} is one of not yet fully wired for the new path; the option is accepted but currently emits a warning and is skipped.)} -\item{imputeOpts}{Named list of RAISS parameters. RAISS imputation scopes its - reference panel to the analysis-region window (so a per-chromosome / - genome-wide \code{ldSketch} does not materialize its full dosage); - \code{flank} (default 0) widens that window by the given number of base - pairs on each side to retain LD context for edge variants. - - \code{mafCutoff} (default 0), \code{macCutoff} (default 0) and - \code{imissCutoff} (default 1) bound which panel variants RAISS will - attempt to impute. Without them every rare variant in the window of a - large LD sketch becomes an imputation target, which is slow and of little - value when the study is far smaller than the panel. The stricter of - \code{mafCutoff} and \code{macCutoff / (2 * nSamples)} applies, matching +\item{imputeArgs}{RAISS settings, built with \code{\link{RaissParam}}. + A bare list is refused, since it cannot be checked. + + RAISS imputation scopes its reference panel to the analysis-region window + (so a per-chromosome / genome-wide \code{ldSketch} does not materialize + its full dosage); \code{flank} widens that window by the given number of + base pairs on each side to retain LD context for edge variants. + + \code{mafCutoff}, \code{macCutoff} and \code{imissCutoff} bound which + panel variants RAISS will attempt to impute. Without them every rare + variant in the window of a large LD sketch becomes an imputation target, + which is slow and of little value when the study is far smaller than the + panel. The stricter of \code{mafCutoff} and + \code{macCutoff / (2 * nSamples)} applies, matching \code{\link{QtlDataset}}. These are a \strong{further} tightening applied to imputation targets @@ -137,42 +112,23 @@ emits a warning and is skipped.)} the panel handed to RAISS holds nothing below those. Use them to impute only common variants from a panel deliberately kept wider than that --- e.g. \code{mafCutoff = 0.001} with - \code{imputeOpts = list(mafCutoff = 0.01)}. A variant present in the - sumstats is never dropped here: RAISS derives its LD basis from those - same panel rows.} + \code{imputeArgs = RaissParam(mafCutoff = 0.01)}. A variant present in + the sumstats is never dropped here: RAISS derives its LD basis from those + same panel rows. + + \code{lamb}, \code{svdTol}, \code{r2Threshold} and \code{minimumLd} + are forwarded to \code{\link{raiss}} itself.} \item{matchMinProp}{Minimum proportion of LD panel variants that must be matched by the sumstats; default 0.} -\item{coerceNumeric}{Logical. Coerce signed columns -(Z/BETA/SE/OR/LOG_ODDS/SIGNED_SUMSTAT/P/MAF/FRQ/INFO/N) to numeric. Default -\code{TRUE}.} - -\item{normalizeChr}{Logical. Strip \code{"chr"} prefix, uppercase the -chromosome label, and map 23->X, 24->Y, M->MT. Default \code{TRUE}.} - -\item{dropNonstandardChr}{Logical. Drop variants whose CHR (after -normalization) is outside 1..22, X, Y, MT. Default \code{TRUE}.} - -\item{dropMissData}{Logical. Drop rows with NA in any vital column (chrom, -pos, A1, A2, and at least one of Z / BETA). Default \code{TRUE}.} - -\item{dropPOutOfRange}{Logical. Drop rows where \code{P < 0} or \code{P > 1}. -Default \code{TRUE}.} - -\item{clampSmallP}{Logical. Floor non-negative P values below -\code{smallPFloor} to \code{smallPFloor} so \code{-log10(P)} stays finite. -Applied to both input and Z-derived P values. Default \code{TRUE}.} - -\item{smallPFloor}{Numeric (length 1). Floor for \code{clampSmallP}. Default -\code{5e-324} (R's smallest positive double).} - -\item{dropZeroEffect}{Logical. Drop rows where any effect column is exactly 0 -(\code{BETA}, \code{LOG_ODDS}, \code{SIGNED_SUMSTAT}) or \code{OR} is -exactly 1. Default \code{TRUE}.} - -\item{dropNonpositiveSe}{Logical. Drop rows where \code{SE <= 0}. Default -\code{TRUE}.} +\item{sumstatsCleaningArgs}{What makes a row a well-formed record, built with +\code{\link{SumstatsCleaningParam}}: \code{coerceNumeric}, +\code{normalizeChr} / \code{dropNonstandardChr}, \code{dropMissData}, +\code{dropPOutOfRange}, \code{clampSmallP} / \code{smallPFloor}, +\code{dropZeroEffect} and \code{dropNonpositiveSe}. Applied before any +filter or screen. Distinct from \code{sumstatsFilter}, which applies +quality thresholds to rows that are already well formed.} } \value{ A new \code{QtlSumStats} / \code{GwasSumStats} with cleaned entries diff --git a/man/susieAshRssWeights.Rd b/man/susieAshRssWeights.Rd index bb9b6953a..52ba85684 100644 --- a/man/susieAshRssWeights.Rd +++ b/man/susieAshRssWeights.Rd @@ -8,8 +8,7 @@ susieAshRssWeights( stat, LD, susieAshRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + fitRetention = c("slim", "none", "full") ) } \arguments{ @@ -20,12 +19,10 @@ sizes).} \item{susieAshRssFit}{Optional pre-fitted SuSiE-ASH-RSS object.} -\item{retainFit}{If TRUE, stores the fitted object as an attribute.} - -\item{methodArgs}{Named list of additional arguments passed to -\code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -matching of short argument names (e.g. \code{L}) to the \code{LD} -parameter.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ Numeric vector of variant weights. @@ -47,5 +44,6 @@ stat <- list( z = vapply(ss, function(s) s[1] / s[2], numeric(1)), n = rep(nrow(X), ncol(X))) LD <- cor(X) -susieAshRssWeights(stat, LD) +fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +susieAshRssWeights(stat, LD, susieAshRssFit = fit) } diff --git a/man/susieAshWeights.Rd b/man/susieAshWeights.Rd index a914895e4..64f86a95b 100644 --- a/man/susieAshWeights.Rd +++ b/man/susieAshWeights.Rd @@ -4,19 +4,25 @@ \alias{susieAshWeights} \title{Compute SuSiE-ASH TWAS weights} \usage{ -susieAshWeights(X = NULL, y = NULL, susieAshFit = NULL, retainFit = FALSE, ...) +susieAshWeights( + X = NULL, + y = NULL, + susieAshFit = NULL, + fitRetention = c("none", "slim", "full") +) } \arguments{ -\item{X}{Genotype matrix. Required when `susieAshFit` is NULL.} +\item{X}{Optional genotype matrix; when supplied it is only used to +check that the fit covers the same number of variants.} -\item{y}{Phenotype vector. Required when `susieAshFit` is NULL.} +\item{y}{Unused; retained for signature compatibility.} \item{susieAshFit}{Optional fitted SuSiE-ASH object.} -\item{retainFit}{If TRUE, stores the fitted object as an attribute on the -returned weights.} - -\item{...}{Additional arguments passed to `susieR::susie()` when fitting.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ Numeric vector of variant weights. @@ -29,5 +35,6 @@ Extracts coefficients from an existing SuSiE-ASH fit or fits data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] y <- eqtlRegionExample$yRes -susieAshWeights(X, y) +fit <- susieR::susie(X, y, L = 5) +susieAshWeights(susieAshFit = fit) } diff --git a/man/susieInfRssWeights.Rd b/man/susieInfRssWeights.Rd index ce7df90c0..35276cecf 100644 --- a/man/susieInfRssWeights.Rd +++ b/man/susieInfRssWeights.Rd @@ -8,8 +8,7 @@ susieInfRssWeights( stat, LD, susieInfRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + fitRetention = c("slim", "none", "full") ) } \arguments{ @@ -20,12 +19,10 @@ sizes).} \item{susieInfRssFit}{Optional pre-fitted SuSiE-inf-RSS object.} -\item{retainFit}{If TRUE, stores the fitted object as an attribute.} - -\item{methodArgs}{Named list of additional arguments passed to -\code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -matching of short argument names (e.g. \code{L}) to the \code{LD} -parameter.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ Numeric vector of variant weights. @@ -47,5 +44,6 @@ stat <- list( z = vapply(ss, function(s) s[1] / s[2], numeric(1)), n = rep(nrow(X), ncol(X))) LD <- cor(X) -susieInfRssWeights(stat, LD) +fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +susieInfRssWeights(stat, LD, susieInfRssFit = fit) } diff --git a/man/susieInfWeights.Rd b/man/susieInfWeights.Rd index 6a5d90f34..09a70847f 100644 --- a/man/susieInfWeights.Rd +++ b/man/susieInfWeights.Rd @@ -4,19 +4,25 @@ \alias{susieInfWeights} \title{Compute SuSiE-inf TWAS weights} \usage{ -susieInfWeights(X = NULL, y = NULL, susieInfFit = NULL, retainFit = FALSE, ...) +susieInfWeights( + X = NULL, + y = NULL, + susieInfFit = NULL, + fitRetention = c("none", "slim", "full") +) } \arguments{ -\item{X}{Genotype matrix. Required when `susieInfFit` is NULL.} +\item{X}{Optional genotype matrix; when supplied it is only used to +check that the fit covers the same number of variants.} -\item{y}{Phenotype vector. Required when `susieInfFit` is NULL.} +\item{y}{Unused; retained for signature compatibility.} \item{susieInfFit}{Optional fitted SuSiE-inf object.} -\item{retainFit}{If TRUE, stores the fitted object as an attribute on the -returned weights.} - -\item{...}{Additional arguments passed to `susieR::susie()` when fitting.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ Numeric vector of variant weights. @@ -42,5 +48,6 @@ Extracts coefficients from an existing SuSiE-inf fit or fits data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] y <- eqtlRegionExample$yRes -susieInfWeights(X, y) +fit <- susieR::susie(X, y, L = 5) +susieInfWeights(susieInfFit = fit) } diff --git a/man/susieRssWeights.Rd b/man/susieRssWeights.Rd index c73eef7f7..c54884361 100644 --- a/man/susieRssWeights.Rd +++ b/man/susieRssWeights.Rd @@ -8,8 +8,7 @@ susieRssWeights( stat, LD, susieRssFit = NULL, - retainFit = TRUE, - methodArgs = list() + fitRetention = c("slim", "none", "full") ) } \arguments{ @@ -18,14 +17,13 @@ sizes).} \item{LD}{LD correlation matrix.} -\item{susieRssFit}{Optional pre-fitted SuSiE-RSS object.} +\item{susieRssFit}{A fitted SuSiE-RSS object. Required: these wrappers +extract weights and never run fine-mapping themselves.} -\item{retainFit}{If TRUE, stores the fitted object as an attribute.} - -\item{methodArgs}{Named list of additional arguments passed to -\code{susieR::susie_rss()}. Use this instead of \code{...} to avoid partial -matching of short argument names (e.g. \code{L}) to the \code{LD} -parameter.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ Numeric vector of variant weights. @@ -47,5 +45,6 @@ stat <- list( z = vapply(ss, function(s) s[1] / s[2], numeric(1)), n = rep(nrow(X), ncol(X))) LD <- cor(X) -susieRssWeights(stat, LD) +fit <- susieR::susie_rss(z = stat$z, R = LD, n = nrow(X), L = 5) +susieRssWeights(stat, LD, susieRssFit = fit) } diff --git a/man/susieWeights.Rd b/man/susieWeights.Rd index 182672737..919dd3958 100644 --- a/man/susieWeights.Rd +++ b/man/susieWeights.Rd @@ -4,30 +4,37 @@ \alias{susieWeights} \title{Compute SuSiE TWAS weights} \usage{ -susieWeights(X = NULL, y = NULL, susieFit = NULL, retainFit = FALSE, ...) +susieWeights( + X = NULL, + y = NULL, + susieFit = NULL, + fitRetention = c("none", "slim", "full") +) } \arguments{ -\item{X}{Genotype matrix. Required when `susieFit` is NULL.} +\item{X}{Optional genotype matrix; when supplied it is only used to +check that the fit covers the same number of variants.} -\item{y}{Phenotype vector. Required when `susieFit` is NULL.} +\item{y}{Unused; retained for signature compatibility.} \item{susieFit}{Optional fitted SuSiE object.} -\item{retainFit}{If TRUE, stores the fitted object as an attribute on the -returned weights.} - -\item{...}{Additional arguments passed to `susieR::susie()` when fitting.} +\item{fitRetention}{How much of the fit is kept on the returned weights: +\code{"none"} attaches nothing, \code{"slim"} and \code{"full"} attach +it as the \code{"fit"} attribute. These extractors hold no trimmable +intermediates, so the two retaining levels behave alike here.} } \value{ Numeric vector of variant weights. } \description{ -Extracts coefficients from an existing SuSiE fit or fits `susieR::susie()` +Extracts coefficients from an existing SuSiE fit. from `X` and `y` before extracting weights. } \examples{ data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] y <- eqtlRegionExample$yRes -susieWeights(X, y) +fit <- susieR::susie(X, y, L = 5) +susieWeights(susieFit = fit) } diff --git a/man/twasEngineOptions.Rd b/man/twasEngineOptions.Rd new file mode 100644 index 000000000..e911fbf78 --- /dev/null +++ b/man/twasEngineOptions.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{twasEngineOptions} +\alias{twasEngineOptions} +\alias{GlmnetOptions} +\alias{QggOptions} +\alias{BglrOptions} +\alias{DprOptions} +\alias{NcvregOptions} +\alias{L0learnOptions} +\alias{MrashOptions} +\alias{MrashRssOptions} +\alias{PrsCsOptions} +\alias{LassosumOptions} +\alias{PenalizedRssOptions} +\alias{SdprOptions} +\alias{MrmashOptions} +\alias{MrmashRssOptions} +\title{Arguments For A TWAS Weight-Fitting Engine} +\usage{ +GlmnetOptions(...) + +QggOptions(...) + +BglrOptions(...) + +DprOptions(...) + +NcvregOptions(...) + +L0learnOptions(...) + +MrashOptions(...) + +MrashRssOptions(...) + +PrsCsOptions(...) + +LassosumOptions(...) + +PenalizedRssOptions(...) + +SdprOptions(...) + +MrmashOptions(...) + +MrmashRssOptions(...) +} +\arguments{ +\item{...}{Arguments for the engine, under its own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Options forwarded to the engine behind a TWAS weight method, + checked against that engine's live formals where it enumerates them. Pass + the result as an element of \code{\link{TwasWeightsMethodsParam}}, or + directly to the matching weights function. + + A method's individual-level and summary-statistic paths often run + DIFFERENT engines, and then each takes its own constructor: + \code{lassoWeights} fits with glmnet (\code{GlmnetOptions}) while + \code{lassosumRssWeights} runs pecotmr's lassosum solver + (\code{LassosumOptions}); \code{scadWeights} / \code{mcpWeights} / + \code{l0learnWeights} use ncvreg and L0Learn while their \code{*Rss} + counterparts use \code{PenalizedRssOptions}; \code{dprGibbsWeights} uses + RcppDPR and \code{sdprWeights} uses \code{SdprOptions}. Splitting them is + what lets each be checked exactly, rather than against a union in which + an option meant for the other path would pass and then be dropped. + + \code{GlmnetOptions}, \code{NcvregOptions} and \code{DprOptions} cannot be + checked: \code{cv.glmnet}, \code{cv.ncvreg} and \code{fit_model} each + take \code{...}, so they accept any name and there is nothing to check + against. Every other constructor here rejects an unknown option. See + \code{\link{MethodOptions}}. +} +\examples{ +GlmnetOptions(nfold = 10) +QggOptions(nit = 1000) +LassosumOptions(thr = 1e-4) +} diff --git a/man/twasWeightsCv.Rd b/man/twasWeightsCv.Rd index b3afdfa3d..a7d4337b7 100644 --- a/man/twasWeightsCv.Rd +++ b/man/twasWeightsCv.Rd @@ -15,9 +15,11 @@ twasWeightsCv( variantsToKeep = NULL, numThreads = 1, verbose = 1, - retainFits = FALSE, + fitRetention = c("none", "slim", "full"), seed = NULL, - ... + dataDrivenPriorMatricesCv = NULL, + reweightedMixturePriorCv = NULL, + fittedModelsCv = NULL ) } \arguments{ @@ -56,8 +58,11 @@ is enabled with that many threads.} messages, 1 = suppress external package messages (default), 2 = show all messages including those from external packages.} -\item{retainFits}{Logical. Retain the per-fold / per-method fitted-model -objects on the result. Default \code{FALSE}.} +\item{fitRetention}{How much of each per-method fit is kept on the result: +\code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed +payload downstream needs, \code{"full"} keeps the whole fitted object. +Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; +for every other method the two behave alike.} \item{seed}{Integer or \code{NULL}. When supplied, seeds both the main-process RNG (fold partitioning, variant sub-sampling) and the @@ -67,7 +72,18 @@ seed is scoped to the call, so the session RNG is left as it was found. \code{NULL} (default) does not seed at all and uses the historical parallel default.} -\item{...}{Additional arguments forwarded to the per-method weight learners.} +\item{dataDrivenPriorMatricesCv}{Optional list, one element per fold, of +data-driven prior matrices for the mr.mash learner.} + +\item{reweightedMixturePriorCv}{Optional list, one element per fold, of +reweighted mixture priors for the mvSuSiE learner.} + +\item{fittedModelsCv}{Optional per-fold fine-mapping fits, as +\code{method -> fold_ -> fit}, from a \code{fineMappingPipeline()} +run with \code{cvFolds > 1}. SuSiE-family weight wrappers extract from a +supplied fit and never fine-map, so this is what makes cross-validating +them possible; it must have been produced on \code{samplePartitions}, +since a fit trained on different folds would leak held-out samples.} } \value{ A list with the following components: @@ -105,6 +121,9 @@ method to the entire Y matrix for each fold. data(multiTraitData) X <- multiTraitData$X[, 1:80] Y <- multiTraitData$Y +# A cross-validated method is refit on each fold's training rows. The +# SuSiE family never fine-maps, so it needs each fold's own fit, passed +# as `fittedModelsCv` from a fineMappingPipeline() run with cvFolds > 1. twasWeightsCv(X, Y[, 1, drop = FALSE], fold = 3, - weightMethods = list(susie_weights = list())) + weightMethods = list(lasso_weights = list())) } diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index 2624d587a..24e4b30f6 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -5,7 +5,6 @@ \alias{twasWeightsPipeline,QtlDataset-method} \alias{twasWeightsPipeline,QtlSumStats-method} \alias{twasWeightsPipeline,MultiStudyQtlDataset-method} -\alias{twasWeightsPipeline,ANY-method} \title{TWAS Weights Pipeline} \usage{ twasWeightsPipeline(data, ...) @@ -17,40 +16,24 @@ twasWeightsPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, - mafCutoff = NULL, - macCutoff = NULL, - xvarCutoff = NULL, - imissCutoff = NULL, - keepIndel = NULL, - keepSamples = NULL, - keepVariants = NULL, + genotypeFilterArgs = GenotypeFilterParam(), jointRegions = FALSE, jointSpecification = NULL, fineMappingResult = NULL, twasWeights = NULL, mashPrior = NULL, - cvFolds = 5, - samplePartition = NULL, + crossValidationArgs = CrossValidationParam(), fitFullData = TRUE, - maxCvVariants = -1, - cvThreads = 1, - cvWeightMethods = NULL, - ensemble = TRUE, - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", - ensembleAlpha = 1, + ensembleArgs = EnsembleParam(), estimatePi = TRUE, - retainFit = TRUE, - retainFitDetail = c("slim", "full"), - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, + usePCA = FALSE, + nPCs = 10L, + fitRetention = c("slim", "none", "full"), + residualizationArgs = ResidualizationParam(), dataType = NULL, naAction = c("drop", "impute"), verbose = 1, - seed = NULL, - ... + seed = NULL ) \S4method{twasWeightsPipeline}{QtlSumStats}( @@ -61,14 +44,11 @@ twasWeightsPipeline(data, ...) jointSpecification = NULL, fineMappingResult = NULL, twasWeights = NULL, - retainFit = TRUE, - retainFitDetail = c("slim", "full"), + fitRetention = c("slim", "none", "full"), dataType = NULL, verbose = 1L, - mafCutoff = 0, - macCutoff = 0, - imissCutoff = 1, - ... + panelFilterArgs = PanelFilterParam(), + crossValidationArgs = CrossValidationParam() ) \S4method{twasWeightsPipeline}{MultiStudyQtlDataset}( @@ -78,23 +58,24 @@ twasWeightsPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, + genotypeFilterArgs = GenotypeFilterParam(), + panelFilterArgs = PanelFilterParam(), jointRegions = FALSE, jointSpecification = NULL, fineMappingResult = NULL, twasWeights = NULL, - retainFit = TRUE, - retainFitDetail = c("slim", "full"), + mashPrior = NULL, + fitFullData = TRUE, + estimatePi = TRUE, + fitRetention = c("slim", "none", "full"), + dataType = NULL, naAction = c("drop", "impute"), verbose = 1, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, - residualizePhenotypeCovariates = TRUE, - residualizeGenotypeCovariates = TRUE, - seed = NULL, - ... + residualizationArgs = ResidualizationParam(), + crossValidationArgs = CrossValidationParam(), + ensembleArgs = EnsembleParam(), + seed = NULL ) - -\S4method{twasWeightsPipeline}{ANY}(data, ...) } \arguments{ \item{data}{A \code{QtlDataset}, \code{MultiStudyQtlDataset}, or @@ -126,17 +107,15 @@ with \code{chrom}/\code{start}/\code{end}. Mutually exclusive with position when extracting variants. Required when \code{traitId} is supplied. Mutually exclusive with \code{region}.} -\item{mafCutoff, macCutoff, xvarCutoff, imissCutoff}{For QtlDataset: optional -per-call genotype-filter overrides. Each replaces the corresponding -construct-time \code{\link{QtlDataset}} slot for this call only (applied to -a validated copy); \code{NULL} (default) leaves the stored value in place. -Variant QC is a property of the data, so these are applied identically here -and in \code{\link{fineMappingPipeline}} -- there is deliberately no +\item{genotypeFilterArgs}{For QtlDataset: per-call genotype-filter overrides, +built with \code{\link{GenotypeFilterParam}}. Each field that is set +replaces the corresponding construct-time \code{\link{QtlDataset}} slot +for this call only (applied to a validated copy); a field left unset +leaves the stored value in place. Variant QC is a property of the data, +so these are applied identically here and in +\code{\link{fineMappingPipeline}} --- there is deliberately no TWAS-specific variant filter.} -\item{keepIndel, keepSamples, keepVariants}{As above: per-call -\code{\link{QtlDataset}} genotype-filter overrides.} - \item{jointRegions}{For QtlDataset with a multi-range \code{region}: \code{FALSE} (default) learns weights for each range independently and concatenates them into one entry per (study, context, trait, method); the @@ -172,55 +151,75 @@ produce one fit jointly across multiple \code{(context, trait)} columns.} \item{mashPrior}{Optional \code{\link{MashPrior}} (or coercible) supplying data-driven prior matrices for mr.mash weight methods; \code{NULL} to skip.} -\item{cvFolds}{Integer. Cross-validation folds. Default 5. Set to 0 to skip -CV (and ensemble).} +\item{crossValidationArgs}{Cross-validation settings, built with + \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no + CV), \code{threads}, \code{samplePartition}, \code{maxVariants} (cap + on the CV design matrix) and \code{weightMethods} (which methods to + cross-validate; unset means every method with non-zero weights). + + \code{folds} defaulted to \code{5} before, while + \code{\link{fineMappingPipeline}}'s defaulted to \code{0}. The two now + agree on \code{0}, so an unspecified setting means one thing. -\item{samplePartition}{Optional pre-defined CV partition data.frame.} + Cross-validation holds out \strong{samples}, so it is not possible on + \code{QtlSumStats} input; that method \strong{errors} if it is set + rather than returning results that were never cross-validated.} \item{fitFullData}{Logical. If \code{TRUE}, fit final weights on the full data after cross-validation. Default \code{TRUE}.} -\item{maxCvVariants}{Maximum number of variants for CV. Default -1 (no -limit).} - -\item{cvThreads}{Threads for CV parallelism. Default 1.} - -\item{cvWeightMethods}{Optional override of methods used for CV.} - -\item{ensemble}{Logical. Compute SR-TWAS ensemble weights. Default -\code{TRUE}.} - -\item{ensembleR2Threshold}{Minimum CV R-squared for ensemble inclusion. -Default 0.01.} - -\item{ensembleSolver}{Solver for ensemble stacking. Default -\code{"quadprog"}.} - -\item{ensembleAlpha}{Elastic-net mixing parameter (only when -\code{ensembleSolver = "glmnet"}). Default 1.} +\item{ensembleArgs}{SR-TWAS ensemble settings, built with +\code{\link{EnsembleParam}}: \code{enabled} (default \code{FALSE}), +\code{r2Threshold}, \code{solver} and \code{alpha}. Stacking reads +out-of-fold predictions, so \code{enabled = TRUE} requires +\code{crossValidation} with \code{folds >= 2} and is an error +otherwise --- it previously returned a result quietly missing its +ensemble row.} \item{estimatePi}{If TRUE, estimate spike-and-slab sparsity from mr.ash before BGLR / qgg spike-and-slab methods that consume it.} -\item{retainFit}{Logical. Retain the fitted-model object on each entry. -Default \code{FALSE}.} - -\item{retainFitDetail}{Character. Level of fit detail to retain: -\code{"slim"} (default) or \code{"full"}.} - -\item{phenotypeCovariatesToResidualize, genotypeCovariatesToResidualize}{Character vector (or \code{NULL}) of covariate column names to residualize -against. Forwarded to \code{\link{getResidualizedPhenotypes}} / -\code{\link{getResidualizedGenotypes}} for \code{QtlDataset} / -\code{MultiStudyQtlDataset} input. Default \code{NULL} (use all available -covariates). Ignored for sumstat inputs.} - -\item{residualizePhenotypeCovariates}{Logical (length 1). When \code{TRUE} -(default) residualize against the phenotype-side covariates listed in -\code{phenotypeCovariatesToResidualize}; set \code{FALSE} to disable.} - -\item{residualizeGenotypeCovariates}{Logical (length 1). When \code{TRUE} -(default) residualize against the genotype-side covariates listed in -\code{genotypeCovariatesToResidualize}; set \code{FALSE} to disable.} +\item{usePCA}{Logical (length 1). \code{QtlDataset} only. When +\code{TRUE}, each multi-trait context is additionally PCA-reduced and +weights are fitted for each top principal component \emph{as a trait} +(\code{topPC1}, \code{topPC2}, ...), alongside the per-trait rows. The +same reduction \code{\link{fineMappingPipeline}} applies, sharing its +scores helper and producing groups the ordinary CV / ensemble / +retention machinery handles unchanged. A single-trait context, or one +with no usable component, contributes nothing.} + +\item{nPCs}{Integer (length 1). Caps the number of top principal +components fitted per context when \code{usePCA = TRUE} (default +\code{10}). The effective count is \code{min(nPCs, usable traits)}.} + +\item{fitRetention}{How much of each fit is kept on the entry: + \code{"slim"} (default), \code{"none"} to keep no fit at all, or + \code{"full"}. The same setting \code{\link{fineMappingPipeline}} + takes, which has no \code{"none"} --- its \code{susieFit} slot is part + of the returned object's contract. + + \code{"full"} is honoured only by the mr.mash engines, the only ones + that distinguish the two retaining levels; every other method keeps its + fit whole or not at all. Requesting \code{"full"} for a run where no + method can honour it is an error, and a mixed run warns rather than + dropping it in silence.} + +\item{residualizationArgs}{Covariate residualization settings, built with + \code{\link{ResidualizationParam}} and forwarded to + \code{\link{getResidualizedPhenotypes}} / + \code{\link{getResidualizedGenotypes}}: \code{phenotypeCovariates} and + \code{genotypeCovariates} name which covariates to regress out + (\code{NULL}, the default, uses every available one), and + \code{residualizePhenotype} / \code{residualizeGenotype} turn each side + off. + + \code{QtlDataset} / \code{MultiStudyQtlDataset} input only. A + \code{QtlSumStats} run has no covariates to regress out, so the bundle + is \strong{ignored} there rather than refused --- unlike + \code{crossValidation}, which errors. Residualization is on by default, + so refusing a non-default value would reject the default bundle; CV is + off by default, so a non-default value there is an explicit request for + something the input cannot do.} \item{dataType}{Optional data-type label recorded on every \code{TwasWeightsRow$dataType} (e.g. \code{"expression"}).} @@ -238,6 +237,11 @@ reproducibility under multi-threading. The main-process seed is scoped to the call, so the session RNG is left as it was found. \code{NULL} (default) does not seed at all, so an outer \code{set.seed()} still governs the main-process draws.} + +\item{panelFilterArgs}{For QtlSumStats: LD-reference-panel filters, +built with +\code{\link{PanelFilterParam}}. See \emph{Panel filters on the RSS path} +above.} } \value{ A \code{\link{TwasWeights}} collection keyed by \code{(study, @@ -293,17 +297,17 @@ same shared partition. } \section{Panel filters on the RSS path}{ On \code{QtlSumStats} input there - is no genotype matrix to filter, so \code{mafCutoff} / \code{macCutoff} / - \code{imissCutoff} are measured against the \strong{LD reference panel} - instead: a variant whose panel genotypes fall below the cutoffs is dropped - before the z-scores and LD matrix are built. The thresholds mean the same - thing as on the \code{QtlDataset} path (MAC is converted to a MAF - equivalent and the stricter of the two applies), so one number carries - across input types. Defaults (\code{0}, \code{0}, \code{1}) filter - nothing. + is no genotype matrix to filter, so \code{panelFilter}'s + \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured + against the \strong{LD reference panel} instead: a variant whose panel + genotypes fall below the cutoffs is dropped before the z-scores and LD + matrix are built. The thresholds mean the same thing as + \code{genotypeFilter}'s on the \code{QtlDataset} path (MAC is converted + to a MAF equivalent and the stricter of the two applies), so one number + carries across input types. The defaults filter nothing. This discards \emph{observed} variants, unlike - \code{summaryStatsQc(imputeOpts = ...)}, which only bounds which variants + \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants RAISS will impute. } diff --git a/man/waldTestPval.Rd b/man/waldTestPval.Rd index 2afa4e121..79436a529 100644 --- a/man/waldTestPval.Rd +++ b/man/waldTestPval.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pvalCombine.R +% Please edit documentation in R/pvalCombineWrappers.R \name{waldTestPval} \alias{waldTestPval} \title{Wald-test two-sided p-value} diff --git a/man/weightedLs.Rd b/man/weightedLs.Rd deleted file mode 100644 index 9bca6b8e1..000000000 --- a/man/weightedLs.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2EstimationWrappers.R -\name{weightedLs} -\alias{weightedLs} -\title{Weighted Least Squares} -\usage{ -weightedLs(y, X, w) -} -\arguments{ -\item{y}{Numeric vector, response.} - -\item{X}{Numeric matrix, predictors.} - -\item{w}{Numeric vector, weights (inverse variance).} -} -\value{ -A list with coefficients, SE, residuals, fitted values. -} -\description{ -Compute WLS estimate with standard errors. -} -\keyword{internal} diff --git a/man/weightedLsRidge.Rd b/man/weightedLsRidge.Rd deleted file mode 100644 index 65d7cefbc..000000000 --- a/man/weightedLsRidge.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2EstimationWrappers.R -\name{weightedLsRidge} -\alias{weightedLsRidge} -\title{Ridge-Regularized Weighted Least Squares} -\usage{ -weightedLsRidge(y, X, w, lambda = 0, penalizeIntercept = FALSE) -} -\arguments{ -\item{y}{Numeric vector, response.} - -\item{X}{Numeric matrix, predictors.} - -\item{w}{Numeric vector, weights (inverse variance).} - -\item{lambda}{Numeric, ridge penalty. 0 = no penalty (delegates to -\code{weightedLs}).} - -\item{penalizeIntercept}{Logical. If FALSE (default), the last column of X -(assumed to be the intercept) is not penalized.} -} -\value{ -Same structure as \code{weightedLs}: coef, se, residuals, fitted, - vcov. -} -\description{ -WLS with optional L2 penalty on coefficients. -} -\keyword{internal} diff --git a/man/writeSumStatsVcf.Rd b/man/writeSumStatsVcf.Rd index b03b988cb..e9cbcdb29 100644 --- a/man/writeSumStatsVcf.Rd +++ b/man/writeSumStatsVcf.Rd @@ -8,7 +8,7 @@ \usage{ writeSumStatsVcf(x, outputPath, sampleName = NULL, ...) -\S4method{writeSumStatsVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, study = NULL, ...) +\S4method{writeSumStatsVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, study = NULL) \S4method{writeSumStatsVcf}{FineMappingResultBase}( x, @@ -19,8 +19,7 @@ writeSumStatsVcf(x, outputPath, sampleName = NULL, ...) trait = NULL, method = NULL, splitByContext = FALSE, - splitByTrait = FALSE, - ... + splitByTrait = FALSE ) } \arguments{ diff --git a/pixi.toml b/pixi.toml index 4957a48e9..3876de8f5 100644 --- a/pixi.toml +++ b/pixi.toml @@ -25,14 +25,18 @@ dependencies = {"r-base" = "4.5.*"} [environments] r45 = {features = ["r45"]} +[target.linux-64.dependencies] +"gcc" = "*" + [dependencies] "air" = "*" "bioconductor-bioccheck" = "*" "bioconductor-plyranges" = "*" "bioconductor-tidysummarizedexperiment" = "*" -"gcc" = "*" "r-covr" = "*" +"r-decor" = "*" "r-devtools" = "*" +"r-goodpractice" = "*" "r-knitr" = "*" "r-lintr" = "*" "r-markdown" = "*" @@ -59,6 +63,7 @@ r45 = {features = ["r45"]} "r-base" = "*" "r-bglr" = "*" "r-bigsnpr" = "*" +"r-checkmate" = "*" "r-coda" = "*" "r-coloc" = "*" "r-colocboost" = "*" @@ -66,7 +71,6 @@ r45 = {features = ["r45"]} "r-cpp11" = "*" "r-cpp11armadillo" = "*" "r-ctwas" = "*" -"r-decor" = "*" "r-dplyr" = "*" "r-flashier" = "*" "r-fsusier" = "*" diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 3e1566068..9a538c073 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -6,10 +6,10 @@ #include // dentist_iterative_impute.cpp -cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int nSample, const doubles& zScoreR, double pValueThreshold, double propSVD, bool gcControl, int nIter, double gPvalueThreshold, int ncpus, bool correctChenEtAlBug, bool verbose, cpp11::sexp seed); -extern "C" SEXP _pecotmr_dentistIterativeImpute(SEXP ldMatR, SEXP nSample, SEXP zScoreR, SEXP pValueThreshold, SEXP propSVD, SEXP gcControl, SEXP nIter, SEXP gPvalueThreshold, SEXP ncpus, SEXP correctChenEtAlBug, SEXP verbose, SEXP seed) { +cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int nSample, const doubles& zScoreR, double pValueThreshold, double propSVD, bool gcControl, int nIter, double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, bool verbose, cpp11::sexp seed); +extern "C" SEXP _pecotmr_dentistIterativeImpute(SEXP ldMatR, SEXP nSample, SEXP zScoreR, SEXP pValueThreshold, SEXP propSVD, SEXP gcControl, SEXP nIter, SEXP gPvalueThreshold, SEXP numThreads, SEXP correctChenEtAlBug, SEXP verbose, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(dentistIterativeImpute(cpp11::as_cpp&>>(ldMatR), cpp11::as_cpp>(nSample), cpp11::as_cpp>(zScoreR), cpp11::as_cpp>(pValueThreshold), cpp11::as_cpp>(propSVD), cpp11::as_cpp>(gcControl), cpp11::as_cpp>(nIter), cpp11::as_cpp>(gPvalueThreshold), cpp11::as_cpp>(ncpus), cpp11::as_cpp>(correctChenEtAlBug), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(dentistIterativeImpute(cpp11::as_cpp&>>(ldMatR), cpp11::as_cpp>(nSample), cpp11::as_cpp>(zScoreR), cpp11::as_cpp>(pValueThreshold), cpp11::as_cpp>(propSVD), cpp11::as_cpp>(gcControl), cpp11::as_cpp>(nIter), cpp11::as_cpp>(gPvalueThreshold), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(correctChenEtAlBug), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); END_CPP11 } // lassosum_rss.cpp @@ -41,10 +41,10 @@ extern "C" SEXP _pecotmr_qtlEnrichmentRcpp(SEXP rGwasPip, SEXP rQtlSusieFit, SEX END_CPP11 } // sdpr.cpp -cpp11::writable::list sdprRcpp(const doubles& bhatR, const list& LD, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int nThreads, int optLlk, bool verbose, sexp seed); -extern "C" SEXP _pecotmr_sdprRcpp(SEXP bhatR, SEXP LD, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP nThreads, SEXP optLlk, SEXP verbose, SEXP seed) { +cpp11::writable::list sdprRcpp(const doubles& bhatR, const list& LD, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int numThreads, int optLlk, bool verbose, sexp seed); +extern "C" SEXP _pecotmr_sdprRcpp(SEXP bhatR, SEXP LD, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP numThreads, SEXP optLlk, SEXP verbose, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(sdprRcpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp>(LD), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(nThreads), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(sdprRcpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp>(LD), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); END_CPP11 } diff --git a/src/dentist_iterative_impute.cpp b/src/dentist_iterative_impute.cpp index 09d87de6c..8524ab4b1 100644 --- a/src/dentist_iterative_impute.cpp +++ b/src/dentist_iterative_impute.cpp @@ -100,7 +100,7 @@ double minusLogPvalueChisq2(double stat) { // eigenvalues in ascending order, so the logic is identical. void oneIteration(const mat& LD_mat, const std::vector& idx, const std::vector& idx2, const vec& zScore, vec& imputedZ, vec& rsqList, vec& zScore_e, - size_t nSample, float probSVD, int ncpus, bool verbose, + size_t nSample, float probSVD, int numThreads, bool verbose, std::vector& rsqExceed) { if (verbose) { Rprintf("LD_mat: %lux%lu idx: %lu idx2: %lu\n", @@ -109,7 +109,7 @@ void oneIteration(const mat& LD_mat, const std::vector& idx, const std:: } int nProcessors = omp_get_max_threads(); - if (ncpus < nProcessors) nProcessors = ncpus; + if (numThreads < nProcessors) nProcessors = numThreads; omp_set_num_threads(nProcessors); size_t K = std::min(static_cast(idx.size()), nSample) * probSVD; @@ -208,7 +208,7 @@ void oneIteration(const mat& LD_mat, const std::vector& idx, const std:: * @param gcControl A boolean flag to apply genetic control corrections. * @param nIter The number of iterations to run the DENTIST algorithm. * @param gPvalueThreshold P-value threshold for grouping variants into significant and null categories. - * @param ncpus The number of CPU cores to use for parallel processing. + * @param numThreads The number of CPU cores to use for parallel processing. * @param correctChenEtAlBug Whether to correct the original DENTIST bug. * @param verbose A boolean flag to enable verbose output for debugging. * @@ -223,7 +223,7 @@ void oneIteration(const mat& LD_mat, const std::vector& idx, const std:: [[cpp11::register]] cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int nSample, const doubles& zScoreR, double pValueThreshold, double propSVD, bool gcControl, int nIter, - double gPvalueThreshold, int ncpus, bool correctChenEtAlBug, + double gPvalueThreshold, int numThreads, bool correctChenEtAlBug, bool verbose, cpp11::sexp seed = R_NilValue) { mat LD_mat = as_Mat(ldMatR); vec zScore = as_Col(zScoreR); @@ -237,13 +237,13 @@ cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int Rprintf("gcControl: %d\n", gcControl); Rprintf("nIter: %d\n", nIter); Rprintf("gPvalueThreshold: %g\n", gPvalueThreshold); - Rprintf("ncpus: %d\n", ncpus); + Rprintf("numThreads: %d\n", numThreads); Rprintf("correctChenEtAlBug: %d\n", correctChenEtAlBug); } // Set number of threads for parallel processing int nProcessors = omp_get_max_threads(); - if (ncpus < nProcessors) nProcessors = ncpus; + if (numThreads < nProcessors) nProcessors = numThreads; omp_set_num_threads(nProcessors); size_t markerSize = zScore.size(); @@ -299,7 +299,7 @@ cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int Rprintf("Performing oneIteration()\n"); } - oneIteration(LD_mat, idx, idx2, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, ncpus, verbose, rsqExceed); + oneIteration(LD_mat, idx, idx2, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, numThreads, verbose, rsqExceed); diff.resize(idx2.size()); grouping_tmp.resize(idx2.size()); @@ -377,7 +377,7 @@ cpp11::writable::list dentistIterativeImpute(const doubles_matrix<>& ldMatR, int Rprintf("Performing oneIteration() with updated sets of indices\n"); } - oneIteration(LD_mat, idx2_QCed, idx, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, ncpus, verbose, rsqExceed); + oneIteration(LD_mat, idx2_QCed, idx, zScore, imputedZ, rsq, zScore_e, nSample, propSVD, numThreads, verbose, rsqExceed); if (verbose) { Rprintf("Recalculating differences and groupings after the iteration\n"); diff --git a/src/sdpr.cpp b/src/sdpr.cpp index 9b10de16c..80830920d 100644 --- a/src/sdpr.cpp +++ b/src/sdpr.cpp @@ -23,7 +23,7 @@ cpp11::writable::list sdprRcpp( int iter = 1000, int burn = 200, int thin = 5, - int nThreads = 1, + int numThreads = 1, int optLlk = 1, bool verbose = true, sexp seed = R_NilValue @@ -64,7 +64,7 @@ cpp11::writable::list sdprRcpp( // Call the mcmc function std::unordered_map results = mcmc( - data, n, a, c, M, a0k, b0k, iter, burn, thin, nThreads, optLlk, verbose, seed_val + data, n, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed_val ); // Convert results to list diff --git a/tests/testthat/helper-cfgForwarding.R b/tests/testthat/helper-cfgForwarding.R new file mode 100644 index 000000000..c34fd15a3 --- /dev/null +++ b/tests/testthat/helper-cfgForwarding.R @@ -0,0 +1,57 @@ +# Shared by the cfg-forwarding tests, which live in +# test_fineMappingPipeline.R and test_mashPipeline.R. +# +# The per-study / per-sumstats recursions hand their cfg record on as +# explicit `name = cfg$name` pairs. R catches the wrong direction for free: +# a name the entry point does not accept is an "unused argument" error, even +# through an S4 generic's `...`. The direction R cannot catch is OMISSION -- +# a field added to the record and forgotten at one call site silently takes +# the callee's default, which is how multi-study TWAS once inherited the +# per-study cross-validation default. This pins that direction. + +# The field names a cfg builder emits, read off its terminal list(). + +.cfgFieldNames <- function(fnName) { + f <- get(fnName, envir = asNamespace("pecotmr")) + lst <- NULL + rec <- function(e) { + if (!is.call(e)) { + return(invisible(NULL)) + } + if (identical(e[[1]], as.name("list")) && !is.null(names(e))) { + nm <- names(e)[nzchar(names(e))] + if (length(nm) > length(lst)) lst <<- nm + } + for (i in seq_along(e)) { + if (i == 1L || rlang::is_missing(e[[i]])) { + next + } + rec(e[[i]]) + } + } + rec(body(f)) + lst +} + +# Every `name = ...` the function's body passes to anything. +.argNamesPassed <- function(fnName) { + f <- get(fnName, envir = asNamespace("pecotmr")) + out <- character(0) + rec <- function(e) { + if (!is.call(e)) { + return(invisible(NULL)) + } + nm <- names(e) + if (!is.null(nm)) { + out <<- c(out, nm[nzchar(nm)]) + } + for (i in seq_along(e)) { + if (i == 1L || rlang::is_missing(e[[i]])) { + next + } + rec(e[[i]]) + } + } + rec(body(f)) + unique(out) +} diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index fd67925bd..a83c85ed4 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -5,7 +5,7 @@ # Test data helpers # ============================================================================= -make_test_granges <- function(n = 10) { +makeTestGRanges <- function(n = 10) { GenomicRanges::GRanges( seqnames = rep("chr1", n), ranges = IRanges::IRanges( @@ -15,7 +15,7 @@ make_test_granges <- function(n = 10) { ) } -make_test_sumstats_df <- function(n = 50) { +makeTestSumstatsDf <- function(n = 50) { set.seed(42) data.frame( SNP = paste0("rs", seq_len(n)), @@ -29,7 +29,7 @@ make_test_sumstats_df <- function(n = 50) { ) } -make_test_ldblocks <- function() { +makeTestLdBlocks <- function() { blocks_gr <- GenomicRanges::GRanges( seqnames = c("chr1", "chr1"), ranges = IRanges::IRanges(start = c(1, 5001), end = c(5000, 10000)) @@ -37,7 +37,7 @@ make_test_ldblocks <- function() { blocks_gr } -make_test_snp_info <- function(n = 10) { +makeTestSnpInfo <- function(n = 10) { data.frame( SNP = paste0("rs", seq_len(n)), CHR = rep("1", n), @@ -48,7 +48,7 @@ make_test_snp_info <- function(n = 10) { ) } -make_test_annotation_meta <- function() { +makeTestAnnotationMeta <- function() { data.frame( name = c("base", "enhancer", "promoter"), tier = c("baseline", "candidate", "candidate"), @@ -249,7 +249,7 @@ makeTestLdDataMultiBlock <- function( ) { gr <- .testLdVariants(sum(sizes), chrom, startBp) LdData( - correlation = lapply(sizes, .testArBlock, rho = rho), + correlation = map(sizes, .testArBlock, rho = rho), variants = gr, blockMetadata = .testBlockMetadata(sizes, chrom, gr), nRef = nRef diff --git a/tests/testthat/helper-mash.R b/tests/testthat/helper-mash.R new file mode 100644 index 000000000..ccddab06b --- /dev/null +++ b/tests/testthat/helper-mash.R @@ -0,0 +1,46 @@ +# Shared fixtures for test_mashPipeline.R. +# +# mashr / flashier fits dominate that file's runtime. These are coverage tests +# for pecotmr's wiring, not numerical checks of mashr, so the fixture is the +# smallest slice that still drives every branch, and the prior is supplied +# outright wherever the prior itself is not what the test is about. + +# The multi-context example trimmed to `n` variants per context. Both prior +# estimation and the mash() weight fit scale with the variant count, and the +# full 200 buys nothing a branch test can see. +mashFixture <- function(n = 60L) { + utils::data( + "qtlSumStatsMulticontextExample", + package = "pecotmr", + envir = environment() + ) + full <- get("qtlSumStatsMulticontextExample", envir = environment()) + if (n >= min(lengths(full))) { + return(full) + } + endoapply(full, function(g) g[seq_len(n)]) +} + +# A two-component prior for tests where the prior is not under test. Supplying +# it takes the `priorCovariances` branch and skips the flash/pca/ed chain -- +# most of the cost -- while still running the mash() weight fit, so anything +# downstream of the prior is exercised exactly as before. +mashTinyPrior <- function(k = 3L) { + list(identity = diag(k), shared = matrix(1, k, k)) +} + +# Shared by test_mashPipeline.R and test_mashWrapper.R. +.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 + ) + )) +} diff --git a/tests/testthat/helper-rrwFixtures.R b/tests/testthat/helper-rrwFixtures.R index d2b3ec0e2..50a420575 100644 --- a/tests/testthat/helper-rrwFixtures.R +++ b/tests/testthat/helper-rrwFixtures.R @@ -10,7 +10,7 @@ rnorm(n * p), n, p, - dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * (seq_len(p)))) + dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * seq_len(p))) ) b <- rnorm(p) b[-(1:2)] <- 0 @@ -21,15 +21,13 @@ # Single-context summary statistics + LD for the *_rss_weights(stat, LD) contract. .rrwStatLd <- function(n = 50, p = 6, seed = 1) { d <- .rrwXy(n, p, seed) - bhat <- vapply( + bhat <- map_dbl( seq_len(p), - function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 1], - numeric(1) + function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 1] ) - sehat <- vapply( + sehat <- map_dbl( seq_len(p), - function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 2], - numeric(1) + function(j) summary(lm(d$y ~ d$X[, j]))$coefficients[2, 2] ) zhat <- bhat / sehat LD <- cor(d$X) @@ -52,25 +50,20 @@ rnorm(n * p), n, p, - dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * (seq_len(p)))) + dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * seq_len(p))) ) B <- matrix(0, p, K) B[1, ] <- rnorm(K, sd = 2) B[2, ] <- rnorm(K, sd = 2) Y <- X %*% B + matrix(rnorm(n * K), n, K) colnames(Y) <- paste0("ctx", seq_len(K)) - Z <- vapply( - seq_len(K), - function(k) { - vapply( - seq_len(p), - function(j) { - summary(lm(Y[, k] ~ X[, j]))$coefficients[2, 3] - }, - numeric(1) - ) - }, - numeric(p) + Z <- exec( + cbind, + !!!map(seq_len(K), function(k) { + map_dbl(seq_len(p), function(j) { + summary(lm(Y[, k] ~ X[, j]))$coefficients[2, 3] + }) + }) ) colnames(Z) <- colnames(Y) list(X = X, Y = Y, LD = cor(X), stat = list(z = Z, n = n), p = p, K = K) diff --git a/tests/testthat/helper-s4Constructors.R b/tests/testthat/helper-s4Constructors.R index aeb17c29c..ccffad526 100644 --- a/tests/testthat/helper-s4Constructors.R +++ b/tests/testthat/helper-s4Constructors.R @@ -62,7 +62,7 @@ context("s4Constructors") dataType = "expression" ) { twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = rnorm(p), standardized = standardized, dataType = dataType diff --git a/tests/testthat/helper-showMethods.R b/tests/testthat/helper-showMethods.R index 0c135c49e..990445a16 100644 --- a/tests/testthat/helper-showMethods.R +++ b/tests/testthat/helper-showMethods.R @@ -53,7 +53,7 @@ context("show methods") .sh_makeTwEntry <- function(p = 4, standardized = FALSE) { twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = rep(0.1, p), cvResult = list(rsq = 0.5), standardized = standardized diff --git a/tests/testthat/helper-sldsc.R b/tests/testthat/helper-sldsc.R index 4d343307d..c6d44959c 100644 --- a/tests/testthat/helper-sldsc.R +++ b/tests/testthat/helper-sldsc.R @@ -11,7 +11,7 @@ # Create a single .annot.gz file for one chromosome. # Real polyfun .annot.gz files have CHR, SNP, BP, CM + annotation columns only # (no MAF/A1/A2 -- those come from the .frq / PLINK files). -.make_annot_gz <- function(dir, chrom, nSnps = 50) { +.makeAnnotGz <- function(dir, chrom, nSnps = 50) { df <- data.frame( CHR = chrom, SNP = paste0("rs", (chrom - 1L) * 100L + seq_len(nSnps)), @@ -47,7 +47,7 @@ # Create the three polyfun output files (.results, .log, .part_delete) # for a single-target run. Real polyfun output includes baseline categories # even in single-target mode, so we add 2 dummy baseline categories. -.make_polyfun_single <- function( +.makePolyfunSingle <- function( dir, prefix, target_name, @@ -107,7 +107,7 @@ } # Create polyfun output files for a joint run (target + baseline annotations) -.make_polyfun_joint <- function( +.makePolyfunJoint <- function( dir, prefix, target_names, @@ -165,7 +165,7 @@ } # Build a complete fixture directory for the full pipeline -.make_sldsc_fixtures <- function(envir = parent.frame()) { +.makeSldscFixtures <- function(envir = parent.frame()) { base_dir <- withr::local_tempdir(.local_envir = envir) anno_dir <- file.path(base_dir, "annot") @@ -179,7 +179,7 @@ # Annotation + freq files for 2 chromosomes for (chr in 1:2) { - .make_annot_gz(anno_dir, chr) + .makeAnnotGz(anno_dir, chr) .make_frq(frq_dir, chr, plinkName = plink_name) } @@ -192,7 +192,7 @@ out_dir, sprintf("%s_single_%s", trait, targets[i]) ) - .make_polyfun_single( + .makePolyfunSingle( out_dir, pref, targets[i], @@ -204,7 +204,7 @@ # Joint runs: 1 per trait for (trait in c("traitX", "traitY")) { pref <- file.path(out_dir, sprintf("%s_joint", trait)) - .make_polyfun_joint(out_dir, pref, targets, h2g = 0.3) + .makePolyfunJoint(out_dir, pref, targets, h2g = 0.3) } list( @@ -294,6 +294,6 @@ } tr } - traits <- setNames(lapply(traitNames, function(.) mkTrait()), traitNames) + traits <- setNames(map(traitNames, function(.) mkTrait()), traitNames) SldscData(annot = annot, frq = frq, traits = traits) } diff --git a/tests/testthat/helper-twas.R b/tests/testthat/helper-twas.R deleted file mode 100644 index 7653fe5a0..000000000 --- a/tests/testthat/helper-twas.R +++ /dev/null @@ -1,35 +0,0 @@ -# Shared test helper: simulate a small (X, Y) pair for twas weights / -# causal-inference tests. Migrated from the old test_twas.R preamble. -generate_X_Y <- function( - seed = 1, - num_samples = 10, - num_features = 10, - X_rownames = TRUE, - y_rownames = TRUE -) { - set.seed(seed) - X <- scale( - matrix(rnorm(num_samples * num_features), nrow = num_samples), - center = TRUE, - scale = TRUE - ) - - if (X_rownames) { - rownames(X) <- paste0("sample", 1:num_samples) - } else { - rownames(X) <- NULL - } - - beta = rep(0, num_features) - beta[1:4] = 1 - y <- X %*% beta + rnorm(num_samples) - y <- matrix(y, nrow = num_samples, ncol = 1) - if (y_rownames) { - rownames(y) <- paste0("sample", 1:num_samples) - } else { - rownames(y) <- NULL - } - colnames(y) <- c("Outcome") - - return(list(X = X, Y = y)) -} diff --git a/tests/testthat/test_AnnotationMatrix.R b/tests/testthat/test_AnnotationMatrix.R index 8935de5e4..4fb4bbefc 100644 --- a/tests/testthat/test_AnnotationMatrix.R +++ b/tests/testthat/test_AnnotationMatrix.R @@ -10,8 +10,8 @@ context("AnnotationMatrix") # helper-h2Classes.R. test_that("AnnotationMatrix validates dimensions and meta", { - gr <- make_test_granges(10) - meta <- make_test_annotation_meta() + gr <- makeTestGRanges(10) + meta <- makeTestAnnotationMeta() mat <- matrix(0, nrow = 10, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta) @@ -20,16 +20,16 @@ test_that("AnnotationMatrix validates dimensions and meta", { }) test_that("AnnotationMatrix rejects row mismatch", { - gr <- make_test_granges(10) - meta <- make_test_annotation_meta() + gr <- makeTestGRanges(10) + meta <- makeTestAnnotationMeta() 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 + gr <- makeTestGRanges(10) + meta <- makeTestAnnotationMeta() # 3 annotations mat <- matrix(0, nrow = 10, ncol = 2) # only 2 columns # Constructor errors when colnames assignment fails (dimnames mismatch) @@ -37,7 +37,7 @@ test_that("AnnotationMatrix rejects column mismatch with meta", { }) test_that("AnnotationMatrix rejects invalid tier values", { - gr <- make_test_granges(10) + gr <- makeTestGRanges(10) meta <- data.frame( name = "x", tier = "invalid_tier", @@ -50,7 +50,7 @@ test_that("AnnotationMatrix rejects invalid tier values", { }) test_that("AnnotationMatrix rejects invalid type values", { - gr <- make_test_granges(10) + gr <- makeTestGRanges(10) meta <- data.frame( name = "x", tier = "baseline", @@ -64,8 +64,8 @@ test_that("AnnotationMatrix rejects invalid type values", { test_that("AnnotationMatrix() constructor creates object from matrix", { n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() + gr <- makeTestGRanges(n) + meta <- makeTestAnnotationMeta() mat <- matrix(runif(n * 3), nrow = n, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta, genome = "hg38") @@ -77,8 +77,8 @@ test_that("AnnotationMatrix() constructor creates object from matrix", { test_that("AnnotationMatrix() sets column names from annotation_meta", { n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() + gr <- makeTestGRanges(n) + meta <- makeTestAnnotationMeta() mat <- matrix(0, nrow = n, ncol = 3) # No colnames set on mat obj <- AnnotationMatrix(mat, gr, meta) @@ -89,7 +89,7 @@ test_that("AnnotationMatrix() sets column names from annotation_meta", { }) test_that("AnnotationMatrix rejects a non-data.frame annotationMeta", { - gr <- make_test_granges(10) + gr <- makeTestGRanges(10) expect_error( AnnotationMatrix(matrix(0, 10, 3), gr, annotationMeta = list(a = 1)), "annotationMeta must be a data.frame" @@ -97,7 +97,7 @@ test_that("AnnotationMatrix rejects a non-data.frame annotationMeta", { }) test_that("AnnotationMatrix rejects annotationMeta missing required columns", { - gr <- make_test_granges(10) + gr <- makeTestGRanges(10) bad_meta <- data.frame(foo = c("a", "b", "c"), stringsAsFactors = FALSE) expect_error( AnnotationMatrix(matrix(0, 10, 3), gr, annotationMeta = bad_meta), @@ -107,8 +107,8 @@ test_that("AnnotationMatrix rejects annotationMeta missing required columns", { test_that("AnnotationMatrix accessors round-trip the stored slots", { n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() + gr <- makeTestGRanges(n) + meta <- makeTestAnnotationMeta() mat <- matrix(runif(n * 3), nrow = n, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta, genome = "hg38") @@ -130,8 +130,8 @@ test_that("AnnotationMatrix accessors round-trip the stored slots", { test_that("getBaseline() subsets to baseline-tier only", { n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() # 1 baseline, 2 candidate + gr <- makeTestGRanges(n) + meta <- makeTestAnnotationMeta() # 1 baseline, 2 candidate mat <- matrix(0, nrow = n, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta) @@ -144,8 +144,8 @@ test_that("getBaseline() subsets to baseline-tier only", { test_that("getCandidates() subsets to candidate-tier only", { n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() # 1 baseline, 2 candidate + gr <- makeTestGRanges(n) + meta <- makeTestAnnotationMeta() # 1 baseline, 2 candidate mat <- matrix(0, nrow = n, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta) @@ -161,7 +161,7 @@ test_that("getCandidates() subsets to candidate-tier only", { test_that("show(AnnotationMatrix) does not error", { am <- AnnotationMatrix( matrix(0, nrow = 10, ncol = 1), - make_test_granges(10), + makeTestGRanges(10), data.frame( name = "base", tier = "baseline", @@ -176,10 +176,10 @@ test_that("the constructor rejects a column/metadata-row mismatch", { # Rows-vs-ranges is checked above; this is the other axis -- one metadata # row per annotation COLUMN. n <- 10 - gr <- make_test_granges(n) + gr <- makeTestGRanges(n) mat <- matrix(runif(n * 4), nrow = n, ncol = 4) expect_error( - AnnotationMatrix(mat, gr, make_test_annotation_meta()), + AnnotationMatrix(mat, gr, makeTestAnnotationMeta()), "column\\(s\\) for 3 metadata row\\(s\\)" ) }) @@ -188,13 +188,23 @@ test_that("validity names the metadata columns it requires", { n <- 10 obj <- AnnotationMatrix( matrix(runif(n * 3), nrow = n, ncol = 3), - make_test_granges(n), - make_test_annotation_meta() + makeTestGRanges(n), + makeTestAnnotationMeta() ) bad <- obj SummarizedExperiment::colData(bad)$tier <- NULL expect_error( methods::validObject(bad), - "must have columns: name, tier, type" + "Colnames must include the elements \\{'name','tier','type'\\}" ) }) + +test_that("AnnotationMatrix keeps the ranges as given when genome is absent", { + # A NULL genome leaves the ranges' seqinfo alone rather than setting it. + gr <- makeTestGRanges(10) + meta <- makeTestAnnotationMeta() + mat <- matrix(0, nrow = 10, ncol = 3) + am <- AnnotationMatrix(mat, gr, meta, genome = NULL) + expect_s4_class(am, "AnnotationMatrix") + expect_true(all(is.na(GenomeInfoDb::genome(am)))) +}) diff --git a/tests/testthat/test_ColocBoostResult.R b/tests/testthat/test_ColocBoostResult.R index 3967cb9bf..355b4e9b6 100644 --- a/tests/testthat/test_ColocBoostResult.R +++ b/tests/testthat/test_ColocBoostResult.R @@ -5,7 +5,6 @@ # pair, and it computes no PP.H0-PP.H4 decomposition at all. Several tests # below guard exactly that boundary. - test_that("ColocBoostResult: one element per confidence set", { x <- ColocBoostResult( list(.cbr_fake()), @@ -253,7 +252,7 @@ test_that("show on an empty ColocBoostResult stops after the header", { # fixture built one, leaving the whole ucos_details path unexecuted. # =========================================================================== -.cbr_with_ucos <- function(ucosIds = "ucos1:y1", outcome = "t1") { +.cbrWithUcos <- function(ucosIds = "ucos1:y1", outcome = "t1") { res <- .cbr_fake() vars <- list("chr1:300:C:T") purity <- matrix( @@ -283,7 +282,7 @@ test_that("show on an empty ColocBoostResult stops after the header", { test_that("an outcome-specific set becomes its own uncolocalized element", { x <- ColocBoostResult( - list(.cbr_with_ucos()), + list(.cbrWithUcos()), "xqtl_coloc", outcomeInfo = .cbr_info() ) @@ -296,7 +295,7 @@ test_that("an uncolocalized set carries no colocalization statistics", { # cosNpc / vcp describe agreement BETWEEN outcomes, so a single-outcome # set has none to report -- NA rather than a misleading zero. x <- ColocBoostResult( - list(.cbr_with_ucos()), + list(.cbrWithUcos()), "xqtl_coloc", outcomeInfo = .cbr_info() ) @@ -310,7 +309,7 @@ test_that("an uncolocalized set carries no colocalization statistics", { test_that("show counts colocalized and outcome-only sets separately", { x <- ColocBoostResult( - list(.cbr_with_ucos()), + list(.cbrWithUcos()), "xqtl_coloc", outcomeInfo = .cbr_info() ) @@ -374,7 +373,10 @@ test_that("validity names missing identity and outcomeInfo columns", { ) bad <- x mcols(bad)$analysis <- NULL - expect_error(methods::validObject(bad), "missing columns: analysis") + expect_error( + methods::validObject(bad), + "missing elements \\{'analysis'\\}" + ) }) @@ -434,7 +436,10 @@ test_that("validity names the outcomeInfo columns that are missing", { cb@outcomeInfo <- data.frame(name = "t1") expect_match( .cbrCheckOutcomeInfo(cb), - "outcomeInfo is missing columns: study, context, trait, dataForm" + paste0( + "outcomeInfo is missing columns: .*", + "missing elements \\{'study','context','trait','dataForm'\\}" + ) ) }) diff --git a/tests/testthat/test_ColocResult.R b/tests/testthat/test_ColocResult.R index 2bf1ddae2..3ba8fad27 100644 --- a/tests/testthat/test_ColocResult.R +++ b/tests/testthat/test_ColocResult.R @@ -345,7 +345,10 @@ test_that("purity is computed per set when an LD reference is supplied", { test_that("validity names missing pair columns", { bad <- ColocResult(.cr_pairs(), .cr_variants()) mcols(bad)$gwasStudy <- NULL - expect_error(methods::validObject(bad), "missing columns: gwasStudy") + expect_error( + methods::validObject(bad), + "missing elements \\{'gwasStudy'\\}" + ) }) test_that("validity names missing posterior columns", { @@ -353,7 +356,7 @@ test_that("validity names missing posterior columns", { mcols(bad)$PP.H4.abf <- NULL expect_error( methods::validObject(bad), - "missing posterior columns: PP.H4.abf" + "missing posterior columns: .*missing elements \\{'PP.H4.abf'\\}" ) }) diff --git a/tests/testthat/test_CtwasResult.R b/tests/testthat/test_CtwasResult.R index ece4412af..51ac9fd3f 100644 --- a/tests/testthat/test_CtwasResult.R +++ b/tests/testthat/test_CtwasResult.R @@ -15,7 +15,7 @@ context("CtwasResult") susie_alpha = pip, stringsAsFactors = FALSE ), - param = prior, + groupPriors = prior, regionInfo = data.frame(region_id = "r1", stringsAsFactors = FALSE) ) } @@ -194,7 +194,10 @@ test_that("CtwasResult: show() prints a one-line-per-run summary", { test_that("validity names a missing required column", { bad <- .ctr_res() bad$context <- NULL - expect_error(methods::validObject(bad), "missing columns: context") + expect_error( + methods::validObject(bad), + "missing elements \\{'context'\\}" + ) }) test_that("validity requires one entry payload per row", { diff --git a/tests/testthat/test_CtwasResultEntry.R b/tests/testthat/test_CtwasResultEntry.R index b5c097c38..9eb9bd60c 100644 --- a/tests/testthat/test_CtwasResultEntry.R +++ b/tests/testthat/test_CtwasResultEntry.R @@ -1,7 +1,7 @@ context("CtwasResultEntry") # Migrated from test_CtwasResult.R: the per-run cTWAS payload class (constructor -# + getFinemap / getSusieAlpha / getCtwasParam accessors). The CtwasResult +# + getFinemap / getSusieAlpha / getCtwasGroupPriors accessors). The CtwasResult # collection tests live in test_CtwasResult.R. test_that("CtwasResultEntry: constructor + accessors round-trip", { @@ -16,13 +16,13 @@ test_that("CtwasResultEntry: constructor + accessors round-trip", { susie_alpha = c(0.9, 0.1), stringsAsFactors = FALSE ), - param = list(group_prior = c(brain = 0.01)), + groupPriors = 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)) + expect_equal(getCtwasGroupPriors(e)$group_prior, c(brain = 0.01)) }) test_that("CtwasResultEntry: an empty entry is valid and its accessors return NULL", { @@ -30,5 +30,5 @@ test_that("CtwasResultEntry: an empty entry is valid and its accessors return NU expect_s4_class(e, "CtwasResultEntry") expect_null(getFinemap(e)) expect_null(getSusieAlpha(e)) - expect_null(getCtwasParam(e)) + expect_null(getCtwasGroupPriors(e)) }) diff --git a/tests/testthat/test_GwasFineMappingResult.R b/tests/testthat/test_GwasFineMappingResult.R index b91366422..62a5af72b 100644 --- a/tests/testthat/test_GwasFineMappingResult.R +++ b/tests/testthat/test_GwasFineMappingResult.R @@ -302,7 +302,7 @@ test_that("GwasFineMappingResult: .tupleSelectRowGwasFmr requires both selectors expect_error(getPip(res), "Pass `study` and `method`") expect_error( getPip(res, study = c("g1", "g2"), method = "susie"), - "must each be length 1" + "Must have length 1" ) expect_error(getPip(res, study = "ghost", method = "susie"), "No entry for") }) @@ -352,7 +352,10 @@ test_that("validity names a missing identity column", { ) bad <- res mcols(bad)$method <- NULL - expect_error(methods::validObject(bad), "missing columns: method") + expect_error( + methods::validObject(bad), + "missing elements \\{'method'\\}" + ) }) test_that("validity names a missing entry payload column", { @@ -365,6 +368,69 @@ test_that("validity names a missing entry payload column", { mcols(bad)$cvResult <- NULL expect_error( methods::validObject(bad), - "missing entry payload columns: cvResult" + "missing entry payload columns: .*missing elements \\{'cvResult'\\}" + ) +}) + +test_that("GwasFineMappingResult: getPip(returnList) keys by study|method", { + # Documented as "a per-entry list keyed by identity tuple". The QTL + # method always honoured it; this one used to ignore the flag and hand + # back the flat vector, so the list branch had no test. + res <- GwasFineMappingResult( + study = c("g1", "g2"), + method = c("susie", "susie"), + entry = list(.ca_makeFmEntry(3), .ca_makeFmEntry(4)) + ) + got <- getPip(res, study = "g2", method = "susie", returnList = TRUE) + expect_type(got, "list") + expect_named(got, "g2|susie") + expect_equal(length(got[["g2|susie"]]), 4L) + # The flat vector is still what you get without the flag. + expect_false(is.list(getPip(res, study = "g2", method = "susie"))) +}) + +test_that("GwasFineMappingResult: context / trait selectors are refused", { + # They belong to the QTL axis. The shared accessor signature keeps them, + # but a GWAS collection has no such axis, so asking is a mistake rather + # than a silent no-op. + res <- GwasFineMappingResult( + study = "g1", + method = "susie", + entry = list(.ca_makeFmEntry(3)) + ) + expect_error( + getPip(res, study = "g1", method = "susie", context = "brain"), + "has no context or trait axis" + ) + expect_error( + getPip(res, study = "g1", method = "susie", context = "brain"), + "`context` does not select anything" + ) + expect_error( + getPip(res, study = "g1", method = "susie", trait = "ENSG_A"), + "`trait` does not select anything" + ) + # Both at once: the message pluralises rather than naming one. + expect_error( + getPip( + res, + study = "g1", + method = "susie", + context = "brain", + trait = "ENSG_A" + ), + "`context` and `trait` do not select anything" + ) + # NA is an absence, not a request: callers threading a whole + # (study, context, trait, method) record fill absent axes with NA. + expect_equal( + length(getPip( + res, + study = "g1", + method = "susie", + context = NA, + trait = NA + )), + 3L ) }) diff --git a/tests/testthat/test_GwasSumStats.R b/tests/testthat/test_GwasSumStats.R index 7634bd6ea..58678ddd7 100644 --- a/tests/testthat/test_GwasSumStats.R +++ b/tests/testthat/test_GwasSumStats.R @@ -35,7 +35,7 @@ test_that("GwasSumStats valid object passes with all required mcols", { test_that("makeGwasSumStatsFromDf() constructor creates object from data.frame", { - df <- make_test_sumstats_df(20) + df <- makeTestSumstatsDf(20) obj <- makeGwasSumStatsFromDf(df, traitName = "height", genome = "hg38") expect_s4_class(obj, "GwasSumStats") @@ -46,7 +46,7 @@ test_that("makeGwasSumStatsFromDf() constructor creates object from data.frame", test_that("makeGwasSumStatsFromDf() normalizes chr prefix", { - df <- make_test_sumstats_df(5) + df <- makeTestSumstatsDf(5) # Input has CHR = "1" (no prefix) obj <- makeGwasSumStatsFromDf(df) chrs <- as.character(GenomicRanges::seqnames(getSumStats(obj))) @@ -70,7 +70,7 @@ test_that("makeGwasSumStatsFromDf() errors on missing columns", { test_that("makeGwasSumStatsFromDf() removes rows with NA in required columns", { - df <- make_test_sumstats_df(10) + df <- makeTestSumstatsDf(10) df$Z[1] <- NA df$N[3] <- NA expect_message( @@ -83,7 +83,7 @@ test_that("makeGwasSumStatsFromDf() removes rows with NA in required columns", { test_that("getz() returns correct Z vector", { set.seed(99) - df <- make_test_sumstats_df(5) + df <- makeTestSumstatsDf(5) obj <- makeGwasSumStatsFromDf(df) z <- getZ(obj) expect_type(z, "double") @@ -92,7 +92,7 @@ test_that("getz() returns correct Z vector", { test_that("getn() returns correct N vector", { - df <- make_test_sumstats_df(5) + df <- makeTestSumstatsDf(5) obj <- makeGwasSumStatsFromDf(df) n <- getN(obj) expect_equal(length(n), 5) @@ -101,7 +101,7 @@ test_that("getn() returns correct N vector", { test_that("getmaf() returns MAF when present, NULL when absent", { - df <- make_test_sumstats_df(5) + df <- makeTestSumstatsDf(5) obj_no_maf <- makeGwasSumStatsFromDf(df) expect_null(getMaf(obj_no_maf)) @@ -114,14 +114,14 @@ test_that("getmaf() returns MAF when present, NULL when absent", { test_that("nSnps() returns correct count", { - df <- make_test_sumstats_df(30) + df <- makeTestSumstatsDf(30) obj <- makeGwasSumStatsFromDf(df) expect_equal(nSnps(obj), 30) }) test_that("subsetchr() filters correctly", { - df <- make_test_sumstats_df(10) + df <- makeTestSumstatsDf(10) df$CHR <- c(rep("1", 6), rep("2", 4)) obj <- makeGwasSumStatsFromDf(df) @@ -167,7 +167,7 @@ test_that("subsetChr() preserves study-level nCase/nControl/nSample scalars", { test_that("getvary() returns var_y and NULL cases", { - df <- make_test_sumstats_df(5) + df <- makeTestSumstatsDf(5) obj_null <- makeGwasSumStatsFromDf(df, varY = NULL) expect_null(getVarY(obj_null)) @@ -178,7 +178,7 @@ test_that("getvary() returns var_y and NULL cases", { test_that("as.data.frame.makeGwasSumStatsFromDf() round-trips", { - df_in <- make_test_sumstats_df(15) + df_in <- makeTestSumstatsDf(15) obj <- makeGwasSumStatsFromDf(df_in) df_out <- as.data.frame(obj) @@ -279,9 +279,20 @@ test_that("GwasSumStats() attaches extra per-study columns via ...", { entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", ldSketch = .sh_makeGenotypeHandle(), - cohort = c("UKB", "FinnGen") + extraCols = list(cohort = c("UKB", "FinnGen")) ) expect_equal(as.character(obj$cohort), c("UKB", "FinnGen")) + # Not variadic: the base class's GRangesList(...) means ELEMENTS, + # so a bare `cohort =` here would read as adding an entry. + expect_error( + GwasSumStats( + study = "g1", + entry = list(), + genome = "hg19", + cohort = "UKB" + ), + "unused argument" + ) }) test_that("getSumStats() errors on an empty GwasSumStats", { @@ -332,7 +343,7 @@ test_that("GwasSumStats: a non-GenotypeHandle ldSketch is rejected", { # show() smoke test, moved here from test_showMethods.R so the test # tree mirrors R/. test_that("show(GwasSumStats) does not error", { - ss <- makeGwasSumStatsFromDf(make_test_sumstats_df(10)) + ss <- makeGwasSumStatsFromDf(makeTestSumstatsDf(10)) expect_output(show(ss), "GwasSumStats") }) @@ -622,3 +633,25 @@ test_that("combineGwasSumStats() validates its inputs", { "every input must be a GwasSumStats" ) }) + +test_that("getSumStats(GwasSumStats) refuses the QtlSumStats selectors", { + # The shared SumStatsBase accessors pass the union of both classes' + # selectors, so a GWAS sees context / trait / annotateSignificance. It + # names them in order to reject them, rather than absorbing them in `...`. + gss <- GwasSumStats( + study = "g1", + entry = list(.gss_entry()), + genome = "hg19" + ) + expect_error(getSumStats(gss, context = "brain"), "QtlSumStats selector") + expect_error(getSumStats(gss, trait = "G1"), "QtlSumStats selector") + expect_error( + getSumStats(gss, annotateSignificance = "qvalue"), + "QtlSumStats selector" + ) + # and the same through an accessor that forwards them + expect_error(getZ(gss, context = "brain"), "QtlSumStats selector") + # the supported selectors still work + expect_s4_class(getSumStats(gss), "GRanges") + expect_type(getZ(gss), "double") +}) diff --git a/tests/testthat/test_JointGroup.R b/tests/testthat/test_JointGroup.R index 4531dc389..2f1eb8b68 100644 --- a/tests/testthat/test_JointGroup.R +++ b/tests/testthat/test_JointGroup.R @@ -143,7 +143,7 @@ test_that("JointDispatchCell + pipeline markers validate at construction", { ) fm <- new("FmJointPipeline", config = list(coverage = 0.95)) - tw <- new("TwasJointPipeline", config = list(retainFit = TRUE)) + tw <- new("TwasJointPipeline", config = list(fitRetention = "slim")) expect_s4_class(fm, "JointPipeline") expect_s4_class(tw, "JointPipeline") expect_equal(fm@config$coverage, 0.95) diff --git a/tests/testthat/test_LdEigen.R b/tests/testthat/test_LdEigen.R index a64d72479..672d76d60 100644 --- a/tests/testthat/test_LdEigen.R +++ b/tests/testthat/test_LdEigen.R @@ -3,8 +3,8 @@ # === Tests migrated from test_h2ClassesSumstats.R (LdEigen) === test_that("LdEigen constructs and validates correctly", { - ldblocks <- make_test_ldblocks() - snp_info <- make_test_snp_info() + ldblocks <- makeTestLdBlocks() + snp_info <- makeTestSnpInfo() eigen_list <- list( list( values = c(1, 0.5), @@ -29,13 +29,13 @@ test_that("LdEigen constructs and validates correctly", { test_that("LdEigen rejects eigen_list length mismatch", { - ldblocks <- make_test_ldblocks() # 2 blocks + ldblocks <- makeTestLdBlocks() # 2 blocks # Only 1 element in eigen_list expect_error( methods::validObject( LdEigen( ldBlocks = ldblocks, - snpInfo = make_test_snp_info(), + snpInfo = makeTestSnpInfo(), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -43,18 +43,18 @@ test_that("LdEigen rejects eigen_list length mismatch", { eigenvalueTruncation = 0.9 ) ), - "eigenList.*must match" + "Variable 'eigenList'.*Must have length" ) }) test_that("LdEigen rejects invalid eigenvalue_truncation", { - ldblocks <- make_test_ldblocks() + ldblocks <- makeTestLdBlocks() expect_error( methods::validObject( LdEigen( ldBlocks = ldblocks, - snpInfo = make_test_snp_info(), + snpInfo = makeTestSnpInfo(), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -70,8 +70,8 @@ test_that("LdEigen rejects invalid eigenvalue_truncation", { # tree mirrors R/. test_that("show(LdEigen) does not error", { eig <- LdEigen( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -86,8 +86,8 @@ test_that("subsetting an LdEigen is refused, not silently allowed", { # per variant: narrowing the ranges would leave decompositions describing # variants the object no longer carries. obj <- LdEigen( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -193,3 +193,49 @@ test_that("eigenvalue truncation keeps everything when there is no mass", { # ...and a truncation of 1 keeps everything by definition. expect_equal(pecotmr:::.ldEigenKeep(c(3, 2, 1), 1), 1:3) }) + +test_that("LdEigen: argument guards fire", { + ldblocks <- makeTestLdBlocks() + snp_info <- makeTestSnpInfo(10) + eigen_list <- list( + list(values = c(1, 0.5), vectors = matrix(0, 10, 2), snpIdx = 1:10), + list(values = 0.8, vectors = matrix(0, 10, 1), snpIdx = 1:10) + ) + ok <- list( + ldBlocks = ldblocks, + snpInfo = snp_info, + nRef = 500L, + eigenList = eigen_list + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(snpInfo = "not-a-df"))), + "snpInfo.*Must be of type 'data.frame'" + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(eigenList = "not-a-list"))), + "eigenList.*Must be of type 'list'" + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(nRef = 0L))), + "nRef.*Must be >= 1" + ) + expect_error( + exec(LdEigen, !!!list_modify(ok, !!!list(nRef = "500"))), + "nRef.*Must be of type 'count'" + ) +}) + +test_that("buildLdEigen: argument guards fire", { + meta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" + ) + ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") + expect_error(buildLdEigen(ld, nRef = 0L), "nRef.*Must be >= 1") + expect_error( + buildLdEigen(ld, inSample = NA), + "inSample.*May not be NA" + ) +}) diff --git a/tests/testthat/test_LdScore.R b/tests/testthat/test_LdScore.R index edad43ae0..394ee37ed 100644 --- a/tests/testthat/test_LdScore.R +++ b/tests/testthat/test_LdScore.R @@ -3,9 +3,9 @@ # === Tests migrated from test_h2ClassesSumstats.R (LdScore) === test_that("LdScore constructs and validates correctly", { - ldblocks <- make_test_ldblocks() + ldblocks <- makeTestLdBlocks() n <- 10 - snp_info <- make_test_snp_info(n) + snp_info <- makeTestSnpInfo(n) obj <- LdScore( ldBlocks = ldblocks, @@ -23,8 +23,8 @@ test_that("LdScore constructs and validates correctly", { test_that("LdScore rejects ld_scores row mismatch with snp_info", { - ldblocks <- make_test_ldblocks() - snp_info <- make_test_snp_info(10) + ldblocks <- makeTestLdBlocks() + snp_info <- makeTestSnpInfo(10) expect_error( methods::validObject( @@ -39,7 +39,7 @@ test_that("LdScore rejects ld_scores row mismatch with snp_info", { ldMatrixList = list() ) ), - "ldScores.*must be parallel" + "ldScores.*Must have exactly 10 rows, but has 5 rows" ) }) @@ -48,8 +48,8 @@ test_that("LdScore rejects ld_scores row mismatch with snp_info", { test_that("show(LdScore) does not error", { n <- 10 lsr <- LdScore( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(n), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(n), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -64,8 +64,8 @@ test_that("LdScore rejects weights that are not parallel to the variants", { n <- 10 expect_error( LdScore( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(n), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(n), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -73,7 +73,7 @@ test_that("LdScore rejects weights that are not parallel to the variants", { ldScoreWeights = runif(n - 1L), ldMatrixList = list() ), - "they must be parallel" + "ldScoreWeights.*Must have length 10, but has length 9" ) }) @@ -81,8 +81,8 @@ test_that("getLdScoreWeights returns the per-variant weights", { n <- 10 w <- runif(n) obj <- LdScore( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(n), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(n), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -98,8 +98,8 @@ test_that("validity requires the score columns to be present in mcols", { # edit rather than a slot edit -- which is exactly why validity checks it. n <- 10 obj <- LdScore( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(n), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(n), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -133,7 +133,7 @@ test_that("buildLdScore computes per-block sums of r^2", { test_that("buildLdScore scores each block against only its own variants", { ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) scores <- as.vector(getLdScores(buildLdScore(ld))[, 1]) - perBlock <- unlist(lapply(getCorrelation(ld), function(R) rowSums(R^2))) + perBlock <- unlist(map(getCorrelation(ld), function(R) rowSums(R^2))) expect_equal(length(scores), 7L) expect_equal(scores, perBlock) @@ -175,6 +175,28 @@ test_that("buildLdScore defaults weights to 1/max(l2, 1)", { expect_equal(getLdScoreWeights(custom), rep(2, 6)) expect_error( buildLdScore(ld, ldScoreWeights = rep(2, 3)), - "3 value\\(s\\) for 6 variant\\(s\\)" + "ldScoreWeights.*Must have length 6, but has length 3" ) }) + +test_that("buildLdScore: argument guards fire", { + meta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" + ) + ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") + expect_error(buildLdScore(ld, nRef = 0L), "nRef.*Must be >= 1") + expect_error(buildLdScore(ld, inSample = NA), "inSample.*May not be NA") + expect_error( + buildLdScore(ld, keepLdMatrices = NA), + "keepLdMatrices.*May not be NA" + ) +}) + +test_that(".ldScoreVector answers all-zero scores when there are no blocks", { + # Variants in no block keep a zero score, so no blocks at all is a + # zero vector of the full variant length rather than an error. + expect_identical(pecotmr:::.ldScoreVector(list(), NULL, 3L), numeric(3)) +}) diff --git a/tests/testthat/test_LdStatistic.R b/tests/testthat/test_LdStatistic.R index f829bf3fe..ba0c0b68e 100644 --- a/tests/testthat/test_LdStatistic.R +++ b/tests/testthat/test_LdStatistic.R @@ -1,14 +1,14 @@ # Tests for R/LdStatistic.R (virtual base class) # getGenome() is defined on the virtual LdStatistic and inherited by its # concrete subclasses (LdEigen / LdScore); exercise it through a concrete -# LdScore instance. Fixtures (make_test_ldblocks / make_test_snp_info) come +# LdScore instance. Fixtures (makeTestLdBlocks / makeTestSnpInfo) come # from helper-h2Classes.R. test_that("getGenome returns the genome build string (via an LdScore subclass)", { n <- 10 obj <- LdScore( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(n), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(n), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -32,8 +32,8 @@ test_that("getGenome returns the genome build string (via an LdScore subclass)", # expect_error(., "nRef") happily matches without ever reaching validity. .lds_score <- function(n = 10, ...) { args <- list( - ldBlocks = make_test_ldblocks(), - snpInfo = make_test_snp_info(n), + ldBlocks = makeTestLdBlocks(), + snpInfo = makeTestSnpInfo(n), nRef = 500L, inSample = FALSE, genome = "hg19", @@ -49,7 +49,7 @@ test_that("getGenome returns the genome build string (via an LdScore subclass)", test_that("validity rejects an nRef that is not a single positive integer", { # Matched on the validity text, not just "nRef": the argument name alone # also appears in R's own argument-matching errors. - msg <- "'nRef' must be a single positive integer" + msg <- "Variable 'nRef'" expect_error(.lds_score(nRef = 0L), msg) expect_error(.lds_score(nRef = -1L), msg) expect_error(.lds_score(nRef = c(10L, 20L)), msg) @@ -62,12 +62,12 @@ test_that("validity rejects an inSample that is not a single flag", { # not collapse length, which is why the nRef branch IS reachable above.) # This one guards direct new() use -- migration scripts, deserialization. gr <- as(.lds_score(), "GRanges") - msg <- "'inSample' must be a single logical value" + msg <- "Variable 'inSample': Must have length 1" mk <- function(flag) { methods::new( "LdScore", gr, - ldBlocks = make_test_ldblocks(), + ldBlocks = makeTestLdBlocks(), nRef = 500L, inSample = flag, ldMatrixList = list() @@ -95,7 +95,7 @@ test_that("validity rejects a statistic carrying no variants", { methods::new( "LdScore", gr, - ldBlocks = make_test_ldblocks(), + ldBlocks = makeTestLdBlocks(), nRef = 500L, inSample = FALSE, ldMatrixList = list() @@ -105,10 +105,10 @@ test_that("validity rejects a statistic carrying no variants", { }) test_that(".ldStatRanges names the snpInfo columns it is missing", { - si <- make_test_snp_info(4) + si <- makeTestSnpInfo(4) expect_error( LdScore( - ldBlocks = make_test_ldblocks(), + ldBlocks = makeTestLdBlocks(), snpInfo = si[, setdiff(colnames(si), c("A1", "A2"))], nRef = 500L, inSample = FALSE, @@ -384,7 +384,7 @@ test_that("a block matrix sized differently from its span is rejected", { correlation = list(diag(2), diag(2)), blockMetadata = misSpan )), - "correlation matrix is 2x2 but covers 3 variant" + "LD block correlation.*Must have exactly 3 rows" ) }) diff --git a/tests/testthat/test_MashPrior.R b/tests/testthat/test_MashPrior.R index 753390ab6..11082b8d6 100644 --- a/tests/testthat/test_MashPrior.R +++ b/tests/testthat/test_MashPrior.R @@ -92,3 +92,11 @@ test_that("the partition check stops when perFoldFits is not a list", { samplePartition = data.frame(Sample = "a", Fold = 1L) ))) }) + +test_that("MashPrior: cvFits must be a list or NULL", { + expect_error( + MashPrior(fullFit = list(U = list(U1 = diag(2))), cvFits = "nope"), + "cvFits.*Must be of type 'list'" + ) + expect_silent(MashPrior(fullFit = list(U = list(U1 = diag(2))))) +}) diff --git a/tests/testthat/test_MethodOptions.R b/tests/testthat/test_MethodOptions.R new file mode 100644 index 000000000..f5a0a63f3 --- /dev/null +++ b/tests/testthat/test_MethodOptions.R @@ -0,0 +1,555 @@ +test_that(".engineCallee resolves pkg::fn and tolerates a missing package", { + expect_identical( + pecotmr:::.engineCallee("stats::var"), + stats::var + ) + # A package that cannot be there is not an error: building an argument + # list is not running the engine. + expect_null(pecotmr:::.engineCallee("notARealPackage::nope")) + # Present package, absent function. + expect_null(pecotmr:::.engineCallee("stats::notARealFunction")) +}) + +test_that(".engineCallee passes a function through unchanged", { + # A caller that already holds the engine need not spell its package. + expect_identical(pecotmr:::.engineCallee(stats::var), stats::var) +}) + +test_that(".newMethodOptions records NA for a callee given as a function", { + res <- pecotmr:::.newMethodOptions( + stats::var, + defaults = list(na.rm = TRUE), + extra = list(), + label = "varArgs" + ) + expect_true(is.na(S4Vectors::metadata(res)$callee)) + # Validation still happens -- the formals come from the function itself. + expect_error( + pecotmr:::.newMethodOptions( + stats::var, + defaults = list(), + extra = list(bogus = 1), + label = "varArgs" + ), + "unknown argument" + ) +}) + +test_that(".engineCallee rejects a malformed callee", { + expect_error( + pecotmr:::.engineCallee("susie_rss"), + "must be 'pkg::fn'" + ) +}) + +test_that(".engineAcceptedNames returns formals, or NULL when unknowable", { + expect_true(is_in("na.rm", pecotmr:::.engineAcceptedNames("stats::var"))) + # `paste` takes `...`, so it accepts anything and there is nothing to + # validate against. So does the `mean` generic, whose `na.rm` lives on + # mean.default rather than on the generic itself. + expect_null(pecotmr:::.engineAcceptedNames("base::paste")) + expect_null(pecotmr:::.engineAcceptedNames("base::mean")) + expect_null(pecotmr:::.engineAcceptedNames("notARealPackage::nope")) +}) + +test_that(".newMethodOptions merges defaults under extras, dropping NULLs", { + res <- pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(na.rm = TRUE, use = NULL), + extra = list(y = 1), + label = "varArgs" + ) + expect_true(pecotmr:::.isMethodOptions(res)) + # `use = NULL` means "leave it to the engine", so it is not forwarded. + expect_false(is_in("use", names(res))) + expect_true(res$na.rm) + expect_equal(res$y, 1) +}) + +test_that(".newMethodOptions rejects a name the engine cannot accept", { + expect_error( + pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(), + extra = list(naRM = TRUE), + label = "varArgs" + ), + "unknown argument\\(s\\) naRM" + ) +}) + +test_that(".newMethodOptions names the engine's accepted arguments in the error", { + expect_error( + pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(), + extra = list(nope = 1), + label = "varArgs" + ), + "stats::var. accepts:.*na\\.rm" + ) +}) + +test_that(".newMethodOptions skips validation when the engine takes dots", { + # base::paste has `...`, so an arbitrary name is legitimate. + res <- pecotmr:::.newMethodOptions( + "base::paste", + defaults = list(sep = "-"), + extra = list(anythingAtAll = 1), + label = "pasteArgs" + ) + expect_equal(res$anythingAtAll, 1) +}) + +test_that(".newMethodOptions skips validation when the package is absent", { + res <- pecotmr:::.newMethodOptions( + "notARealPackage::nope", + defaults = list(), + extra = list(whatever = 2), + label = "nopeArgs" + ) + expect_equal(res$whatever, 2) +}) + +test_that(".newMethodOptions requires every extra to be named", { + expect_error( + pecotmr:::.newMethodOptions( + "base::paste", + defaults = list(), + extra = list(1, 2), + label = "pasteArgs" + ), + "must be named" + ) +}) + +test_that(".newMethodOptions rejects an argument supplied twice", { + # Two entries in `extra` -- what .methodOptionsWith() produces when a + # wrapper's own contribution meets the caller's record -- have no winner. + expect_error( + pecotmr:::.newMethodOptions( + "base::paste", + defaults = list(), + extra = list(sep = "-", sep = "+"), + label = "pasteArgs" + ), + "given twice: sep" + ) +}) + +test_that(".newMethodOptions lets an explicit value override a default", { + res <- pecotmr:::.newMethodOptions( + "base::paste", + defaults = list(sep = "-", collapse = ","), + extra = list(sep = "+"), + label = "pasteArgs" + ) + expect_equal(res$sep, "+") + expect_equal(res$collapse, ",") + # The default keeps its position, so the record reads the same either way. + expect_equal(names(res), c("sep", "collapse")) +}) + +test_that(".newMethodOptions records the engine and callee for reporting", { + res <- pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(na.rm = TRUE), + extra = list(), + label = "varArgs", + engine = "var" + ) + expect_equal(S4Vectors::metadata(res)$engine, "var") + expect_equal(S4Vectors::metadata(res)$callee, "stats::var") +}) + +test_that("MethodOptions keeps its class through pecotmr's list operations", { + res <- pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(na.rm = TRUE, y = 1), + extra = list(), + label = "varArgs", + engine = "var" + ) + # .fmNarrowAfterJoint / .fmQssJointPhase subset these records by name, and + # a plain list carrying an S3 class loses the class right here. + expect_true(pecotmr:::.isMethodOptions(res["na.rm"])) + expect_true(pecotmr:::.isMethodOptions(res[1])) + expect_equal(S4Vectors::metadata(res["na.rm"])$engine, "var") +}) + +test_that(".newMethodOptions splices into a call exactly like a bare list", { + # The whole point of returning a plain list: every existing + # exec(fn, !!!args) call site keeps working unchanged. + res <- pecotmr:::.newMethodOptions( + "base::paste", + defaults = list(sep = "-"), + extra = list(), + label = "pasteArgs" + ) + expect_equal(exec(paste, "a", "b", !!!res), "a-b") +}) + +test_that(".assertMethodOptions accepts a constructed record and empty list", { + res <- pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(), + extra = list(), + label = "varArgs" + ) + expect_silent(pecotmr:::.assertMethodOptions(res, "varArgs", "methodArgs")) + # `list()` carries no settings, so there is nothing a constructor would + # have added and nothing to validate. + expect_silent(pecotmr:::.assertMethodOptions( + list(), + "varArgs", + "methodArgs" + )) +}) + +test_that(".assertMethodOptions rejects a populated bare list", { + expect_error( + pecotmr:::.assertMethodOptions( + list(na.rm = TRUE), + "varArgs", + "methodArgs" + ), + "`methodArgs` must be built with varArgs\\(\\)" + ) +}) + +test_that("show(MethodOptions) reports the engine and its settings", { + res <- pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(na.rm = TRUE), + extra = list(), + label = "varArgs", + engine = "var" + ) + expect_output(show(res), "MethodOptions: var") + expect_output(show(res), "forwarded to stats::var") + expect_output(show(res), "na\\.rm") +}) + +test_that("show(MethodOptions) says so when nothing is set", { + res <- pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(), + extra = list(), + label = "varArgs" + ) + expect_output(show(res), "no options set") +}) + +# --- character-or-constructor selection ------------------------------------ + +.ma_fooArgs <- function(a = 1, b = 2) { + pecotmr:::.newMethodOptions( + NULL, + defaults = list(a = a, b = b), + extra = list(), + label = "fooArgs", + engine = "foo" + ) +} + +.ma_barArgs <- function(z = 9) { + pecotmr:::.newMethodOptions( + NULL, + defaults = list(z = z), + extra = list(), + label = "barArgs", + engine = "bar" + ) +} + +.ma_ctors <- function() list(foo = .ma_fooArgs, bar = .ma_barArgs) + +test_that(".engineOf reads the engine from a name or a record", { + expect_equal(pecotmr:::.engineOf("foo"), "foo") + expect_equal(pecotmr:::.engineOf(.ma_fooArgs()), "foo") + expect_null(pecotmr:::.engineOf(list(a = 1))) + expect_null(pecotmr:::.engineOf(c("foo", "bar"))) +}) + +test_that(".resolveEngineChoice accepts a bare name with no options", { + res <- pecotmr:::.resolveEngineChoice("foo", c("foo", "bar"), "engine") + expect_equal(res$engine, "foo") + expect_length(res$args, 0L) + expect_true(pecotmr:::.isMethodOptions(res$args)) +}) + +test_that(".resolveEngineChoice carries a constructor's options through", { + res <- pecotmr:::.resolveEngineChoice( + .ma_fooArgs(a = 3), + c("foo", "bar"), + "engine" + ) + expect_equal(res$engine, "foo") + expect_equal(res$args$a, 3) +}) + +test_that(".resolveEngineChoice rejects an engine outside the vocabulary", { + expect_error( + pecotmr:::.resolveEngineChoice("zzz", c("foo", "bar"), "engine"), + "unknown engine 'zzz'" + ) + # A record built for an engine this argument does not accept is caught by + # name rather than left to fail further down. + expect_error( + pecotmr:::.resolveEngineChoice(.ma_barArgs(), c("foo"), "engine"), + "unknown engine 'bar'" + ) +}) + +test_that(".resolveEngineChoice rejects a value that names no engine", { + expect_error( + pecotmr:::.resolveEngineChoice(list(a = 1), c("foo"), "engine"), + "must be one of foo, or the matching constructor" + ) +}) + +# --- nested per-engine bundles --------------------------------------------- + +test_that("a record says whether its names were checked", { + checked <- pecotmr:::.newMethodOptions( + "stats::var", + defaults = list(na.rm = TRUE), + extra = list(), + label = "varArgs", + engine = "var" + ) + expect_output(show(checked), "argument names checked against stats::var") + # An engine taking `...` accepts anything, so a misspelling reaches it. + dots <- pecotmr:::.newMethodOptions( + "base::paste", + defaults = list(sep = "-"), + extra = list(), + label = "pasteArgs", + engine = "paste" + ) + expect_output(show(dots), "NOT checked") + expect_output(show(dots), "takes `\\.\\.\\.`") +}) + +test_that("a record says when the engine's package is absent", { + absent <- pecotmr:::.newMethodOptions( + "notARealPackage::nope", + defaults = list(a = 1), + extra = list(), + label = "nopeArgs", + engine = "nope" + ) + expect_output(show(absent), "is not installed") +}) + +test_that("a zero-length default survives; only NULL is dropped", { + # compact() drops zero-length values as well as NULLs, which silently lost + # keepSamples = character(0) and CovFlashOptions(greedy_args = list()). + # Both are settings, not absent arguments. + # An EXPLICIT character(0) is a real instruction ("no restriction") and + # must survive; GenotypeFilterParam() defaults it to NULL, which means + # "not set" and is correctly dropped. + a <- GenotypeFilterParam(keepSamples = character(0)) + expect_true(is_in("keepSamples", names(a))) + expect_identical(a$keepSamples, character(0)) + expect_false(is_in("keepSamples", names(GenotypeFilterParam()))) + expect_true(is_in("greedy_args", names(CovFlashOptions()))) + # A NULL default still means "leave it to the engine". + expect_false(is_in("subset", names(CovFlashOptions()))) +}) + +# TRUE when the package behind a "pkg::fn" string is installed. +.maPkgAvailable <- function(callee) { + requireNamespace(sub("::.*$", "", callee), quietly = TRUE) +} + +test_that("a constructor is unchecked only when its engine takes dots", { + # The package-wide invariant behind splitting a method's individual and + # summary-statistic paths into separate constructors: an argument name + # goes unchecked ONLY where the engine's own signature ends in `...`, so + # every name really is legal. Any other unchecked constructor is one + # whose engine was never enumerated, and a misspelled option there is + # dropped in silence -- the failure this whole design exists to prevent. + ns <- asNamespace("pecotmr") + unchecked <- character(0) + # *Options() only: a *Param() carries no callee, so `show` prints no + # check note for it and it could never be counted here anyway. + for (n in sort(getNamespaceExports("pecotmr"))) { + if (!str_detect(n, "Options$")) { + next + } + f <- get(n, envir = ns) + if (!is.function(f)) { + next + } + rec <- tryCatch(f(), error = function(cnd) NULL) + if (is.null(rec) || !is(rec, "MethodOptions")) { + next + } + out <- paste(capture.output(show(rec)), collapse = " ") + if (grepl("NOT checked", out)) unchecked <- c(unchecked, n) + } + # Each of these reaches an engine whose formals include `...`; where a + # constructor serves several engines (poolr's three tests), one of them + # taking dots is enough to make the whole record uncheckable. + dotEngines <- c( + CovEdOptions = "mashr::cov_ed", + DprOptions = "RcppDPR::fit_model", + GlmnetOptions = "glmnet::cv.glmnet", + MashCorEmOptions = "mashr::mash_estimate_corr_em", + MvsusieRssOptions = "mvsusieR::mvsusie_rss", + NcvregOptions = "ncvreg::cv.ncvreg", + PoolrOptions = "poolr::fisher", + QvalueOptions = "qvalue::qvalue", + RmaOptions = "metafor::rma" + ) + # Only count the ones whose package is actually installed: an absent + # package is a third, legitimate reason a record cannot be checked. + installed <- keep(dotEngines, .maPkgAvailable) + expect_setequal(intersect(unchecked, names(dotEngines)), names(installed)) + extra <- setdiff(unchecked, names(dotEngines)) + expect_equal( + extra, + character(0), + info = paste( + "unchecked for a reason other than the engine taking dots:", + paste(extra, collapse = ", ") + ) + ) +}) + +test_that("an Options record knows which input classes it is for", { + # A method on both data paths reaches a different engine on each -- often + # in a different package -- so a record built for one path is not usable + # on the other. Recording it lets a pipeline ask the record instead of + # joining against a registry at the point of use. + expect_equal(pecotmr:::.optionsInputType(SusieOptions()), "QtlDataset") + expect_setequal( + pecotmr:::.optionsInputType(SusieRssOptions()), + c("QtlSumStats", "GwasSumStats") + ) + # Cross-package pairs: the whole reason one constructor per method could + # not carry this. + expect_equal(pecotmr:::.optionsInputType(GlmnetOptions()), "QtlDataset") + expect_equal(pecotmr:::.optionsInputType(LassosumOptions()), "QtlSumStats") + expect_equal(pecotmr:::.optionsInputType(DprOptions()), "QtlDataset") + expect_equal(pecotmr:::.optionsInputType(SdprOptions()), "QtlSumStats") + + # GwasSumStats is a summary-statistics class the multivariate methods do + # not accept, which is what gwasAllowed already records -- so the + # derivation must not hand it to mvsusie. + expect_setequal( + pecotmr:::.optionsInputType(SerOptions()), + c("QtlSumStats", "GwasSumStats") + ) + expect_equal( + pecotmr:::.optionsInputType(MvsusieRssOptions()), + "QtlSumStats" + ) + expect_false( + isTRUE(pecotmr:::.fineMappingMethodCapabilities$mvsusie$gwasAllowed) + ) + + # Most engines have no input-path dimension at all: a mash prior + # component or a p-value test is reached the same way whatever the data + # looked like. + expect_null(pecotmr:::.optionsInputType(CovPcaOptions())) + expect_null(pecotmr:::.optionsInputType(PoolrOptions())) + expect_null(pecotmr:::.optionsInputType(CtwasOptions())) + expect_null(pecotmr:::.optionsInputType(UdFitOptions())) + # And it is reported where a user can see it. + expect_match( + paste(capture.output(show(SusieRssOptions())), collapse = " "), + "for input class" + ) + expect_no_match( + paste(capture.output(show(CovPcaOptions())), collapse = " "), + "for input class" + ) +}) + +test_that("inputType is derived, not declared per constructor", { + # The index is built from the two dispatch tables, so a method moving + # between paths needs no edit here. Checking the shape of that + # dependency rather than the values: every Options whose callee is a + # fine-mapping implementation must report that path. + caps <- pecotmr:::.fineMappingMethodCapabilities + expect_equal( + pecotmr:::.fmCalleeInputType(caps$susie$individualImpl), + "QtlDataset" + ) + expect_setequal( + pecotmr:::.fmCalleeInputType(caps$susie$sumstatImpl), + c("QtlSumStats", "GwasSumStats") + ) + expect_length(pecotmr:::.fmCalleeInputType("nosuch::fn"), 0L) + expect_length(pecotmr:::.fmCalleeInputType(NULL), 0L) + # The TWAS half keys on the constructor name, because its table stores + # pecotmr implementations rather than callees. + expect_equal(pecotmr:::.twasLabelInputType("GlmnetOptions"), "QtlDataset") + expect_equal( + pecotmr:::.twasLabelInputType("LassosumOptions"), + "QtlSumStats" + ) + expect_length(pecotmr:::.twasLabelInputType("NoSuchOptions"), 0L) +}) + +# =========================================================================== +# Why a name was or was not checked, and the nested-entry helpers +# =========================================================================== + +test_that(".engineCheckNote says WHICH reason a name went unchecked", { + note <- pecotmr:::.engineCheckNote + # A package that is not installed cannot have its formals read. + expect_match( + as.character(note("nosuchpkg::nosuchfn")), + "package 'nosuchpkg' is not installed" + ) + # A primitive has no formals at all, which is a different reason. + expect_match( + as.character(note("base::sum")), + "the engine's formals are unknown" + ) + # An engine taking `...` accepts any name, so checking is meaningless. + expect_match( + as.character(note("base::paste")), + "takes `...`, so any name is accepted" + ) + # The normal case names the callee it checked against. + expect_match( + as.character(note("stats::rnorm")), + "checked against stats::rnorm" + ) +}) + +test_that(".twasLabelInputType answers nothing for a label it cannot use", { + f <- pecotmr:::.twasLabelInputType + expect_equal(f(42), character(0)) + expect_equal(f(c("a", "b")), character(0)) + expect_equal(f(NULL), character(0)) +}) + +test_that(".nestedExpectedEngine falls back to the key it was given", { + # The engine is read off a record the constructor builds. When the + # constructor cannot run, the key is the best name available. + expect_equal( + pecotmr:::.nestedExpectedEngine( + "broken", + list(broken = function(...) stop("no")) + ), + "broken" + ) +}) + +test_that(".nestedElement refuses an entry that is neither list nor record", { + expect_error( + pecotmr:::.nestedElement(42, "pca", list(pca = CovPcaOptions), "lbl"), + "the `pca` entry must be a list or a constructor result" + ) + # An already-built record passes straight through. + rec <- CovPcaOptions() + expect_identical( + pecotmr:::.nestedElement(rec, "pca", list(pca = CovPcaOptions), "lbl"), + rec + ) +}) diff --git a/tests/testthat/test_MethodParam.R b/tests/testthat/test_MethodParam.R new file mode 100644 index 000000000..9bb7f3155 --- /dev/null +++ b/tests/testthat/test_MethodParam.R @@ -0,0 +1,644 @@ +# Validity of the method-selection Params lives in R/MethodParam.R, shared +# by FineMappingMethodsParam and TwasWeightsMethodsParam. + +test_that("naming a method selects it, in any of the three slots", { + p <- FineMappingMethodsParam(methods = "susie") + expect_s4_class(p, "FineMappingMethodsParam") + expect_s4_class(p, "MethodsSelectionParam") + expect_s4_class(p, "MethodParam") + expect_named(p$methods, "susie") + expect_equal( + FineMappingMethodsParam(methods = list(susie = list()))$methods, + p$methods + ) + expect_null(p$qtlDatasetMethods) + expect_setequal(names(p), "methods") +}) + +test_that("one method may appear in both path slots, with its own options", { + # The point of having two: on a dual-type input the same method reaches + # a different engine on each path, so it needs separate arguments. + p <- FineMappingMethodsParam( + qtlDatasetMethods = list(susie = list(L = 20)), + qtlSumStatsMethods = list(susie = list(L = 10)) + ) + expect_equal(p$qtlDatasetMethods$susie$L, 20) + expect_equal(p$qtlSumStatsMethods$susie$L, 10) + # Entries are stored as written: a per-method bundle is legitimately + # mixed -- the wrapper's own formals alongside the engine's arguments -- + # so coercing it into the engine's constructor would reject the wrapper + # half. Only the NAMES are judged. + expect_type(p$qtlDatasetMethods$susie, "list") + expect_false(isS4(p$qtlDatasetMethods$susie)) + # A name belonging to the other path is refused at construction, which + # the union-validated aggregator accepted. + expect_error( + FineMappingMethodsParam(qtlDatasetMethods = list(susie = list(z = 1))), + "unknown argument\\(s\\) z for susie on QtlDataset" + ) + # ... and a wrapper-level formal is accepted, not just engine arguments. + expect_s4_class( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(mrmash = list(fitRetention = "slim")) + ), + "TwasWeightsMethodsParam" + ) +}) + +test_that("a method in `methods` may not also name an input path", { + expect_error( + FineMappingMethodsParam( + methods = list(susie = list()), + qtlDatasetMethods = list(susie = list()) + ), + "named in `methods` and also under an input path" + ) +}) + +test_that("a path slot refuses options built for the other path", { + expect_error( + FineMappingMethodsParam( + qtlDatasetMethods = list(susie = SusieRssOptions()) + ), + "but `qtlDatasetMethods` is forwarded to QtlDataset" + ) + expect_error( + FineMappingMethodsParam( + qtlSumStatsMethods = list(susie = SusieOptions()) + ), + "options are for QtlDataset" + ) +}) + +test_that("a path slot offers only the methods that run on it", { + expect_error( + FineMappingMethodsParam(qtlSumStatsMethods = list(fsusie = list())), + "fsusie is not a method this pipeline runs on QtlSumStats" + ) + expect_error( + FineMappingMethodsParam(qtlDatasetMethods = list(ser = list())), + "ser is not a method this pipeline runs on QtlDataset" + ) + # `methods` states no path, so it accepts either; the pipeline's own + # input class decides whether it can be honoured. + expect_s4_class( + FineMappingMethodsParam(methods = list(ser = list())), + "FineMappingMethodsParam" + ) +}) + +test_that("`methods` entries must share one input class", { + expect_error( + FineMappingMethodsParam( + methods = list(susie = SusieOptions(), ser = SerOptions()) + ), + "cannot all be used with one input class" + ) + expect_s4_class( + FineMappingMethodsParam( + methods = list(susie = SusieRssOptions(), ser = SerOptions()) + ), + "FineMappingMethodsParam" + ) +}) + +test_that("`methods` defers name checking to the pipeline", { + # `methods` names no input path, so there is nothing to check the + # argument names against here -- the pipeline does it once dispatch has + # settled the input class (.fmCheckMethodArgsForInput). + expect_s4_class( + FineMappingMethodsParam(methods = list(susie = list(L = 20))), + "FineMappingMethodsParam" + ) + expect_equal( + pecotmr:::.fmNormalizeMethods( + list(susie = list(z = 1)), + inputKind = "QtlSumStats" + )$methodArgs$susie$z, + 1 + ) + expect_error( + pecotmr:::.fmNormalizeMethods( + list(susie = list(z = 1)), + inputKind = "QtlDataset" + ), + "unknown argument" + ) +}) + +test_that("malformed slots are rejected with the caller's own error", { + expect_error( + FineMappingMethodsParam(methods = list(list())), + "every `methods` entry must be named" + ) + expect_error( + FineMappingMethodsParam(methods = 42), + "must be a named list of per-method options" + ) + expect_error( + FineMappingMethodsParam(methods = "nosuch"), + "nosuch is not a method this pipeline runs" + ) + dup <- list(list(), list()) + names(dup) <- c("susie", "susie") + expect_error(FineMappingMethodsParam(methods = dup), "given more than once") + # Not wrapped in purrr's "In index: 1" framing. + expect_no_match( + tryCatch( + FineMappingMethodsParam( + qtlDatasetMethods = list(susie = list(LL = 1)) + ), + error = function(e) conditionMessage(e) + ), + "In index" + ) +}) + +test_that("TwasWeightsMethodsParam shares the rules with its own registry", { + p <- TwasWeightsMethodsParam( + methods = list(susie = list()), + qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), + qtlSumStatsMethods = list(lasso = LassosumOptions()) + ) + expect_s4_class(p, "TwasWeightsMethodsParam") + expect_equal(p$qtlDatasetMethods$lasso$alpha, 0.5) + # The registries differ: prsCs is summary-statistics only, enet + # individual only, and both are methods a fine-mapping Param never has. + expect_error( + TwasWeightsMethodsParam(qtlDatasetMethods = list(prsCs = list())), + "prsCs is not a method this pipeline runs on QtlDataset" + ) + expect_error( + TwasWeightsMethodsParam(qtlSumStatsMethods = list(enet = list())), + "enet is not a method this pipeline runs on QtlSumStats" + ) + expect_error( + FineMappingMethodsParam(methods = list(lasso = list())), + "lasso is not a method this pipeline runs" + ) + # Cross-package per-path pairing, which one bag per method could not do. + expect_error( + TwasWeightsMethodsParam( + qtlSumStatsMethods = list(lasso = GlmnetOptions()) + ), + "options are for QtlDataset" + ) +}) + +test_that("a pipeline resolves only the slots its input class reads", { + p <- FineMappingMethodsParam( + methods = list(ser = list()), + qtlDatasetMethods = list(susie = list(L = 20)), + qtlSumStatsMethods = list(susieInf = list(L = 10)) + ) + # `methods` applies to every class; the other path's slot is not this + # run's business. + ind <- pecotmr:::.methodsParamResolve(p, "QtlDataset") + expect_setequal(ind$tokens, c("ser", "susie")) + expect_equal(ind$methodArgs$susie$L, 20) + + rss <- pecotmr:::.methodsParamResolve(p, "QtlSumStats") + expect_setequal(rss$tokens, c("ser", "susieInf")) + expect_equal(rss$methodArgs$susieInf$L, 10) + + # GwasSumStats is a summary-statistics class, so it reads the same slot. + expect_setequal( + pecotmr:::.methodsParamResolve(p, "GwasSumStats")$tokens, + c("ser", "susieInf") + ) +}) + +test_that("a pipeline refuses a Param built for the other pipeline", { + expect_error( + pecotmr:::.methodsParamFor( + TwasWeightsMethodsParam(methods = "lasso"), + "QtlDataset", + "FineMappingMethodsParam", + "fineMappingPipeline" + ), + "configures a different pipeline" + ) + # Its own family passes through untouched. + p <- FineMappingMethodsParam(methods = "susie") + expect_identical( + pecotmr:::.methodsParamFor( + p, + "QtlDataset", + "FineMappingMethodsParam", + "fineMappingPipeline" + ), + p + ) +}) + +test_that("an entry must be built by that method's own constructor", { + skip_if_not_installed("susieR") + # The input-type check cannot see this: lasso and bayesA both run on + # individual-level data, so GlmnetOptions() and QggOptions() are + # indistinguishable by path and only the engine tells them apart. + expect_s4_class( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(lasso = GlmnetOptions()) + ), + "TwasWeightsMethodsParam" + ) + expect_error( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(lasso = QggOptions()) + ), + "built with the constructor for 'qgg'.*lasso on QtlDataset" + ) + expect_error( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(bayesA = GlmnetOptions()) + ), + "built with the constructor for 'glmnet'" + ) + # Each path wants that path's own constructor. + expect_s4_class( + TwasWeightsMethodsParam( + qtlSumStatsMethods = list(lasso = LassosumOptions()) + ), + "TwasWeightsMethodsParam" + ) + + # susie and susieInf BOTH run susieR::susie on individual data, so the + # callee cannot separate them -- only the token's own constructor pair + # can, which is what the expected engine is derived from. + expect_s4_class( + FineMappingMethodsParam( + qtlDatasetMethods = list(susie = SusieOptions()) + ), + "FineMappingMethodsParam" + ) + expect_error( + FineMappingMethodsParam( + qtlDatasetMethods = list(susie = SusieInfOptions()) + ), + "built with the constructor for 'susieInf'" + ) + expect_error( + FineMappingMethodsParam( + qtlDatasetMethods = list(susie = MvsusieOptions()) + ), + "built with the constructor for 'mvsusie'" + ) + expect_s4_class( + FineMappingMethodsParam( + qtlSumStatsMethods = list(susie = SusieRssOptions()) + ), + "FineMappingMethodsParam" + ) +}) + +test_that("a fit-derived method is selected but never configured", { + # These extract weights from a fit a prior fineMappingPipeline() run + # produced, so they have no arguments of their own. Naming one with + # list() SELECTS it -- the only thing it can say -- and anything else is + # a misunderstanding the error names. + expect_s4_class( + TwasWeightsMethodsParam(qtlDatasetMethods = list(mvsusie = list())), + "TwasWeightsMethodsParam" + ) + expect_error( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(mvsusie = list(L = 1)) + ), + "extracts weights from a fit supplied via" + ) + # Path-independent: the answer does not depend on the input class, so + # `methods` is held to it too. + expect_error( + TwasWeightsMethodsParam(methods = list(susie = list(L = 1))), + "extracts weights from a fit supplied via" + ) + # A method that does have arguments is unaffected. + expect_s4_class( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(lasso = list(alpha = 0.5)) + ), + "TwasWeightsMethodsParam" + ) +}) + +test_that("a MultiStudyQtlDataset selects per half with path keys", { + # Bare names run on whatever the dataset holds; a path key names methods + # for that half only. fsusie has no summary-statistics implementation + # and ser no individual one, so this is the only way to ask for both. + p <- pecotmr:::.methodsParamForMulti( + list("susie", qtlDataset = "fsusie", qtlSumStats = "ser"), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ) + expect_named(p$methods, "susie") + expect_named(p$qtlDatasetMethods, "fsusie") + expect_named(p$qtlSumStatsMethods, "ser") +}) + +test_that("shared arguments are distributed to both halves", { + skip_if_not_installed("susieR") + # A method named at the top level carries arguments both halves share. + # They are copied into both path slots, so each is checked against the + # engine that half actually runs -- which is what makes a shared + # argument have to be valid on BOTH. + p <- pecotmr:::.methodsParamForMulti( + list(susie = list(L = 20), qtlSumStats = list(susie = list(z = 1))), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ) + expect_equal(p$qtlDatasetMethods$susie$L, 20) + expect_equal(p$qtlSumStatsMethods$susie$L, 20) + # The per-path extra lands on that half only. + expect_null(p$qtlDatasetMethods$susie$z) + expect_equal(p$qtlSumStatsMethods$susie$z, 1) + # A per-path value of the same name wins over the shared one. + q <- pecotmr:::.methodsParamForMulti( + list(susie = list(L = 20), qtlSumStats = list(susie = list(L = 5))), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ) + expect_equal(q$qtlDatasetMethods$susie$L, 20) + expect_equal(q$qtlSumStatsMethods$susie$L, 5) + # `z` is susie_rss-only, so sharing it is a mistake: distributing it to + # the individual half fails, which is the intersection rule in action. + expect_error( + pecotmr:::.methodsParamForMulti( + list(susie = list(z = 1)), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ), + "unknown argument" + ) +}) + +test_that("the two MultiStudy list shapes may not be mixed", { + expect_error( + pecotmr:::.methodsParamForMulti( + list("susie", susieInf = list(L = 2)), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ), + "mixes two shapes" + ) + expect_error( + pecotmr:::.methodsParamForMulti( + list(qtlDataset = 42), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ), + "must be a character vector of methods or a named list" + ) +}) + +test_that("summary-statistics methods need a dataset that carries some", { + expect_error( + pecotmr:::.methodsParamForMulti( + list(qtlSumStats = "ser"), + "FineMappingMethodsParam", + "fineMappingPipeline", + FALSE + ), + "carries no summary statistics" + ) + # With sumstats present it is fine, and the individual half never needs + # them. + expect_s4_class( + pecotmr:::.methodsParamForMulti( + list(qtlSumStats = "ser"), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ), + "FineMappingMethodsParam" + ) + expect_s4_class( + pecotmr:::.methodsParamForMulti( + list(qtlDataset = "fsusie"), + "FineMappingMethodsParam", + "fineMappingPipeline", + FALSE + ), + "FineMappingMethodsParam" + ) +}) + +test_that("a Param keeps its structure through the MultiStudy helpers", { + # The joint phase runs mrmash itself, so the per-method loop must not + # also run it -- and dropping it has to leave a Param, or the + # per-component recursion loses which path each entry was for. + p <- TwasWeightsMethodsParam( + methods = list(mrmash = list()), + qtlDatasetMethods = list(lasso = list()) + ) + expect_setequal(pecotmr:::.methodsParamTokens(p), c("mrmash", "lasso")) + stripped <- pecotmr:::.twasMsStripMrmash(p) + expect_s4_class(stripped, "TwasWeightsMethodsParam") + expect_setequal(pecotmr:::.methodsParamTokens(stripped), "lasso") + # Stripping the only method leaves a Param that reports itself empty -- + # which is how the joint phase knows there is no per-method work left. + only <- TwasWeightsMethodsParam(methods = list(mrmash = list())) + expect_true(pecotmr:::.twasMethodsEmpty( + pecotmr:::.twasMsStripMrmash(only) + )) +}) + +test_that("show renders a slot holding per-method entries", { + skip_if_not_installed("susieR") + # format() cannot render a list of S4 records -- it falls through to + # as.character() and errors -- so a slot holding per-method entries is + # shown by naming them. Printing a populated Param used to fail, and + # only the examples caught it: nothing called show() on one. + out <- paste( + capture.output(show( + FineMappingMethodsParam( + methods = list(susie = SusieOptions(L = 20)) + ) + )), + collapse = " " + ) + expect_match(out, "FineMappingMethodsParam") + expect_match(out, "methods\\s+susie") + expect_match(out, "unset: qtlDatasetMethods, qtlSumStatsMethods") + + multi <- paste( + capture.output(show(TwasWeightsMethodsParam( + methods = list(susie = list()), + qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), + qtlSumStatsMethods = list(lasso = LassosumOptions()) + ))), + collapse = " " + ) + expect_match(multi, "qtlDatasetMethods\\s+lasso") + expect_match(multi, "qtlSumStatsMethods\\s+lasso") + + # A settings Param still prints its values, not its names. + expect_match( + paste( + capture.output(show(CredibleSetParam(coverage = 0.9))), + collapse = " " + ), + "coverage\\s+0.9" + ) +}) + +# =========================================================================== +# show() and the slot-rendering helpers +# --------------------------------------------------------------------------- +# A populated Param used to fail to print: format() falls through to +# as.character() on an S4 slot value and errors. Nothing printed one, so the +# whole suite stayed green while show() was broken. These pin each rendering +# branch -- a nested Options record, a nested Param, a named list, an +# unnamed list -- so the next one cannot regress silently. +# =========================================================================== + +test_that("show renders a Param with nothing set", { + out <- capture.output(show(MashComponentParam())) + expect_true(any(str_detect(out, "MashComponentParam"))) + expect_true(any(str_detect(out, fixed("(nothing set)")))) + expect_true(any(str_detect(out, "unset: components"))) +}) + +test_that("show names a nested Options record by its engine", { + # Defaults carry no settings, so the record is reported as such. + bare <- capture.output(show(SusieRssParam( + control = SusieRssControlOptions() + ))) + expect_true(any(str_detect(bare, fixed("")))) + # With settings, they are listed instead. + set <- capture.output(show(SusieRssParam( + control = SusieRssControlOptions(r_tol = 1e-08) + ))) + expect_true(any(str_detect(set, "susieRssControl: r_tol"))) +}) + +test_that("show names a nested Param by what it contains", { + # Not by slot name: the reader wants the fields, not "credibleSetArgs". + out <- capture.output(show(GwasFineMappingParam())) + expect_true(any(str_detect(out, "credibleSetArgs"))) + expect_true(any(str_detect(out, "coverage, secondaryCoverage"))) +}) + +test_that("show counts an unnamed list slot and names a named one", { + unnamed <- capture.output(show(CrossValidationParam( + samplePartition = list(1:2, 3:4) + ))) + expect_true(any(str_detect(unnamed, fixed("2 entries")))) + one <- capture.output(show(CrossValidationParam( + samplePartition = list(1:2) + ))) + expect_true(any(str_detect(one, fixed("1 entry")))) + named <- capture.output(show(FineMappingMethodsParam( + qtlDatasetMethods = list(susie = SusieOptions()) + ))) + expect_true(any(str_detect(named, "susie"))) +}) + +test_that(".paramNestedText reports a nested Param that is empty", { + expect_match( + as.character(pecotmr:::.paramNestedText(MashComponentParam())), + "nothing set" + ) +}) + +test_that("$ and [[ refuse names and positions a Param does not have", { + cs <- CredibleSetParam() + expect_error(cs$nosuch, "is not a setting of CredibleSetParam") + expect_error(cs$nosuch, "It has:") + expect_error(cs[[99L]], "subscript out of bounds") + expect_equal(cs[["coverage"]], 0.95) + expect_error(cs[["nosuch"]], "is not a setting of CredibleSetParam") + expect_error(cs[[NA_integer_]], "subscript out of bounds") +}) + +test_that(".assetMethodParam names the record it was handed", { + # A Param of the wrong class reports its own class, not "a bare list". + expect_error( + pecotmr:::.assertMethodParam( + CredibleSetParam(), + "ColocPriorParam", + "priors" + ), + "a CredibleSetParam" + ) + expect_error( + pecotmr:::.assertMethodParam(list(a = 1), "ColocPriorParam", "priors"), + "a bare list" + ) + # An empty list is "no settings", as it is for MethodOptions. + expect_silent(pecotmr:::.assertMethodParam( + list(), + "ColocPriorParam", + "priors" + )) +}) + +test_that("validity catches unnamed entries that bypass the constructor", { + # Two different checks produce near-identical text, and only one is on + # the constructor path: .methodsNormalizeSlot() aborts first, so the + # validity guard in .methodsSlotProblems() is reached only by a direct + # new() or a slot<- afterwards. Asserting on the phrase alone cannot + # tell them apart -- the prefix is what distinguishes them. + expect_error( + FineMappingMethodsParam(qtlDatasetMethods = list(list(L = 1))), + "FineMappingMethodsParam: every `qtlDatasetMethods` entry must be" + ) + expect_error( + new( + "FineMappingMethodsParam", + qtlDatasetMethods = list(list(L = 1)) + ), + "`qtlDatasetMethods`: every entry must be named for its method" + ) + # An empty-string name is the same failure as a missing one. + expect_error( + new( + "FineMappingMethodsParam", + qtlDatasetMethods = set_names(list(list()), "") + ), + "`qtlDatasetMethods`: every entry must be named for its method" + ) +}) + +test_that(".methodsParamFor and ...ForMulti route each input shape", { + f <- pecotmr:::.methodsParamFor + m <- pecotmr:::.methodsParamForMulti + # A record of the right class passes straight through. + p <- FineMappingMethodsParam(methods = "susie") + expect_identical(f(p, "QtlDataset", "FineMappingMethodsParam", "x"), p) + expect_identical(m(p, "FineMappingMethodsParam", "x", TRUE), p) + # A character vector names methods with their defaults. + expect_equal( + names(f("susie", "QtlDataset", "FineMappingMethodsParam", "x")$methods), + "susie" + ) + # A record for the OTHER pipeline is refused by name, not silently used. + expect_error( + f( + TwasWeightsMethodsParam(methods = "lasso"), + "QtlDataset", + "FineMappingMethodsParam", + "fineMappingPipeline" + ), + "configures a different pipeline" + ) + expect_error( + m( + TwasWeightsMethodsParam(methods = "lasso"), + "FineMappingMethodsParam", + "fineMappingPipeline", + TRUE + ), + "configures a different pipeline" + ) + # Anything that is neither a record, a character vector nor a list. + expect_error( + m(42, "FineMappingMethodsParam", "fineMappingPipeline", TRUE), + "must be a character vector, a named list" + ) +}) diff --git a/tests/testthat/test_MultiStudyQtlDataset.R b/tests/testthat/test_MultiStudyQtlDataset.R index 769cd4efa..7499b0c68 100644 --- a/tests/testthat/test_MultiStudyQtlDataset.R +++ b/tests/testthat/test_MultiStudyQtlDataset.R @@ -40,7 +40,7 @@ test_that("MultiStudyQtlDataset: rejects unnamed qtlDatasets list", { ) expect_error( MultiStudyQtlDataset(qtlDatasets = list(qd, qd)), - "named list" + "Must have names" ) }) @@ -154,7 +154,8 @@ test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { # Bare call returns the embedded QtlSumStats collection ... expect_s4_class(getSumStats(mt), "QtlSumStats") # ... but any selection argument is rejected. - expect_error(getSumStats(mt, study = "s1"), "does not accept selection") + # Taking no extra formals is the rejection: R names the argument. + expect_error(getSumStats(mt, study = "s1"), "unused argument") }) @@ -168,7 +169,7 @@ test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { test_that("MultiStudyQtlDataset: rejects an empty qtlDatasets list", { expect_error( MultiStudyQtlDataset(qtlDatasets = list()), - "'qtlDatasets' must be a non-empty named list" + "qtlDatasets.*Must have length >= 1" ) }) @@ -180,7 +181,7 @@ test_that("MultiStudyQtlDataset: rejects duplicated study names", { ) expect_error( MultiStudyQtlDataset(qtlDatasets = list(s1 = qd, s1 = qd)), - "names of 'qtlDatasets' must be unique" + "qtlDatasets.*Must have unique names" ) }) @@ -215,3 +216,14 @@ test_that("getStudy unions the individual-level and summary-only studies", { ) expect_setequal(getStudy(mt), c("s1", "study1")) }) + +test_that("MultiStudyQtlDataset: qtlDatasets guard fires on a non-list", { + expect_error( + MultiStudyQtlDataset(qtlDatasets = "not-a-list"), + "qtlDatasets.*Must be of type 'list'" + ) +}) + +test_that(".msqdConcat answers an empty list for no pieces", { + expect_identical(pecotmr:::.msqdConcat(list()), list()) +}) diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index f839ee526..c88fe97c7 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -83,18 +83,20 @@ context("QtlDataset internal helpers") ) { gh <- .qh_makeHandle(n_samples = n_samples, a1 = a1, a2 = a2) pheno <- setNames( - lapply(contexts, function(.) .qh_makeSe(n_samples = n_samples)), + map(contexts, function(.) .qh_makeSe(n_samples = n_samples)), contexts ) if (is.null(geno_cov)) { geno_cov <- matrix(numeric(0), nrow = 0, ncol = 0) } + # `...` is the genotype filter now: every caller passes only filter + # fields (mafCutoff / xvarCutoff / imissCutoff / keepVariants). QtlDataset( study = "study1", genotypes = gh, phenotypes = pheno, genotypeCovariates = geno_cov, - ... + genotypeFilterArgs = GenotypeFilterParam(...) ) } @@ -269,7 +271,7 @@ test_that(".qtlResolveVariantRegion: region must be a GRanges; multi-range is al qd <- .qh_makeDataset() expect_error( pecotmr:::.qtlResolveVariantRegion(qd, region = "chr1:100-200"), - "must be a GRanges object" + "Must inherit from class 'GRanges'" ) expect_error( pecotmr:::.qtlResolveVariantRegion( @@ -374,13 +376,15 @@ test_that(".qtlApplyFilterOverrides replaces every supplied slot on a validated 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") + GenotypeFilterParam( + mafCutoff = 0.05, + macCutoff = 10, + xvarCutoff = 0.01, + imissCutoff = 0.1, + keepIndel = FALSE, + keepSamples = c("s1", "s2"), + keepVariants = c("rs1", "rs2") + ) ) expect_equal(out@mafCutoff, 0.05) expect_equal(out@macCutoff, 10) @@ -396,7 +400,10 @@ test_that(".qtlApplyFilterOverrides replaces every supplied slot on a validated test_that(".qtlApplyFilterOverrides leaves stored slots untouched when args are NULL", { qd <- .qh_makeDataset(contexts = "brain") - expect_identical(pecotmr:::.qtlApplyFilterOverrides(qd), qd) + expect_identical( + pecotmr:::.qtlApplyFilterOverrides(qd, GenotypeFilterParam()), + qd + ) }) # =========================================================================== @@ -743,7 +750,7 @@ test_that(".qtlExtractBlock: keepSamples restriction narrows the returned set", qd <- .qh_makeDataset() qd <- pecotmr:::.qtlApplyFilterOverrides( qd, - keepSamples = paste0("s", 1:6) + GenotypeFilterParam(keepSamples = paste0("s", 1:6)) ) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), @@ -757,7 +764,7 @@ test_that(".qtlExtractBlock: per-call samples arg further narrows the sample set qd <- .qh_makeDataset() qd <- pecotmr:::.qtlApplyFilterOverrides( qd, - keepSamples = paste0("s", 1:6) + GenotypeFilterParam(keepSamples = paste0("s", 1:6)) ) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), @@ -809,7 +816,7 @@ test_that("QtlDataset: keepIndel defaults to TRUE; validity rejects non-scalar", expect_true(qd@keepIndel) # The constructor coerces via isTRUE(); validity guards direct new()/slot sets. qd@keepIndel <- c(TRUE, FALSE) - expect_error(validObject(qd), "keepIndel.*single logical") + expect_error(validObject(qd), "Variable 'keepIndel'") }) test_that(".qtlExtractBlock: mafCutoff drops low-MAF variants", { @@ -986,7 +993,7 @@ context("QtlDataset residualization methods") ) { gh <- .qr_makeHandle(n_samples = n_samples) pheno <- setNames( - lapply(contexts, function(.) .qr_makeSe(n_samples = n_samples)), + map(contexts, function(.) .qr_makeSe(n_samples = n_samples)), contexts ) if (is.null(geno_cov)) { @@ -1039,82 +1046,28 @@ context("QtlDataset residualization methods") } # =========================================================================== -# .qtlResolveResidualizationFlag (pure helper used by both methods) # =========================================================================== +# Residualization flags (NULL = unset) +# =========================================================================== +# .qtlResolveResidualizationFlag and its two `*Flags` callers are gone: the +# convenience/precise pair of booleans plus a missing() companion for each +# existed only because a flat formal defaulting to TRUE cannot tell FALSE +# from "not given". ResidualizationParam() defaults them to NULL, so +# absence is representable and the accessors just read the field. -test_that(".qtlResolveResidualizationFlag: both missing returns TRUE", { - res <- pecotmr:::.qtlResolveResidualizationFlag( - conveniencePassed = NA, - convenienceMissing = TRUE, - precisePassed = NA, - preciseMissing = TRUE, - convenienceName = "conv", - preciseName = "prec" - ) - expect_true(res) -}) - -test_that(".qtlResolveResidualizationFlag: only convenience set returns that value", { - expect_true(pecotmr:::.qtlResolveResidualizationFlag( - TRUE, - FALSE, - NA, - TRUE, - "conv", - "prec" - )) - expect_false(pecotmr:::.qtlResolveResidualizationFlag( - FALSE, - FALSE, - NA, - TRUE, - "conv", - "prec" - )) -}) - -test_that(".qtlResolveResidualizationFlag: only precise set returns that value", { - expect_true(pecotmr:::.qtlResolveResidualizationFlag( - NA, - TRUE, - TRUE, - FALSE, - "conv", - "prec" - )) - expect_false(pecotmr:::.qtlResolveResidualizationFlag( - NA, - TRUE, - FALSE, - FALSE, - "conv", - "prec" - )) -}) - -test_that(".qtlResolveResidualizationFlag: both set + agreeing returns the shared value", { - expect_true(pecotmr:::.qtlResolveResidualizationFlag( - TRUE, - FALSE, - TRUE, - FALSE, - "conv", - "prec" - )) +test_that("an unset residualization flag means the side is residualized", { + cfg <- ResidualizationParam() + expect_null(cfg$residualizePhenotype) + expect_null(cfg$residualizeGenotype) + expect_length(cfg, 0L) }) -test_that(".qtlResolveResidualizationFlag: both set + conflicting errors", { - expect_error( - pecotmr:::.qtlResolveResidualizationFlag( - TRUE, - FALSE, - FALSE, - FALSE, - "conv", - "prec" - ), - "Conflicting values: `conv`" - ) +test_that("FALSE is distinguishable from unset", { + cfg <- ResidualizationParam(residualizePhenotype = FALSE) + expect_false(cfg$residualizePhenotype) + # the other side stays unset rather than being pinned to TRUE + expect_null(cfg$residualizeGenotype) + expect_equal(names(cfg), "residualizePhenotype") }) # =========================================================================== @@ -1237,7 +1190,7 @@ test_that("getResidualizedGenotypes: residualizes only against selected pheno co G <- getResidualizedGenotypes( qd, contexts = "brain", - phenotypeCovariatesToResidualize = "age" + residualizationArgs = ResidualizationParam(phenotypeCovariates = "age") ) expect_equal(nrow(G), 12L) # Resulting columns should be uncorrelated with 'age'. @@ -1247,7 +1200,7 @@ test_that("getResidualizedGenotypes: residualizes only against selected pheno co } }) -test_that("getResidualizedGenotypes: respects residualizePhenotypeCovariates = FALSE", { +test_that("getResidualizedGenotypes: respects residualizePhenotype = FALSE", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( extractBlockGenotypes = .qr_mockExtractor(), @@ -1258,7 +1211,9 @@ test_that("getResidualizedGenotypes: respects residualizePhenotypeCovariates = F G1 <- getResidualizedGenotypes( qd, contexts = "brain", - residualizePhenotypeCovariates = FALSE + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE + ) ) expect_equal(nrow(G1), 12L) expect_equal(ncol(G1), 6L) @@ -1273,26 +1228,35 @@ test_that("getResidualizedGenotypes: precise-name kwarg routes correctly", { G_precise <- getResidualizedGenotypes( qd, contexts = "brain", - residualizePhenotypeCovariatesFromGenotypes = FALSE + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE + ) ) G_conv <- getResidualizedGenotypes( qd, contexts = "brain", - residualizePhenotypeCovariates = FALSE + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE + ) ) expect_equal(G_precise, G_conv) }) -test_that("getResidualizedGenotypes: conflict between convenience and precise errors", { +# The convenience/precise conflict test is gone with the duality itself: +# residualizePhenotypeCovariates and its FromGenotypes twin were two +# spellings of one +# boolean, needing a conflict check between them. ResidualizationParam() +# has one field, so there is nothing left to conflict. + +test_that("getResidualizedGenotypes refuses a bare list for the bundle", { qd <- .qr_makeDataset(contexts = "brain") expect_error( getResidualizedGenotypes( qd, contexts = "brain", - residualizePhenotypeCovariates = TRUE, - residualizePhenotypeCovariatesFromGenotypes = FALSE + residualizationArgs = list(residualizePhenotype = FALSE) ), - "Conflicting values" + "ResidualizationParam" ) }) @@ -1322,7 +1286,9 @@ test_that("getResidualizedGenotypes: includes genotype covariates when supplied" G <- getResidualizedGenotypes( qd, contexts = "brain", - genotypeCovariatesToResidualize = c("pc1", "pc2") + residualizationArgs = ResidualizationParam( + genotypeCovariates = c("pc1", "pc2") + ) ) # Columns should be uncorrelated with the included PCs. for (j in seq_len(ncol(G))) { @@ -1348,7 +1314,9 @@ test_that("getResidualizedGenotypes: mean-imputes missing covariates by default" G <- getResidualizedGenotypes( qd, contexts = "brain", - genotypeCovariatesToResidualize = c("pc1", "pc2") + residualizationArgs = ResidualizationParam( + genotypeCovariates = c("pc1", "pc2") + ) ) expect_equal(nrow(G), 12L) expect_false(anyNA(G)) @@ -1370,8 +1338,10 @@ test_that("getResidualizedGenotypes: covariateNaAction='drop' removes samples wi G <- getResidualizedGenotypes( qd, contexts = "brain", - genotypeCovariatesToResidualize = c("pc1", "pc2"), - covariateNaAction = "drop" + residualizationArgs = ResidualizationParam( + genotypeCovariates = c("pc1", "pc2"), + covariateNaAction = "drop" + ) ) expect_equal(nrow(G), 11L) expect_false("s3" %in% rownames(G)) @@ -1408,7 +1378,7 @@ test_that("getResidualizedPhenotypes: residualizes against age covariate", { Y <- getResidualizedPhenotypes( qd, contexts = "brain", - phenotypeCovariatesToResidualize = "age" + residualizationArgs = ResidualizationParam(phenotypeCovariates = "age") ) age <- seq_len(12) for (j in seq_len(ncol(Y))) { @@ -1416,12 +1386,14 @@ test_that("getResidualizedPhenotypes: residualizes against age covariate", { } }) -test_that("getResidualizedPhenotypes: respects residualizePhenotypeCovariates = FALSE", { +test_that("getResidualizedPhenotypes: respects residualizePhenotype = FALSE", { qd <- .qr_makeDataset(contexts = "brain") Y <- getResidualizedPhenotypes( qd, contexts = "brain", - residualizePhenotypeCovariates = FALSE + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE + ) ) expect_equal(nrow(Y), 12L) expect_equal(ncol(Y), 2L) @@ -1432,12 +1404,16 @@ test_that("getResidualizedPhenotypes: precise-name kwarg routes correctly", { Y_precise <- getResidualizedPhenotypes( qd, contexts = "brain", - residualizePhenotypeCovariatesFromPhenotypes = FALSE + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE + ) ) Y_conv <- getResidualizedPhenotypes( qd, contexts = "brain", - residualizePhenotypeCovariates = FALSE + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE + ) ) expect_equal(Y_precise, Y_conv) }) @@ -1655,7 +1631,7 @@ test_data_dir <- test_path("test_data") plink_prefix <- file.path(test_data_dir, "test_variants") # Load genotype matrix once for reuse across tests -load_test_genotype <- function() { +loadTestGenotype <- function() { loadGenotypeRegion(plink_prefix, returnVariantInfo = TRUE) } @@ -1663,7 +1639,7 @@ load_test_genotype <- function() { test_that("computeLd produces valid sample correlation matrix", { skip_if_not_installed("pgenlibr") - geno <- load_test_genotype() + geno <- loadTestGenotype() R <- computeLd(geno$X, method = "sample") expect_true(is.matrix(R)) expect_equal(nrow(R), ncol(geno$X)) @@ -1676,7 +1652,7 @@ test_that("computeLd produces valid sample correlation matrix", { test_that("computeLd population method produces valid matrix", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "population") expect_true(isSymmetric(R)) expect_true(all(abs(diag(R) - 1) < 1e-10)) @@ -1685,7 +1661,7 @@ test_that("computeLd population method produces valid matrix", { test_that("computeLd sample and population methods are similar", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R_s <- computeLd(X, method = "sample") R_p <- computeLd(X, method = "population") # Should be close but not identical (N-1 vs N denominator) @@ -1700,7 +1676,7 @@ test_that("computeLd errors on NULL input", { test_that("checkLd diagnoses real LD matrix correctly", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") result <- checkLd(R) expect_true(is.list(result)) @@ -1714,7 +1690,7 @@ test_that("checkLd diagnoses real LD matrix correctly", { test_that("checkLd eigenfix improves non-PSD matrix", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") # Make a non-PSD matrix by negating a small block of off-diagonal entries R_bad <- R @@ -1735,7 +1711,7 @@ test_that("checkLd eigenfix improves non-PSD matrix", { test_that("checkLd shrink repairs perturbed LD matrix", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") R_bad <- R R_bad[1, 2] <- R_bad[2, 1] <- 1.5 @@ -1748,7 +1724,7 @@ test_that("checkLd shrink repairs perturbed LD matrix", { test_that("ldPruneByCorrelation prunes correlated variants", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X result <- ldPruneByCorrelation(X, corThres = 0.8) expect_true(is.list(result)) expect_true(is.matrix(result$X.new)) @@ -1761,7 +1737,7 @@ test_that("ldPruneByCorrelation prunes correlated variants", { test_that("ldPruneByCorrelation with strict threshold prunes more", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X loose <- ldPruneByCorrelation(X, corThres = 0.95) strict <- ldPruneByCorrelation(X, corThres = 0.5) expect_true(ncol(strict$X.new) <= ncol(loose$X.new)) @@ -1769,7 +1745,7 @@ test_that("ldPruneByCorrelation with strict threshold prunes more", { test_that("ldPruneByCorrelation with high threshold keeps most columns", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X result <- ldPruneByCorrelation(X, corThres = 0.999) # At threshold near 1, only near-duplicates are pruned; real data may have many expect_true(ncol(result$X.new) >= ncol(X) * 0.4) @@ -1781,7 +1757,7 @@ test_that("ldClumpByScore returns valid indices", { skip_if_not_installed("pgenlibr") skip_if_not_installed("bigsnpr") skip_if_not_installed("bigstatsr") - geno <- load_test_genotype() + geno <- loadTestGenotype() set.seed(42) score <- runif(ncol(geno$X)) chr <- as.integer(geno$variant_info$chrom) @@ -1803,7 +1779,7 @@ test_that("ldClumpByScore returns valid indices", { test_that("enforceDesignFullRank handles genotype matrix with covariates", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X # Create a simple covariate matrix (e.g., first 2 PCs of X) pca <- prcomp(X, rank. = 2) C <- pca$x @@ -1819,7 +1795,7 @@ test_that("enforceDesignFullRank handles genotype matrix with covariates", { test_that("filterVariantsByLdReference filters against PLINK reference via metadata", { skip_if_not_installed("pgenlibr") - geno <- load_test_genotype() + geno <- loadTestGenotype() vi <- geno$variant_info variant_ids <- paste0(vi$chrom, ":", vi$pos, ":", vi$A2, ":", vi$A1) fake_ids <- c("21:999999:A:G", "21:888888:C:T") @@ -1854,7 +1830,7 @@ test_that("filterVariantsByLdReference filters against PLINK reference via metad test_that("resolveLdInput computes LD from genotype matrix", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X result <- pecotmr:::resolveLdInput(X = X, needNSample = TRUE) expect_true(is.list(result)) expect_true(is.matrix(result$R)) @@ -1865,7 +1841,7 @@ test_that("resolveLdInput computes LD from genotype matrix", { test_that("resolveLdInput passes through pre-computed R", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") result <- pecotmr:::resolveLdInput( R = R, @@ -1885,7 +1861,7 @@ test_that("resolveLdInput errors when neither R nor X provided", { test_that("resolveLdInput errors when both R and X provided", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") expect_error( pecotmr:::resolveLdInput(R = R, X = X), @@ -1895,7 +1871,7 @@ test_that("resolveLdInput errors when both R and X provided", { test_that("resolveLdInput errors when R given without nSample and needed", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") expect_error( pecotmr:::resolveLdInput(R = R, needNSample = TRUE), @@ -1907,7 +1883,7 @@ test_that("resolveLdInput errors when R given without nSample and needed", { test_that("dentistSingleWindow works with genotype matrix X", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X set.seed(42) z <- rnorm(ncol(X)) result <- suppressWarnings(dentistSingleWindow(z, X = X)) @@ -1921,7 +1897,7 @@ test_that("dentistSingleWindow works with genotype matrix X", { test_that("dentistSingleWindow works with pre-computed R", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") set.seed(42) z <- rnorm(ncol(X)) @@ -1932,7 +1908,7 @@ test_that("dentistSingleWindow works with pre-computed R", { test_that("dentistSingleWindow detects injected outliers", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X + X <- loadTestGenotype()$X R <- computeLd(X, method = "sample") set.seed(42) z <- rnorm(ncol(X)) @@ -1948,7 +1924,7 @@ test_that("dentistSingleWindow detects injected outliers", { test_that("dentist works with genotype matrix and sum_stat data frame", { skip_if_not_installed("pgenlibr") - geno <- load_test_genotype() + geno <- loadTestGenotype() set.seed(42) sum_stat <- data.frame( pos = geno$variant_info$pos, @@ -1966,7 +1942,7 @@ test_that("dentist works with genotype matrix and sum_stat data frame", { test_that("dentist accepts zscore column name variant", { skip_if_not_installed("pgenlibr") - geno <- load_test_genotype() + geno <- loadTestGenotype() R <- computeLd(geno$X, method = "sample") set.seed(42) sum_stat <- data.frame( @@ -1987,8 +1963,8 @@ test_that("dentist accepts zscore column name variant", { test_that("dentist errors when sum_stat missing required columns", { skip_if_not_installed("pgenlibr") - X <- load_test_genotype()$X - bad_stat <- data.frame(x = 1:ncol(X), y = rnorm(ncol(X))) + X <- loadTestGenotype()$X + bad_stat <- data.frame(x = seq_len(ncol(X)), y = rnorm(ncol(X))) expect_error(dentist(bad_stat, X = X), "missing either") }) @@ -2016,7 +1992,7 @@ test_that("QtlDataset: rejects empty study name", { genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se) ), - "non-empty character string" + "Variable 'study'.*at least 1 characters" ) }) @@ -2065,9 +2041,9 @@ test_that("QtlDataset: rejects negative QC cutoffs", { study = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se), - mafCutoff = -0.1 + genotypeFilterArgs = GenotypeFilterParam(mafCutoff = -0.1) ), - "non-negative numeric" + "is not >= 0" ) }) @@ -2319,7 +2295,10 @@ test_that(".qtlResolveVariantRegion rejects a non-GRanges / empty region", { genotypes = h, phenotypes = list(ctx = .mr_makeSE(getSampleIds(h))) ) - expect_error(getGenotypes(qd, region = "chr21:1-2"), "must be a GRanges") + expect_error( + getGenotypes(qd, region = "chr21:1-2"), + "Must inherit from class 'GRanges'" + ) expect_error( getGenotypes(qd, region = GenomicRanges::GRanges()), "at least one range" @@ -2386,7 +2365,7 @@ test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative c region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100, 200)) expect_error( pecotmr:::.qtlResolveVariantRegion(qd, region = region, cisWindow = -5), - "must be a single non-negative value" + "cisWindow" ) expect_error( pecotmr:::.qtlResolveVariantRegion( @@ -2394,7 +2373,7 @@ test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative c region = region, cisWindow = c(1, 2) ), - "must be a single non-negative value" + "cisWindow" ) }) @@ -2421,7 +2400,7 @@ test_that(".qtlExtractBlock: keepSamples disjoint from the panel returns a zero- # none are panel samples qd <- pecotmr:::.qtlApplyFilterOverrides( qd, - keepSamples = c("zzz1", "zzz2") + GenotypeFilterParam(keepSamples = c("zzz1", "zzz2")) ) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), @@ -2760,8 +2739,10 @@ test_that("getResidualizedGenotypes: errors when genotypes and covariates share getResidualizedGenotypes( qd, contexts = "brain", - residualizePhenotypeCovariates = FALSE, - genotypeCovariatesToResidualize = c("pc1", "pc2") + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE, + genotypeCovariates = c("pc1", "pc2") + ) ), "No samples in common" ) @@ -2779,8 +2760,10 @@ test_that("getResidualizedPhenotypes: errors when phenotypes and covariates shar getResidualizedPhenotypes( qd, contexts = "brain", - residualizePhenotypeCovariates = FALSE, - genotypeCovariatesToResidualize = c("pc1", "pc2") + residualizationArgs = ResidualizationParam( + residualizePhenotype = FALSE, + genotypeCovariates = c("pc1", "pc2") + ) ), "No samples in common" ) @@ -2802,11 +2785,13 @@ test_that("QtlDataset filter accessors round-trip what was passed in", { data(qtlDatasetExample, envir = environment()) x <- .qtlApplyFilterOverrides( qtlDatasetExample, - mafCutoff = 0.05, - macCutoff = 10, - xvarCutoff = 0.01, - imissCutoff = 0.1, - keepIndel = FALSE + GenotypeFilterParam( + mafCutoff = 0.05, + macCutoff = 10, + xvarCutoff = 0.01, + imissCutoff = 0.1, + keepIndel = FALSE + ) ) expect_equal(getMafCutoff(x), 0.05) expect_equal(getMacCutoff(x), 10) @@ -3158,7 +3143,7 @@ test_that("validity rejects a non-scalar scaleResiduals", { # The constructor coerces via isTRUE(); validity guards direct slot sets. qd <- .qh_makeDataset() qd@scaleResiduals <- c(TRUE, FALSE) - expect_error(validObject(qd), "scaleResiduals.*single logical") + expect_error(validObject(qd), "Variable 'scaleResiduals'") }) test_that("the phenotype-list check rejects duplicated context names", { @@ -3254,3 +3239,111 @@ test_that("trait-position validation skips a context whose ranges do not line up test_that("aligning covariates with nothing to align returns NULL", { expect_null(pecotmr:::.qtlAlignCovariates(list(), NULL)) }) + +test_that("outlier detection reports a singular trait covariance", { + # A singular covariance silently became a pseudo-inverse, while the + # sibling robustbase-missing branch already informed the user. + Y <- cbind(a = c(1, 2, 3, 4), b = c(2, 4, 6, 8)) + cnd <- rlang::catch_cnd( + pecotmr:::.qtlOutlierKeepMask(Y, pvalThreshold = 0.05), + classes = "message" + ) + expect_match(conditionMessage(cnd), "singular") + expect_match(conditionMessage(cnd), "pseudo-inverse") +}) + +test_that(".qtlConcat answers an empty list for no pieces", { + expect_identical(pecotmr:::.qtlConcat(list()), list()) +}) + +test_that("CovMcdOptions refuses the data and the RNG seed", { + expect_error(CovMcdOptions(x = matrix(0)), "the trait matrix") + expect_error(CovMcdOptions(seed = 1), "pecotmr's own RNG handling") + expect_error(CovMcdOptions(nosuch = 1), "unknown argument") + expect_equal(CovMcdOptions(alpha = 0.75)$alpha, 0.75) +}) + +test_that(".qtlOutlierKeepMask forwards outlierArgs to robustbase::covMcd", { + skip_if_not_installed("robustbase") + seen <- NULL + real <- robustbase::covMcd + set.seed(3) + Y <- matrix(rnorm(60 * 2), 60, 2) + with_mocked_bindings( + pecotmr:::.qtlOutlierKeepMask( + Y, + pvalThreshold = 1e-3, + outlierArgs = CovMcdOptions(alpha = 0.9) + ), + covMcd = function(...) { + seen <<- list(...) + real(...) + }, + .package = "robustbase" + ) + expect_equal(seen$alpha, 0.9) +}) + +test_that("the three filter bundles are separate on purpose", { + # imissCutoff genuinely differs: it resolves to 0 on the genotype path + # (admit no missingness) and 1 on the panel path (filter nothing, so the + # allele-frequency sidecar can be read instead of materializing dosage). + expect_equal( + pecotmr:::.qtlResolveFilter(GenotypeFilterParam())$imissCutoff, + 0 + ) + expect_equal(PanelFilterParam()$imissCutoff, 1) +}) + +test_that("an unset genotype filter field is absent, not NULL", { + # Absence is what distinguishes "pin this value" from "leave it alone": + # QtlDataset resolves an unset field to its own default, a pipeline + # leaves the dataset's construct-time slot untouched. + expect_length(GenotypeFilterParam(), 0L) + expect_equal(names(GenotypeFilterParam(mafCutoff = 0)), "mafCutoff") + # A pinned zero is NOT the same as unset. + expect_equal(GenotypeFilterParam(mafCutoff = 0)$mafCutoff, 0) + expect_null(GenotypeFilterParam()$mafCutoff) +}) + +test_that("every GenotypeFilterParam field is one QtlDataset resolves", { + expect_setequal( + names(formals(GenotypeFilterParam)), + names(pecotmr:::.qtlResolveFilter(GenotypeFilterParam())) + ) +}) + +test_that("each bundle carries only fields its consumers read", { + expect_setequal( + names(PanelFilterParam()), + c("mafCutoff", "macCutoff", "imissCutoff") + ) + expect_setequal( + names(SumstatsFilterParam()), + c("removeIndels", "removeStrandAmbiguous", "infoCutoff", "nCutoff") + ) +}) + +test_that("a field belonging to another bundle is refused", { + # The whole point of three constructors: a sumstats-row option passed to + # the genotype filter would be silently ignored if they were one. + expect_error(GenotypeFilterParam(removeIndels = TRUE), "unused argument") + expect_error(PanelFilterParam(xvarCutoff = 0.1), "unused argument") + expect_error(SumstatsFilterParam(mafCutoff = 0.01), "unused argument") +}) + +test_that("all three are MethodParams and read like a list", { + bundles <- list( + GenotypeFilterParam(), + PanelFilterParam(), + SumstatsFilterParam() + ) + for (a in bundles) { + expect_s4_class(a, "MethodParam") + # A settings record is NOT an engine argument bag: the two families + # are disjoint, which is what lets .assertMethodParam() reject one where + # the other was wanted. + expect_false(is(a, "MethodOptions")) + expect_type(as.list(a), "list") + } +}) diff --git a/tests/testthat/test_QtlFineMappingResult.R b/tests/testthat/test_QtlFineMappingResult.R index 58351a8c4..33e31e93f 100644 --- a/tests/testthat/test_QtlFineMappingResult.R +++ b/tests/testthat/test_QtlFineMappingResult.R @@ -626,7 +626,10 @@ test_that("QtlFineMappingResult: getMarginalEffects with tuple selectors", { test_that("validity names a missing identity column", { bad <- .qfmr_res() mcols(bad)$trait <- NULL - expect_error(methods::validObject(bad), "missing columns: trait") + expect_error( + methods::validObject(bad), + "missing elements \\{'trait'\\}" + ) }) test_that("validity names a missing entry payload column", { @@ -634,7 +637,7 @@ test_that("validity names a missing entry payload column", { mcols(bad)$susieFit <- NULL expect_error( methods::validObject(bad), - "missing entry payload columns: susieFit" + "missing entry payload columns: .*missing elements \\{'susieFit'\\}" ) }) @@ -648,3 +651,21 @@ test_that("a joint column must be character, not a factor or number", { "'jointStudies' column must be character \\(got integer\\)" ) }) + +test_that("a QtlFineMappingResult refuses a region selector", { + data(qtlFineMappingExample) + # Region selection belongs to GwasFineMappingResult. The shared + # FineMappingResultBase accessors pass `region` to every selector, and + # this one used to absorb it in `...` and silently return the + # study/context/trait/method match instead. + expect_error( + getSusieFit(qtlFineMappingExample, region = "chr22:1-2"), + "not region-indexed" + ) + expect_error( + getVariantIds(qtlFineMappingExample, region = "chr22:1-2"), + "not region-indexed" + ) + # The supported selectors still work. + expect_type(getSusieFit(qtlFineMappingExample, method = "susie"), "list") +}) diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 1374e47b3..6dfd637f7 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -308,7 +308,10 @@ test_that("subsetRegion differs from subsetByOverlaps and restrict", { test_that(".rtlSplitByBlocks splits one element into per-block pieces", { r <- .rtlSplitByBlocks(list(.rtl_variants()), .rtl_blocks()) - expect_equal(names(r$entry), c("b1", "b2")) + # `blockId` is the documented channel for which block a piece came from; + # the flattened entry list is deliberately unnamed (base unlist()'s + # `outer.inner` mangling was an artifact, and inconsistent at that). + expect_null(names(r$entry)) expect_equal(r$blockId, c("b1", "b2")) expect_equal(unname(lengths(r$entry)), c(2L, 1L)) # Both pieces came from the one input element, so its metadata row is @@ -816,8 +819,8 @@ test_that(".rtlTupleKeyCols is empty when there are no mcols", { test_that("`[[<-` rejects a non-scalar or NA index", { x <- .rtl_makeKid() - expect_error(x[[c(1L, 2L)]] <- x[[1L]], "takes a single non-NA index") - expect_error(x[[NA_integer_]] <- x[[1L]], "takes a single non-NA index") + expect_error(x[[c(1L, 2L)]] <- x[[1L]], "Must have length 1") + expect_error(x[[NA_integer_]] <- x[[1L]], "May not be NA") }) diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index 6fb43e6f5..533ee1c28 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -12,7 +12,7 @@ context("causalInferencePipeline") path = "/tmp/sketch.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -141,7 +141,7 @@ context("causalInferencePipeline") test_that("causalInferencePipeline: rejects non-GwasSumStats input", { expect_error( causalInferencePipeline(gwasSumStats = "no"), - "must be a GwasSumStats" + "Must inherit from class 'GwasSumStats'" ) }) @@ -168,7 +168,7 @@ test_that("causalInferencePipeline: rejects non-TwasWeights twasWeights arg", { gwasSumStats = .cip_makeGwasSumstats(), twasWeights = "not a TwasWeights" ), - "must be a TwasWeights" + "Must inherit from class 'TwasWeights'" ) }) @@ -301,7 +301,7 @@ test_that("causalInferencePipeline: with both inputs, MR fields are populated", gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, fineMappingResult = fmr, - mrPipCutoff = 0.5 + mrArgs = MrParam(pipCutoff = 0.5) ) mc <- S4Vectors::mcols(out) # MR uses PIP > 0.5 variants from the FMR (v1, v3, v4). @@ -514,7 +514,7 @@ test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per gro out <- causalInferencePipeline( gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, - rsqCutoff = 0.1 + weightSelectionArgs = WeightSelectionParam(cutoff = 0.1) ) expect_equal(as.character(S4Vectors::mcols(out)$method), "lasso") }) @@ -547,7 +547,7 @@ test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", out <- causalInferencePipeline( gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, - rsqCutoff = 0.1 + weightSelectionArgs = WeightSelectionParam(cutoff = 0.1) ) expect_equal(as.character(S4Vectors::mcols(out)$method), "lasso") expect_true(is.finite(S4Vectors::mcols(out)$twasZ)) @@ -580,8 +580,10 @@ test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods out <- causalInferencePipeline( gwasSumStats = .cip_makeGwasSumstats(), twasWeights = tw, - rsqCutoff = 0.1, - rsqPvalCutoff = 0.05 + weightSelectionArgs = WeightSelectionParam( + cutoff = 0.1, + pvalCutoff = 0.05 + ) ) expect_equal(as.character(S4Vectors::mcols(out)$method), "lasso") }) @@ -596,7 +598,7 @@ context("twas: twasZ and harmonize deprecated wrappers") .tz_makeLd <- function(n = 100, p = 8, seed = 7) { set.seed(seed) X <- matrix(rbinom(n * p, 2, runif(p, 0.2, 0.8)), nrow = n, ncol = p) - vid <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + vid <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) colnames(X) <- vid af <- colMeans(X) / 2 Xstd <- sweep(X, 2, 2 * af) @@ -640,7 +642,7 @@ test_that("twasZ: non-matrix non-numeric weights errors out", { test_that("twasZ: length mismatch between weights and z errors", { expect_error( pecotmr:::twasZ(c(0.1, 0.2, 0.3), z = c(1, 2)), - "nrow\\(weights\\) must equal length\\(z\\)" + "weights.*Must have exactly 2 rows" ) }) @@ -689,7 +691,7 @@ test_that("twasZ: R path errors when R is missing rows named in weights", { d <- .tz_makeLd() w <- rnorm(d$p) names(w) <- d$vid - R_short <- d$R[1:(d$p - 1), 1:(d$p - 1)] + R_short <- d$R[seq_len(d$p - 1), seq_len(d$p - 1)] expect_error( pecotmr:::twasZ(w, rnorm(d$p), R = R_short), "R is missing rows for" @@ -699,10 +701,10 @@ test_that("twasZ: R path errors when R is missing rows named in weights", { test_that("twasZ: R path positional alignment errors on dim mismatch", { d <- .tz_makeLd() w <- rnorm(d$p) # unnamed -> positional alignment - R_short <- unname(d$R[1:(d$p - 1), 1:(d$p - 1)]) + R_short <- unname(d$R[seq_len(d$p - 1), seq_len(d$p - 1)]) expect_error( pecotmr:::twasZ(w, rnorm(d$p), R = R_short), - "positional alignment requires nrow\\(R\\) == nrow\\(weights\\)" + "R \\(positional alignment\\).*Must have exactly 8 rows" ) }) @@ -734,7 +736,7 @@ test_that("twasZ: SVD path errors when V is missing rows named in weights", { s <- svd(d$Xstd) rownames(s$v) <- d$vid[seq_len(nrow(s$v))] w <- rnorm(d$p) - names(w) <- c(d$vid[1:(d$p - 1)], "ghost") + names(w) <- c(d$vid[seq_len(d$p - 1)], "ghost") expect_error( pecotmr:::twasZ(w, rnorm(d$p), V = s$v, D = s$d, nSketch = d$n), "V is missing rows for" @@ -746,10 +748,10 @@ test_that("twasZ: SVD path positional alignment errors on dim mismatch", { s <- svd(d$Xstd) # Pass an unnamed V with the wrong nrow. w <- rnorm(d$p) - V_short <- s$v[1:(d$p - 1), , drop = FALSE] + V_short <- s$v[seq_len(d$p - 1), , drop = FALSE] expect_error( pecotmr:::twasZ(w, rnorm(d$p), V = V_short, D = s$d, nSketch = d$n), - "positional alignment requires nrow\\(V\\) == nrow\\(weights\\)" + "V \\(positional alignment\\).*Must have exactly 8 rows" ) }) @@ -794,7 +796,7 @@ test_that("twasZ: combineMethods K>=2 forwards to combinePValues with correlatio # =========================================================================== test_that("twasZ errors when weights and z lengths differ", { - expect_error(twasZ(c(1, 2), c(1, 2, 3)), "must equal") + expect_error(twasZ(c(1, 2), c(1, 2, 3)), "Must have exactly 3 rows") }) @@ -889,7 +891,7 @@ test_that("twasZ: computing R from X matches providing R directly", { n <- 20 p <- 5 X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- paste0("SNP", 1:p) + colnames(X) <- paste0("SNP", seq_len(p)) R <- cor(X) weights <- rnorm(p) z <- rnorm(p) @@ -1012,14 +1014,14 @@ test_that("twasZ: matrix weights produce one Z row per column", { p <- 5 k <- 3 weights <- matrix(rnorm(p * k), nrow = p, ncol = k) - rownames(weights) <- paste0("SNP", 1:p) - colnames(weights) <- paste0("Cond", 1:k) + rownames(weights) <- paste0("SNP", seq_len(p)) + colnames(weights) <- paste0("Cond", seq_len(k)) z <- rnorm(p) R <- diag(p) - rownames(R) <- colnames(R) <- paste0("SNP", 1:p) + rownames(R) <- colnames(R) <- paste0("SNP", seq_len(p)) result <- twasZ(weights, z, R = R) expect_equal(nrow(result$Z), k) - expect_equal(rownames(result$Z), paste0("Cond", 1:k)) + expect_equal(rownames(result$Z), paste0("Cond", seq_len(k))) expect_equal(colnames(result$Z), c("Z", "pval")) # combineMethods omitted -> combined is NULL expect_null(result$combined) @@ -1035,11 +1037,11 @@ test_that("twasZ: combineMethods returns combined p-value summary", { rnorm(p * k), nrow = p, ncol = k, - dimnames = list(paste0("SNP", 1:p), paste0("Cond", 1:k)) + dimnames = list(paste0("SNP", seq_len(p)), paste0("Cond", seq_len(k))) ) z <- rnorm(p) R <- diag(p) - rownames(R) <- colnames(R) <- paste0("SNP", 1:p) + rownames(R) <- colnames(R) <- paste0("SNP", seq_len(p)) result <- twasZ(weights, z, R = R, combineMethods = "ACAT") expect_false(is.null(result$combined)) }) @@ -1157,7 +1159,7 @@ test_that("twasZ: error when weights and z have different lengths", { D = c(1, 1), nSketch = 10 ), - "nrow\\(weights\\) must equal length\\(z\\)" + "weights.*Must have exactly 3 rows" ) }) @@ -1763,21 +1765,28 @@ test_that(".cipCvSelection errors when no method clears the CV cutoffs", { local_mocked_bindings( .cipMethodMetrics = function(...) { data.frame( - qtlStudy = "s", context = "c", trait = "t", - method = "m", rsq = 0.01, stringsAsFactors = FALSE + qtlStudy = "s", + context = "c", + trait = "t", + method = "m", + rsq = 0.01, + stringsAsFactors = FALSE ) }, .cipFilterEligibleMethods = function(...) data.frame(), .package = "pecotmr" ) - p <- list( - twasWeights = "notNull", rsqCutoff = 0.5, rsqPvalCutoff = 0.05, - qtlRows = data.frame(a = 1), rsqOption = NULL, rsqPvalOption = NULL - ) # Naming the cutoffs in the message is what makes this actionable. expect_error( - pecotmr:::.cipCvSelection(p), - "rsqCutoff = 0.5 / rsqPvalCutoff = 0.05" + pecotmr:::.cipCvSelection( + qtlRows = data.frame(a = 1), + twasWeights = "notNull", + weightSelectionArgs = WeightSelectionParam( + cutoff = 0.5, + pvalCutoff = 0.05 + ) + ), + "cutoff = 0.5, pvalCutoff = 0.05" ) }) @@ -1786,18 +1795,26 @@ test_that(".cipRun errors when no tuple produced a result", { .cipValidateInputs = function(...) invisible(NULL), .cipCheckLdSketches = function(...) NULL, .cipResolveWorkList = function(...) data.frame(x = 1), - .cipCvSelection = function(p) { + .cipCvSelection = function(...) { list( qtlRows = data.frame(x = 1), rsqLookup = NULL, selectionActive = FALSE ) }, - .cipScoreQtlTuple = function(qi, p) list(), + .cipScoreQtlTuple = function(qi, ...) list(), .package = "pecotmr" ) expect_error( - pecotmr:::.cipRun(list()), + pecotmr:::.cipRun( + gwasSumStats = NULL, + twasWeights = NULL, + fineMappingResult = NULL, + combineMethods = NULL, + weightSelectionArgs = WeightSelectionParam(), + alleleFlip = FALSE, + mrArgs = MrParam(method = "csAware", cpipCutoff = 0) + ), "no \\(qtl, gwas\\) tuples produced a result" ) }) @@ -1809,8 +1826,12 @@ test_that(".cipScoreQtlTuple skips a tuple with no weights", { ) p <- list( qtlRows = data.frame( - qtlStudy = "s", context = "c", trait = "t", method = "m", - useFmrForWeights = FALSE, stringsAsFactors = FALSE + qtlStudy = "s", + context = "c", + trait = "t", + method = "m", + useFmrForWeights = FALSE, + stringsAsFactors = FALSE ), twasWeights = NULL, fineMappingResult = NULL @@ -1826,10 +1847,21 @@ test_that(".cipScoreGwasPair skips a pair with no TWAS z", { .cipPairLabel = function(...) "lab", .package = "pecotmr" ) - p <- list(gwasSumStats = list(study = "G1"), gwasLd = NULL, - alleleFlip = FALSE) expect_null( - pecotmr:::.cipScoreGwasPair(1L, NULL, list(), NULL, p) + pecotmr:::.cipScoreGwasPair( + 1L, + NULL, + list(), + NULL, + gwasSumStats = list(study = "G1"), + gwasLd = NULL, + alleleFlip = FALSE, + mrArgs = MrParam( + method = "csAware", + cpipCutoff = 0, + pvalCutoff = 1 + ) + ) ) }) @@ -1838,15 +1870,12 @@ test_that(".cipRunMr routes to the CS-aware estimator when asked", { .cipComputeMrCsAware = function(...) list(SENTINEL = TRUE), .package = "pecotmr" ) - p <- list( - mrPvalCutoff = 1, mrMethod = "csAware", - mrCpipCutoff = 0.5, alleleFlip = FALSE - ) out <- pecotmr:::.cipRunMr( fmrEntry = "notNull", gdf = NULL, twasOut = list(pval = 0.001), - p = p + alleleFlip = FALSE, + mrArgs = MrParam(method = "csAware", cpipCutoff = 0.5, pvalCutoff = 1) ) expect_true(isTRUE(out$SENTINEL)) }) @@ -1870,3 +1899,55 @@ test_that(".cipCvMetric returns NA when the CV result cannot be read", { is.na(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "rsq")) ) }) + +test_that("twasZ: nSketch / combineMethods guards fire", { + expect_error( + twasZ(matrix(1, 1, 1), 1, nSketch = 0), + "nSketch.*Must be >= 1" + ) + expect_error( + twasZ(matrix(1, 1, 1), 1, combineMethods = 1L), + "combineMethods.*Must be of type 'character'" + ) +}) + +# --------------------------------------------------------------------------- +# Empty-input guards. These exist because list_c() errors on an empty list, +# so the guard is the contract: nothing in, empty of the right type out. +# --------------------------------------------------------------------------- + +test_that("the concat helpers answer an empty vector of their own type", { + expect_identical(pecotmr:::.cipConcatInt(list()), integer(0)) + expect_identical(pecotmr:::.cipConcat(list()), list()) +}) + +test_that("MrParam refuses the PIP cutoff its method does not read", { + # Each method reads exactly one of the two. Setting the other used to be + # silently ignored. + expect_error( + MrParam(method = "csAware", pipCutoff = 0.9), + "not read by method" + ) + expect_error( + MrParam(method = "ivwPerVariant", cpipCutoff = 0.9), + "not read by method" + ) + # Leaving the inapplicable one at its default is not a request. + expect_s4_class( + MrParam(method = "csAware", cpipCutoff = 0.9), + "MrParam" + ) + expect_s4_class(MrParam(pipCutoff = 0.9), "MrParam") +}) + +test_that("WeightSelectionParam and MrParam do not overlap", { + expect_length( + intersect( + names(formals(WeightSelectionParam)), + names(formals(MrParam)) + ), + 1L # both carry a pvalCutoff, gating different things + ) + expect_equal(WeightSelectionParam()$cutoff, 0) + expect_equal(MrParam()$method, "ivwPerVariant") +}) diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index ee2c318f4..46767826b 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -13,7 +13,7 @@ context("colocPipeline") path = "/tmp/sketch.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -36,7 +36,7 @@ context("colocPipeline") tl <- data.frame( variant_id = variant_ids, chrom = rep("1", n), - pos = as.integer(100 * (1:n)), + pos = as.integer(100 * seq_len(n)), A1 = rep("G", n), A2 = rep("A", n), N = rep(1000, n), @@ -84,10 +84,10 @@ context("colocPipeline") ) } QtlFineMappingResult( - study = vapply(tuples, `[[`, character(1), 1), - context = vapply(tuples, `[[`, character(1), 2), - trait = vapply(tuples, `[[`, character(1), 3), - method = vapply(tuples, `[[`, character(1), 4), + study = map_chr(tuples, 1L), + context = map_chr(tuples, 2L), + trait = map_chr(tuples, 3L), + method = map_chr(tuples, 4L), entry = entries, ldSketch = if (with_sketch) .cp_makeHandle() else NULL ) @@ -106,8 +106,8 @@ context("colocPipeline") ) } GwasFineMappingResult( - study = vapply(tuples, `[[`, character(1), 1), - method = vapply(tuples, `[[`, character(1), 2), + study = map_chr(tuples, 1L), + method = map_chr(tuples, 2L), entry = entries, ldSketch = if (with_sketch) .cp_makeHandle() else NULL ) @@ -520,9 +520,7 @@ test_that(".colocExtractLbfFromEntry: entry without trimmedFit returns NULL with expect_warning( out <- pecotmr:::.colocExtractLbfFromEntry( e, - FALSE, - NULL, - 1e-9 + ColocLbfFilterParam() ), "has no trimmedFit" ) @@ -561,9 +559,10 @@ test_that(".colocExtractLbfFromEntry: filterLbfCs subsets by cs_index", { ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = TRUE, - filterLbfCsSecondary = NULL, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = TRUE, + secondary = NULL + ) ) expect_equal(nrow(out$lbf), 2L) }) @@ -638,13 +637,15 @@ test_that(".colocLookupEnrichment: returns the value for a (gwasStudy, qtlStudy, enrichment = c(2.0, 3.5), stringsAsFactors = FALSE ) + # Returns the matching ROW, so the caller can read the enloc priors off + # it rather than only the enrichment factor. expect_equal( pecotmr:::.colocLookupEnrichment( enr, .cp_side("G2"), .cp_side("Q1", "c1") ), - 3.5 + 2L ) }) @@ -705,7 +706,7 @@ test_that("colocPipeline: rejects a non-data.frame enrichment", { gwasInput = gfmr, enrichment = "not a data frame" ), - "must be a data.frame" + "Must be of type 'data.frame'" ) }) @@ -723,13 +724,13 @@ test_that("colocPipeline: rejects enrichment missing required columns", { gwasInput = gfmr, enrichment = bad ), - "is missing column" + "Colnames must include the elements" ) }) # --- enrichment end-to-end (lookup + p12 scaling + output columns) ---------- -test_that("colocPipeline: enrichment hit scales p12 and emits enrichment/p12Used", { +test_that("colocPipeline: enrichment mode takes its priors from the table", { qfmr <- .cp_makeQtlFmr() # Q1 / c1 / t1 / susie gfmr <- .cp_makeGwasFmr() # G1 / susie enr <- data.frame( @@ -737,6 +738,9 @@ test_that("colocPipeline: enrichment hit scales p12 and emits enrichment/p12Used qtlStudy = "Q1", qtlContext = "c1", enrichment = 2.0, + colocP1 = 3e-4, + colocP2 = 7e-4, + colocP12 = 2.5e-5, stringsAsFactors = FALSE ) local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") @@ -747,11 +751,68 @@ test_that("colocPipeline: enrichment hit scales p12 and emits enrichment/p12Used enrichment = enr ) ) - expect_equal(nrow(out), 1L) + # Enrichment mode scores every (QTL effect, GWAS effect) pair itself + # rather than calling coloc.bf_bf, so the fixture's 2 x 2 effects give + # four rows; the mock used elsewhere collapses them to one. + expect_equal(nrow(out), 4L) expect_true(all(c("enrichment", "p12Used") %in% colnames(out))) expect_equal(unique(out$enrichment), 2.0) - # min(p12 * (1 + enrichment), p12Max) = min(5e-6 * 3, 1e-3) = 1.5e-5 - expect_equal(unique(out$p12Used), min(5e-6 * 3, 1e-3)) + # qtlEnrichmentPipeline derives p12 = P_eqtl * expit(a0 + a1) the way + # fastenloc does; the pipeline uses that, rather than scaling a default. + expect_equal(unique(out$p12Used), 2.5e-5) +}) + +test_that("enrichment mode reports RCP and LCP alongside the hypotheses", { + qfmr <- .cp_makeQtlFmr() + gfmr <- .cp_makeGwasFmr() + enr <- data.frame( + gwasStudy = "G1", + qtlStudy = "Q1", + qtlContext = "c1", + enrichment = 2.0, + colocP1 = 3e-4, + colocP2 = 7e-4, + colocP12 = 2.5e-5, + stringsAsFactors = FALSE + ) + out <- suppressWarnings(colocPipeline( + qtlFineMappingResult = qfmr, + gwasInput = gfmr, + enrichment = enr + )) + pairs <- getColocPairs(out) + expect_true(all(c("RCP", "LCP") %in% colnames(pairs))) + # The two names for the same quantities: fastenloc's RCP is the posterior + # of one shared causal variant, and LCP adds the distinct-variant case. + expect_equal(pairs$RCP, pairs$PP.H4.abf) + expect_equal(pairs$LCP, pairs$PP.H3.abf + pairs$PP.H4.abf) + probs <- pairs$PP.H0.abf + + pairs$PP.H1.abf + + pairs$PP.H2.abf + + pairs$PP.H3.abf + + pairs$PP.H4.abf + expect_equal(probs, rep(1, nrow(pairs))) +}) + +test_that("colocPipeline: an enrichment table without the priors is refused", { + qfmr <- .cp_makeQtlFmr() + gfmr <- .cp_makeGwasFmr() + enr <- data.frame( + gwasStudy = "G1", + qtlStudy = "Q1", + qtlContext = "c1", + enrichment = 2.0, + stringsAsFactors = FALSE + ) + local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") + expect_error( + suppressWarnings(colocPipeline( + qtlFineMappingResult = qfmr, + gwasInput = gfmr, + enrichment = enr + )), + "missing colocP1, colocP2, colocP12" + ) }) test_that("colocPipeline: enrichment joins on the second side's trait", { @@ -771,6 +832,9 @@ test_that("colocPipeline: enrichment joins on the second side's trait", { qtlStudy = c("Q1", "Q1"), qtlContext = c("c1", "c1"), enrichment = c(1.0, 3.0), + colocP1 = c(3e-4, 3e-4), + colocP2 = c(7e-4, 7e-4), + colocP12 = c(1e-5, 3e-5), stringsAsFactors = FALSE ) local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") @@ -780,9 +844,15 @@ test_that("colocPipeline: enrichment joins on the second side's trait", { enrichment = enr )) pairs <- getColocPairs(out) + # Four effect pairs per trait now that enrichment mode scores each one, + # so the check is that each trait carries its own factor throughout. expect_equal( - pairs$enrichment[order(pairs$gwasTrait)], - c(1.0, 3.0) + unique(pairs$enrichment[pairs$gwasTrait == "t1"]), + 1.0 + ) + expect_equal( + unique(pairs$enrichment[pairs$gwasTrait == "t2"]), + 3.0 ) }) @@ -804,7 +874,7 @@ test_that("colocPipeline: rejects an enrichment table with repeated keys", { ) }) -test_that("colocPipeline: enrichment miss warns and falls back to baseline p12", { +test_that("colocPipeline: an enrichment miss warns and drops to plain priors", { qfmr <- .cp_makeQtlFmr() gfmr <- .cp_makeGwasFmr() enr <- data.frame( @@ -823,9 +893,12 @@ test_that("colocPipeline: enrichment miss warns and falls back to baseline p12", ) ) expect_match(w, "no enrichment entry", all = FALSE) - expect_equal(nrow(out), 1L) - expect_equal(unique(out$enrichment), 0) # enRow reset to 0 on miss - expect_equal(unique(out$p12Used), 5e-6) # baseline p12 unchanged + expect_equal(nrow(out), 4L) + # A miss means there is no enrichment estimate for this pair, so it is + # scored with the unconditional priors rather than a fabricated factor + # of zero applied to a default. + expect_true(is.na(unique(out$enrichment))) + expect_equal(unique(out$p12Used), 5e-6) }) # --- returnGwasFineMapping attached on the empty-pair early return (~205) ---- @@ -973,10 +1046,11 @@ test_that(".colocExtractLbfFromEntry: stacks fSuSiE lBF list into a matrix", { ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5 + ) ) expect_equal(nrow(out$lbf), 4L) # 2 + 2 stacked expect_setequal(colnames(out$lbf), sprintf("chr1:%d:A:G", 100L * (1:4))) @@ -997,10 +1071,11 @@ test_that(".colocExtractLbfFromEntry: stacks nested fSuSiE lBF (fit[[1]] path)", ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5 + ) ) expect_equal(nrow(out$lbf), 2L) }) @@ -1015,10 +1090,11 @@ test_that(".colocExtractLbfFromEntry: warns + NULL when fit carries no LBF slot" expect_warning( out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5 + ) ), "no lbf_variable" ) @@ -1042,10 +1118,11 @@ test_that(".colocExtractLbfFromEntry: warns + NULL on an empty LBF matrix", { expect_warning( out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5 + ) ), "LBF matrix is empty" ) @@ -1075,10 +1152,11 @@ test_that(".colocExtractLbfFromEntry: secondary CS filter subsets rows", { ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = FALSE, - filterLbfCsSecondary = 0.95, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = 0.95, + concentration = 0.5 + ) ) expect_equal(nrow(out$lbf), 1L) expect_equal(as.numeric(out$lbf), c(2, 5, 8, 11)) # row 2 of matrix(1:12, 3, 4) @@ -1093,10 +1171,11 @@ test_that(".colocExtractLbfFromEntry: assigns colnames from variantIds when fit ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5 + ) ) expect_equal(colnames(out$lbf), sprintf("chr1:%d:A:G", 100L * (1:4))) }) @@ -1119,10 +1198,11 @@ test_that(".colocExtractLbfFromEntry: NULL when every variant column is NA-named ) out <- pecotmr:::.colocExtractLbfFromEntry( e, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, - filterLbfCsConcentration = 0.5, - priorTol = 1e-9 + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, + concentration = 0.5 + ) ) expect_null(out) }) @@ -1161,11 +1241,19 @@ test_that(".colocSelectLbfRows returns indices into the unfiltered rows", { V = c(0.5, 0, 0.2, 0) ) expect_equal( - .colocSelectLbfRows(lbf, fit, TRUE, NULL, NULL, 1e-9), + .colocSelectLbfRows( + lbf, + fit, + ColocLbfFilterParam(filterLbfCs = TRUE) + ), c(2L, 4L) ) expect_equal( - .colocSelectLbfRows(lbf, fit, FALSE, NULL, NULL, 1e-9), + .colocSelectLbfRows( + lbf, + fit, + ColocLbfFilterParam(filterLbfCs = FALSE) + ), c(1L, 3L) ) }) @@ -1175,7 +1263,11 @@ test_that(".colocSelectLbfRows does not prefix-match sets_secondary", { lbf <- matrix(0, nrow = 3L, ncol = 2L) fit <- list(sets_secondary = list(cs_index = 1L), V = c(1, 1, 0)) expect_equal( - .colocSelectLbfRows(lbf, fit, TRUE, NULL, NULL, 1e-9), + .colocSelectLbfRows( + lbf, + fit, + ColocLbfFilterParam(filterLbfCs = TRUE) + ), seq_len(3L) ) }) @@ -1219,6 +1311,30 @@ test_that("colocPipeline publishes coloc's variant count as nSnps", { }) +test_that("gwasFineMapping is refused when the GWAS is already fine-mapped", { + # The bundle configures the fine-mapping run colocPipeline does on a raw + # GwasSumStats. Handed an already-fine-mapped GWAS there is no such run, + # so a setting given here would be dropped rather than honoured. + data(qtlFineMappingExample, gwasFineMappingExample) + expect_error( + colocPipeline( + qtlFineMappingExample, + gwasFineMappingExample, + gwasFineMappingArgs = GwasFineMappingParam(methods = "susieInf") + ), + "there is no run to configure" + ) + # The default bundle is not a request, so it passes silently. + expect_no_error(pecotmr:::.colocResolveGwasFmr( + gwasFineMappingExample, + GwasFineMappingParam() + )) + expect_no_error(pecotmr:::.colocResolveGwasFmr( + gwasFineMappingExample, + list() + )) +}) + test_that("an explicit blockId is preferred over the derived range key", { # blockId keys the external block manifest, so it carries the true block # BOUNDARIES rather than the span of whichever variants survived QC. @@ -1251,19 +1367,32 @@ test_that("PIP adjustment is skipped when either side has no rows", { # Intersecting variants across an empty side would empty the other, so # the inputs are passed through untouched instead. data(qtlFineMappingExample, gwasFineMappingExample) - p <- list( - adjustPips = TRUE, + # It now returns just the two (possibly adjusted) inputs, not a bundle. + emptyQtl <- list( qtlFineMappingResult = qtlFineMappingExample[0], gwasFmr = gwasFineMappingExample ) - expect_identical(pecotmr:::.colocMaybeAdjustPips(p), p) + expect_identical( + pecotmr:::.colocMaybeAdjustPips( + adjustPips = TRUE, + qtlFineMappingResult = emptyQtl$qtlFineMappingResult, + gwasFmr = emptyQtl$gwasFmr + ), + emptyQtl + ) # ...and it is skipped outright when not requested. - p2 <- list( - adjustPips = FALSE, + notAsked <- list( qtlFineMappingResult = qtlFineMappingExample, gwasFmr = gwasFineMappingExample ) - expect_identical(pecotmr:::.colocMaybeAdjustPips(p2), p2) + expect_identical( + pecotmr:::.colocMaybeAdjustPips( + adjustPips = FALSE, + qtlFineMappingResult = notAsked$qtlFineMappingResult, + gwasFmr = notAsked$gwasFmr + ), + notAsked + ) }) test_that("pre-extracting LBF from an empty GWAS result yields no blocks", { @@ -1271,11 +1400,209 @@ test_that("pre-extracting LBF from an empty GWAS result yields no blocks", { expect_equal( pecotmr:::.colocPreextractGwasLbf( gwasFineMappingExample[0], - FALSE, - FALSE, - FALSE, - 1e-9 + ColocLbfFilterParam() ), list() ) }) + +test_that("ColocPriorParam carries the priors and rejects a typo", { + pr <- ColocPriorParam(p12 = 1e-5) + expect_s4_class(pr, "ColocPriorParam") + expect_equal(pr$p12, 1e-5) + expect_equal(pr$p1, 1e-4) + expect_error(ColocPriorParam(p13 = 1e-5), "unused argument") +}) + +test_that("ColocLbfFilterParam carries the filter settings", { + lf <- ColocLbfFilterParam(filterLbfCs = TRUE, concentration = 0.25) + expect_true(lf$filterLbfCs) + expect_equal(lf$concentration, 0.25) + # NULL secondary means "primary sets only" and is not forwarded. + expect_false(is_in("secondary", names(ColocLbfFilterParam()))) + expect_error(ColocLbfFilterParam(concentrations = 0.25), "unused argument") +}) + +test_that("ColocOptions is checked against coloc.bf_bf", { + skip_if_not_installed("coloc") + expect_s4_class(ColocOptions(), "MethodOptions") + expect_output(show(ColocOptions()), "checked against coloc::coloc.bf_bf") + expect_error(ColocOptions(overlapMin = 0.5), "unknown argument") +}) + +test_that("priors cannot be set twice", { + skip_if_not_installed("coloc") + # p1/p2/p12 are read by the enrichment adjustment as well as forwarded, + # so allowing them in methodArgs would let the two disagree. + expect_error( + pecotmr:::.colocEngineArgs(ColocOptions(p12 = 1e-5), ColocPriorParam()), + "set through `priors`" + ) + expect_silent( + pecotmr:::.colocEngineArgs(ColocOptions(), ColocPriorParam()) + ) +}) + +test_that("colocPipeline refuses bare lists where a constructor is due", { + expect_error( + pecotmr:::.colocAssertGroups( + list(p1 = 1e-4), + ColocLbfFilterParam(), + ColocOptions() + ), + "must be built with ColocPriorParam\\(\\)" + ) + expect_error( + pecotmr:::.colocAssertGroups( + ColocPriorParam(), + list(filterLbfCs = TRUE), + ColocOptions() + ), + "must be built with ColocLbfFilterParam\\(\\)" + ) +}) + +test_that("priors and enrichment cannot both be given", { + qfmr <- .cp_makeQtlFmr() + gfmr <- .cp_makeGwasFmr() + enr <- data.frame( + gwasStudy = "G1", + qtlStudy = "Q1", + qtlContext = "c1", + enrichment = 2.0, + colocP1 = 3e-4, + colocP2 = 7e-4, + colocP12 = 2.5e-5, + stringsAsFactors = FALSE + ) + local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") + # fastenloc skips enrichment silently in this situation; pecotmr refuses, + # because scoring with one set of priors while enriching with another is + # never what the caller meant. + expect_error( + colocPipeline( + qtlFineMappingResult = qfmr, + gwasInput = gfmr, + priors = ColocPriorParam(p12 = 1e-5), + enrichment = enr + ), + "cannot both be given" + ) + # Either alone is fine. + expect_no_error(suppressWarnings(colocPipeline( + qtlFineMappingResult = qfmr, + gwasInput = gfmr, + priors = ColocPriorParam(p12 = 1e-5) + ))) + expect_no_error(suppressWarnings(colocPipeline( + qtlFineMappingResult = qfmr, + gwasInput = gfmr, + enrichment = enr + ))) +}) + +test_that("GwasFineMappingParam carries only what the inline fit can use", { + g <- GwasFineMappingParam() + expect_s4_class(g, "GwasFineMappingParam") + expect_setequal( + names(g), + c( + "methods", + "credibleSetArgs", + "rssArgs", + "panelFilterArgs", + "addSusieInf", + "fitRetention" + ) + ) + # Nested bundles survive: the inline fit gets a real credibleSetArgs. + expect_s4_class( + GwasFineMappingParam( + credibleSetArgs = CredibleSetParam(coverage = 0.9) + )$credibleSetArgs, + "CredibleSetParam" + ) + expect_equal( + GwasFineMappingParam( + credibleSetArgs = CredibleSetParam(coverage = 0.9) + )$credibleSetArgs$coverage, + 0.9 + ) + # The fineMappingPipeline settings that cannot apply are absent, not + # carried-and-ignored: it IS the fine-mapping call, so there is no + # resume cache; CV is refused on sumstats; residualization has nothing + # to regress out. + for (nm in c("fineMappingResult", "crossValidation", "residualization")) { + expect_false(nm %in% names(formals(GwasFineMappingParam)), label = nm) + } + # Every field it does carry is a real fineMappingPipeline(GwasSumStats) + # argument. + accepted <- names(formals( + getMethod( + "fineMappingPipeline", + "GwasSumStats" + )@.Data + )) + expect_true(all(is_in( + setdiff(names(formals(GwasFineMappingParam)), "methods"), + c( + accepted, + "credibleSetArgs", + "rssArgs", + "panelFilterArgs", + "addSusieInf", + "fitRetention" + ) + ))) + expect_error(GwasFineMappingParam(fitRetention = "none"), "must be one of") +}) + +test_that("GwasFineMappingParam accessors round-trip a nested bundle", { + g <- GwasFineMappingParam() + expect_equal(getFineMappingMethods(g), "susie") + expect_s4_class(getCredibleSetArgs(g), "CredibleSetParam") + + # Why this class has accessors at all: once CredibleSetParam is + # settable, the container must let the edited record back in, or the + # nested settings would be readable but not writable. + g2 <- setCredibleSetArgs(g, setCoverage(getCredibleSetArgs(g), 0.8)) + expect_equal(getCoverage(getCredibleSetArgs(g2)), 0.8) + expect_equal(getCoverage(getCredibleSetArgs(g)), 0.95) + + # The nested slots are typed, so the wrong Param is refused rather than + # surfacing as a missing field somewhere downstream. + expect_error( + setRssArgs(g, CredibleSetParam()), + "not valid for @.+rssArgs" + ) + expect_s4_class( + setRssArgs(g, SusieRssParam(serFallback = TRUE)), + "GwasFineMappingParam" + ) +}) + +test_that("GwasFineMappingParam accessors read and replace every field", { + # Dispatching each accessor is what exercises the generics declared in + # AllGenerics.R; the constructor alone never reaches them. + p <- GwasFineMappingParam() + expect_equal(getFineMappingMethods(p), "susie") + expect_s4_class(getRssArgs(p), "SusieRssParam") + expect_s4_class(getPanelFilterArgs(p), "PanelFilterParam") + expect_s4_class(getCredibleSetArgs(p), "CredibleSetParam") + expect_true(getAddSusieInf(p)) + expect_equal(getFitRetention(p), "slim") + + # Each setter returns a new record and leaves the original alone. + expect_equal( + getFineMappingMethods(setFineMappingMethods(p, "susieInf")), + "susieInf" + ) + expect_false(getAddSusieInf(setAddSusieInf(p, FALSE))) + expect_equal(getFitRetention(setFitRetention(p, "full")), "full") + expect_s4_class( + getPanelFilterArgs(setPanelFilterArgs(p, PanelFilterParam())), + "PanelFilterParam" + ) + expect_equal(getFineMappingMethods(p), "susie") + expect_true(getAddSusieInf(p)) +}) diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index f6b68352f..baebc7338 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -95,7 +95,7 @@ context("colocboostPipeline (S4 dispatch)") path = "/tmp/cb.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -179,7 +179,7 @@ context("colocboostPipeline (S4 dispatch)") ) { gh <- .cbp_makeHandle() phen <- setNames( - lapply(contexts, function(.) .cbp_makeSe(traits = traits)), + map(contexts, function(.) .cbp_makeSe(traits = traits)), contexts ) QtlDataset( @@ -262,21 +262,26 @@ test_that(".cbBuildLdArgs: empty list returns empty list", { expect_equal(pecotmr:::.cbBuildLdArgs(list()), list()) }) -test_that(".cbScreenSpec enforces one metric and threads the right spec", { - expect_error(pecotmr:::.cbScreenSpec(0.5, 5, 0, 0), "one signal screen") +test_that("SignalScreenParam enforces one metric and threads the right spec", { + expect_error( + SignalScreenParam(pip = 0.5, absZ = 5), + "only one screening metric" + ) expect_equal( - pecotmr:::.cbScreenSpec(0, 5, 0, 0), + pecotmr:::.screenResolve(SignalScreenParam(absZ = 5)), list(metric = "absZ", cutoff = 5) ) expect_equal( - pecotmr:::.cbScreenSpec(0, 0, 100, 0), + pecotmr:::.screenResolve(SignalScreenParam(bf = 100)), list(metric = "bf", cutoff = 100) ) - expect_equal(pecotmr:::.cbScreenSpec(0.3, 0, 0, 0), 0.3) # legacy pip scalar + # legacy pip scalar passes through as a bare numeric + expect_equal(pecotmr:::.screenResolve(SignalScreenParam(pip = 0.3)), 0.3) expect_equal( - pecotmr:::.cbScreenSpec(c(brain = 0.3), 0, 0, 0), + pecotmr:::.screenResolve(SignalScreenParam(pip = c(brain = 0.3))), c(brain = 0.3) ) # context-named pass-through + expect_null(pecotmr:::.screenResolve(SignalScreenParam())) }) test_that(".cbResolveCutoff passes a screen object through uniformly", { @@ -288,12 +293,12 @@ test_that(".cbResolveCutoff passes a screen object through uniformly", { expect_equal(pecotmr:::.cbResolveCutoff(0.5, "any"), 0.5) }) -test_that("colocboostPipeline(QtlDataset): enabling two screen metrics errors", { - qd <- .cbp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - # .cbScreenSpec runs before the bundle/engine, so this fails fast. +test_that("enabling two screen metrics errors where it is written", { + # The constructor enforces it, so this fails at the call that builds the + # bundle -- before any pipeline runs. expect_error( - colocboostPipeline(qd, pipCutoffToSkip = 0.5, bfCutoffToSkip = 100), - "one signal screen" + SignalScreenParam(pip = 0.5, bf = 100), + "only one screening metric" ) }) @@ -518,23 +523,36 @@ test_that("colocboostPipeline: separateGwas runs once per merged sumstat study", ) }) -test_that("colocboostPipeline: no analysis flag set emits a message and returns empty", { +test_that("colocboostPipeline: no analysis flag set is an error", { ss <- .cbp_makeQtlSumStats() local_mocked_bindings( extractBlockGenotypes = .cbp_mockExtractor(), .package = "pecotmr" ) - out <- suppressMessages( + # All three FALSE is the one combination that is not a request. It used + # to run silently and hand back an empty result. + expect_error( colocboostPipeline( ss, xqtlColoc = FALSE, jointGwas = FALSE, separateGwas = FALSE + ), + "no analysis selected" + ) + # Any single flag is still a valid request -- they are independent, not + # a mutually exclusive set. + for (flag in c("xqtlColoc", "jointGwas", "separateGwas")) { + args <- set_names( + list(FALSE, FALSE, FALSE), + c("xqtlColoc", "jointGwas", "separateGwas") ) - ) - expect_null(out$xqtl_coloc) - expect_null(out$joint_gwas) - expect_null(out$separate_gwas) + args[[flag]] <- TRUE + expect_silent(exec( + pecotmr:::.cbAssertAnyRun, + !!!set_names(unname(args), NULL) + )) + } }) test_that("colocboostPipeline: GWAS ldSketch mismatch errors during the driver", { @@ -608,11 +626,11 @@ test_that("GwasSumStats: nCase/nControl are optional columns (absent by default) ldSketch = .cbp_makeHandle(), qcInfo = list(ok = 1) ) - g0 <- do.call(GwasSumStats, base) + g0 <- exec(GwasSumStats, !!!base) expect_false(any( c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g0)) )) - g1 <- do.call(GwasSumStats, c(base, list(nCase = 500, nControl = 1500))) + g1 <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) expect_true(all(c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g1)))) expect_equal(g1$nCase, 500) expect_equal(g1$nControl, 1500) @@ -645,11 +663,11 @@ test_that("colocboost GWAS bundle: effective N for case/control, per-variant N o .package = "pecotmr" ) # case/control -> effective N = 4 / (1/500 + 1/1500) = 1500 - gcc <- do.call(GwasSumStats, c(base, list(nCase = 500, nControl = 1500))) + gcc <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) bcc <- pecotmr:::.cbGwasSumStatsBundle(gcc) expect_true(all(bcc[["G1"]]$sumstat$n == 4 / (1 / 500 + 1 / 1500))) # quantitative (no nCase/nControl) -> per-variant N (1000) - bq <- pecotmr:::.cbGwasSumStatsBundle(do.call(GwasSumStats, base)) + bq <- pecotmr:::.cbGwasSumStatsBundle(exec(GwasSumStats, !!!base)) expect_true(all(bq[["G1"]]$sumstat$n == 1000L)) }) @@ -666,7 +684,10 @@ test_that(".cbPipSkipOutcomes: keeps signal outcomes, drops noise, honours cutof rbinom(n * p, 2, 0.3), n, p, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:p))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * seq_len(p)) + ) ) Y <- cbind( sig = X[, 1] * 1.5 + rnorm(n, sd = 0.3), # strong signal at v1 @@ -785,7 +806,11 @@ test_that("colocboostPipeline(QtlDataset): pipCutoffToSkip dropping every outcom .package = "pecotmr" ) out <- suppressMessages(suppressWarnings( - colocboostPipeline(qd, xqtlColoc = TRUE, pipCutoffToSkip = 0.9999) + colocboostPipeline( + qd, + xqtlColoc = TRUE, + signalScreenArgs = SignalScreenParam(pip = 0.9999) + ) )) expect_null(out$xqtl_coloc) # 249-253 skip -> empty }) @@ -962,7 +987,7 @@ test_that("colocboostPipeline(MultiStudyQtlDataset): a study with no usable bund .cbf_n <- function(ss, ...) { b <- suppressMessages(.cbQtlSumStatsBundle( ss, - cutoffs = .panelCutoffs(list(...)) + cutoffs = .panelCutoffs(PanelFilterParam(...)) )) if (length(b) == 0L) 0L else length(b[[1L]]$variantIds) } @@ -998,7 +1023,7 @@ test_that("colocboost RSS cutoffs match .panelVariantFilter", { length(.panelVariantFilter( getLdSketch(ss), ids, - mafCutoff = cut + PanelFilterParam(mafCutoff = cut) )), label = str_c("mafCutoff ", cut) ) @@ -1185,19 +1210,19 @@ test_that(".cbResidualizedX reports why genotypes were unavailable", { getResidualizedGenotypes = function(...) stop("kaboom"), .package = "pecotmr" ) - # The underlying message is carried through so the skip is diagnosable. - expect_message( - res <- pecotmr:::.cbResidualizedX( - NULL, - "c1", - NULL, - NULL, - NULL, - NULL - ), - "residualized genotypes unavailable: kaboom" - ) - expect_null(res) + # The cause is chained via `parent`, not flattened into the text, so the + # rendered message still shows it AND it stays reachable as a condition. + # catch_cnd() rather than expect_message(), which returns NULL. + cnd <- rlang::catch_cnd( + pecotmr:::.cbResidualizedX(NULL, "c1", NULL, NULL, NULL, NULL), + classes = "message" + ) + expect_match(conditionMessage(cnd), "residualized genotypes unavailable") + expect_match(conditionMessage(cnd), "kaboom") + expect_match(conditionMessage(cnd$parent), "kaboom") + expect_null(suppressMessages( + pecotmr:::.cbResidualizedX(NULL, "c1", NULL, NULL, NULL, NULL) + )) }) test_that(".cbApplyScreen keeps the outcomes that clear the screen", { @@ -1334,7 +1359,7 @@ test_that(".cbRunVariants: xqtlColoc runs on a QTL-only sumstat bundle", { jointGwas = FALSE, separateGwas = FALSE, focalTrait = NULL, - dotArgs = list(), + methodArgs = ColocboostOptions(), qtlSumstatBundle = qtlOnly )) expect_equal(called, "xqtl") @@ -1362,7 +1387,7 @@ test_that(".cbRunVariants warns instead of silently skipping an analysis", { jointGwas = TRUE, separateGwas = TRUE, focalTrait = NULL, - dotArgs = list() + methodArgs = ColocboostOptions() )) ) expect_length(warnings, 2L) @@ -1386,7 +1411,7 @@ test_that(".cbRunVariants warns when xqtlColoc has only GWAS sumstats", { jointGwas = FALSE, separateGwas = FALSE, focalTrait = NULL, - dotArgs = list(), + methodArgs = ColocboostOptions(), qtlSumstatBundle = pecotmr:::.cbMergeSumstatBundles(list()) )), "xqtlColoc = TRUE was requested" @@ -1394,6 +1419,42 @@ test_that(".cbRunVariants warns when xqtlColoc has only GWAS sumstats", { expect_null(getComputingTime(out)$Analysis$xqtl_coloc) }) +test_that("ColocboostOptions() options reach the engine by name", { + # Regression: the bundle was merged with c(), which appends a MethodOptions + # (a SimpleList) as ONE opaque element instead of splicing its entries. + # exec() then handed that object to colocboost as a positional argument, + # so every option set through ColocboostOptions() was silently lost. + seen <- NULL + local_mocked_bindings( + colocboost = function(...) { + seen <<- list(...) + list(stub = TRUE) + }, + .package = "colocboost" + ) + local_mocked_bindings( + .cbOutcomeInfo = function(...) pecotmr:::.cbEmptyOutcomeInfo(), + .package = "pecotmr" + ) + qtlOnly <- pecotmr:::.cbMergeSumstatBundles(list( + qtlA = list(sumstat = list(z = 1), LD = diag(2)) + )) + suppressMessages(pecotmr:::.cbRunVariants( + NULL, + qtlOnly, + xqtlColoc = TRUE, + jointGwas = FALSE, + separateGwas = FALSE, + focalTrait = NULL, + methodArgs = ColocboostOptions(M = 3L, stop_thresh = 0.02), + qtlSumstatBundle = qtlOnly + )) + expect_equal(seen$M, 3L) + expect_equal(seen$stop_thresh, 0.02) + # ...and nothing rode along unnamed, which is how the record used to travel + expect_false(any(names(seen) == "")) +}) + test_that(".cbAppendGwasPairs disambiguates a colliding study key", { local_mocked_bindings( .cbRequireSumStatsQc = function(...) invisible(NULL), @@ -1413,3 +1474,7 @@ test_that(".cbAppendGwasPairs disambiguates a colliding study key", { expect_equal(out[["dup"]], "QTL") expect_equal(out[["dup.1"]], "GWAS") }) + +test_that(".cbConcat answers an empty list for no pieces", { + expect_identical(pecotmr:::.cbConcat(list()), list()) +}) diff --git a/tests/testthat/test_crossValidation.R b/tests/testthat/test_crossValidation.R index 671dab2eb..34c87b66c 100644 --- a/tests/testthat/test_crossValidation.R +++ b/tests/testthat/test_crossValidation.R @@ -10,7 +10,7 @@ cv <- function(...) pecotmr:::.crossValidateWeights(...) # One "mock" method whose weights are all 1s over the training columns, so a # held-out prediction is the row sum of that sample's (training-column) dosages. -mock_fit_fold <- function(Xtr, Ytr, j, ...) { +mockFitFold <- function(Xtr, Ytr, j, ...) { list( weights = list( mock = matrix( @@ -24,7 +24,7 @@ mock_fit_fold <- function(Xtr, Ytr, j, ...) { ) } -mk_xy <- function(n = 30, p = 6, k = 1, seed = 1) { +mkXY <- function(n = 30, p = 6, k = 1, seed = 1) { set.seed(seed) X <- matrix( rnorm(n * p), @@ -32,7 +32,7 @@ mk_xy <- function(n = 30, p = 6, k = 1, seed = 1) { p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) Y <- matrix( @@ -45,37 +45,37 @@ mk_xy <- function(n = 30, p = 6, k = 1, seed = 1) { } test_that("input is validated", { - d <- mk_xy() + d <- mkXY() expect_error( - cv(d$X, d$Y, fold = 0, fitFold = mock_fit_fold), - "positive integer" + cv(d$X, d$Y, fold = 0, fitFold = mockFitFold), + "Must be >= 1" ) expect_error( - cv(d$X, d$Y, fold = "a", fitFold = mock_fit_fold), - "positive integer" + cv(d$X, d$Y, fold = "a", fitFold = mockFitFold), + "Must be of type 'count'" ) expect_error( - cv(as.data.frame(d$X), d$Y, fold = 2, fitFold = mock_fit_fold), - "X must be a matrix" + cv(as.data.frame(d$X), d$Y, fold = 2, fitFold = mockFitFold), + "Must be of type 'matrix'" ) expect_error( - cv(d$X, d$Y[1:5, , drop = FALSE], fold = 2, fitFold = mock_fit_fold), - "same" + cv(d$X, d$Y[1:5, , drop = FALSE], fold = 2, fitFold = mockFitFold), + "Must have exactly 30 rows" ) expect_error( - cv(d$X, d$Y, fitFold = mock_fit_fold), + cv(d$X, d$Y, fitFold = mockFitFold), "Either 'fold' or 'samplePartitions'" ) }) test_that("Y as a vector is converted to a matrix with a message", { - d <- mk_xy(k = 1) + d <- mkXY(k = 1) expect_message( cv( d$X, as.numeric(d$Y), fold = 2, - fitFold = mock_fit_fold, + fitFold = mockFitFold, verbose = 1 ), "Y converted to matrix" @@ -83,15 +83,15 @@ test_that("Y as a vector is converted to a matrix with a message", { }) test_that("output keys use the canonical _predicted / _performance", { - d <- mk_xy() - r <- suppressMessages(cv(d$X, d$Y, fold = 3, fitFold = mock_fit_fold)) + d <- mkXY() + r <- suppressMessages(cv(d$X, d$Y, fold = 3, fitFold = mockFitFold)) expect_equal(names(r$prediction), "mock_predicted") expect_equal(names(r$performance), "mock_performance") }) test_that("performance carries the six metric colnames and outcome rownames", { - d <- mk_xy(k = 2) - r <- suppressMessages(cv(d$X, d$Y, fold = 3, fitFold = mock_fit_fold)) + d <- mkXY(k = 2) + r <- suppressMessages(cv(d$X, d$Y, fold = 3, fitFold = mockFitFold)) perf <- r$performance[["mock_performance"]] expect_equal( colnames(perf), @@ -101,15 +101,15 @@ test_that("performance carries the six metric colnames and outcome rownames", { }) test_that("every sample is predicted exactly once across folds", { - d <- mk_xy(n = 30) - r <- suppressMessages(cv(d$X, d$Y, fold = 5, fitFold = mock_fit_fold)) + d <- mkXY(n = 30) + r <- suppressMessages(cv(d$X, d$Y, fold = 5, fitFold = mockFitFold)) pred <- r$prediction[["mock_predicted"]] expect_equal(nrow(pred), nrow(d$X)) expect_false(any(is.na(pred))) }) test_that("a provided samplePartition is reused; a fold mismatch warns", { - d <- mk_xy(n = 12) + d <- mkXY(n = 12) sp <- data.frame( Sample = rownames(d$X), Fold = rep(1:3, each = 4), @@ -119,7 +119,7 @@ test_that("a provided samplePartition is reused; a fold mismatch warns", { d$X, d$Y, samplePartitions = sp, - fitFold = mock_fit_fold + fitFold = mockFitFold )) expect_equal(r$samplePartition, sp) expect_message( @@ -128,7 +128,7 @@ test_that("a provided samplePartition is reused; a fold mismatch warns", { d$Y, fold = 2, samplePartitions = sp, - fitFold = mock_fit_fold, + fitFold = mockFitFold, verbose = 1 ), "does not match" @@ -136,25 +136,25 @@ test_that("a provided samplePartition is reused; a fold mismatch warns", { }) test_that("a samplePartition with unknown samples errors", { - d <- mk_xy() + d <- mkXY() sp <- data.frame( Sample = paste0("zzz", 1:5), Fold = rep(1:2, length.out = 5) ) expect_error( - cv(d$X, d$Y, samplePartitions = sp, fitFold = mock_fit_fold), + cv(d$X, d$Y, samplePartitions = sp, fitFold = mockFitFold), "do not match" ) }) test_that("maxNumVariants subsamples variants with a message", { - d <- mk_xy(p = 20) + d <- mkXY(p = 20) expect_message( cv( d$X, d$Y, fold = 2, - fitFold = mock_fit_fold, + fitFold = mockFitFold, maxNumVariants = 8, verbose = 1 ), @@ -163,13 +163,13 @@ test_that("maxNumVariants subsamples variants with a message", { }) test_that("maxNumVariants with variantsToKeep retains the specified variants", { - d <- mk_xy(p = 20) + d <- mkXY(p = 20) expect_message( cv( d$X, d$Y, fold = 2, - fitFold = mock_fit_fold, + fitFold = mockFitFold, maxNumVariants = 8, variantsToKeep = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), verbose = 1 @@ -179,19 +179,19 @@ test_that("maxNumVariants with variantsToKeep retains the specified variants", { }) test_that("a degenerate fold (empty train/test) is skipped, not errored", { - d <- mk_xy(n = 10) + d <- mkXY(n = 10) sp <- data.frame(Sample = rownames(d$X), Fold = rep(1L, nrow(d$X))) r <- suppressMessages(cv( d$X, d$Y, samplePartitions = sp, - fitFold = mock_fit_fold + fitFold = mockFitFold )) expect_true(all(is.na(r$prediction[["mock_predicted"]]))) }) test_that("zero-variance predictions yield NA metrics with a message", { - d <- mk_xy() + d <- mkXY() zero_fit <- function(Xtr, Ytr, j, ...) { list( weights = list( @@ -213,13 +213,13 @@ test_that("zero-variance predictions yield NA metrics with a message", { }) test_that("the parallel fold path matches the serial one", { - d <- mk_xy(n = 40, seed = 7) + d <- mkXY(n = 40, seed = 7) set.seed(1) r1 <- suppressMessages(cv( d$X, d$Y, fold = 4, - fitFold = mock_fit_fold, + fitFold = mockFitFold, numThreads = 1 )) set.seed(1) @@ -227,14 +227,14 @@ test_that("the parallel fold path matches the serial one", { d$X, d$Y, fold = 4, - fitFold = mock_fit_fold, + fitFold = mockFitFold, numThreads = 2 )) expect_equal(r1$prediction, r2$prediction) }) -test_that("retainFits collects per-fold fits only when requested", { - d <- mk_xy() +test_that("fold fits are collected only when fitRetention asks", { + d <- mkXY() fit_with_model <- function(Xtr, Ytr, j, ...) { list( weights = list( @@ -253,35 +253,35 @@ test_that("retainFits collects per-fold fits only when requested", { d$Y, fold = 3, fitFold = fit_with_model, - retainFits = FALSE + fitRetention = "none" )) - expect_true(all(vapply(r_off$foldFits, length, integer(1)) == 0L)) + expect_true(all(map_int(r_off$foldFits, length) == 0L)) r_on <- suppressMessages(cv( d$X, d$Y, fold = 3, fitFold = fit_with_model, - retainFits = TRUE + fitRetention = "slim" )) expect_equal(r_on$foldFits[["fold_1"]][["mock"]]$fold, 1L) }) test_that("X without rownames inherits the sample names (from Y)", { - d <- mk_xy() + d <- mkXY() X2 <- d$X rownames(X2) <- NULL - r <- suppressMessages(cv(X2, d$Y, fold = 3, fitFold = mock_fit_fold)) + r <- suppressMessages(cv(X2, d$Y, fold = 3, fitFold = mockFitFold)) expect_equal(rownames(r$prediction$mock_predicted), rownames(d$Y)) }) test_that("maxNumVariants subsamples from variantsToKeep when it already exceeds the cap", { - d <- mk_xy(p = 6) + d <- mkXY(p = 6) expect_message( cv( d$X, d$Y, fold = 2, - fitFold = mock_fit_fold, + fitFold = mockFitFold, maxNumVariants = 2, variantsToKeep = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), verbose = 1 @@ -291,7 +291,7 @@ test_that("maxNumVariants subsamples from variantsToKeep when it already exceeds }) test_that("a NULL per-method weight matrix yields an all-NA prediction, not an error", { - d <- mk_xy() + d <- mkXY() fit_with_null <- function(Xtr, Ytr, j, ...) { list( weights = list( @@ -326,7 +326,7 @@ test_that("numThreads = -1 asks BiocParallel for the worker count", { # -1 means "all available"; anything else is capped at what is available. expect_equal( pecotmr:::.cvNumCores(-1), - BiocParallel::bpworkers(BiocParallel::MulticoreParam()) + BiocParallel::multicoreWorkers() ) expect_equal(pecotmr:::.cvNumCores(1), 1) }) @@ -345,3 +345,47 @@ test_that("a seed makes a CV call reproducible without leaking RNG state", { invisible(f()) expect_equal(runif(1), before) }) + +test_that(".cvPartitionKey answers NULL when there is no partition to key", { + expect_null(pecotmr:::.cvPartitionKey(NULL)) +}) + +test_that("sumstats inputs ignore residualization but refuse crossValidation", { + # The asymmetry follows from the defaults, not from taste. CV is off + # unless asked for (folds = 0), so a non-default value on a + # summary-statistics run is an explicit request for something the input + # cannot do -> error. Residualization is ON by default, so refusing a + # non-default would reject the DEFAULT bundle and force every sumstats + # caller to unset it -> ignore. + expect_equal(CrossValidationParam()$folds, 0) + # Residualization's flags are NULL = unset, which the accessors read as + # "on"; the default bundle therefore pins nothing and is safe to carry + # onto an input that cannot residualize. + expect_length(ResidualizationParam(), 0L) + # CV is refused on a summary-statistics input ... + expect_error( + pecotmr:::.cvRefuseOnSumstats( + CrossValidationParam(folds = 5), + "fineMappingPipeline", + "QtlSumStats" + ), + "cross-validation" + ) + # ... while the DEFAULT CV bundle passes, so one bundle still travels to + # either input kind. + expect_silent(pecotmr:::.cvRefuseOnSumstats( + CrossValidationParam(), + "fineMappingPipeline", + "QtlSumStats" + )) + # Residualization has no equivalent refusal: the sumstats workers do not + # take it at all, so it cannot reach an engine and cannot error. + for (fn in c( + ".fmPipelineQtlSumStats", + ".fmPipelineGwas", + ".twasPipelineQtlSumStats" + )) { + f <- get(fn, envir = asNamespace("pecotmr")) + expect_false("residualization" %in% names(formals(f)), label = fn) + } +}) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index d981f6e81..1ee7894ec 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -91,7 +91,7 @@ context("ctwasPipeline") ranges = IRanges::IRanges(start = 100L * idx, width = 1L) ) S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = vapply(idx, .ctp_snpId, character(1)), + SNP = map_chr(idx, .ctp_snpId), A1 = rep("A", 6), A2 = rep("G", 6), Z = rnorm(6), @@ -119,7 +119,7 @@ context("ctwasPipeline") # inside block 1 -- pass 7:11 for a gene that lives in block 2. .ctp_makeTwasWeights <- function(variantIdx = 1:5) { e <- twasWeightsRow( - variantIds = vapply(variantIdx, .ctp_snpId, character(1)), + variantIds = map_chr(variantIdx, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) TwasWeights( @@ -136,7 +136,7 @@ context("ctwasPipeline") # the topLoci posterior_mean carries the weight vector (what resolveWeights # reads). Mirrors .ctp_makeTwasWeights so the two sources are comparable. .ctp_makeFmrWeightSource <- function() { - vids <- vapply(1:5, .ctp_snpId, character(1)) + vids <- map_chr(1:5, .ctp_snpId) w <- c(0.1, 0.05, -0.2, 0.3, 0.0) tl <- data.frame( variant_id = vids, @@ -271,7 +271,7 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to trait = "t1", method = "susie", entry = list(twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0), standardized = TRUE )), @@ -325,11 +325,11 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { qcInfo = if (qc) list(step1 = "ok") else list() ) } - ss1 <- mkBlockGss("G1", vapply(1:3, .ctp_snpId, character(1))) - ss2 <- mkBlockGss("G2", vapply(4:6, .ctp_snpId, character(1))) + ss1 <- mkBlockGss("G1", map_chr(1:3, .ctp_snpId)) + ss2 <- mkBlockGss("G2", map_chr(4:6, .ctp_snpId)) # Cross-boundary weights: v2..v5 (4 variants spanning both blocks). crossEntry <- twasWeightsRow( - variantIds = vapply(2:5, .ctp_snpId, character(1)), + variantIds = map_chr(2:5, .ctp_snpId), weights = c(0.1, 0.2, 0.3, 0.4) ) tw <- TwasWeights( @@ -358,7 +358,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { entry <- inputs$weights[[1L]] wgt <- entry$wgt expect_equal(nrow(wgt), 2L) - expect_setequal(rownames(wgt), vapply(2:3, .ctp_snpId, character(1))) + expect_setequal(rownames(wgt), map_chr(2:3, .ctp_snpId)) expect_equal(nrow(entry$R_wgt), 2L) expect_equal(entry$n_wgt, 2L) expect_equal(entry$p0, 200L) @@ -392,16 +392,17 @@ test_that("ctwasPipeline: rejects non-GRanges twasZ", { ) }) -test_that("ctwasPipeline: rejects unknown groupPriorVarStructure value", { - skip_if_not_installed("ctwas") - inp <- .ctp_makeMultiBlockInputs() +test_that("CtwasPriorParam rejects an unknown varStructure", { + # The check moved to the constructor, so it fires where it is written + # rather than part-way into a run -- and needs no ctwas install. expect_error( - ctwasPipeline( - gwasSumStats = inp$gwasSumStats, - twasWeights = inp$twasWeights, - groupPriorVarStructure = "bogus" - ), - "groupPriorVarStructure" + CtwasPriorParam(varStructure = "bogus"), + "`varStructure` must be one of" + ) + expect_equal(CtwasPriorParam()$varStructure, "shared_type") + expect_equal( + CtwasPriorParam(varStructure = "independent")$varStructure, + "independent" ) }) @@ -457,14 +458,14 @@ test_that(".ctwasRequireMatchingLdSketches: disjoint panels error", { test_that(".ctwasBuildZSnp: produces a flat data.frame keyed by SNP/study", { ss <- .ctp_makeGwasSumstats(blockIds = "block1") - df <- pecotmr:::.ctwasBuildZSnp(ss, vapply(1:6, .ctp_snpId, character(1))) + df <- pecotmr:::.ctwasBuildZSnp(ss, map_chr(1:6, .ctp_snpId)) expect_s3_class(df, "data.frame") expect_equal(nrow(df), 6L) expect_setequal( colnames(df), c("id", "chrom", "pos", "A1", "A2", "z", "study") ) - expect_setequal(df$id, vapply(1:6, .ctp_snpId, character(1))) + expect_setequal(df$id, map_chr(1:6, .ctp_snpId)) expect_setequal(unique(df$study), "G1") }) @@ -474,7 +475,7 @@ test_that(".ctwasBuildZSnp: negates z for a panel-flipped variant", { # both sides, so nothing reported it missing and the gene just lost an # instrument. ss <- .ctp_makeGwasSumstats(blockIds = "block1") - gwasIds <- vapply(1:6, .ctp_snpId, character(1)) + gwasIds <- map_chr(1:6, .ctp_snpId) panelIds <- gwasIds panelIds[2] <- "chr1:200:A:G" # fixture spells this one G:A plain <- pecotmr:::.ctwasBuildZSnp(ss, gwasIds) @@ -490,7 +491,7 @@ test_that(".ctwasBuildZSnp: negates z for a panel-flipped variant", { test_that(".ctwasBuildZSnp: leaves variants absent from the panel untouched", { ss <- .ctp_makeGwasSumstats(blockIds = "block1") - gwasIds <- vapply(1:6, .ctp_snpId, character(1)) + gwasIds <- map_chr(1:6, .ctp_snpId) plain <- pecotmr:::.ctwasBuildZSnp(ss, gwasIds) none <- pecotmr:::.ctwasBuildZSnp(ss, "chr9:999:A:T") expect_equal(none$id, plain$id) @@ -800,7 +801,7 @@ test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method er context = rep("c1", length(methods)), trait = rep("t1", length(methods)), method = methods, - entry = lapply(methods, function(m) { + entry = map(methods, function(m) { twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = c(0.1, 0.2, 0.3) @@ -900,9 +901,9 @@ test_that(".ctwasPlaceByAnchor: block interval is half-open [start, stop)", { test_that(".ctwasIsPreBucketed / .ctwasCombineWeightSources: dispatch flat vs pre-bucketed", { tw <- .ctp_makeTwasWeights() grid <- list(block1 = 1, block2 = 2) - expect_true(pecotmr:::.ctwasIsPreBucketed(list(block1 = tw), grid)) # named list - expect_false(pecotmr:::.ctwasIsPreBucketed(tw, grid)) # flat S4 - expect_false(pecotmr:::.ctwasIsPreBucketed(list(tw), grid)) # unnamed + expect_true(pecotmr:::.ctwasIsPreBucketed(list(block1 = tw))) # named list + expect_false(pecotmr:::.ctwasIsPreBucketed(tw)) # flat S4 + expect_false(pecotmr:::.ctwasIsPreBucketed(list(tw))) # unnamed expect_s4_class(pecotmr:::.ctwasCombineWeightSources(tw), "TwasWeights") expect_s4_class( pecotmr:::.ctwasCombineWeightSources(list(tw)), @@ -913,7 +914,7 @@ test_that(".ctwasIsPreBucketed / .ctwasCombineWeightSources: dispatch flat vs pr test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks", { mkE <- function() { twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) } @@ -1019,7 +1020,10 @@ test_that(".ctwasRunToRows: single-context run -> one row, no jointContexts", { expect_equal(rows[[1L]]$gwasStudy, "D1") expect_true(is.na(rows[[1L]]$jointContexts)) expect_equal(nrow(getFinemap(rows[[1L]]$entry)), 2L) - expect_equal(getCtwasParam(rows[[1L]]$entry)$group_prior[["c1"]], 0.01) + expect_equal( + getCtwasGroupPriors(rows[[1L]]$entry)$group_prior[["c1"]], + 0.01 + ) }) test_that(".ctwasRunToRows: multi-context run -> per-context rows sharing jointContexts + param", { @@ -1037,16 +1041,16 @@ test_that(".ctwasRunToRows: multi-context run -> per-context rows sharing jointC rows <- pecotmr:::.ctwasRunToRows(run, gwasStudy = "D1", method = "susie") expect_length(rows, 2L) expect_setequal( - vapply(rows, function(r) r$context, ""), + map_chr(rows, function(r) r$context), c("brain", "liver") ) expect_true(all( - vapply(rows, function(r) r$jointContexts, "") == "brain,liver" + map_chr(rows, function(r) r$jointContexts) == "brain,liver" )) # Each per-context row keeps only its own genes but shares the joint param. expect_equal(nrow(getFinemap(rows[[1L]]$entry)), 2L) expect_named( - getCtwasParam(rows[[1L]]$entry)$group_prior, + getCtwasGroupPriors(rows[[1L]]$entry)$group_prior, c("brain", "liver", "SNP") ) }) @@ -1157,7 +1161,7 @@ test_that(".ctwasBuildWeights: scales non-standardized weights by sqrt(variance) # weights should be multiplied by sqrt(variance) before reaching the # final wgt matrix. panel$variance <- setNames(c(0.5, 1, 2, 4, 8, 16), panel$snpInfo$id) - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) tw <- TwasWeights( study = "Q1", @@ -1175,7 +1179,7 @@ test_that(".ctwasBuildWeights: scales non-standardized weights by sqrt(variance) test_that(".ctwasBuildWeights: standardized weights bypass variance scaling", { panel <- .ctp_makeLdPanel() panel$variance <- setNames(c(0.5, 1, 2, 4, 8, 16), panel$snpInfo$id) - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) tw <- TwasWeights( study = "Q1", @@ -1410,21 +1414,18 @@ test_that(".ctwasRenormalizeSusieWeights: skips Omega-weighted susieInf fits", { harmonizedW = origW[1:3] ) expect_type( - do.call( - pecotmr:::.ctwasRenormalizeSusieWeights, - c(list(base), args) - ), + exec(pecotmr:::.ctwasRenormalizeSusieWeights, !!!c(list(base), args)), "double" ) withTheta <- c(base, list(theta = rep(0.1, 4))) - expect_null(do.call( + expect_null(exec( pecotmr:::.ctwasRenormalizeSusieWeights, - c(list(withTheta), args) + !!!c(list(withTheta), args) )) withOmega <- c(base, list(omega_weights = rep(1, 4))) - expect_null(do.call( + expect_null(exec( pecotmr:::.ctwasRenormalizeSusieWeights, - c(list(withOmega), args) + !!!c(list(withOmega), args) )) }) @@ -1432,7 +1433,7 @@ test_that(".ctwasSnpInfoForGwasBlock: restricts panel snpInfo to block GWAS vari ss <- .ctp_makeGwasSumstats() panelInfo <- data.frame( chrom = 1L, - id = vapply(1:6, .ctp_snpId, character(1)), # whole panel + id = map_chr(1:6, .ctp_snpId), # whole panel pos = seq(100L, by = 100L, length.out = 6L), alt = "A", ref = "G", @@ -1450,7 +1451,7 @@ test_that(".ctwasSnpInfoForGwasBlock: restricts panel snpInfo to block GWAS vari test_that(".ctwasBuildWeights: keys per-tuple weights, adds gene metadata", { tw <- .ctp_makeTwasWeights() panel <- .ctp_makeLdPanel() - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) wl <- pecotmr:::.ctwasBuildWeights(tw, panel) expect_equal(length(wl), 1L) expect_equal(names(wl), "Q1|c1|t1|susie") @@ -1471,7 +1472,7 @@ test_that(".ctwasBuildWeights: keys per-tuple weights, adds gene metadata", { }) test_that(".ctwasBuildWeights: drops variants not present in the LD panel", { - ids3 <- vapply(1:3, .ctp_snpId, character(1)) + ids3 <- map_chr(1:3, .ctp_snpId) missing <- c("chr1:99900:G:A", "chr1:99910:G:A") # not in panel tw <- TwasWeights( study = "Q1", @@ -1496,8 +1497,8 @@ test_that(".ctwasBuildWeights: intersects with gwasSnpIds when supplied", { # ids 1, 2, 4 (a subset). Weight variants that live in the panel but # outside the block (id 3 here) must be dropped, otherwise ctwas's # compute_gene_z asserts the weight variant is missing from z_snp. - ids5 <- vapply(1:5, .ctp_snpId, character(1)) - blockIds <- vapply(c(1, 2, 4), .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) + blockIds <- map_chr(c(1, 2, 4), .ctp_snpId) tw <- TwasWeights( study = "Q1", context = "c1", @@ -1525,7 +1526,7 @@ test_that(".ctwasComputeFullPanelLd: extracts once + returns cached R + snpInfo .package = "pecotmr" ) out <- pecotmr:::.ctwasComputeFullPanelLd(.ctp_makeHandle(snp_n = 6L)) - ids6 <- vapply(1:6, .ctp_snpId, character(1)) + ids6 <- map_chr(1:6, .ctp_snpId) expect_named(out, c("R", "snpInfo", "variance")) expect_true(is.matrix(out$R)) expect_equal(dim(out$R), c(6L, 6L)) @@ -1664,7 +1665,7 @@ test_that("assembleCtwasInputs: forwards a twasZ argument as z_gene", { }) # =========================================================================== -# Step-wise dispatch: estCtwasParam → screenCtwasRegions → finemapCtwasRegions +# Step-wise dispatch: estCtwasGroupPriors → screenCtwasRegions → finemapCtwasRegions # =========================================================================== test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and accumulates state", { @@ -1747,7 +1748,7 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and expect_equal(as.character(out$gwasStudy), "G1") # The run's jointly-estimated param is carried on the row. expect_equal( - unname(getCtwasParam(out$entry[[1L]])$group_prior), + unname(getCtwasGroupPriors(out$entry[[1L]])$group_prior), c(0.1, 0.0001) ) # getFinemap aggregates the per-gene rows, tagged with run identity. @@ -1899,6 +1900,33 @@ test_that("mergeCtwasBoundaryRegions: LD path splices updated_* back + merge_res expect_true(!is.null(out$merge_res)) }) +test_that("mergeCtwasBoundaryRegions passes no unnamed argument to ctwas", { + skip_if_not_installed("ctwas") + # Regression: methodArgs was merged with c(), which appends a MethodOptions + # (a SimpleList) as ONE opaque element instead of splicing its entries. + # exec() then handed that object to ctwas positionally, binding it to + # `combine_PIPs` -- so even the default CtwasOptions() broke the real call. + captured <- NULL + local_mocked_bindings( + postprocess_region_merging = function(...) { + captured <<- list(...) + .ctp_mergeReturn() + }, + .package = "ctwas" + ) + mergeCtwasBoundaryRegions(.ctp_finemapResult(hasLd = TRUE)) + expect_false(any(names(captured) == "")) + expect_false("combine_PIPs" %in% names(captured)) + + # ...and a user option still arrives spliced, by its own name + mergeCtwasBoundaryRegions( + .ctp_finemapResult(hasLd = TRUE), + methodArgs = CtwasOptions(min_abs_corr = 0.1) + ) + expect_equal(captured$min_abs_corr, 0.1) + expect_false(any(names(captured) == "")) +}) + test_that("mergeCtwasBoundaryRegions: no-LD path uses postprocess_region_merging_noLD", { skip_if_not_installed("ctwas") usedNoLd <- FALSE @@ -1987,7 +2015,7 @@ test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into Ctwas out <- ctwasPipeline( inp$gwasSumStats, inp$twasWeights, - mergeBoundary = TRUE + boundaryMergeArgs = BoundaryMergeParam(enabled = TRUE) ) expect_true(merged) # merging ran expect_s4_class(out, "CtwasResult") @@ -2037,11 +2065,11 @@ test_that("asCtwasResult: errors when the weights mix methods", { expect_error(asCtwasResult(fmr), "mixes weight methods") }) -test_that("estCtwasParam: fallbackToPrefit recovers from accurate-EM NaN divergence", { +test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN divergence", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() # Mock est_param to throw the documented NaN error, and fit_EM to - # produce a stub prefit result. Verify estCtwasParam catches the + # produce a stub prefit result. Verify estCtwasGroupPriors catches the # NaN error AND that the returned param is the prefit estimate. local_mocked_bindings( assemble_region_data = function(...) { @@ -2076,9 +2104,9 @@ test_that("estCtwasParam: fallbackToPrefit recovers from accurate-EM NaN diverge ) # Without fallback: the NaN error propagates. expect_error( - estCtwasParam( + estCtwasGroupPriors( assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), - fallbackToPrefit = FALSE + ctwasPriorArgs = CtwasPriorParam(fallbackToPrefit = FALSE) ), "contains NAs" ) @@ -2086,15 +2114,15 @@ test_that("estCtwasParam: fallbackToPrefit recovers from accurate-EM NaN diverge # .ctwasFitPrefitEm thin-scales the SNP group_prior (mirroring ctwas's # est_param), so the mocked SNP prior 1e-4 emerges as 1e-4 * thin # (default thin = 0.1) → 1e-5. The group_prior_var is not thinned. - est <- estCtwasParam( + est <- estCtwasGroupPriors( assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), - fallbackToPrefit = TRUE + ctwasPriorArgs = CtwasPriorParam(fallbackToPrefit = TRUE) ) expect_equal(unname(est$param$group_prior), c(0.05, 1e-5)) expect_equal(unname(est$param$group_prior_var), c(4.0, 5.0)) }) -test_that("estCtwasParam fallback drops degenerate regions before fit_EM", { +test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", { # Regression for the ctwas >= 0.6.0 breakage: the prefit fallback used to hand # ALL regions to ctwas::fit_EM, so a degenerate region (empty gid/sid, whose # `sid` ctwas::extract_region_data now requires) crashed with @@ -2129,9 +2157,9 @@ test_that("estCtwasParam fallback drops degenerate regions before fit_EM", { extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) - est <- estCtwasParam( + est <- estCtwasGroupPriors( assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), - fallbackToPrefit = TRUE + ctwasPriorArgs = CtwasPriorParam(fallbackToPrefit = TRUE) ) # only the qualifying region reached fit_EM; the degenerate region was filtered expect_equal(seen, "good") @@ -2161,7 +2189,7 @@ test_that("(real ctwas) prefit fallback skips a degenerate region fit_EM would r niter = 3L, groupPriorVarStructure = "shared_all", thin = 1, - ncore = 1L + numThreads = 1L ) # the prefit EM ran on the valid region only and returns finite real group priors expect_true("SNP" %in% names(res$group_prior)) @@ -2170,7 +2198,7 @@ test_that("(real ctwas) prefit fallback skips a degenerate region fit_EM would r expect_setequal(res$p_single_effect$region_id, names(region_data)) }) -test_that("estCtwasParam / screenCtwasRegions / finemapCtwasRegions can be called independently", { +test_that("estCtwasGroupPriors / screenCtwasRegions / finemapCtwasRegions can be called independently", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() local_mocked_bindings( @@ -2206,7 +2234,7 @@ test_that("estCtwasParam / screenCtwasRegions / finemapCtwasRegions can be calle expect_true("region_info" %in% names(inputs)) expect_true("LD_loader_fun" %in% names(inputs)) # Step 2 - est <- estCtwasParam(inputs) + est <- estCtwasGroupPriors(inputs) expect_true("region_data" %in% names(est)) expect_true("param" %in% names(est)) # User can OVERRIDE the estimated priors before screen/finemap — this is @@ -2313,12 +2341,15 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", ctwasPipeline( gwasSumStats = gssTwoBlocks, twasWeights = tw, - niter = 5L, - niterPrefit = 2L, - # Toy panel: relax the production filters that gate out tiny inputs. - min_group_size = 1L, - min_p_single_effect = 0, - filter_L = FALSE + ctwasPriorArgs = CtwasPriorParam(niter = 5L, niterPrefit = 2L), + # Toy panel: relax the production filters that gate out tiny + # inputs. `filter_L = FALSE` used to sit here too; no ctwas + # function has ever had such a formal, so .ctwasInvoke dropped it + # silently. CtwasOptions() now rejects it. + methodArgs = CtwasOptions( + min_group_size = 1L, + min_p_single_effect = 0 + ) ) )) @@ -2672,7 +2703,7 @@ test_that("assembleCtwasInputs: rejects a non-FineMappingResultBase fineMappingR test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolved method", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() - ids5 <- vapply(1:5, .ctp_snpId, character(1)) + ids5 <- map_chr(1:5, .ctp_snpId) mkTw <- function(m) { TwasWeights( study = "Q1", @@ -2782,7 +2813,7 @@ test_that("TwasWeightsRow: rejects mismatched variantIds/weights lengths", { # rather than producing a gene that gets silently dropped downstream. expect_error( twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.2, 0.3) ), "length\\(weights\\) is 3 but 5 variants were supplied" @@ -2816,7 +2847,7 @@ test_that(".ctwasBuildWeights: skips a gene when no variant survives gwasSnpIds test_that(".ctwasBuildWeights: SuSiE renormalization fires when variants are dropped", { panel <- .ctp_makeLdPanel() - ids4 <- vapply(1:4, .ctp_snpId, character(1)) + ids4 <- map_chr(1:4, .ctp_snpId) bogus <- "chr1:99900:G:A" # absent from the 6-SNP panel # Fit dims line up with the 5 original variants. Two single effects, # each concentrated on one of the first two variants; lbfToAlpha @@ -3096,7 +3127,7 @@ test_that(".ctwasRunToRows: empty weights -> no rows; a context mixing studies e test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped", { mkE <- function() { twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) } @@ -3127,7 +3158,7 @@ test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped test_that(".ctwasBucketWeights: errors when no gene lands in any block", { mkE <- function() { twasWeightsRow( - variantIds = vapply(1:5, .ctp_snpId, character(1)), + variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) } @@ -3221,11 +3252,9 @@ test_that("bundled cTWAS payloads carry a resolvable LD token", { )) { tokens <- as.character(payload$LD_map$LD_file) expect_true(all(startsWith(tokens, "pecotmr://extdata/"))) - resolved <- vapply( + resolved <- map_chr( tokens, - pecotmr:::.resolveCtwasLdToken, - character(1), - USE.NAMES = FALSE + pecotmr:::.resolveCtwasLdToken ) expect_true(all(file.exists(resolved))) expect_equal( @@ -3269,7 +3298,10 @@ test_that("finemapCtwasRegions runs from the bundled est payload", { data(ctwasEstExample) # The step that the stale absolute paths broke. screened <- suppressMessages( - screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) + screenCtwasRegions( + ctwasEstExample, + methodArgs = CtwasOptions(min_nonSNP_PIP = 0) + ) ) out <- suppressMessages(finemapCtwasRegions(screened)) expect_gt(nrow(out$finemap_res), 0L) @@ -3586,11 +3618,11 @@ test_that(".ctwasBlockGrFromIds places unparseable ids on chrUn", { }) test_that(".ctwasCoordField falls back for an unplaced feature", { - expect_equal(pecotmr:::.ctwasCoordField(NULL, "chrom", TRUE), "chrUnplaced") - expect_equal(pecotmr:::.ctwasCoordField2(NULL, "start", TRUE), 1L) + expect_equal(pecotmr:::.ctwasCoordField(NULL, "chrom"), "chrUnplaced") + expect_equal(pecotmr:::.ctwasCoordField2(NULL, "start"), 1L) co <- list(chrom = "chr7", start = 42L) - expect_equal(pecotmr:::.ctwasCoordField(co, "chrom", TRUE), "chr7") - expect_equal(pecotmr:::.ctwasCoordField2(co, "start", TRUE), 42L) + expect_equal(pecotmr:::.ctwasCoordField(co, "chrom"), "chr7") + expect_equal(pecotmr:::.ctwasCoordField2(co, "start"), 42L) }) test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { @@ -3693,7 +3725,11 @@ test_that(".ctwasRenormalizeSusieWeights skips fits it cannot slice", { harmonizedW <- c(0.5, 0.5) run <- function(fits) { pecotmr:::.ctwasRenormalizeSusieWeights( - fits, origVids, origW, keptIdx, harmonizedW + fits, + origVids, + origW, + keptIdx, + harmonizedW ) } # Any missing susie field: nothing to renormalize from. @@ -3746,3 +3782,24 @@ test_that(".ctwasResolveAndValidateWeights rejects a blank region name", { "must resolve to a named list keyed by region_id" ) }) + +test_that("asCtwasResult: keepSnps must be a flag", { + expect_error(asCtwasResult(NULL, keepSnps = NA), "keepSnps.*May not be NA") + expect_error( + asCtwasResult(NULL, keepSnps = 1L), + "keepSnps.*logical flag" + ) +}) + +test_that("the ctwas concat helpers answer an empty vector of their own type", { + expect_identical(pecotmr:::.ctwasConcat(list()), list()) + expect_identical(pecotmr:::.ctwasConcatInt(list()), integer(0)) + expect_identical(pecotmr:::.ctwasConcatChr(list()), character(0)) +}) + +test_that("ctwas entry points refuse a bare list for methodArgs", { + expect_error( + screenCtwasRegions(list(), methodArgs = list(min_nonSNP_PIP = 0)), + "must be built with CtwasOptions\\(\\)" + ) +}) diff --git a/tests/testthat/test_ctwasWrapper.R b/tests/testthat/test_ctwasWrapper.R new file mode 100644 index 000000000..a0f082276 --- /dev/null +++ b/tests/testthat/test_ctwasWrapper.R @@ -0,0 +1,95 @@ +context("ctwasWrapper") + +# ============================================================================= +# Tests for the ctwas engine interface (R/ctwasWrapper.R): CtwasOptions and +# the screen step. The pipeline orchestration tests, and the ctwas:: helpers +# that are exercised only through a full run, stay in test_ctwasPipeline.R. +# ============================================================================= + +test_that("CtwasOptions now reaches compute_gene_z too", { + skip_if_not_installed("ctwas") + # compute_gene_z was the one ctwas step methodArgs could not configure: + # it was called directly rather than through .ctwasInvoke, so its + # `logfile` was unreachable and the name was not in the accepted union. + expect_true("ctwas::compute_gene_z" %in% pecotmr:::.ctwasCallees()) + expect_s4_class(CtwasOptions(logfile = "gene-z.log"), "MethodOptions") + seen <- NULL + local_mocked_bindings( + # The mock must carry the REAL formals: .ctwasInvoke filters the + # bundle to the callee's explicit formals, so a `function(...)` mock + # would drop `logfile` and hide the thing being tested. + compute_gene_z = function(z_snp, weights, ncore = 1L, logfile = NULL) { + seen <<- list(ncore = ncore, logfile = logfile) + data.frame(id = "t1", z = 1.0) + }, + .package = "ctwas" + ) + inputs <- list( + z_snp = data.frame(id = "s1", z = 1), + weights = list(t1 = list(wgt = 1)), + z_gene = NULL + ) + pecotmr:::.ctwasEnsureZGene( + inputs, + numThreads = 1L, + extra = CtwasOptions(logfile = "gene-z.log") + ) + expect_equal(seen$logfile, "gene-z.log") + expect_equal(seen$ncore, 1L) + # A supplied z_gene still short-circuits without calling the engine. + seen <- NULL + inputs$z_gene <- data.frame(id = "t1", z = 2.0) + pecotmr:::.ctwasEnsureZGene(inputs, numThreads = 1L) + expect_null(seen) +}) + +test_that("screenCtwasRegions no longer advertises an L it cannot use", { + skip_if_not_installed("ctwas") + # ctwas::screen_regions has no `L` formal -- screening is always SER -- + # so the parameter could never be honoured. It was documented as + # "Unused. Retained for call-site compatibility"; a knob that cannot + # work is better removed than explained. + expect_false("L" %in% names(formals(screenCtwasRegions))) + expect_false("L" %in% names(formals(ctwas::screen_regions))) + # finemapCtwasRegions is where L genuinely applies, and still takes it. + expect_true("L" %in% names(formals(finemapCtwasRegions))) +}) + +test_that("CtwasOptions validates against what the ctwas steps accept together", { + a <- CtwasOptions(min_group_size = 2L, min_gene = 1L) + expect_s4_class(a, "MethodOptions") + expect_equal(a$min_group_size, 2L) + # A name valid for only ONE of the steps is still accepted here; the + # per-step filtering in .ctwasInvoke routes it to the step that takes it. + expect_true(is_in( + "min_nonSNP_PIP", + names(CtwasOptions(min_nonSNP_PIP = 0)) + )) + expect_true(is_in("min_gene", names(CtwasOptions(min_gene = 1L)))) +}) + +test_that("CtwasOptions rejects a name no ctwas step accepts", { + # `filter_L` is the real case that prompted this: it is not a formal of + # any ctwas function, so it was silently dropped for years. + expect_error( + CtwasOptions(filter_L = FALSE), + "unknown argument\\(s\\) filter_L" + ) + expect_error(CtwasOptions(min_genee = 1L), "unknown argument") +}) + +test_that("CtwasOptions does not accept pecotmr's own pipeline parameters", { + # These ARE real ctwas formals, so the union check would wave them + # through -- but .ctwasInvoke drops any name the pipeline already + # supplies, so a value set here was silently discarded. The error names + # the setting that actually takes effect. + expect_error(CtwasOptions(thin = 0.1), "CtwasPriorParam\\(thin =\\)") + expect_error(CtwasOptions(niter = 10L), "CtwasPriorParam\\(niter =\\)") + expect_error( + CtwasOptions(group_prior_var_structure = "shared_all"), + "CtwasPriorParam\\(varStructure =\\)" + ) + expect_error(CtwasOptions(L = 5L), "the pipeline's own") + expect_error(CtwasOptions(ncore = 4L), "the pipeline's own") + expect_error(CtwasOptions(maxSNP = 10L), "BoundaryMergeParam\\(maxSnp =\\)") +}) diff --git a/tests/testthat/test_enloc.R b/tests/testthat/test_enloc.R new file mode 100644 index 000000000..fed9e4151 --- /dev/null +++ b/tests/testthat/test_enloc.R @@ -0,0 +1,121 @@ +test_that("the hypothesis probabilities are a partition", { + set.seed(1) + p <- 40L + r <- enlocClusterProbabilities( + gwasLog10Bf = rnorm(p, 1, 1), + qtlPip = { + v <- runif(p) + v / sum(v) * 0.6 + }, + pi1e = 0.02, + pi1ne = 0.001 + ) + expect_equal(r$ppH0 + r$ppH1 + r$ppH2 + r$ppH3 + r$ppH4, 1) + expect_true(all( + c(r$ppH0, r$ppH1, r$ppH2, r$ppH3, r$ppH4) >= 0 + )) +}) + +test_that("RCP and LCP are the coloc hypotheses under other names", { + set.seed(2) + p <- 25L + r <- enlocClusterProbabilities( + gwasLog10Bf = rnorm(p), + qtlPip = { + v <- runif(p) + v / sum(v) * 0.4 + }, + pi1e = 0.05, + pi1ne = 0.002 + ) + # fastenloc sums the grid's diagonal for RCP and the whole grid for LCP; + # those are exactly "one shared causal variant" and "both traits causal". + expect_equal(r$rcp, r$ppH4) + expect_equal(r$lcp, r$ppH3 + r$ppH4) + expect_equal(sum(r$scp), r$rcp) +}) + +test_that("enrichment raises the shared-variant probability", { + set.seed(3) + p <- 30L + bf <- rnorm(p, 1, 1) + pip <- runif(p) + pip <- pip / sum(pip) * 0.5 + none <- enlocClusterProbabilities(bf, pip, pi1e = 0.001, pi1ne = 0.001) + some <- enlocClusterProbabilities(bf, pip, pi1e = 0.05, pi1ne = 0.001) + # a1 = 0 means pi1e == pi1ne: being an eQTL says nothing about GWAS + # causality, which is the no-enrichment case. + expect_gt(some$rcp, none$rcp) +}) + +test_that("the priors match fastenloc's set_enrich_params", { + a0 <- -6 + a1 <- 3 + pQtl <- 0.01 + pr <- pecotmr:::.enlocPriorsFromEnrichment(a0, a1, pQtl) + expect_equal(pr$pi1e, stats::plogis(a0 + a1)) + expect_equal(pr$pi1ne, stats::plogis(a0)) + # p1 = (1 - P_eqtl) * exp(a0)/(1 + exp(a0)) + expect_equal(pr$p1, (1 - pQtl) * exp(a0) / (1 + exp(a0))) + # p2 = P_eqtl / (1 + exp(a0 + a1)) + expect_equal(pr$p2, pQtl / (1 + exp(a0 + a1))) + # p12 = P_eqtl * exp(a0 + a1)/(1 + exp(a0 + a1)) + expect_equal(pr$p12, pQtl * exp(a0 + a1) / (1 + exp(a0 + a1))) +}) + +test_that("the enrichment parameters round-trip through the priors", { + a0 <- -6 + a1 <- 3 + pr <- pecotmr:::.enlocPriorsFromEnrichment(a0, a1, pQtl = 0.01) + back <- pecotmr:::.enlocEnrichmentFromPriors(pr$p1, pr$p2, pr$p12) + expect_equal(back$a0, a0) + expect_equal(back$a1, a1) +}) + +test_that("a1 is capped before the priors are formed", { + uncapped <- pecotmr:::.enlocPriorsFromEnrichment(-6, 5, 0.01) + capped <- pecotmr:::.enlocPriorsFromEnrichment(-6, 5, 0.01, capA1 = 2) + expect_equal(capped$pi1e, stats::plogis(-6 + 2)) + expect_lt(capped$p12, uncapped$p12) +}) + +test_that("the SNP-level floor is applied only when asked", { + bf <- c(0, 0, 0) + pip <- c(1e-12, 1e-12, 1e-12) + without <- enlocClusterProbabilities( + bf, + pip, + pi1e = 0.02, + pi1ne = 0.001, + p12 = 1e-5 + ) + with <- enlocClusterProbabilities( + bf, + pip, + pi1e = 0.02, + pi1ne = 0.001, + p12 = 1e-5, + applyFloor = TRUE + ) + # fastenloc floors each SNP-level term at p12 when the full variant set + # is present, so a vanishing term cannot read as certainty against + # colocalisation. + expect_gt(with$rcp, without$rcp) +}) + +test_that("recovered GWAS Bayes factors follow the DAP-1 contrast", { + pip <- c(0.6, 0.2, 0.0) + bf <- pecotmr:::.enlocGwasLog10Bf(pip, pGwas = 1e-4, clusterPip = 0.8) + # A zero PIP is floored rather than giving -Inf. + expect_true(all(is.finite(bf))) + # Monotone in the PIP, since the other terms are shared. + expect_true(bf[[1]] > bf[[2]]) + expect_true(bf[[2]] > bf[[3]]) +}) + +test_that("mismatched input lengths are rejected", { + expect_error( + enlocClusterProbabilities(c(1, 2), c(0.1), pi1e = 0.02, pi1ne = 0.001), + "same variants" + ) +}) diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index fbaf534ef..a8f9c1ddb 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -17,7 +17,7 @@ context("fineMappingPipeline") path = "/tmp/fmsketch.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -105,7 +105,7 @@ context("fineMappingPipeline") ) { gh <- .fmp_makeHandle() phen <- setNames( - lapply(contexts, function(.) .fmp_makeSe(traits = traits)), + map(contexts, function(.) .fmp_makeSe(traits = traits)), contexts ) QtlDataset( @@ -162,7 +162,7 @@ context("fineMappingPipeline") # only by the token so post-process knows what to wrap. The `userArgs` # parameter (per-method kwargs merged in by .fmMergeUserArgs) is accepted # but ignored — the mocks don't simulate downstream susie behaviour. -.fmp_mockFitIndiv <- function() { +.fmp_mockFitIndiv <- function(capture = NULL) { function( X, y, @@ -171,6 +171,9 @@ context("fineMappingPipeline") coverage = 0.95, userArgs = NULL ) { + if (!is.null(capture)) { + capture$userArgs <- userArgs + } list(token = token, X_cols = ncol(X)) } } @@ -186,7 +189,8 @@ context("fineMappingPipeline") userArgs = NULL, rFinite = NULL, rMismatch = "none", - rssControl = NULL + rssControl = NULL, + ... ) { list(token = token, n_variants = length(z)) } @@ -207,12 +211,14 @@ context("fineMappingPipeline") userArgs = NULL, rFinite = NULL, rMismatch = "none", - rssControl = NULL + rssControl = NULL, + ... ) { if (!is.null(capture)) { capture$rFinite <- rFinite capture$rMismatch <- rMismatch capture$rssControl <- rssControl + capture$userArgs <- userArgs } fit <- list(token = token, n_variants = length(z), multiTag = "multi") fit$R_finite_diagnostics <- list( @@ -275,16 +281,25 @@ context("fineMappingPipeline") # =========================================================================== test_that(".fmNormalizeMethods: rejects NULL / empty / non-character/list", { - expect_error(pecotmr:::.fmNormalizeMethods(NULL), "non-empty character") expect_error( - pecotmr:::.fmNormalizeMethods(character(0)), + pecotmr:::.fmNormalizeMethods(NULL, inputKind = "QtlDataset"), "non-empty character" ) - expect_error(pecotmr:::.fmNormalizeMethods(42L), "character vector or") + expect_error( + pecotmr:::.fmNormalizeMethods(character(0), inputKind = "QtlDataset"), + "non-empty character" + ) + expect_error( + pecotmr:::.fmNormalizeMethods(42L, inputKind = "QtlDataset"), + "must be a character vector, a named list" + ) }) test_that(".fmNormalizeMethods: char-vector form deduplicates + seeds susie L defaults", { - res <- pecotmr:::.fmNormalizeMethods(c("susie", "susie", "susieInf")) + res <- pecotmr:::.fmNormalizeMethods( + c("susie", "susie", "susieInf"), + inputKind = "QtlDataset" + ) expect_equal(res$tokens, c("susie", "susieInf")) expect_equal(names(res$methodArgs), c("susie", "susieInf")) # SuSiE-family tokens get the pipeline L default (pecotmr owns these, not the @@ -294,14 +309,23 @@ test_that(".fmNormalizeMethods: char-vector form deduplicates + seeds susie L de expect_equal(res$methodArgs$susieInf$L, 10L) # Non-susie-family tokens are left untouched. expect_length( - pecotmr:::.fmNormalizeMethods("mvsusie")$methodArgs$mvsusie, + pecotmr:::.fmNormalizeMethods( + "mvsusie", + inputKind = "QtlDataset" + )$methodArgs$mvsusie, 0L ) }) -test_that(".fmNormalizeMethods: named-list keeps kwargs + fills missing susie L", { +test_that(".fmNormalizeMethods: a methods record keeps kwargs + fills susie L", { res <- pecotmr:::.fmNormalizeMethods( - list(susie = list(L = 1, refine = FALSE), susieInf = list()) + FineMappingMethodsParam( + qtlDatasetMethods = list( + susie = list(L = 1, refine = FALSE), + susieInf = list() + ) + ), + inputKind = "QtlDataset" ) expect_equal(res$tokens, c("susie", "susieInf")) expect_equal(res$methodArgs$susie$L, 1) # explicit kwarg wins @@ -311,22 +335,54 @@ test_that(".fmNormalizeMethods: named-list keeps kwargs + fills missing susie L" }) test_that(".fmNormalizeMethods: L / Lgreedy args override the susie defaults", { - res <- pecotmr:::.fmNormalizeMethods(c("susie"), L = 30L, Lgreedy = 7L) + res <- pecotmr:::.fmNormalizeMethods( + c("susie"), + L = 30L, + Lgreedy = 7L, + inputKind = "QtlDataset" + ) expect_equal(res$methodArgs$susie$L, 30L) expect_equal(res$methodArgs$susie$L_greedy, 7L) }) -test_that(".fmNormalizeMethods: list without names errors", { +test_that(".fmNormalizeMethods: a bare named list is routed by input class", { + # It used to be refused, on the grounds that options must be checked + # against the engine receiving them. They still are -- but this call + # knows its input class, so the overrides go into that path's slot and + # are checked there. The constructor, which knows no path, still + # refuses a plain list under `methods`. + ind <- pecotmr:::.fmNormalizeMethods( + list(susie = list(L = 1)), + inputKind = "QtlDataset" + ) + expect_equal(ind$tokens, "susie") + expect_equal(ind$methodArgs$susie$L, 1) + # And an argument belonging to the other path is caught, which neither + # the old refusal nor the union-validated constructor managed. expect_error( - pecotmr:::.fmNormalizeMethods(list(list(L = 1), list())), - "must be named" + pecotmr:::.fmNormalizeMethods( + list(susie = list(z = 1)), + inputKind = "QtlDataset" + ), + "unknown argument" + ) + expect_equal( + pecotmr:::.fmNormalizeMethods( + list(susie = list(z = 1)), + inputKind = "QtlSumStats" + )$methodArgs$susie$z, + 1 ) }) -test_that(".fmNormalizeMethods: list with non-list child errors", { +test_that("FineMappingMethodsParam rejects unnamed and non-list entries", { + expect_error( + FineMappingMethodsParam(qtlDatasetMethods = list(list(L = 1), list())), + "must be named for its method" + ) expect_error( - pecotmr:::.fmNormalizeMethods(list(susie = 42, susieInf = list())), - "list of named kwargs" + FineMappingMethodsParam(qtlDatasetMethods = list(susie = 42)), + "must be that method's Options record or a list of its arguments" ) }) @@ -599,11 +655,11 @@ test_that(".rbindFineMappingResult: rejects non-FineMappingResultBase input", { ) expect_error( pecotmr:::.rbindFineMappingResult(fmr, "not_an_fmr"), - "expects two FineMappingResultBase inputs" + "Must inherit from class 'FineMappingResultBase'" ) expect_error( pecotmr:::.rbindFineMappingResult("not_an_fmr", fmr), - "expects two FineMappingResultBase inputs" + "Must inherit from class 'FineMappingResultBase'" ) }) @@ -900,24 +956,6 @@ test_that("fineMappingPipeline(QtlDataset): seed argument is accepted and runs", expect_equal(nrow(res), 1L) }) -test_that(".fmSerScreen: disables on 0, skips no-signal, keeps signal + adaptive", { - skip_if_not_installed("susieR") - set.seed(1) - n <- 150L - p <- 25L - X <- matrix(rnorm(n * p), n, p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) - yNull <- rnorm(n) # no association - ySig <- X[, 1] * 2 + rnorm(n, sd = 0.3) # strong single effect at v1 - fn <- function(...) suppressMessages(pecotmr:::.fmSerScreen(...)) - expect_true(fn(X, yNull, 0)) # cutoff 0 disables -> always keep - expect_false(fn(X, yNull, 0.5)) # no PIP that high -> skip - expect_true(fn(X, ySig, 0.5)) # strong signal clears 0.5 -> keep - expect_true(fn(X, ySig, -1)) # adaptive 3/p: signal keeps - expect_false(fn(X, yNull, -1)) # adaptive 3/p: null skips - expect_true(fn(X, yNull, NA)) # malformed cutoff -> advisory keep -}) - test_that(".fmTopPcScores: clean matrix -> samples x min(nPCs, traits) topPC scores", { set.seed(7) n <- 30L @@ -954,7 +992,10 @@ test_that(".fmTopPcScores: clean matrix -> samples x min(nPCs, traits) topPC sco expect_false(any(c("s1", "s2") %in% rownames(scn))) }) -test_that("fineMappingPipeline(QtlDataset, usePCA): top-PC susie rows keyed topPC{i}", { +test_that("fineMappingPipeline( + QtlDataset, + usePCA +): top-PC susie rows keyed topPC{i}", { qd <- .fmp_makeQtlDataset( contexts = "brain", traits = c("ENSG_A", "ENSG_B", "ENSG_C") @@ -984,54 +1025,6 @@ test_that("fineMappingPipeline(QtlDataset, usePCA): top-PC susie rows keyed topP expect_setequal(as.character(res$method)[pcRows], "susie") }) -test_that(".buildMvsusieReweightedPrior: canonical fallback when no usable fit", { - bp <- function(...) pecotmr:::.buildMvsusieReweightedPrior(...) - # No fit at all -> canonical prior, residualVariance NULL. - p1 <- bp(NULL, c("c1", "c2")) - expect_false(is.null(p1$priorVariance)) - expect_null(p1$residualVariance) - # Fit with no data-driven matrices -> canonical prior, but V carried through. - p2 <- bp(list(dataDrivenPriorMatrices = NULL, V = diag(2)), c("c1", "c2")) - expect_equal(p2$residualVariance, diag(2)) -}) - -test_that(".buildMvsusieReweightedPrior: reweights matrices by rescaleCovW0(w0)", { - ddpm <- list( - U = list(compA = diag(2), compB = diag(2) * 2), - w = c(compA = 0.5, compB = 0.5) - ) - fit <- list( - dataDrivenPriorMatrices = ddpm, - w0 = c(compA_grid1 = 0.3, compB_grid1 = 0.7), - V = diag(2) * 3 - ) - captured <- NULL - # rescaleCovW0 collapses expanded w0 onto the original matrix names; mock it - # so the test asserts the wiring, not rescaleCovW0's internals. - local_mocked_bindings( - rescaleCovW0 = function(w0) c(compA = 0.4, compB = 0.6), - .package = "pecotmr" - ) - local_mocked_bindings( - create_mixture_prior = function(...) { - captured <<- list(...) - "PRIOR" - }, - .package = "mvsusieR" - ) - res <- pecotmr:::.buildMvsusieReweightedPrior( - fit, - c("c1", "c2"), - weightsTol = 1e-8 - ) - expect_identical(res$priorVariance, "PRIOR") - expect_equal(res$residualVariance, diag(2) * 3) - expect_equal(captured$mixture_prior$weights, c(compA = 0.4, compB = 0.6)) - expect_equal(names(captured$mixture_prior$matrices), c("compA", "compB")) - expect_equal(captured$include_indices, c("c1", "c2")) - expect_equal(captured$weights_tol, 1e-8) -}) - test_that(".fmLookupMrmashFit: finds the mr.mash fit by (study, trait)", { mkEntry <- function(fits) { twasWeightsRow( @@ -1095,34 +1088,6 @@ test_that(".fmLookupMrmashCv: finds the per-fold CV payload by (study, trait)", expect_null(lk(tw2, "S", "G")) }) -test_that(".buildMvsusieReweightedPrior: overrideU swaps matrices, keeps fit w0/V", { - fit <- list( - dataDrivenPriorMatrices = list(U = list(K = diag(2)), w = c(K = 1)), - w0 = c(K_grid1 = 1), - V = diag(2) * 7 - ) - override <- list(U = list(K = diag(2) * 5)) - captured <- NULL - local_mocked_bindings( - rescaleCovW0 = function(w0) c(K = 1), - .package = "pecotmr" - ) - local_mocked_bindings( - create_mixture_prior = function(...) { - captured <<- list(...) - "PRIOR" - }, - .package = "mvsusieR" - ) - res <- pecotmr:::.buildMvsusieReweightedPrior( - fit, - c("c1", "c2"), - overrideU = override - ) - expect_equal(captured$mixture_prior$matrices$K, diag(2) * 5) # the override U - expect_equal(res$residualVariance, diag(2) * 7) # the fit's own V -}) - test_that(".fmBuildMvsusiePriorCv: mode B reweights each fold's own fit", { sp <- data.frame( Sample = paste0("s", 1:6), @@ -1211,65 +1176,17 @@ test_that(".fmBuildMvsusiePriorCv: mode C reuses full-fit w0/V with per-fold U", expect_equal(captured[[2]]$mixture_prior$matrices$Z, diag(2) * 3) # fold 2's U }) -test_that(".fmSerScreen supports absZ / bf / logBf metrics and the legacy pip scalar", { - skip_if_not_installed("susieR") - set.seed(11) - n <- 200L - p <- 6L - X <- matrix(stats::rnorm(n * p), n, p) - yStrong <- X[, 2] * 0.6 + stats::rnorm(n) # column 2 strongly associated - yNull <- stats::rnorm(n) # no association - - # absZ: max marginal |z| (no susie fit). - expect_true(pecotmr:::.fmSerScreen( - X, - yStrong, - list(metric = "absZ", cutoff = 3) - )) - expect_false(pecotmr:::.fmSerScreen( - X, - yNull, - list(metric = "absZ", cutoff = 3) - )) - # bf / logBf from the L = 1 susie lbf_variable. - expect_true(pecotmr:::.fmSerScreen( - X, - yStrong, - list(metric = "logBf", cutoff = 2) - )) - expect_false(pecotmr:::.fmSerScreen( - X, - yNull, - list(metric = "logBf", cutoff = 5) - )) - expect_true(pecotmr:::.fmSerScreen( - X, - yStrong, - list(metric = "bf", cutoff = 10) - )) - # Legacy scalar spec still screens on PIP; 0 disables (always keep). - expect_true(pecotmr:::.fmSerScreen(X, yStrong, 0.5)) - expect_true(pecotmr:::.fmSerScreen(X, yNull, 0)) - # Too few samples -> advisory fallback (keep by default). - expect_true(pecotmr:::.fmSerScreen( - X[1, , drop = FALSE], - yStrong[1], - list(metric = "absZ", cutoff = 3) - )) -}) - -test_that("fineMappingPipeline(QtlDataset): enabling two screen metrics errors", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - # The resolver runs before any fitting, so this fails fast on the public call. +test_that("enabling two screen metrics errors at the constructor", { + # It used to take a pipeline call to find this out; now the bundle + # refuses to be built, so the mistake is caught where it is written. expect_error( - fineMappingPipeline( - qd, - methods = "susie", - cisWindow = 1000L, - pipCutoffToSkip = 0.5, - absZCutoffToSkip = 5 - ), - "one signal screen" + SignalScreenParam(pip = 0.5, absZ = 5), + "only one screening metric" + ) + # 0 is the long-standing "off" spelling, so this is one screen, not two. + expect_equal( + pecotmr:::.screenResolve(SignalScreenParam(pip = 0, absZ = 5)), + list(metric = "absZ", cutoff = 5) ) }) @@ -1296,7 +1213,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips no-signal univ methods = "susie", cisWindow = 1000L, addSusieInf = FALSE, - pipCutoffToSkip = -1 + signalScreenArgs = SignalScreenParam(pip = -1) ) ) # ENSG_A screened out, ENSG_B kept -> a single row. @@ -1304,7 +1221,10 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips no-signal univ expect_setequal(getTraits(res), "ENSG_B") }) -test_that("fineMappingPipeline(QtlDataset, cvFolds>1): attaches cvResult end to end", { +test_that("fineMappingPipeline( + QtlDataset, + cvFolds>1 +): attaches cvResult end to end", { skip_if_not_installed("susieR") qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") # Real susie fits drive CV; the genotype extraction and the full-data @@ -1322,7 +1242,7 @@ test_that("fineMappingPipeline(QtlDataset, cvFolds>1): attaches cvResult end to methods = "susie", cisWindow = 1000L, addSusieInf = FALSE, - cvFolds = 3, + crossValidationArgs = CrossValidationParam(folds = 3), verbose = 0 ) ) @@ -1342,7 +1262,10 @@ test_that("fineMappingPipeline(QtlDataset, cvFolds>1): attaches cvResult end to expect_false(anyNA(cv$prediction[["susie_predicted"]])) }) -test_that("fineMappingPipeline(QtlDataset, cvFolds=0): leaves cvResult NULL", { +test_that("fineMappingPipeline( + QtlDataset, + crossValidation = CrossValidationParam(folds = 0) +): leaves cvResult NULL", { qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), @@ -1391,7 +1314,7 @@ test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake metho p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) y <- X[, 2] * 1.5 + rnorm(n, sd = 0.5) @@ -1405,7 +1328,10 @@ test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake metho coverage = 0.95, verbose = 0 ) - expect_named(cv, c("samplePartition", "prediction", "performance")) + expect_named( + cv, + c("samplePartition", "prediction", "performance", "foldFits") + ) expect_setequal(colnames(cv$samplePartition), c("Sample", "Fold")) # Keyed by the TWAS snake method name (adapter methodKey base). expect_true("susie_predicted" %in% names(cv$prediction)) @@ -1434,7 +1360,7 @@ test_that(".fmWeightsCv reuses a supplied samplePartition verbatim", { p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) y <- X[, 1] + rnorm(n, sd = 0.5) @@ -1634,7 +1560,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip drops null contexts qd, methods = "mvsusie", cisWindow = 1000L, - pipCutoffToSkip = -1 + signalScreenArgs = SignalScreenParam(pip = -1) ) ) # liver screened out -> the joint fit runs on brain + heart only. @@ -1664,7 +1590,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < methods = c("susie", "mvsusie"), cisWindow = 1000L, addSusieInf = FALSE, - pipCutoffToSkip = -1 + signalScreenArgs = SignalScreenParam(pip = -1) ) ) # mvsusie skipped (only 1 context survives); susie still produced per-context. @@ -1755,14 +1681,14 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait auto-detection USES the qd, methods = "mvsusie", cisWindow = 1000L, - twasWeights = tw + mrmashPrior = tw ) ) expect_equal(nrow(res), 2L) expect_true(sawMixturePrior) # data-driven prior built, not canonical }) -test_that("fineMappingPipeline(QtlDataset): multi-trait without twasWeights keeps the canonical prior", { +test_that("fineMappingPipeline(QtlDataset): multi-trait without mrmashPrior keeps the canonical prior", { qd <- .fmp_makeQtlDataset( contexts = "brain", traits = c("ENSG_A", "ENSG_B") @@ -2067,6 +1993,110 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across expect_null(getLdSketch(res)) }) +test_that("fineMappingPipeline(MultiStudyQtlDataset): per-study options are not dropped", { + # fitRetention was declared on the multi-study method and passed nowhere; + # genotypeFilter / usePCA / nPCs were reachable only through `...`. + capX <- new.env(parent = emptyenv()) + capSs <- new.env(parent = emptyenv()) + local_mocked_bindings( + .fmPerStudy = function(qd, cfg) { + capX$cfg <- cfg + NULL + }, + .fmSumStats = function(ss, cfg) { + capSs$cfg <- cfg + NULL + }, + .package = "pecotmr" + ) + expect_error( + suppressMessages(fineMappingPipeline( + MultiStudyQtlDataset( + qtlDatasets = list( + study1 = .fmp_makeQtlDataset( + contexts = "brain", + traits = "ENSG_A" + ) + ), + sumStats = .fmp_makeQtlSumStats() + ), + methods = "susie", + cisWindow = 1000L, + credibleSetArgs = CredibleSetParam(coverage = 0.9), + fitRetention = "full", + genotypeFilterArgs = GenotypeFilterParam(mafCutoff = 0.05), + usePCA = TRUE, + nPCs = 3L + )), + "no entries produced" + ) + expect_equal(capX$cfg$fitRetention, "full") + expect_equal(capX$cfg$genotypeFilterArgs$mafCutoff, 0.05) + expect_true(capX$cfg$usePCA) + expect_equal(capX$cfg$nPCs, 3L) + # The embedded QtlSumStats used to be post-processed at the default + # coverage while its sibling QtlDatasets used the caller's. + expect_equal(capSs$cfg$credibleSetArgs$coverage, 0.9) + expect_equal(capSs$cfg$fitRetention, "full") +}) + +test_that("fineMappingPipeline(MultiStudyQtlDataset): a misspelled option errors", { + # The method no longer takes `...`, so a typo cannot be swallowed. + expect_error( + fineMappingPipeline( + MultiStudyQtlDataset( + qtlDatasets = list( + study1 = .fmp_makeQtlDataset( + contexts = "brain", + traits = "ENSG_A" + ) + ), + sumStats = .fmp_makeQtlSumStats() + ), + methods = "susie", + credibelSet = CredibleSetParam() + ), + "unused argument" + ) +}) + +test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { + # One individual-level study and one embedded QtlSumStats, so both + # per-study workers (.fmPerStudy and .fmSumStats) are exercised. + mt <- MultiStudyQtlDataset( + qtlDatasets = list( + study1 = .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + ), + sumStats = .fmp_makeQtlSumStats() + ) + capX <- new.env(parent = emptyenv()) + capRss <- new.env(parent = emptyenv()) + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(capture = capX), + .fmFitSusieRss = .fmp_mockFitRssDiag(capture = capRss), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + suppressMessages( + fineMappingPipeline( + mt, + methods = "susie", + cisWindow = 1000L, + addSusieInf = FALSE, + credibleSetArgs = CredibleSetParam(L = 4L, Lgreedy = 2L) + ) + ) + # The multi-study method had no L / Lgreedy formals of its own before the + # bundle: they rode `...` into the per-study recursion, so a misspelling + # was silently discarded and .fmMsResolveTokens -- which seeds the joint + # phase -- never saw them at all. They are checked formals instead. + expect_equal(capX$userArgs$L, 4L) + expect_equal(capX$userArgs$L_greedy, 2L) + expect_equal(capRss$userArgs$L, 4L) + expect_equal(capRss$userArgs$L_greedy, 2L) +}) + test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges per region in each study", { qd1 <- QtlDataset( study = "s1", @@ -2156,7 +2186,11 @@ test_that("fineMappingPipeline(QtlSumStats): runs end-to-end with mocked RSS fit .package = "pecotmr" ) res <- suppressMessages( - fineMappingPipeline(ss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + ss, + methods = "susie", + addSusieInf = FALSE + ) ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 1L) @@ -2191,7 +2225,11 @@ test_that("fineMappingPipeline(GwasSumStats): runs end-to-end with mocked RSS fi .package = "pecotmr" ) res <- suppressMessages( - fineMappingPipeline(gss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + gss, + methods = "susie", + addSusieInf = FALSE + ) ) expect_s4_class(res, "GwasFineMappingResult") expect_equal(nrow(res), 1L) @@ -2265,7 +2303,11 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { .package = "pecotmr" ) suppressMessages( - fineMappingPipeline(gss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + gss, + methods = "susie", + addSusieInf = FALSE + ) ) # per-variant N forwarded (all 5 distinct), not the scalar median, not 1. expect_false(identical(captured$n, "UNSET")) @@ -2297,7 +2339,11 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { test_that("fineMappingPipeline(GwasSumStats): a PIP-screened region yields an empty result, not an error", { gss <- .fmp_makeScreenedGwas() expect_message( - res <- fineMappingPipeline(gss, methods = "susie", addSusieInf = FALSE), + res <- fineMappingPipeline( + gss, + methods = "susie", + addSusieInf = FALSE + ), "region skipped" ) expect_s4_class(res, "GwasFineMappingResult") @@ -2324,7 +2370,11 @@ test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only t .package = "pecotmr" ) res <- suppressMessages( - fineMappingPipeline(gss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + gss, + methods = "susie", + addSusieInf = FALSE + ) ) expect_equal(unique(as.character(res$study)), "Greal") # screened study absent expect_gt(nrow(res), 0L) @@ -2339,7 +2389,11 @@ test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even qcInfo = list(step1 = "ok") ) res <- suppressMessages( - fineMappingPipeline(gss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + gss, + methods = "susie", + addSusieInf = FALSE + ) ) expect_s4_class(res, "GwasFineMappingResult") expect_equal(nrow(res), 0L) @@ -2361,7 +2415,11 @@ test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefu ) ) res <- suppressMessages( - fineMappingPipeline(qss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + qss, + methods = "susie", + addSusieInf = FALSE + ) ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 0L) @@ -2382,8 +2440,10 @@ test_that("fineMappingPipeline(GwasSumStats): serFallback + reliable R keeps mul gss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb" + ) ) ) sf <- getSusieFit(res, study = "G1", method = "susie") @@ -2408,8 +2468,10 @@ test_that("fineMappingPipeline(GwasSumStats): serFallback + unreliable R falls b gss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb" + ) ) ) sf <- getSusieFit(res, study = "G1", method = "susie") @@ -2431,7 +2493,11 @@ test_that("fineMappingPipeline(GwasSumStats): serFallback=FALSE default is behav .package = "pecotmr" ) res <- suppressMessages( - fineMappingPipeline(gss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + gss, + methods = "susie", + addSusieInf = FALSE + ) ) sf <- getSusieFit(res, study = "G1", method = "susie") # No fallback even though flag=TRUE; multi-effect result kept. @@ -2457,8 +2523,10 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini gss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb" + ) ) ) # rFinite defaulted to the LD-panel sample size (40 in .fmp_makeHandle). @@ -2478,9 +2546,11 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini gss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rFinite = 12345, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rFinite = 12345, + rMismatch = "eb" + ) ) ) expect_equal(cap2$rFinite, 12345) @@ -2498,8 +2568,10 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini gss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb_mix" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb_mix" + ) ) ) expect_equal(cap3$rMismatch, "eb_mix") @@ -2517,7 +2589,12 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini gss, methods = "susie", addSusieInf = FALSE, - rssControl = list(check_prior = TRUE, mismatch_estimator = "map") + rssArgs = SusieRssParam( + control = SusieRssControlOptions( + check_prior = TRUE, + mismatch_estimator = "map" + ) + ) ) ) expect_equal( @@ -2533,7 +2610,11 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini .package = "pecotmr" ) suppressMessages( - fineMappingPipeline(gss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + gss, + methods = "susie", + addSusieInf = FALSE + ) ) expect_null(cap5$rssControl) }) @@ -2551,9 +2632,11 @@ test_that("fineMappingPipeline(GwasSumStats): keepFullFit='all' retains fit on n gss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb", - keepFullFit = "all" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb", + keepFullFit = "all" + ) ) ) sf <- getSusieFit(res, study = "G1", method = "susie") @@ -2561,6 +2644,49 @@ test_that("fineMappingPipeline(GwasSumStats): keepFullFit='all' retains fit on n expect_equal(sf$multiEffectFit$multiTag, "multi") }) +test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the susie fit", { + ss <- .fmp_makeQtlSumStats() + cap <- new.env(parent = emptyenv()) + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieRss = .fmp_mockFitRssDiag(capture = cap), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + suppressMessages( + fineMappingPipeline( + ss, + methods = "susie", + addSusieInf = FALSE, + credibleSetArgs = CredibleSetParam(L = 4L, Lgreedy = 2L) + ) + ) + # QtlDataset and GwasSumStats have always taken these; QtlSumStats did not, + # so its susie fits were pinned to the L = 10 default. + expect_equal(cap$userArgs$L, 4L) + expect_equal(cap$userArgs$L_greedy, 2L) +}) + +test_that("fineMappingPipeline(QtlSumStats): per-method L beats the top-level L", { + ss <- .fmp_makeQtlSumStats() + cap <- new.env(parent = emptyenv()) + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieRss = .fmp_mockFitRssDiag(capture = cap), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + suppressMessages( + fineMappingPipeline( + ss, + methods = list(susie = list(L = 7L)), + addSusieInf = FALSE, + credibleSetArgs = CredibleSetParam(L = 4L) + ) + ) + expect_equal(cap$userArgs$L, 7L) +}) + test_that("fineMappingPipeline(QtlSumStats): serFallback=FALSE default leaves the QTL path unchanged", { ss <- .fmp_makeQtlSumStats() cap <- new.env(parent = emptyenv()) @@ -2571,7 +2697,11 @@ test_that("fineMappingPipeline(QtlSumStats): serFallback=FALSE default leaves th .package = "pecotmr" ) res <- suppressMessages( - fineMappingPipeline(ss, methods = "susie", addSusieInf = FALSE) + fineMappingPipeline( + ss, + methods = "susie", + addSusieInf = FALSE + ) ) expect_s4_class(res, "QtlFineMappingResult") # With serFallback off (the default), the shared block never fires the @@ -2604,8 +2734,10 @@ test_that("fineMappingPipeline(QtlSumStats): serFallback + reliable R keeps mult ss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb" + ) ) ) sf <- getSusieFit( @@ -2636,8 +2768,10 @@ test_that("fineMappingPipeline(QtlSumStats): serFallback + unreliable R falls ba ss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb" + ) ) ) sf <- getSusieFit( @@ -2670,8 +2804,10 @@ test_that("fineMappingPipeline(QtlSumStats): rFinite/rMismatch forwarded; rFinit ss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb" + ) ) ) # rFinite defaulted to the LD-panel sample size (40 in .fmp_makeHandle). @@ -2691,9 +2827,11 @@ test_that("fineMappingPipeline(QtlSumStats): rFinite/rMismatch forwarded; rFinit ss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rFinite = 12345, - rMismatch = "eb" + rssArgs = SusieRssParam( + serFallback = TRUE, + rFinite = 12345, + rMismatch = "eb" + ) ) ) expect_equal(cap2$rFinite, 12345) @@ -2712,9 +2850,11 @@ test_that("fineMappingPipeline(QtlSumStats): keepFullFit='all' retains fit on no ss, methods = "susie", addSusieInf = FALSE, - serFallback = TRUE, - rMismatch = "eb", - keepFullFit = "all" + rssArgs = SusieRssParam( + serFallback = TRUE, + rMismatch = "eb", + keepFullFit = "all" + ) ) ) sf <- getSusieFit( @@ -2785,30 +2925,13 @@ test_that("ser is sumstat-only: rejected on QtlDataset, allowed on all sumstat k )) }) -test_that(".fmFitSusieSer calls susieR::susie_ser with z + n and no R / L", { - captured <- new.env(parent = emptyenv()) - local_mocked_bindings( - susie_ser = function(z, n, coverage = 0.95, ...) { - captured$args <- list( - z = z, - n = n, - coverage = coverage, - dots = list(...) - ) - list(pip = rep(0.1, length(z))) - }, - .package = "susieR" - ) - fit <- pecotmr:::.fmFitSusieSer(z = rnorm(5), n = 1000) - expect_equal(captured$args$n, 1000) - expect_length(captured$args$z, 5) - expect_null(captured$args$dots$R) - expect_null(captured$args$dots$L) - expect_true("susieRss" %in% class(fit)) -}) - test_that(".fmNormalizeMethods does not inject L / L_greedy for ser", { - norm <- pecotmr:::.fmNormalizeMethods("ser", L = 20L, Lgreedy = 5L) + norm <- pecotmr:::.fmNormalizeMethods( + "ser", + L = 20L, + Lgreedy = 5L, + inputKind = "QtlDataset" + ) expect_null(norm$methodArgs[["ser"]][["L"]]) expect_null(norm$methodArgs[["ser"]][["L_greedy"]]) }) @@ -2832,162 +2955,6 @@ test_that("fineMappingPipeline(ANY): unsupported input class errors", { # .fmFitSusieIndiv / .fmFitSusieRss — chained-init and branch coverage # =========================================================================== -# Capture the args passed to susieR::susie / susie_rss by mocking each to -# stash its first invocation's args into a global. The captured args let -# us assert which code path was taken. -.fmp_capturingSusie <- function(captured) { - function(X, y, ...) { - captured$lastArgs <<- list(X = X, y = y, ...) - # Return a minimal "fit" shape downstream cares about; .setFinemappingFitClass - # only attaches an S3 class, so any list works. - list(token = "test", V = 0.1) - } -} - -.fmp_capturingSusieRss <- function(captured) { - function(z, R, n, ...) { - captured$lastArgs <<- list(z = z, R = R, n = n, ...) - list(token = "test_rss", V = 0.1) - } -} - -test_that(".fmFitSusieIndiv: susieInf branch passes convergence_method='pip', refine=FALSE, model_init=NULL", { - captured <- new.env(parent = emptyenv()) - X <- matrix(rnorm(20), 10, 2) - y <- rnorm(10) - local_mocked_bindings( - susie = .fmp_capturingSusie(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieIndiv(X, y, "susieInf") - expect_equal(captured$lastArgs$convergence_method, "pip") - expect_false(captured$lastArgs$refine) - expect_null(captured$lastArgs$model_init) - expect_equal(captured$lastArgs$unmappable_effects, "inf") -}) - -test_that(".fmFitSusieIndiv: chained branch (chainFromInf) propagates susieInf fit as model_init", { - captured <- new.env(parent = emptyenv()) - X <- matrix(rnorm(20), 10, 2) - y <- rnorm(10) - # Build a stub susieInf fit with a V slot so prepareSusieFromInfArgs can read L. - infFit <- list(V = c(0.1, 0.2)) - local_mocked_bindings( - susie = .fmp_capturingSusie(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieIndiv(X, y, "susie", chainFromInf = infFit) - # prepareSusieFromInfArgs writes the susieInf fit into model_init and - # sets unmappable_effects to "none" for the `susie` token. - expect_identical(captured$lastArgs$model_init, infFit) - expect_equal(captured$lastArgs$unmappable_effects, "none") -}) - -test_that(".fmFitSusieIndiv: chained susieAsh branch sets unmappable_effects='ash'", { - captured <- new.env(parent = emptyenv()) - X <- matrix(rnorm(20), 10, 2) - y <- rnorm(10) - infFit <- list(V = c(0.1, 0.2)) - local_mocked_bindings( - susie = .fmp_capturingSusie(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieIndiv(X, y, "susieAsh", chainFromInf = infFit) - expect_equal(captured$lastArgs$unmappable_effects, "ash") - expect_identical(captured$lastArgs$model_init, infFit) -}) - -test_that(".fmFitSusieIndiv: unchained susieAsh branch sets convergence_method='pip'", { - captured <- new.env(parent = emptyenv()) - X <- matrix(rnorm(20), 10, 2) - y <- rnorm(10) - local_mocked_bindings( - susie = .fmp_capturingSusie(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieIndiv(X, y, "susieAsh") - expect_equal(captured$lastArgs$convergence_method, "pip") - expect_equal(captured$lastArgs$unmappable_effects, "ash") -}) - -test_that(".fmFitSusieIndiv: rejects non-SuSiE-family token", { - expect_error( - pecotmr:::.fmFitSusieIndiv(matrix(0, 2, 2), c(0, 0), "mvsusie"), - "not a SuSiE-family method" - ) - expect_error( - pecotmr:::.fmFitSusieIndiv(matrix(0, 2, 2), c(0, 0), "ghost"), - "not a SuSiE-family method" - ) -}) - -test_that(".fmFitSusieRss: susieInf branch passes convergence_method='pip', refine=FALSE, model_init=NULL", { - captured <- new.env(parent = emptyenv()) - z <- rnorm(3) - R <- diag(3) - n <- 1000 - local_mocked_bindings( - susie_rss = .fmp_capturingSusieRss(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieRss(z, R, n, "susieInf") - expect_equal(captured$lastArgs$convergence_method, "pip") - expect_false(captured$lastArgs$refine) - expect_null(captured$lastArgs$model_init) - expect_equal(captured$lastArgs$unmappable_effects, "inf") -}) - -test_that(".fmFitSusieRss: chained branch (chainFromInf) propagates susieInf fit as model_init", { - captured <- new.env(parent = emptyenv()) - z <- rnorm(3) - R <- diag(3) - n <- 1000 - infFit <- list(V = c(0.1, 0.2)) - local_mocked_bindings( - susie_rss = .fmp_capturingSusieRss(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieRss(z, R, n, "susie", chainFromInf = infFit) - expect_identical(captured$lastArgs$model_init, infFit) - expect_equal(captured$lastArgs$unmappable_effects, "none") -}) - -test_that(".fmFitSusieRss: chained susieAsh branch sets unmappable_effects='ash'", { - captured <- new.env(parent = emptyenv()) - z <- rnorm(3) - R <- diag(3) - n <- 1000 - infFit <- list(V = c(0.1, 0.2)) - local_mocked_bindings( - susie_rss = .fmp_capturingSusieRss(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieRss(z, R, n, "susieAsh", chainFromInf = infFit) - expect_equal(captured$lastArgs$unmappable_effects, "ash") - expect_identical(captured$lastArgs$model_init, infFit) -}) - -test_that(".fmFitSusieRss: unchained susieAsh branch sets convergence_method='pip'", { - captured <- new.env(parent = emptyenv()) - z <- rnorm(3) - R <- diag(3) - n <- 1000 - local_mocked_bindings( - susie_rss = .fmp_capturingSusieRss(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieRss(z, R, n, "susieAsh") - expect_equal(captured$lastArgs$convergence_method, "pip") - expect_equal(captured$lastArgs$unmappable_effects, "ash") -}) - -test_that(".fmFitSusieRss: rejects non-SuSiE-family token", { - expect_error( - pecotmr:::.fmFitSusieRss(c(0, 0), diag(2), 1000, "mvsusie"), - "not a SuSiE-family method" - ) -}) - # =========================================================================== # QtlSumStats: empty selection, mvsusie single-context rejection, cache hits # =========================================================================== @@ -3016,7 +2983,10 @@ test_that("fineMappingPipeline(QtlSumStats): traitId filter that selects no rows ) }) -test_that("fineMappingPipeline(QtlSumStats): mvsusie rejected when every (study, trait) has only one context", { +test_that("fineMappingPipeline( + QtlSumStats): mvsusie rejected when every (study, + trait +) has only one context", { # Build a single-context-per-(study, trait) collection. Mvsusie requires # at least two contexts per (study, trait) group. ss <- QtlSumStats( @@ -3034,7 +3004,10 @@ test_that("fineMappingPipeline(QtlSumStats): mvsusie rejected when every (study, ) }) -test_that("fineMappingPipeline(QtlSumStats): mvsusie auto-detection fits cross-context per (study, trait)", { +test_that("fineMappingPipeline( + QtlSumStats): mvsusie auto-detection fits cross-context per (study, + trait +)", { # Multi-context (c1, c2) single-trait collection: mvsusie without an explicit # jointSpecification routes through the joint engine -> per-context rows that # share the cross-context RSS fit, each tagged with the co-fit membership. @@ -3307,48 +3280,15 @@ test_that("resolveLdInput does not error when nSample not needed", { expect_null(result$nSample) }) # =========================================================================== -# Residualization flag propagation +# Residualization settings propagation # =========================================================================== -# .resPickFlags() walks up the call stack and harvests the four -# residualization flags from whichever frame defines them. The -# fineMappingPipeline / twasWeightsPipeline setMethod signatures -# define these flags so they reach `getResidualized{Phenotypes, -# Genotypes}` via the .fmResid* wrappers without per-call-site -# threading. - -test_that(".resPickFlags picks up flags from the enclosing frame", { - outerFn <- function() { - # Mirror the QtlDataset setMethod's residualization signature. - residualizePhenotypeCovariates <- FALSE - residualizeGenotypeCovariates <- TRUE - phenotypeCovariatesToResidualize <- c("age", "sex") - genotypeCovariatesToResidualize <- NULL - innerFn <- function() { - pecotmr:::.resPickFlags() - } - innerFn() - } - flags <- outerFn() - expect_false(flags$residualizePhenotypeCovariates) - expect_true(flags$residualizeGenotypeCovariates) - expect_equal(flags$phenotypeCovariatesToResidualize, c("age", "sex")) - expect_null(flags$genotypeCovariatesToResidualize) -}) - -test_that(".resPickFlags returns an empty list when nothing is in scope", { - flags <- pecotmr:::.resPickFlags() - # Top-level call should not pick up any of the flags (the names are - # not defined here). - expect_false(any( - c( - "residualizePhenotypeCovariates", - "residualizeGenotypeCovariates" - ) %in% - names(flags) - )) -}) +# These used to be four loose flags scraped off the call stack by +# .resPickFlags() (sys.frames() + get(envir = )), then four translated +# argument names via .resArgsFor(). The accessors now take the bundle +# itself, so there is no translation left to test -- only that the bundle +# travels intact. -test_that(".fmResidGeno / .fmResidPheno forward picked-up flags to the real accessors", { +test_that(".fmResidGeno / .fmResidPheno forward the bundle to the accessors", { capturedGeno <- NULL capturedPheno <- NULL fakeGeno <- function(x, ...) { @@ -3364,23 +3304,37 @@ test_that(".fmResidGeno / .fmResidPheno forward picked-up flags to the real acce getResidualizedPhenotypes = fakePheno, .package = "pecotmr" ) - - # Emulate the setMethod frame: define the four flags then call the - # wrappers. - outerFn <- function() { - residualizePhenotypeCovariates <- FALSE - residualizeGenotypeCovariates <- TRUE - phenotypeCovariatesToResidualize <- "age" - genotypeCovariatesToResidualize <- NULL - pecotmr:::.fmResidGeno(NULL, contexts = "c1") - pecotmr:::.fmResidPheno(NULL, contexts = "c1") + res <- ResidualizationParam( + phenotypeCovariates = "age", + residualizePhenotype = FALSE, + residualizeGenotype = TRUE + ) + # Passed, not scraped: the settings reach the accessors because the + # caller hands them over, with no enclosing frame involved. + pecotmr:::.fmResidGeno(NULL, contexts = "c1", residualizationArgs = res) + pecotmr:::.fmResidPheno(NULL, contexts = "c1", residualizationArgs = res) + for (captured in list(capturedGeno, capturedPheno)) { + got <- captured$residualizationArgs + expect_s4_class(got, "ResidualizationParam") + expect_equal(got$phenotypeCovariates, "age") + expect_false(got$residualizePhenotype) + expect_true(got$residualizeGenotype) } - outerFn() - expect_false(capturedGeno$residualizePhenotypeCovariates) - expect_true(capturedGeno$residualizeGenotypeCovariates) - expect_equal(capturedGeno$phenotypeCovariatesToResidualize, "age") - expect_false(capturedPheno$residualizePhenotypeCovariates) - expect_true(capturedPheno$residualizeGenotypeCovariates) +}) + +test_that("an absent bundle becomes the constructor's own defaults", { + captured <- NULL + local_mocked_bindings( + getResidualizedPhenotypes = function(x, ...) { + captured <<- list(...) + matrix(0, 0, 0) + }, + .package = "pecotmr" + ) + pecotmr:::.fmResidPheno(NULL, contexts = "c1", residualizationArgs = NULL) + expect_s4_class(captured$residualizationArgs, "ResidualizationParam") + # Nothing pinned: every flag is unset, which the accessors read as "on". + expect_length(captured$residualizationArgs, 0L) }) # =========================================================================== @@ -3407,7 +3361,7 @@ test_that(".fmResidGeno / .fmResidPheno forward picked-up flags to the real acce # * input-file validation; empty sumstats branches; pip_cutoff_to_skip # branches; full QC + imputation + fine-mapping; method-name # conventions (NO_QC / SLALOM / DENTIST / RAISS); outlierNumber -# plumbing; finemappingMethod = NULL skip; zMismatchQc = NULL; +# plumbing; finemappingMethod = NULL skip; ldMismatchQcMethod = NULL; # impute = FALSE; diagnostics branches (BCR + SER re-analysis); # finemappingOpts passthrough; mafCutoff (af single source); # finemapping-defaults passthrough; X-as-LD genotype path; @@ -3710,24 +3664,6 @@ test_that(".fmCacheLookupGwas: NULL / non-GwasFineMappingResult -> NULL", { expect_null(pecotmr:::.fmCacheLookupGwas(fmr, "S", "susie", "chr1:1-100")) }) -test_that(".buildMvsusieReweightedPrior: empty reweighted w0 -> canonical(V)", { - local_mocked_bindings( - rescaleCovW0 = function(w0) c(zzz = 1), - .package = "pecotmr" - ) - local_mocked_bindings( - create_mixture_prior = function(...) "PV", - .package = "mvsusieR" - ) - fp <- list( - dataDrivenPriorMatrices = list(U = list(compA = diag(2))), - w0 = c(compA_grid1 = 1), - V = diag(2) - ) - res <- pecotmr:::.buildMvsusieReweightedPrior(fp, c("c1", "c2")) - expect_equal(res$residualVariance, diag(2)) # w0 names disjoint from U (749) -}) - test_that(".fmBuildMvsusiePriorCv: NULL CV -> NULL; NULL fold fits are skipped", { expect_null(pecotmr:::.fmBuildMvsusiePriorCv(NULL, NULL, c("c1", "c2"))) local_mocked_bindings( @@ -3769,31 +3705,6 @@ test_that(".fmTopPcScores: PCA scores for multi-trait Y; degenerate inputs -> NU expect_equal(colnames(sc), c("topPC1", "topPC2")) }) -test_that(".fmSerScreen / .fmScreenActive / .fmSerScreenColumns", { - set.seed(2) - X <- matrix( - rnorm(40), - 20, - 2, - dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) - ) - y <- rnorm(20) - expect_true(pecotmr:::.fmSerScreen(X, y, 0)) # disabled - expect_true(pecotmr:::.fmSerScreen(X, c(1, rep(NA, 19)), 0.5)) # < 2 obs (880) - expect_type(pecotmr:::.fmSerScreen(X, y, 0.5), "logical") # real susie fit - local_mocked_bindings( - susie = function(...) stop("boom"), - .package = "susieR" - ) - expect_true(pecotmr:::.fmSerScreen(X, y, 0.5)) # fit fails -> keep (886) - expect_false(pecotmr:::.fmScreenActive(0)) - expect_true(pecotmr:::.fmScreenActive(0.5)) - expect_length( - pecotmr:::.fmSerScreenColumns(X, matrix(rnorm(40), 20, 2), 0), - 2L - ) -}) - test_that(".fmMergeEntries: empty -> NULL; merges per-region entries + relabels CS", { expect_null(pecotmr:::.fmMergeEntries(list(NULL, NULL))) e1 <- fineMappingRow( @@ -3929,6 +3840,44 @@ test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec with no fits ) } +test_that("MultiStudyQtlDataset forwards the mvsusie prior settings", { + # `mrmashPrior` and `dataDrivenPriorWeightsCutoff` configure the mvsusie + # data-driven reweighted prior. They used to reach ONLY jointCfg (the + # cross-study joint phase); the per-study config omitted them, so every + # per-study recursion silently refit mr.mash and used the 1e-10 cutoff. + mt <- .fmp_makeMultiStudy() + seen <- new.env(parent = emptyenv()) + seen$perStudy <- NULL + seen$sumStats <- NULL + local_mocked_bindings( + .fmPerStudy = function(qd, cfg) { + seen$perStudy <- cfg + NULL + }, + .fmSumStats = function(ss, cfg) { + seen$sumStats <- cfg + NULL + }, + .package = "pecotmr" + ) + # Both workers are stubbed, so the driver rbinds nothing -- the configs + # they were handed are what this test is about. + try( + suppressMessages(suppressWarnings(fineMappingPipeline( + mt, + methods = "susie", + verbose = 0, + mrmashPrior = "cache-sentinel", + dataDrivenPriorWeightsCutoff = 0.5 + ))), + silent = TRUE + ) + for (cfg in list(seen$perStudy, seen$sumStats)) { + expect_equal(cfg$mrmashPrior, "cache-sentinel") + expect_equal(cfg$dataDrivenPriorWeightsCutoff, 0.5) + } +}) + test_that("fineMappingPipeline(MultiStudyQtlDataset): region + cisWindow is rejected", { expect_error( fineMappingPipeline( @@ -4007,7 +3956,10 @@ test_that(".fmWeightsCv + .fmFoldWeights cover the mvSuSiE CV path (mocked fitte rbinom(n * p, 2, 0.4), n, p, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:p))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * seq_len(p)) + ) ) Y <- matrix(rnorm(n * R), n, R, dimnames = list(rownames(X), c("c1", "c2"))) cv <- pecotmr:::.fmWeightsCv( @@ -4019,7 +3971,10 @@ test_that(".fmWeightsCv + .fmFoldWeights cover the mvSuSiE CV path (mocked fitte coverage = 0.95, verbose = 0 ) - expect_named(cv, c("samplePartition", "prediction", "performance")) + expect_named( + cv, + c("samplePartition", "prediction", "performance", "foldFits") + ) expect_true("mvsusie_performance" %in% names(cv$performance)) expect_equal(dim(cv$prediction[["mvsusie_predicted"]]), c(n, R)) }) @@ -4044,7 +3999,10 @@ test_that(".fmFoldWeights covers the fSuSiE branch (mocked fitter)", { rbinom(n * p, 2, 0.4), n, p, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:p))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * seq_len(p)) + ) ) Y <- matrix(rnorm(n * 4L), n, 4L, dimnames = list(rownames(X), NULL)) W <- pecotmr:::.fmFoldWeights( @@ -4059,51 +4017,6 @@ test_that(".fmFoldWeights covers the fSuSiE branch (mocked fitter)", { expect_equal(rownames(W), colnames(X)) }) -test_that(".fmFitXBlock fits the susieInf indiv chain + cross-validates (mocked)", { - local_mocked_bindings( - .fmFitSusieIndiv = function(...) list(), - .fmPostprocessOne = function(fit, method, dataX, dataY, ...) { - fineMappingRow( - colnames(dataX), - list(), - data.frame(variant_id = colnames(dataX), pip = 0.5) - ) - }, - .fmFoldWeights = function(token, Xtr, Ytr, ...) { - matrix(0.01, ncol(Xtr), 1L, dimnames = list(colnames(Xtr), NULL)) - }, - .package = "pecotmr" - ) - set.seed(1) - X <- matrix( - rbinom(60, 2, 0.4), - 20, - 3, - dimnames = list( - paste0("s", 1:20), - c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") - ) - ) - y <- rnorm(20) - out <- pecotmr:::.fmFitXBlock( - X, - y, - toRun = "susieInf", - addSusieInf = FALSE, - coverage = 0.95, - secondaryCoverage = 0.7, - signalCutoff = 0.1, - minAbsCorr = 0.5, - methodArgs = list(susieInf = list()), - verbose = 1, - ctx = "brain", - tid = "ENSG_A", - cvFolds = 3L - ) - expect_named(out, "susieInf") - expect_s4_class(out$susieInf, "FineMappingRow") -}) - test_that(".fmPostprocessOne wraps a fit into a FineMappingRow", { local_mocked_bindings( postprocessFinemappingFits = function(...) list(x = 1), @@ -4123,10 +4036,12 @@ test_that(".fmPostprocessOne wraps a fit into a FineMappingRow", { method = "susie", dataX = matrix(0, 2, 1, dimnames = list(NULL, "chr1:100:A:G")), dataY = c(1, 2), - coverage = 0.95, - secondaryCoverage = 0.7, - signalCutoff = 0.1, - minAbsCorr = 0.5 + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.7, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) ) expect_s4_class(ent, "FineMappingRow") }) @@ -4192,7 +4107,10 @@ test_that(".fmWeightsCv covers per-fold prior, NULL-weights, and no-overlap bran verbose = 0, mvPriorCv = list("1" = list(priorVariance = diag(2))) ) - expect_named(cv, c("samplePartition", "prediction", "performance")) + expect_named( + cv, + c("samplePartition", "prediction", "performance", "foldFits") + ) }) test_that("fineMappingPipeline(QtlSumStats): susieInf RSS chain (mocked)", { @@ -4677,8 +4595,13 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block screened out # @noRd .rssf_n <- function(ss, ...) { + # `...` is the panel filter: every caller passes only its fields. sum(lengths(suppressWarnings(suppressMessages( - fineMappingPipeline(ss, methods = "susie", ...) + fineMappingPipeline( + ss, + methods = "susie", + panelFilterArgs = PanelFilterParam(...) + ) )))) } @@ -4706,7 +4629,7 @@ test_that("fineMappingPipeline RSS cutoffs agree with .panelVariantFilter", { expected <- length(.panelVariantFilter( getLdSketch(ss), ids, - mafCutoff = cut + PanelFilterParam(mafCutoff = cut) )) expect_equal( .rssf_n(ss, mafCutoff = cut), @@ -4750,3 +4673,430 @@ test_that(".fmExtractZn keeps z, ids and n aligned after filtering", { expect_equal(filtered$z, unfiltered$z[keep]) expect_equal(filtered$variantIds, unfiltered$variantIds[keep]) }) + +test_that(".fmLeanFoldFit passes a NULL fit straight through", { + expect_null(pecotmr:::.fmLeanFoldFit(NULL, "susie")) +}) + +test_that(".fmPerStudy / .fmSumStats answer NULL when no method fits the kind", { + # No individual / sumstat method in the list means there is nothing for + # that route to run, which is a NULL rather than an empty result object. + expect_null(pecotmr:::.fmPerStudy(NULL, list(methods = list()))) + expect_null(pecotmr:::.fmSumStats(NULL, list(methods = list()))) +}) + +test_that("a method takes its own constructor for the slot's own path", { + skip_if_not_installed("susieR") + skip_if_not_installed("mvsusieR") + expect_s4_class( + FineMappingMethodsParam( + qtlSumStatsMethods = list( + susie = SusieRssOptions(), + mvsusie = MvsusieRssOptions() + ) + ), + "FineMappingMethodsParam" + ) + expect_error( + FineMappingMethodsParam( + qtlDatasetMethods = list(susie = MvsusieOptions()) + ), + "uses the 'susie' constructor" + ) + # susieInf shares susie's ENGINE -- both run susieR::susie on + # individual data -- so only the token's own constructor pair tells + # them apart. + expect_error( + FineMappingMethodsParam( + qtlDatasetMethods = list(susieInf = SusieOptions()) + ), + "uses the 'susieInf' constructor" + ) + # A plain list declares no engine, so it is judged by its NAMES against + # the path the slot names -- `z` belongs to susie_rss. + expect_s4_class( + FineMappingMethodsParam(qtlSumStatsMethods = list(susie = list(z = 1))), + "FineMappingMethodsParam" + ) + expect_error( + FineMappingMethodsParam(qtlDatasetMethods = list(susie = list(z = 1))), + "unknown argument" + ) +}) + +test_that("FineMappingMethodsParam takes lists or constructors per entry", { + skip_if_not_installed("susieR") + a <- FineMappingMethodsParam( + qtlDatasetMethods = list( + susie = list(L = 5), + susieInf = SusieInfOptions() + ) + ) + expect_s4_class(a, "FineMappingMethodsParam") + expect_setequal(names(a$qtlDatasetMethods), c("susie", "susieInf")) + expect_equal(a$qtlDatasetMethods$susie$L, 5) + expect_error( + FineMappingMethodsParam(qtlDatasetMethods = list(susie = list(LL = 5))), + "unknown argument" + ) + expect_error( + FineMappingMethodsParam( + qtlDatasetMethods = list(susie = SusieInfOptions()) + ), + "built with the constructor for 'susieInf'" + ) + expect_error( + FineMappingMethodsParam(qtlDatasetMethods = list(nope = list())), + "not a method this pipeline runs" + ) +}) + +test_that("fineMappingPipeline accepts the record and the character form", { + skip_if_not_installed("susieR") + byName <- pecotmr:::.fmNormalizeMethods( + c("susie", "susieInf"), + inputKind = "QtlDataset" + ) + expect_equal(byName$tokens, c("susie", "susieInf")) + byRecord <- pecotmr:::.fmNormalizeMethods( + FineMappingMethodsParam(qtlDatasetMethods = list(susie = list(L = 3))), + inputKind = "QtlDataset" + ) + expect_equal(byRecord$tokens, "susie") + expect_equal(byRecord$methodArgs$susie$L, 3) +}) + +test_that("argument checking narrows to the engine the input class reaches", { + skip_if_not_installed("susieR") + skip_if_not_installed("mvsusieR") + # A constructor cannot know the input class, so it checks against both + # entry points. The pipeline knows, so it checks against the one. + expect_equal( + pecotmr:::.fmMethodCalleeFor("susie", "QtlDataset"), + "susieR::susie" + ) + expect_equal( + pecotmr:::.fmMethodCalleeFor("susie", "QtlSumStats"), + "susieR::susie_rss" + ) +}) + +test_that("an argument for the other entry point is caught per input class", { + skip_if_not_installed("susieR") + # `z` is a formal of susie_rss but not of susie, so it is legal on a + # summary-statistics run and a mistake on an individual-level one. The + # union check the constructor applies cannot tell these apart. + norm <- pecotmr:::.fmNormalizeMethods( + FineMappingMethodsParam(qtlSumStatsMethods = list(susie = list(z = 1))), + inputKind = "QtlSumStats" + ) + expect_error( + pecotmr:::.fmCheckMethodArgsForInput(norm$methodArgs, "QtlDataset"), + "method 'susie': unknown argument\\(s\\) z" + ) + expect_silent( + pecotmr:::.fmCheckMethodArgsForInput(norm$methodArgs, "QtlSumStats") + ) +}) + +test_that("mvsusie becomes checkable on the individual-level path", { + skip_if_not_installed("mvsusieR") + norm <- pecotmr:::.fmNormalizeMethods( + FineMappingMethodsParam( + qtlSumStatsMethods = list(mvsusie = list(nope = 1)) + ), + inputKind = "QtlSumStats" + ) + # mvsusieR::mvsusie_rss takes `...`, so nothing can be rejected on the + # RSS path; mvsusieR::mvsusie enumerates its formals, so the QtlDataset + # path rejects the same argument. + expect_error( + pecotmr:::.fmCheckMethodArgsForInput(norm$methodArgs, "QtlDataset"), + "method 'mvsusie': unknown argument\\(s\\) nope" + ) + expect_silent( + pecotmr:::.fmCheckMethodArgsForInput(norm$methodArgs, "QtlSumStats") + ) +}) + +test_that("pecotmr's own seeded arguments are not checked against the engine", { + skip_if_not_installed("susieR") + # L_greedy is a pecotmr concept seeded onto susie-family tokens; it is not + # a susieR formal and must not be reported as a user mistake. + norm <- pecotmr:::.fmNormalizeMethods( + "susieInf", + L = 5L, + Lgreedy = 2L, + inputKind = "QtlDataset" + ) + expect_true(is_in("L_greedy", names(norm$methodArgs$susieInf))) + expect_silent( + pecotmr:::.fmCheckMethodArgsForInput(norm$methodArgs, "QtlDataset") + ) +}) + +test_that(".fmRssArgsResolved fills rFinite without leaving the class", { + # `rFinite` defaults to NULL meaning "use the LD panel's N", which is not + # knowable when the caller builds the record. It is resolved here, and + # the result must still be an SusieRssParam: the previous code spliced the + # value in with list_assign(as.list(...)), handing everything downstream + # a bare list at exactly the point the value became concrete. + with_mocked_bindings( + { + # Nothing needs an N, so the record comes back untouched. + plain <- SusieRssParam() + expect_identical( + pecotmr:::.fmRssArgsResolved(plain, "sketch"), + plain + ) + # serFallback needs one, so it is taken from the panel. + got <- pecotmr:::.fmRssArgsResolved( + SusieRssParam(serFallback = TRUE), + "sketch" + ) + expect_s4_class(got, "SusieRssParam") + expect_equal(got$rFinite, 4321L) + expect_true(got$serFallback) + expect_equal(got$keepFullFit, "fallback") + # An rMismatch policy needs one too. + expect_equal( + pecotmr:::.fmRssArgsResolved( + SusieRssParam(rMismatch = "drop"), + "sketch" + )$rFinite, + 4321L + ) + # A value the caller gave is never overwritten. + expect_equal( + pecotmr:::.fmRssArgsResolved( + SusieRssParam(rFinite = 99, serFallback = TRUE), + "sketch" + )$rFinite, + 99 + ) + }, + .ldSketchNSamples = function(x) 4321L, + .package = "pecotmr" + ) +}) + +test_that("a path-exact method constructor refuses the other path's names", { + skip_if_not_installed("susieR") + indiv <- pecotmr:::.fmTokenPathConfig("susie", "QtlDataset") + sumst <- pecotmr:::.fmTokenPathConfig("susie", "QtlSumStats") + # `z` is a susie_rss argument and not a susie one. + expect_error(indiv(z = 1), "unknown argument") + expect_no_error(sumst(z = 1)) + # `y` is susie-only, so the mirror image holds. + expect_no_error(indiv(y = 1)) + expect_error(sumst(y = 1), "unknown argument") + # A name both callees accept is fine either way. + expect_no_error(indiv(L = 5)) + expect_no_error(sumst(L = 5)) + # Why this matters: the retired aggregator validated against the UNION + # of both callees, so it accepted `z` even for an individual-level run + # and the setting reached an engine that never reads it. + both <- pecotmr:::.engineAcceptedNames( + c("susieR::susie", "susieR::susie_rss") + ) + expect_true(is_in("z", both)) + expect_false(is_in("z", pecotmr:::.engineAcceptedNames("susieR::susie"))) +}) + +test_that("each input path offers only the methods it implements", { + expect_setequal( + names(pecotmr:::.fmMethodCtorsFor("QtlDataset")), + c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie") + ) + expect_setequal( + names(pecotmr:::.fmMethodCtorsFor("QtlSumStats")), + c("susie", "susieInf", "susieAsh", "ser", "mvsusie") + ) + # fsusie has no summary-statistics implementation; ser no individual one. + expect_null(pecotmr:::.fmTokenPathConfig("fsusie", "QtlSumStats")) + expect_null(pecotmr:::.fmTokenPathConfig("ser", "QtlDataset")) +}) + +test_that("CredibleSetParam owns L / Lgreedy", { + # They bound how many credible sets can exist. They reach the engine by a + # different route from the rest of the bundle -- seeded onto each + # SuSiE-family token rather than read by postprocessFinemappingFits() -- + # but that is a plumbing difference, not a different setting. + expect_equal(CredibleSetParam()$L, 10L) + expect_false("Lgreedy" %in% names(CredibleSetParam())) + expect_equal(CredibleSetParam(Lgreedy = 3L)$Lgreedy, 3L) + # addSusieInf stands alone: it selects a chained initialisation between + # methods rather than describing credible sets. + expect_false("addSusieInf" %in% names(formals(CredibleSetParam))) + expect_false("fitStructureArgs" %in% getNamespaceExports("pecotmr")) +}) + +test_that("CredibleSetParam owns the topLoci per-CS columns", { + # perCsColumns used to be two booleans on fitRetentionArgs -- `fullFit` + # and `fullFitAlphaOnly`, the second a documented no-op unless the first. + # They govern the topLoci TABLE, next to includeAllCs which decides the + # column labels, not the stored fit. + expect_equal(CredibleSetParam()$perCsColumns, "none") + expect_equal(CredibleSetParam(perCsColumns = "full")$perCsColumns, "full") + expect_error(CredibleSetParam(perCsColumns = "yes"), "must be one of") + # fitRetentionArgs() is retired: one axis is not a bundle. + expect_false("fitRetentionArgs" %in% getNamespaceExports("pecotmr")) +}) + +test_that("SignalScreenParam resolves each metric to a pipeline spec", { + # pip keeps the legacy bare-numeric spelling; the other three resolve to + # list(metric, cutoff). .asScreen() canonicalizes either. + expect_null(pecotmr:::.screenResolve(SignalScreenParam())) + expect_equal(pecotmr:::.screenResolve(SignalScreenParam(pip = 0.5)), 0.5) + expect_equal( + pecotmr:::.screenResolve(SignalScreenParam(absZ = 5)), + list(metric = "absZ", cutoff = 5) + ) + expect_equal( + pecotmr:::.screenResolve(SignalScreenParam(bf = 100)), + list(metric = "bf", cutoff = 100) + ) + expect_equal( + pecotmr:::.screenResolve(SignalScreenParam(logBf = 3)), + list(metric = "logBf", cutoff = 3) + ) +}) + +test_that("SignalScreenParam rejects two metrics and negative absZ / bf", { + expect_error( + SignalScreenParam(pip = 0.5, absZ = 5), + "only one screening metric" + ) + # 0 is the long-standing "off" spelling, so it is not a second metric. + expect_equal( + pecotmr:::.screenResolve(SignalScreenParam(pip = 0, absZ = 5)), + list(metric = "absZ", cutoff = 5) + ) + expect_error(SignalScreenParam(absZ = -1), "must be > 0") + expect_error(SignalScreenParam(bf = -1), "must be > 0") + # pip < 0 is the adaptive 3 / nVariants convention, and logBf is a log. + expect_equal(pecotmr:::.screenResolve(SignalScreenParam(pip = -1)), -1) + expect_equal( + pecotmr:::.screenResolve(SignalScreenParam(logBf = -2)), + list(metric = "logBf", cutoff = -2) + ) +}) + +test_that("every recursion forwards each cfg field its callee accepts", { + ns <- asNamespace("pecotmr") + cases <- list( + list( + site = ".fmPerStudy", + builder = ".fmPipelineMultiStudy", + callee = ".fmPipelineQtlDataset" + ), + list( + site = ".fmSumStats", + builder = ".fmPipelineMultiStudy", + callee = ".fmPipelineQtlSumStats" + ), + list( + site = ".twasPerStudy", + builder = ".twasMsDriver", + callee = ".twasPipelineQtlDataset" + ), + list( + site = ".twasSumStats", + builder = ".twasMsDriver", + callee = ".twasPipelineQtlSumStats" + ) + ) + for (cs in cases) { + fields <- .cfgFieldNames(cs$builder) + accepted <- setdiff( + names(formals(get(cs$callee, envir = ns))), + "..." + ) + passed <- .argNamesPassed(cs$site) + # A field the record carries AND the callee accepts must be passed. + dropped <- setdiff(intersect(fields, accepted), passed) + expect_equal( + dropped, + character(0), + info = paste0( + cs$site, + " never forwards: ", + paste(dropped, collapse = ", "), + " -- the callee accepts them and the record carries them, so ", + "they silently fall back to ", + cs$callee, + "'s defaults." + ) + ) + } +}) + +test_that("CredibleSetParam accessors read and replace, L is get-only", { + cs <- CredibleSetParam(coverage = 0.95) + expect_equal(getCoverage(cs), 0.95) + expect_equal(getL(cs), 10L) + expect_null(getMedianAbsCorr(cs)) + + # Copy semantics: the setter returns a new record, the original stands. + cs2 <- setCoverage(cs, 0.9) + expect_equal(getCoverage(cs2), 0.9) + expect_equal(getCoverage(cs), 0.95) + expect_s4_class(cs2, "CredibleSetParam") + + # The slot's declared type still holds through a setter. + expect_error(setCoverage(cs, "wide"), "not valid for @.+coverage") + + # L / Lgreedy are deliberately get-only: they are seeded onto each + # SuSiE-family token's own arguments, so changing one needs a refit, not + # a re-summary. A setter would hand back a record that looks applied. + ns <- asNamespace("pecotmr") + expect_false(exists("setL", envir = ns, inherits = FALSE)) + expect_false(exists("setLgreedy", envir = ns, inherits = FALSE)) + expect_true(is.function(getLgreedy)) +}) + +test_that("every settable CredibleSetParam field has both accessors", { + # The pairing is the contract: a field you can read and not write is a + # deliberate exception, so it must be one of exactly these two. + getOnly <- c("L", "Lgreedy") + ns <- asNamespace("pecotmr") + for (f in names(formals(CredibleSetParam))) { + stem <- str_c(str_to_upper(str_sub(f, 1L, 1L)), str_sub(f, 2L)) + expect_true( + exists(str_c("get", stem), envir = ns, inherits = FALSE), + info = paste("no getter for", f) + ) + expect_equal( + exists(str_c("set", stem), envir = ns, inherits = FALSE), + !is_in(f, getOnly), + info = paste("setter presence wrong for", f) + ) + } +}) + +test_that("CredibleSetParam accessors read and replace every field", { + # The pairing test above asserts the accessors EXIST; this one dispatches + # them. Existence is checked with exists(), which never reaches the + # generic, so without this the setGeneric bodies in AllGenerics.R and the + # copy semantics of each setter go unexercised. + cs <- CredibleSetParam() + expect_equal(getSecondaryCoverage(cs), c(0.7, 0.5)) + expect_equal(getSignalCutoff(cs), 0.025) + expect_equal(getMinAbsCorr(cs), 0.8) + expect_false(getIncludeAllCs(cs)) + expect_equal(getPerCsColumns(cs), "none") + expect_null(getLgreedy(cs)) + + # Each setter hands back a new record; the original is untouched. + expect_equal(getSecondaryCoverage(setSecondaryCoverage(cs, 0.6)), 0.6) + expect_equal(getSignalCutoff(setSignalCutoff(cs, 0.1)), 0.1) + expect_equal(getMinAbsCorr(setMinAbsCorr(cs, 0.5)), 0.5) + expect_equal(getMedianAbsCorr(setMedianAbsCorr(cs, 0.4)), 0.4) + expect_true(getIncludeAllCs(setIncludeAllCs(cs, TRUE))) + expect_equal(getPerCsColumns(setPerCsColumns(cs, "alpha")), "alpha") + expect_equal(getSecondaryCoverage(cs), c(0.7, 0.5)) + expect_false(getIncludeAllCs(cs)) + + # Setters revalidate, so a wrong-typed replacement is refused. + expect_error(setIncludeAllCs(cs, "yes"), "includeAllCs") +}) diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index c3bbebf06..290b0283e 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -288,7 +288,7 @@ test_that("FineMappingRow cvResult defaults to NULL and rejects non-list", { topLoci = tl, cvResult = 1:3 ), - "cvResult must be NULL or a list" + "cvResult.*Must be of type 'list' \\(or 'NULL'\\)" ) }) @@ -978,7 +978,7 @@ test_that("getCredibleSetSummary aggregates across a collection with entry ident p, dimnames = list( paste0("s", seq_len(n)), - paste0("chr1:", (seq_len(p)) * 100, ":A:G") + paste0("chr1:", seq_len(p) * 100, ":A:G") ) ) b1 <- sin(seq(0, 2 * pi, length.out = J)) @@ -1662,3 +1662,33 @@ test_that("show(FineMappingRow) reports zero sets for an empty row", { ) expect_output(show(withCs), "2 variants, 1 credible sets") }) + +test_that(".csLog10Bf and .csMeanEffect return NA, never -Inf or NaN", { + # Both previously disagreed with their own missing-column branch: an empty + # or all-NA column yielded -Inf / NaN from max() / mean() while a missing + # column yielded NA_real_. These values reach output tables. + expect_identical(pecotmr:::.csLog10Bf(list()), NA_real_) + expect_identical( + pecotmr:::.csLog10Bf(list(logBF = numeric(0))), + NA_real_ + ) + expect_identical( + pecotmr:::.csLog10Bf(list(logBF = c(NA_real_, NA_real_))), + NA_real_ + ) + expect_identical(pecotmr:::.csLog10Bf(list(logBF = c(1, 3, 2))), 3) + + expect_identical(pecotmr:::.csMeanEffect(list()), NA_real_) + expect_identical( + pecotmr:::.csMeanEffect(list(conditional_effect = numeric(0))), + NA_real_ + ) + expect_identical( + pecotmr:::.csMeanEffect(list(conditional_effect = c(NA, NA))), + NA_real_ + ) + expect_identical( + pecotmr:::.csMeanEffect(list(conditional_effect = c(1, 3))), + 2 + ) +}) diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index d62962391..0a604f22c 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -4,6 +4,43 @@ context("susie_finemapping") # lbf_to_alpha_vector (internal) # ============================================================================= +# Fixtures moved here with the tests that use them. + +# Capture the args passed to susieR::susie / susie_rss by mocking each to +# stash its first invocation's args into a global. The captured args let +# us assert which code path was taken. +.fmp_capturingSusie <- function(captured) { + function(X, y, ...) { + captured$lastArgs <<- list(X = X, y = y, ...) + # Return a minimal "fit" shape downstream cares about; .setFinemappingFitClass + # only attaches an S3 class, so any list works. + list(token = "test", V = 0.1) + } +} + +.fmp_capturingSusieRss <- function(captured) { + function(z, R, n, ...) { + captured$lastArgs <<- list(z = z, R = R, n = n, ...) + list(token = "test_rss", V = 0.1) + } +} + +# An allele switch (what the flip rule targets) is an LD-CONSISTENT z with one +# entry's sign reversed -- not a magnitude outlier. Build z = R %*% b (a single +# causal SNP) then negate a strongly-tagged neighbour, so susieR's logLR fires. +.kr_switchScenario <- function() { + m <- 10 + rho <- 0.9 + R <- outer(seq_len(m), seq_len(m), function(i, j) rho^abs(i - j)) + ids <- paste0("1:", seq_len(m) * 100, ":A:G") + rownames(R) <- colnames(R) <- ids + b <- numeric(m) + b[5] <- 6 + z <- as.numeric(R %*% b) + z[6] <- -z[6] # flip a strongly-tagged neighbour of the causal + list(z = z, R = R, ids = ids, flipped = 6L) +} + test_that("lbf_to_alpha_vector converts correctly", { lbf <- c(a = -0.5, b = 1.2, c = 0.3) alpha <- pecotmr:::lbfToAlphaVector(lbf) @@ -257,6 +294,18 @@ test_that("get_cs_info reports variant in multiple CSs as multiple rows", { # susieWeights # ============================================================================= +test_that("susie*Weights refuse to fine-map when no fit is supplied", { + # These extract weights from an existing fit; twasWeightsPipeline gates + # susie-family tokens up front, so a NULL fit here is a caller error, not + # an invitation to run susie. + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:30] + y <- eqtlRegionExample$yRes + expect_error(susieWeights(X, y), "no 'susie' fit supplied") + expect_error(susieAshWeights(X, y), "no 'susieAsh' fit supplied") + expect_error(susieInfWeights(X, y), "no 'susieInf' fit supplied") +}) + test_that("susieWeights returns zeros when fit lacks alpha/mu", { fake_fit <- list(pip = rep(0.01, 5)) result <- susieWeights(susieFit = fake_fit) @@ -345,8 +394,8 @@ test_that("init_prior_sd returns n standard deviations", { # ============================================================================= # Helper: build a minimal synthetic SuSiE-family output for post-processing -make_fake_susie_output <- function(p = 5, L = 3, has_V = TRUE) { - vnames <- paste0("chr1:", 1:p, ":A:G") +makeFakeSusieOutput <- function(p = 5, L = 3, has_V = TRUE) { + vnames <- paste0("chr1:", seq_len(p), ":A:G") out <- list( pip = setNames(rep(0.01, p), vnames), alpha = matrix(1 / p, nrow = L, ncol = p), @@ -367,7 +416,7 @@ test_that("postprocessFinemappingFits keeps all effects when V is NULL", { skip_if_not_installed("susieR") p <- 5 L <- 3 - fake_output <- make_fake_susie_output(p, L = L, has_V = FALSE) + fake_output <- makeFakeSusieOutput(p, L = L, has_V = FALSE) R <- diag(p) colnames(R) <- rownames(R) <- names(fake_output$pip) post <- postprocessFinemappingFits( @@ -379,7 +428,9 @@ test_that("postprocessFinemappingFits keeps all effects when V is NULL", { ), dataX = R, dataY = list(z = rnorm(p)), - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) result <- formatFinemappingOutput(post, primaryMethod = "susieRss") trimmed <- pecotmr:::.fmrPartsSusieFit(result$finemappingEntry) @@ -399,8 +450,8 @@ test_that("postprocessFinemappingFits stores outcome_names, coef, and clfsr for p <- 5 L <- 3 R <- 2 - vnames <- paste0("chr1:", 1:p, ":A:G") - cnames <- paste0("cond_", 1:R) + vnames <- paste0("chr1:", seq_len(p), ":A:G") + cnames <- paste0("cond_", seq_len(R)) fake_coef <- matrix(rnorm((p + 1) * R), nrow = p + 1, ncol = R) fake_output <- list( @@ -431,7 +482,9 @@ test_that("postprocessFinemappingFits stores outcome_names, coef, and clfsr for dataY = NULL, xScalar = 1, yScalar = 1, - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) result <- formatFinemappingOutput(post, primaryMethod = "mvsusie") @@ -477,7 +530,7 @@ test_that("formatFinemappingOutput does not duplicate top loci variants", { ) }) -.make_univariate_data <- function( +.makeUnivariateData <- function( seed = 42, n = 300, p = 50, @@ -540,8 +593,8 @@ test_that(".translate_legacy_top_loci_cs_columns leaves existing pip column alon # Reuse the existing local helper. Re-declared inside this block so the file # remains correct whether the unified-section tests are run alone or as part of # the full file. -if (!exists(".make_univariate_data", inherits = FALSE)) { - .make_univariate_data <- function( +if (!exists(".makeUnivariateData", inherits = FALSE)) { + .makeUnivariateData <- function( seed = 42, n = 300, p = 50, @@ -602,7 +655,7 @@ if (!exists(".make_univariate_data", inherits = FALSE)) { # coverage. The CS numbering is 1-based per coverage. PIP values are filled # from `pip` (variants outside the CS get small non-zero PIP so they can be # retained or dropped via `signal_cutoff`). -.fake_fit_and_cs <- function( +.fakeFitAndCs <- function( variant_ids, cs_at_cov, cs_purity_value = 0.85, @@ -630,7 +683,7 @@ if (!exists(".make_univariate_data", inherits = FALSE)) { mu2 = mu2 ) - cs_tables <- lapply(names(cs_at_cov), function(cov_str) { + cs_tables <- map(names(cs_at_cov), function(cov_str) { cs_list <- cs_at_cov[[cov_str]] if (is.null(cs_list)) { cs_list <- list() @@ -660,7 +713,7 @@ if (!exists(".make_univariate_data", inherits = FALSE)) { purity = purity_df ), cs_corr = if (n_cs > 0L) { - lapply(seq_len(n_cs), function(i) { + map(seq_len(n_cs), function(i) { matrix(c(1, cs_purity_value, cs_purity_value, 1), nrow = 2) }) } else { @@ -707,10 +760,12 @@ if (!exists(".make_univariate_data", inherits = FALSE)) { sumstats = sumstats, af = af, method = method, - signalCutoff = signalCutoff, dataY = inp$data_y, otherQuantities = otherQuantities, - region = region + region = region, + credibleSetArgs = CredibleSetParam( + signalCutoff = signalCutoff + ) ) } @@ -972,7 +1027,7 @@ test_that("buildTopLoci: per-variant logBF is the max single-effect lbf", { 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( + inp <- .fakeFitAndCs( variant_ids, cs_at_cov = list( "0.95" = list(c(1L, 2L)), @@ -1005,7 +1060,7 @@ test_that("buildTopLoci: RSS per-variant N threads; list dataY isn't 1", { # as.matrix() collapse to a 1x1 cell, so nrow (and every N) was 1. The # per-variant effective N must instead be threaded into the N column. variant_ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:A:T") - inp <- .fake_fit_and_cs( + inp <- .fakeFitAndCs( variant_ids, cs_at_cov = list( "0.95" = list(c(1L, 2L, 3L)), @@ -1025,8 +1080,10 @@ test_that("buildTopLoci: RSS per-variant N threads; list dataY isn't 1", { af = NULL, n = perVarN, method = "susie", - signalCutoff = 0, - dataY = list(z = rnorm(length(variant_ids))) + dataY = list(z = rnorm(length(variant_ids))), + credibleSetArgs = CredibleSetParam( + signalCutoff = 0 + ) ) ord <- match(variant_ids, out$variant_id) expect_equal(out$N[ord], perVarN) @@ -1039,8 +1096,10 @@ test_that("buildTopLoci: RSS per-variant N threads; list dataY isn't 1", { variantNames = inp$variantNames, af = NULL, method = "susie", - signalCutoff = 0, - dataY = list(z = rnorm(length(variant_ids))) + dataY = list(z = rnorm(length(variant_ids))), + credibleSetArgs = CredibleSetParam( + signalCutoff = 0 + ) ) expect_true(is.numeric(out_na$N)) expect_true(all(is.na(out_na$N))) @@ -1052,7 +1111,7 @@ test_that("buildTopLoci: individual-level vector dataY fills N with nSamples", { # excluded the individual-level path's bare numeric outcome vector -- so # every top_loci N there silently became NA instead of the sample count. variant_ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:A:T") - inp <- .fake_fit_and_cs( + inp <- .fakeFitAndCs( variant_ids, cs_at_cov = list( "0.95" = list(c(1L, 2L, 3L)), @@ -1069,8 +1128,10 @@ test_that("buildTopLoci: individual-level vector dataY fills N with nSamples", { variantNames = inp$variantNames, af = NULL, method = "susie", - signalCutoff = 0, - dataY = y + dataY = y, + credibleSetArgs = CredibleSetParam( + signalCutoff = 0 + ) ) } nSamp <- 49L @@ -1142,21 +1203,20 @@ test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", cst, variantNames = vn, method = "susie", - fullFit = TRUE, - fullFitAlphaOnly = FALSE + credibleSetArgs = CredibleSetParam(perCsColumns = "full") ) 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. + # perCsColumns = "alpha": only alpha widened, both passing CS. tl2 <- buildTopLoci( fit, cst, variantNames = vn, method = "susie", - fullFit = TRUE + credibleSetArgs = CredibleSetParam(perCsColumns = "alpha") ) expect_false(any(grepl("^cs_logbf_|^cs_effect_", names(tl2)))) expect_setequal( @@ -1189,9 +1249,10 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) csTables, variantNames = vn, method = "susie", - signalCutoff = 0, - fullFit = TRUE, - fullFitAlphaOnly = TRUE + credibleSetArgs = CredibleSetParam( + signalCutoff = 0, + perCsColumns = "alpha" + ) )) # within_cs_pip is populated for exactly the CS members, = their L1 alpha. expect_equal(sum(!is.na(tl$within_cs_pip)), length(member)) @@ -1209,9 +1270,10 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) csTables, variantNames = vn, method = "susie", - signalCutoff = 0, - fullFit = TRUE, - fullFitAlphaOnly = FALSE + credibleSetArgs = CredibleSetParam( + signalCutoff = 0, + perCsColumns = "full" + ) )) expect_true(any(grepl("^cs_logbf_|^cs_effect_", names(tlFull)))) @@ -1226,9 +1288,10 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) csTables, variantNames = vn, method = "susie", - signalCutoff = 0, - fullFit = TRUE, - fullFitAlphaOnly = FALSE + credibleSetArgs = CredibleSetParam( + signalCutoff = 0, + perCsColumns = "full" + ) )) expect_false(any(grepl("^cs_logbf_|^cs_effect_", names(tlF)))) expect_true("within_cs_pip_cs1" %in% names(tlF)) @@ -1236,7 +1299,7 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) 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( + inp <- .fakeFitAndCs( variant_ids, cs_at_cov = list( "0.95" = list(c(1L, 2L)), @@ -1255,7 +1318,7 @@ test_that("buildTopLoci exports af (not MAF) and carries the supplied af values" test_that("buildTopLoci sets af = NA when no af is supplied (no silent coercion)", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") - inp <- .fake_fit_and_cs( + inp <- .fakeFitAndCs( variant_ids, cs_at_cov = list( "0.95" = list(c(1L, 2L)), @@ -1281,7 +1344,7 @@ test_that("postprocessFinemappingFits forwards medianAbsCorr to susie_get_cs (OR "median_abs_corr" %in% names(formals(susieR::susie_get_cs)), "installed susieR has no median_abs_corr support" ) - d <- .make_univariate_data(seed = 11, effect_idx = c(10, 35)) + d <- .makeUnivariateData(seed = 11, effect_idx = c(10, 35)) fit <- susieR::susie(d$X, d$y, L = 5) # A very strict min_abs_corr alone vs the same min_abs_corr OR a lenient # median_abs_corr: OR-logic keeps at least as many credible sets. @@ -1289,36 +1352,44 @@ test_that("postprocessFinemappingFits forwards medianAbsCorr to susie_get_cs (OR list(susie = fit), dataX = d$X, dataY = d$y, - coverage = 0.95, - minAbsCorr = 0.999, - medianAbsCorr = NULL + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + minAbsCorr = 0.999, + medianAbsCorr = NULL + ) ) pOr <- postprocessFinemappingFits( list(susie = fit), dataX = d$X, dataY = d$y, - coverage = 0.95, - minAbsCorr = 0.999, - medianAbsCorr = 0.1 + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + minAbsCorr = 0.999, + medianAbsCorr = 0.1 + ) ) expect_gte(.n_cs95(pOr), .n_cs95(pStrict)) }) test_that("postprocessFinemappingFits with medianAbsCorr = NULL is a no-op", { - d <- .make_univariate_data(seed = 7, effect_idx = c(20)) + d <- .makeUnivariateData(seed = 7, effect_idx = c(20)) fit <- susieR::susie(d$X, d$y, L = 5) p1 <- postprocessFinemappingFits( list(susie = fit), dataX = d$X, dataY = d$y, - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) p2 <- postprocessFinemappingFits( list(susie = fit), dataX = d$X, dataY = d$y, - coverage = 0.95, - medianAbsCorr = NULL + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + medianAbsCorr = NULL + ) ) expect_equal(p1$top_loci$cs_95, p2$top_loci$cs_95) expect_equal(p1$top_loci$af, p2$top_loci$af) @@ -1333,7 +1404,7 @@ test_that("cs_95 / cs_70 / cs_50 are character strings of the form '__0' at every coverage and c # No CS at any coverage; variant 2 has high PIP so it is retained via # signal_cutoff and produces a "_0" row. cs_at_cov <- list("0.95" = list(), "0.7" = list(), "0.5" = list()) - inp <- .fake_fit_and_cs(variant_ids, cs_at_cov, pip = c(0.02, 0.95)) + inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = c(0.02, 0.95)) out <- .runBuildTopLoci(inp, method = "susie", signalCutoff = 0.5) expect_gte(nrow(out), 1L) # Every row must have _0 at every coverage and cs_95_purity = 0. @@ -1358,14 +1429,16 @@ test_that("PIP-only retained variants carry '_0' at every coverage and c }) test_that("per-method CS indices are independent across susie and susieInf (postprocessFinemappingFits)", { - d <- .make_univariate_data(seed = 21, effect_idx = c(15, 35)) + d <- .makeUnivariateData(seed = 21, effect_idx = c(15, 35)) fits <- fitSusieInfThenSusie(d$X, d$y) post <- postprocessFinemappingFits( fits, dataX = d$X, dataY = d$y, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5) + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = c(0.7, 0.5) + ) ) tl <- post$top_loci expect_setequal(unique(tl$method), c("susie", "susieInf")) @@ -1397,7 +1470,7 @@ test_that("cs_95_purity = 0 when cs_95 is '_0', and in (0, 1] otherwise" # Variant 1 in CS 1 at 95-cov; variant 2 PIP-only retained; variant 3 # PIP-only retained. cs_at_cov <- list("0.95" = list(1L), "0.7" = list(1L), "0.5" = list(1L)) - inp <- .fake_fit_and_cs( + inp <- .fakeFitAndCs( variant_ids, cs_at_cov, cs_purity_value = 0.85, @@ -1420,7 +1493,7 @@ test_that("overlapping CS within one method: one row per variant; smallest cs_id "0.7" = list(1L, 1L), "0.5" = list(1L, 1L) ) - inp <- .fake_fit_and_cs(variant_ids, cs_at_cov, pip = 0.9) + inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = 0.9) out <- .runBuildTopLoci(inp, method = "susie") # Canonical schema is one row per variant. When a variant is in # multiple CSs at a coverage, the smallest cs_idx is reported. @@ -1431,14 +1504,16 @@ test_that("overlapping CS within one method: one row per variant; smallest cs_id }) test_that("overlapping CS across methods produces one row per method", { - d <- .make_univariate_data(seed = 22, effect_idx = c(12, 32)) + d <- .makeUnivariateData(seed = 22, effect_idx = c(12, 32)) fits <- fitSusieInfThenSusie(d$X, d$y) post <- postprocessFinemappingFits( fits, dataX = d$X, dataY = d$y, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5) + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = c(0.7, 0.5) + ) ) tl <- post$top_loci if (nrow(tl) > 0L) { @@ -1463,13 +1538,15 @@ test_that("overlapping CS across methods produces one row per method", { }) test_that("formatFinemappingOutput exposes exactly one top_loci field; no top_loci_long, no wide top_loci, no top_loci_export", { - d <- .make_univariate_data(seed = 23, effect_idx = c(15, 40)) + d <- .makeUnivariateData(seed = 23, effect_idx = c(15, 40)) fits <- fitSusieInfThenSusie(d$X, d$y) post <- postprocessFinemappingFits( fits, dataX = d$X, dataY = d$y, - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) out <- formatFinemappingOutput(post, primaryMethod = "susie") expect_true("top_loci" %in% names(out)) @@ -1480,13 +1557,15 @@ test_that("formatFinemappingOutput exposes exactly one top_loci field; no top_lo }) test_that("postprocessFinemappingFits does not return top_loci_long anywhere", { - d <- .make_univariate_data(seed = 24, effect_idx = c(25)) + d <- .makeUnivariateData(seed = 24, effect_idx = c(25)) fit <- susieR::susie(d$X, d$y, L = 5) post <- postprocessFinemappingFits( list(susie = fit), dataX = d$X, dataY = d$y, - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) expect_true("top_loci" %in% names(post)) expect_false("top_loci_long" %in% names(post)) @@ -1554,14 +1633,14 @@ test_that("build_top_loci_long / build_top_loci_wide / build_top_loci_export are test_that("buildTopLoci raises an explicit error on invalid variant_id rather than silently filling NA", { variant_ids <- c("not_a_valid_id") cs_at_cov <- list("0.95" = list(1L), "0.7" = list(1L), "0.5" = list(1L)) - inp <- .fake_fit_and_cs(variant_ids, cs_at_cov, pip = 0.9) + inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = 0.9) expect_error(.runBuildTopLoci(inp, method = "susie"), "parseVariantId") }) test_that("buildTopLoci requires `method`", { variant_ids <- c("chr1:100:A:G") cs_at_cov <- list("0.95" = list(1L), "0.7" = list(1L), "0.5" = list(1L)) - inp <- .fake_fit_and_cs(variant_ids, cs_at_cov, pip = 0.9) + inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = 0.9) expect_error( buildTopLoci( fit = inp$fit, @@ -1573,13 +1652,15 @@ test_that("buildTopLoci requires `method`", { }) test_that("formatFinemappingOutput exposes finemappingEntry with S4 accessors", { - d <- .make_univariate_data(seed = 25, effect_idx = c(20)) + d <- .makeUnivariateData(seed = 25, effect_idx = c(20)) fit <- susieR::susie(d$X, d$y, L = 5) post <- postprocessFinemappingFits( list(susie = fit), dataX = d$X, dataY = d$y, - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) out <- formatFinemappingOutput(post, primaryMethod = "susie") expect_true("finemappingEntry" %in% names(out)) @@ -1595,7 +1676,7 @@ test_that("formatFinemappingOutput exposes finemappingEntry with S4 accessors", test_that("missing region produces NA grange columns rather than silent omission", { variant_ids <- c("chr1:100:A:G") cs_at_cov <- list("0.95" = list(1L), "0.7" = list(1L), "0.5" = list(1L)) - inp <- .fake_fit_and_cs(variant_ids, cs_at_cov, pip = 0.9) + inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = 0.9) out <- .runBuildTopLoci( inp, method = "susie", @@ -1616,7 +1697,7 @@ test_that("posterior_mean equals colSums(alpha*mu); posterior_sd equals sqrt(pma "0.7" = list(c(1L, 2L)), "0.5" = list(c(1L, 2L)) ) - inp <- .fake_fit_and_cs(variant_ids, cs_at_cov, pip = c(0.8, 0.6)) + inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = c(0.8, 0.6)) out <- .runBuildTopLoci(inp, method = "susie") expected_mean <- colSums(inp$fit$alpha * inp$fit$mu) expected_se <- sqrt(pmax( @@ -2109,10 +2190,9 @@ test_that("extractVariantNames reads pip names, then alpha colnames, then a fall # ---- extractSumstats ---- test_that("extractSumstats returns NULL / passthrough across non-regression branches", { - expect_null(pecotmr:::extractSumstats(list(), NULL, NULL)) + expect_null(pecotmr:::extractSumstats(NULL, NULL)) expect_equal( pecotmr:::extractSumstats( - list(), NULL, list(z = c(1, 2)), method = "susieRss" @@ -2121,13 +2201,12 @@ test_that("extractSumstats returns NULL / passthrough across non-regression bran ) expect_equal( pecotmr:::extractSumstats( - list(), NULL, list(betahat = c(1, 2), sebetahat = c(0.1, 0.2)) ), list(betahat = c(1, 2), sebetahat = c(0.1, 0.2)) ) - expect_null(pecotmr:::extractSumstats(list(), NULL, c(1, 2, 3))) # dataX NULL + expect_null(pecotmr:::extractSumstats(NULL, c(1, 2, 3))) # dataX NULL expect_null(pecotmr:::extractSumstats( list(), matrix(0, 3, 2), @@ -2141,9 +2220,9 @@ test_that("extractSumstats runs univariate regression and applies x/y scalars", X <- matrix(rnorm(60), 20, 3) colnames(X) <- c("chr1:1:A:G", "chr1:2:A:G", "chr1:3:A:G") y <- X[, 1] * 2 + rnorm(20) - s1 <- pecotmr:::extractSumstats(list(), X, y) + s1 <- pecotmr:::extractSumstats(X, y) expect_named(s1, c("betahat", "sebetahat")) - s2 <- pecotmr:::extractSumstats(list(), X, y, yScalar = 2, xScalar = 1) + s2 <- pecotmr:::extractSumstats(X, y, yScalar = 2, xScalar = 1) expect_equal(s2$betahat, s1$betahat * 2) expect_equal(s2$sebetahat, s1$sebetahat * 2) }) @@ -2163,7 +2242,7 @@ test_that("computeCsTable fsusie branch returns empty sets when no CS", { test_that("computeCsTable X and Xcorr branches return sets/pip", { skip_if_not_installed("susieR") - d <- .make_univariate_data(seed = 7, n = 200, p = 8, effect_idx = c(2)) + d <- .makeUnivariateData(seed = 7, n = 200, p = 8, effect_idx = c(2)) fit <- susieR::susie(d$X, d$y, L = 4) ctx <- pecotmr:::computeCsTable(fit, d$X, coverage = 0.95, csInput = "X") expect_true(all(c("sets", "pip") %in% names(ctx))) @@ -2178,7 +2257,7 @@ test_that("computeCsTable X and Xcorr branches return sets/pip", { test_that("computeCsTables names tables, sets coverage attr, defaults coverage from fit", { skip_if_not_installed("susieR") - d <- .make_univariate_data(seed = 7, n = 200, p = 8, effect_idx = c(2)) + d <- .makeUnivariateData(seed = 7, n = 200, p = 8, effect_idx = c(2)) fit <- susieR::susie(d$X, d$y, L = 4) cts <- pecotmr:::computeCsTables( fit, @@ -2373,8 +2452,10 @@ test_that("postprocessFinemappingFit.susiF post-processes an fsusie fit (empty-C dimnames = list(NULL, c("chr1:100:A:G", "chr1:200:C:T")) ), dataY = NULL, - coverage = 0.95, - otherQuantities = list(condition_id = "ctx") + otherQuantities = list(condition_id = "ctx"), + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) expect_equal(res$method, "fsusie") expect_equal(unique(res$top_loci$method), "fsusie") @@ -2387,14 +2468,16 @@ test_that("postprocessFinemappingFit.susiF post-processes an fsusie fit (empty-C test_that("postprocessFinemappingFit.susieInf labels credible sets with the susie_inf_ prefix", { skip_if_not_installed("susieR") - d <- .make_univariate_data(seed = 7, n = 200, p = 8, effect_idx = c(2)) + d <- .makeUnivariateData(seed = 7, n = 200, p = 8, effect_idx = c(2)) fits <- fitSusieInfThenSusie(d$X, d$y) res <- pecotmr:::postprocessFinemappingFit( fits$susieInf, method = "susieInf", dataX = d$X, dataY = d$y, - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ) ) expect_equal(res$method, "susieInf") expect_gt(nrow(res$top_loci), 0L) @@ -2417,7 +2500,6 @@ test_that(".postprocessFinemappingFitCommon trim=FALSE stores the untrimmed fit" res <- pecotmr:::postprocessFinemappingFit( fit, method = "fsusie", - trim = FALSE, dataX = matrix( 0, 5, @@ -2425,7 +2507,10 @@ test_that(".postprocessFinemappingFitCommon trim=FALSE stores the untrimmed fit" dimnames = list(NULL, c("chr1:100:A:G", "chr1:200:C:T")) ), dataY = NULL, - coverage = 0.95 + credibleSetArgs = CredibleSetParam( + coverage = 0.95 + ), + fitRetention = "full" ) expect_equal( pecotmr:::.fmrPartsSusieFit(res$finemappingEntry)$extra_slot, @@ -2466,7 +2551,7 @@ test_that("formatFinemappingOutput errors when primaryMethod is absent", { # ---- buildTopLoci: marginal z/p passthrough ---- test_that("buildTopLoci passes through marginal z and p supplied in sumstats", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") - inp <- .fake_fit_and_cs( + inp <- .fakeFitAndCs( variant_ids, cs_at_cov = list( "0.95" = list(c(1L, 2L)), @@ -2496,7 +2581,7 @@ test_that("lbfToAlpha handles a single-column matrix", { # ---- fitSusieInfThenSusie ---- test_that("fitSusieInfThenSusie returns classed susie and susieInf fits", { skip_if_not_installed("susieR") - d <- .make_univariate_data(seed = 3, n = 200, p = 8, effect_idx = c(4)) + d <- .makeUnivariateData(seed = 3, n = 200, p = 8, effect_idx = c(4)) fits <- fitSusieInfThenSusie(d$X, d$y) expect_named(fits, c("susie", "susieInf")) expect_true("susie" %in% class(fits$susie)) @@ -2506,7 +2591,7 @@ test_that("fitSusieInfThenSusie returns classed susie and susieInf fits", { test_that("fitSusieInfThenSusie reuses fittedModels without refitting", { skip_if_not_installed("susieR") - d <- .make_univariate_data(seed = 3, n = 200, p = 8, effect_idx = c(4)) + d <- .makeUnivariateData(seed = 3, n = 200, p = 8, effect_idx = c(4)) fits <- fitSusieInfThenSusie(d$X, d$y) again <- fitSusieInfThenSusie( d$X, @@ -2641,13 +2726,11 @@ test_that(".susie_rss_extract_weights returns correct-length vector", { n <- 500 R <- diag(p) z <- rnorm(p) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) w <- pecotmr:::.susieRssExtractWeights( - fit = NULL, - z = z, + fit = fit, R = R, - n = n, - requiredFields = c("alpha", "mu", "X_column_scale_factors"), - userArgs = list(L = 5) + requiredFields = c("alpha", "mu", "X_column_scale_factors") ) expect_equal(length(w), p) expect_true(all(is.finite(w))) @@ -2661,12 +2744,13 @@ test_that("susieRssWeights follows (stat, LD) convention", { R <- diag(p) z <- rnorm(p) stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) - w <- susieRssWeights(stat, R, methodArgs = list(L = 5)) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) + w <- susieRssWeights(stat, R, susieRssFit = fit) expect_equal(length(w), p) expect_true(all(is.finite(w))) }) -test_that("susieRssWeights retains fit when retainFit = TRUE", { +test_that("susieRssWeights retains fit unless fitRetention is none", { skip_if_not_installed("susieR") set.seed(42) p <- 20 @@ -2674,7 +2758,8 @@ test_that("susieRssWeights retains fit when retainFit = TRUE", { R <- diag(p) z <- rnorm(p) stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) - w <- susieRssWeights(stat, R, retainFit = TRUE, methodArgs = list(L = 5)) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) + w <- susieRssWeights(stat, R, susieRssFit = fit, fitRetention = "slim") expect_false(is.null(attr(w, "fit"))) }) @@ -2686,7 +2771,8 @@ test_that("susieInfRssWeights works", { R <- diag(p) z <- rnorm(p) stat <- list(b = z / sqrt(n), cor = z / sqrt(n), z = z, n = rep(n, p)) - w <- susieInfRssWeights(stat, R, methodArgs = list(L = 5)) + fit <- susieR::susie_rss(z = z, R = R, n = n, L = 5) + w <- susieInfRssWeights(stat, R, susieInfRssFit = fit) expect_equal(length(w), p) expect_true(all(is.finite(w))) }) @@ -2712,47 +2798,77 @@ test_that("mvsusieWeights real fit returns p x K weights or errors on unstable s test_that("susieAshRssWeights returns weights of length p", { skip_if_not_installed("susieR") f <- .rrwStatLd() - w <- susieAshRssWeights(f$stat, f$LD, methodArgs = list(L = 5)) + fit <- susieR::susie_rss( + z = f$stat$z, + R = f$LD, + n = median(f$stat$n), + L = 5 + ) + w <- susieAshRssWeights(f$stat, f$LD, susieAshRssFit = fit) expect_length(w, f$p) expect_true(all(is.finite(w))) }) -test_that("mvsusieRssWeights fits mvsusie_rss and returns p x K weights", { +test_that("mvsusieRssWeights returns p x K weights from a supplied fit", { skip_if_not_installed("mvsusieR") m <- .rrwMulti(n = 80, p = 8, K = 2) - # LGreedy stays at its NULL default: mvsusieR's greedy-L loop errors on - # small data ("Values and their weights should have equal length"), which - # is why the greedy loop is off unless a caller asks for it. - w <- mvsusieRssWeights(m$stat, m$LD, L = 5) + fakeCoef <- matrix(rnorm((m$p + 1) * m$K), nrow = m$p + 1, ncol = m$K) + local_mocked_bindings( + coef.mvsusie = function(...) fakeCoef, + .package = "mvsusieR" + ) + w <- mvsusieRssWeights(m$stat, m$LD, mvsusieRssFit = "precomputed_fit") expect_equal(dim(w), c(m$p, m$K)) expect_true(all(is.finite(w))) }) -test_that("mvsusieRssWeights forwards L / clamped LGreedy to mvsusie_rss", { +test_that("mvsusieRssWeights checks the fit against the LD block", { skip_if_not_installed("mvsusieR") + # It takes (stat, LD) like every other *RssWeights wrapper, and used to + # read NEITHER -- a fit from a different block was extracted without + # complaint. The susie siblings have always checked this. m <- .rrwMulti(n = 80, p = 8, K = 2) fakeCoef <- matrix(rnorm((m$p + 1) * m$K), nrow = m$p + 1, ncol = m$K) - captured <- list() local_mocked_bindings( - create_mixture_prior = function(...) list(), - mvsusie_rss = function(...) { - captured <<- list(...) - "mock_fit" - }, coef.mvsusie = function(...) fakeCoef, .package = "mvsusieR" ) - w <- mvsusieRssWeights(m$stat, m$LD, L = 3, LGreedy = 7) - expect_equal(dim(w), c(m$p, m$K)) - expect_equal(captured$L, 3) - expect_equal(captured$L_greedy, 3) # clamped to min(LGreedy, L) + # An LD block of the wrong size cannot belong to this fit. + expect_error( + mvsusieRssWeights( + m$stat, + m$LD[seq_len(m$p - 1), seq_len(m$p - 1), drop = FALSE], + mvsusieRssFit = "precomputed_fit" + ), + "Dimension mismatch: mvsusieRss fit has 8 variants but LD has 7" + ) + # `stat` is validated as the list the contract says it is. + expect_error( + mvsusieRssWeights("not-a-list", m$LD, mvsusieRssFit = "f"), + "stat" + ) }) -test_that("mvsusieRssWeights errors on single-context stat$z", { +test_that("mvsusieRssWeights refuses to fine-map when no fit is supplied", { + skip_if_not_installed("mvsusieR") + m <- .rrwMulti(n = 80, p = 8, K = 2) + expect_error( + mvsusieRssWeights(m$stat, m$LD), + "`mvsusieRssFit` is required" + ) +}) + +test_that("mvsusieRssWeights demands a fit before anything else", { skip_if_not_installed("mvsusieR") f <- .rrwStatLd() oneCol <- list(z = matrix(f$stat$z, ncol = 1), n = f$n) - expect_error(mvsusieRssWeights(oneCol, f$LD), ">= 2 columns") + # The old ">= 2 columns" guard validated *fitting* inputs and left with + # the fitting branch; with no fit supplied, the missing fit is the + # fundamental problem and `stat` is not read at all. + expect_error( + mvsusieRssWeights(oneCol, f$LD), + "`mvsusieRssFit` is required" + ) }) # ---- mvsusieWeights ---- @@ -2762,60 +2878,20 @@ test_that("mvsusieWeights errors when mvsusieR package is not available", { "mvsusieR is installed; skipping missing-package test" ) - expect_error( - mvsusieWeights( - mvsusieFit = NULL, - X = matrix(1, 10, 5), - Y = matrix(1, 10, 3) - ), - "mvsusieR" - ) + expect_error(mvsusieWeights(mvsusieFit = NULL), "mvsusieR") }) -test_that("mvsusieWeights errors when X and Y are NULL and fit is NULL", { +test_that("mvsusieWeights refuses to fine-map when no fit is supplied", { skip_if_not( requireNamespace("mvsusieR", quietly = TRUE), "mvsusieR not installed" ) + # mvSuSiE fitting belongs to fineMappingPipeline(); this extractor must + # not silently refit when the caller forgets the fit. expect_error( - mvsusieWeights(mvsusieFit = NULL, X = NULL, Y = NULL), - "Both X and Y must be provided" - ) -}) - -test_that("mvsusieWeights fits model and returns coefficients when fit is NULL", { - skip_if_not( - requireNamespace("mvsusieR", quietly = TRUE), - "mvsusieR not installed" + mvsusieWeights(mvsusieFit = NULL), + "`mvsusieFit` is required" ) - set.seed(42) - n <- 30 - p <- 5 - R <- 3 - X <- matrix(rnorm(n * p), n, p) - Y <- matrix(rnorm(n * R), n, R) - fake_coef <- matrix(rnorm((p + 1) * R), nrow = p + 1, ncol = R) - captured <- list() - - local_mocked_bindings( - create_mixture_prior = function(...) list(), - mvsusie = function(...) { - captured <<- list(...) - "mock_fit" - }, - coef.mvsusie = function(...) fake_coef, - .package = "mvsusieR" - ) - - result <- expect_message( - mvsusieWeights(X = X, Y = Y, L = 12, LGreedy = 4), - "mvsusieFit is not provided" - ) - # Should return coef without intercept row - expect_equal(dim(result), c(p, R)) - expect_equal(result, fake_coef[-1, ]) - expect_equal(captured$L, 12) - expect_equal(captured$L_greedy, 4) }) test_that("mvsusieWeights returns coefficients from provided fit", { @@ -2837,8 +2913,13 @@ test_that("mvsusieWeights returns coefficients from provided fit", { expect_equal(result, fake_coef[-1, ]) }) -.fw_makeFsusieFit <- function(seed = 1, n = 150L, p = 24L, J = 16L, - prior = "mixture_normal_per_scale") { +.fw_makeFsusieFit <- function( + seed = 1, + n = 150L, + p = 24L, + J = 16L, + prior = "mixture_normal_per_scale" +) { set.seed(seed) X <- matrix( rnorm(n * p), @@ -2846,7 +2927,7 @@ test_that("mvsusieWeights returns coefficients from provided fit", { p, dimnames = list( paste0("s", seq_len(n)), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) ) b1 <- sin(seq(0, 2 * pi, length.out = J)) @@ -3476,9 +3557,7 @@ test_that("susieRss weight extraction rejects a fit that does not match R", { expect_error( pecotmr:::.susieRssExtractWeights( fit = list(pip = c(0.1, 0.2)), - z = c(1, 2, 3), R = diag(3), - n = 100, requiredFields = c("alpha", "mu") ), "Dimension mismatch: susieRss fit has 2 variants but R has 3 rows" @@ -3490,9 +3569,7 @@ test_that("susieRss weights are zero when the fit lacks the coefficient fields", # contribution is zero rather than an error or a partial answer. w <- pecotmr:::.susieRssExtractWeights( fit = list(pip = c(0.1, 0.2, 0.3)), - z = c(1, 2, 3), R = diag(3), - n = 100, requiredFields = c("alpha", "mu", "X_column_scale_factors") ) expect_equal(w, c(0, 0, 0)) @@ -3501,11 +3578,9 @@ test_that("susieRss weights are zero when the fit lacks the coefficient fields", test_that("susieRss weights carry the fit when asked to retain it", { w <- pecotmr:::.susieRssExtractWeights( fit = list(pip = c(0.1, 0.2, 0.3)), - z = c(1, 2, 3), R = diag(3), - n = 100, requiredFields = "absentField", - retainFit = TRUE + fitRetention = "slim" ) expect_false(is.null(attr(w, "fit"))) expect_equal(attr(w, "fit")$pip, c(0.1, 0.2, 0.3)) @@ -3817,7 +3892,7 @@ test_that("the fsusie fast path uses a trimmed fit's precomputed coef", { W <- pecotmr:::.fsusieWeightsFastPath( list(coef = cf, fitted_wc = NULL), c("a", "b", "c"), - retainFit = TRUE + fitRetention = "slim" ) expect_equal(rownames(W), c("a", "b", "c")) expect_false(is.null(attr(W, "fit"))) @@ -3825,7 +3900,7 @@ test_that("the fsusie fast path uses a trimmed fit's precomputed coef", { expect_null(pecotmr:::.fsusieWeightsFastPath( list(coef = cf, fitted_wc = list(1)), c("a", "b", "c"), - retainFit = FALSE + fitRetention = "none" )) }) @@ -3843,20 +3918,76 @@ test_that("susieInf is skipped as a result when it was only a chain input", { # from, but keepInf is FALSE so it must not surface as its own method. chainOnly <- pecotmr:::.fmResolveSusieChain("susie", TRUE) expect_false(chainOnly$keepInf) - expect_null(pecotmr:::.fmXFitOne("susieInf", list(), chainOnly, "INFFIT")) - expect_null(pecotmr:::.fmRssFitOne("susieInf", list(), chainOnly, "INFFIT")) + expect_null(pecotmr:::.fmXFitOne( + "susieInf", + chainOnly, + "INFFIT", + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )) + expect_null(pecotmr:::.fmRssFitOne( + "susieInf", + chainOnly, + "INFFIT", + z = NULL, + R = NULL, + n = 100L, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + label = "lab", + rssArgs = SusieRssParam( + rFinite = NULL, + rMismatch = NULL, + control = NULL, + serFallback = FALSE + ) + )) }) test_that("susieInf is returned as its own fit when it was requested", { asked <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) expect_true(asked$keepInf) expect_equal( - pecotmr:::.fmXFitOne("susieInf", list(), asked, "INFFIT"), + pecotmr:::.fmXFitOne( + "susieInf", + asked, + "INFFIT", + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + ), "INFFIT" ) - rss <- pecotmr:::.fmRssFitOne("susieInf", list(), asked, "INFFIT") - expect_equal(rss$fit, "INFFIT") - expect_false(rss$isStd) + rssArgs <- pecotmr:::.fmRssFitOne( + "susieInf", + asked, + "INFFIT", + z = NULL, + R = NULL, + n = 100L, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + label = "lab", + rssArgs = SusieRssParam( + rFinite = NULL, + rMismatch = NULL, + control = NULL, + serFallback = FALSE + ) + ) + expect_equal(rssArgs$fit, "INFFIT") + expect_false(rssArgs$isStd) }) @@ -3901,8 +4032,10 @@ test_that("includeAllCs widens to every effect rather than the kept ones", { scale = c(1, 1), primaryCsPos = c(0L, 1L), effectOf = c(1L, 2L), - fullFit = TRUE, - includeAllCs = TRUE + credibleSetArgs = CredibleSetParam( + includeAllCs = TRUE, + perCsColumns = "alpha" + ) ) expect_equal(nrow(out), 2L) expect_gt(ncol(out), 1L) @@ -3912,9 +4045,8 @@ test_that("susie weight extraction can carry the fit alongside the weights", { w <- pecotmr:::.susieExtractWeights( fit = list(pip = c(0.1, 0.2)), X = NULL, - y = NULL, requiredFields = "absentField", - retainFit = TRUE + fitRetention = "slim" ) expect_equal(attr(w, "fit")$pip, c(0.1, 0.2)) # Without the required fields the weights are zero, not an error. @@ -3980,37 +4112,74 @@ test_that("no credible sets leaves the conditional lfsr untouched", { test_that(".fmXFitOne threads the shared susieInf fit into chained tokens", { local_mocked_bindings( - .fmFitSusieIndiv = function(X, y, tk, chainFromInf, coverage, - userArgs) { + .fmFitSusieIndiv = function( + X, + y, + tk, + chainFromInf, + coverage, + userArgs + ) { list(tk = tk, chained = !is.null(chainFromInf)) }, .package = "pecotmr" ) - p <- list( - X = NULL, y = NULL, verbose = 0, coverage = 0.95, - methodArgs = list(), ctx = "c1", tid = "t1" - ) chain <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) expect_true(chain$chainSusie) - expect_true(pecotmr:::.fmXFitOne("susie", p, chain, list(S = TRUE))$chained) + expect_true( + pecotmr:::.fmXFitOne( + "susie", + chain, + list(S = TRUE), + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )$chained + ) # susieAsh is not in this chain, so it fits from scratch. expect_false( - pecotmr:::.fmXFitOne("susieAsh", p, chain, list(S = TRUE))$chained + pecotmr:::.fmXFitOne( + "susieAsh", + chain, + list(S = TRUE), + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )$chained ) chainAsh <- pecotmr:::.fmResolveSusieChain(c("susieAsh", "susieInf"), TRUE) expect_true( - pecotmr:::.fmXFitOne("susieAsh", p, chainAsh, list(S = TRUE))$chained + pecotmr:::.fmXFitOne( + "susieAsh", + chainAsh, + list(S = TRUE), + X = NULL, + y = NULL, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + ctx = "c1", + tid = "t1" + )$chained ) }) test_that(".fmFitXBlock skips a token that produced no fit", { local_mocked_bindings( - .fmXInfFit = function(p, chainLocal) NULL, - .fmXFitOne = function(tk, p, chainLocal, infFit) { + .fmXInfFit = function(chainLocal, ...) NULL, + .fmXFitOne = function(tk, chainLocal, infFit, ...) { if (tk == "susie") NULL else list(tk = tk) }, - .fmXPostprocess = function(fit, tk, p) list(done = tk), - .fmXCrossValidate = function(out, p) out, + .fmXPostprocess = function(fit, tk, ...) list(done = tk), + .fmXCrossValidate = function(out, ...) out, .package = "pecotmr" ) out <- pecotmr:::.fmFitXBlock( @@ -4025,33 +4194,56 @@ test_that(".fmFitXBlock skips a token that produced no fit", { test_that(".fmRssFitStd threads the shared susieInf fit when chained", { local_mocked_bindings( - .fmFitSusieRss = function(z, R, n, tk, chainFromInf, coverage, - userArgs, rFinite, rMismatch, rssControl) { + .fmFitSusieRss = function( + z, + R, + n, + tk, + chainFromInf, + coverage, + userArgs, + rFinite, + rMismatch, + rssControl, + ... + ) { list(tk = tk, chained = !is.null(chainFromInf)) }, .package = "pecotmr" ) - p <- list( - z = NULL, R = NULL, n = 100L, verbose = 0, coverage = 0.95, - methodArgs = list(), label = "lab", rFinite = NULL, - rMismatch = NULL, rssControl = NULL - ) chain <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) - out <- pecotmr:::.fmRssFitStd("susie", p, chain, list(S = TRUE)) + out <- pecotmr:::.fmRssFitStd( + "susie", + chain, + list(S = TRUE), + z = NULL, + R = NULL, + n = 100L, + coverage = 0.95, + methodArgs = list(), + verbose = 0, + label = "lab", + rssArgs = SusieRssParam( + rFinite = NULL, + rMismatch = NULL, + control = NULL, + serFallback = FALSE + ) + ) expect_true(out$fit$chained) }) test_that(".fmFitRssBlock skips a token that produced no fit", { local_mocked_bindings( - .fmRssInfFit = function(p, chainLocal) NULL, - .fmRssFitOne = function(tk, p, chainLocal, infFit) { + .fmRssInfFit = function(chainLocal, ...) NULL, + .fmRssFitOne = function(tk, chainLocal, infFit, ...) { if (tk == "susie") { NULL } else { list(fit = list(tk = tk), isStd = FALSE) } }, - .fmRssPostprocess = function(fit, p) list(done = fit$tk), + .fmRssPostprocess = function(fit, ...) list(done = fit$tk), .package = "pecotmr" ) out <- pecotmr:::.fmFitRssBlock( @@ -4066,7 +4258,7 @@ test_that(".fmFitRssBlock skips a token that produced no fit", { test_that("computeCsTables falls back to 0.95 when nothing supplies coverage", { skip_if_not_installed("susieR") - d <- .make_univariate_data(seed = 7, n = 200, p = 8, effect_idx = c(2)) + d <- .makeUnivariateData(seed = 7, n = 200, p = 8, effect_idx = c(2)) fit <- susieR::susie(d$X, d$y, L = 4) # Neither the argument nor the fit names a coverage. fit$sets$requested_coverage <- NULL @@ -4088,30 +4280,39 @@ test_that(".ppAssembleRes records sample names from a matrix dataY", { nrow = 3L, dimnames = list(c("s1", "s2", "s3"), c("a", "b")) ) - p <- list( - signalCutoff = 0, method = "susie", dataY = Y, - fit = list(), otherQuantities = NULL - ) topLoci <- data.frame( variant_id = "chr1:1:A:G", pip = 0.9, stringsAsFactors = FALSE ) - res <- pecotmr:::.ppAssembleRes(p, topLoci, NULL, NULL) + res <- pecotmr:::.ppAssembleRes( + topLoci, + NULL, + NULL, + fit = list(), + method = "susie", + dataY = Y, + otherQuantities = NULL, + signalCutoff = 0 + ) expect_equal(res$sampleNames, c("s1", "s2", "s3")) # A list dataY (multi-context) has no single sample vector to record. expect_null(pecotmr:::.sampleNamesFromDataY(list(Y))) }) -test_that(".btlParseVariants surfaces a parse failure as an error", { +test_that(".btlParseVariants surfaces a parse failure as a chained error", { local_mocked_bindings( parseVariantId = function(...) stop("boom"), .package = "pecotmr" ) - expect_error( + cnd <- expect_error( pecotmr:::.btlParseVariants("chr1:1:A:G"), - "buildTopLoci: parseVariantId failed: boom" + "buildTopLoci: parseVariantId failed" ) + # try_fetch(parent = cnd) keeps the cause as a real condition rather than + # flattening it into the message, so the original is still reachable. + expect_s3_class(cnd$parent, "condition") + expect_match(conditionMessage(cnd$parent), "boom") }) test_that(".btlParseVariants requires one parsed row per variant", { @@ -4242,7 +4443,7 @@ test_that("fsusieWeights attaches the fit only when asked", { kept <- fsusieWeights( fsusieFit = obj$fit, variantIds = colnames(obj$X), - retainFit = TRUE + fitRetention = "slim" ) expect_false(is.null(attr(kept, "fit"))) plain <- fsusieWeights(fsusieFit = obj$fit, variantIds = colnames(obj$X)) @@ -4252,8 +4453,16 @@ test_that("fsusieWeights attaches the fit only when asked", { test_that("mvsusieRssWeights attaches the fit only when asked", { skip_if_not_installed("mvsusieR") m <- .rrwMulti(n = 80, p = 8, K = 2) - kept <- suppressMessages( - mvsusieRssWeights(m$stat, m$LD, L = 5, retainFit = TRUE) + fakeCoef <- matrix(rnorm((m$p + 1) * m$K), nrow = m$p + 1, ncol = m$K) + local_mocked_bindings( + coef.mvsusie = function(...) fakeCoef, + .package = "mvsusieR" + ) + kept <- mvsusieRssWeights( + m$stat, + m$LD, + mvsusieRssFit = "precomputed_fit", + fitRetention = "slim" ) expect_false(is.null(attr(kept, "fit"))) expect_equal(dim(kept), c(m$p, m$K)) @@ -4313,3 +4522,753 @@ test_that("mergeSusieCs returns NULL when the combined table is empty", { # Rows were extracted, but combining them produced nothing to merge. expect_null(mergeSusieCs(res, coverage = 0.95)) }) + +test_that("susie*Weights: fitRetention / stat / methodArgs guards fire", { + # Each guard is the first statement, so the remaining arguments stay + # unforced and can be left as placeholders. + expect_error( + susieWeights(fitRetention = NA), + "must be a character vector" + ) + expect_error( + susieAshWeights(fitRetention = 1L), + "must be a character vector" + ) + expect_error( + susieInfWeights(fitRetention = "sometimes"), + "must be one of" + ) + expect_error( + susieRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + susieInfRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + susieAshRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) +}) + +test_that("mvsusie / fsusie wrappers: numeric guards fire", { + expect_error( + fitMvsusie(NULL, NULL, NULL, coverage = 2), + "coverage.*is not <= 1" + ) + expect_error( + fitMvsusieRss(NULL, NULL, N = -1, NULL), + "N.*is not >= 0" + ) + expect_error( + fitMvsusieRss(NULL, NULL, N = 100, NULL, coverage = -1), + "coverage.*is not >= 0" + ) + expect_error( + fsusieGetCs(NULL, NULL, requestedCoverage = 2), + "requestedCoverage.*is not <= 1" + ) +}) + +test_that("fitSusieInfThenSusieRss: argument guards fire", { + expect_error( + fitSusieInfThenSusieRss(z = "nope", R = NULL, n = 100), + "z.*Must be of type 'numeric'" + ) + expect_error( + fitSusieInfThenSusieRss(z = 1, R = NULL, n = -1), + "n.*is not >= 0" + ) + expect_error( + fitSusieInfThenSusieRss(z = 1, R = NULL, n = 1, args = 1L), + "must be built with SusieOptions" + ) + # A bare list is the case the constructors exist to refuse: it cannot be + # checked, so a misspelling would reach susieR and be ignored. + expect_error( + fitSusieInfThenSusieRss( + z = 1, + R = NULL, + n = 1, + SusieInfOptions = list(L = 5) + ), + "must be built with SusieInfOptions" + ) + expect_error( + fitSusieInfThenSusieRss( + z = 1, + R = NULL, + n = 1, + SusieOptions = SusieOptions(nope = 1) + ), + "unknown argument" + ) + expect_error( + fitSusieInfThenSusieRss( + z = 1, + R = NULL, + n = 1, + fittedModels = 1L + ), + "fittedModels.*Must be of type 'list'" + ) +}) + +test_that(".fmwConcat answers an empty list for no pieces", { + expect_identical(pecotmr:::.fmwConcat(list()), list()) +}) + +test_that(".ufOverlapPairs needs at least two sets to form a pair", { + expect_identical(pecotmr:::.ufOverlapPairs(list()), list()) + expect_identical(pecotmr:::.ufOverlapPairs(list(1L)), list()) +}) + +test_that(".btlPrimaryEffects answers integer(0) with no primary CS", { + # No coverage values at all, and a coverage that matches no CS: both mean + # there is no primary set whose effects could be named. + expect_identical( + pecotmr:::.btlPrimaryEffects( + c(0.95), + list(covSorted = numeric(0)), + list() + ), + integer(0) + ) + expect_identical( + pecotmr:::.btlPrimaryEffects(c(0.95), list(covSorted = 0.5), list()), + integer(0) + ) +}) + +test_that(".btlCondLfsrForSet answers NULL for an unusable effect index", { + clf <- array(0, dim = c(1L, 2L, 1L)) + # effect index out of range for clf's first dimension + expect_null( + pecotmr:::.btlCondLfsrForSet(1L, list(1L), c(99L), clf, 1L, 2L) + ) + # in range, but the set names no variant inside 1..nV + expect_null( + pecotmr:::.btlCondLfsrForSet(1L, list(integer(0)), c(1L), clf, 1L, 2L) + ) +}) + +test_that("serWeights extracts weights from a single-effect fit", { + skip_if_not_installed("susieR") + # `ser` was listed in .twasFineMappingTokens() but had no implementation + # and no .twasMethodMap entry, so requesting it produced a stub that + # dispatch could not satisfy. The SER model carries the same + # alpha/mu/X_column_scale_factors structure as a SuSiE fit -- with one + # row of alpha -- so extraction is the same operation. + set.seed(1) + nObs <- 200L + nVar <- 20L + X <- matrix(rnorm(nObs * nVar), nObs, nVar) + y <- X[, 3] * 0.5 + rnorm(nObs) + z <- map_dbl( + seq_len(nVar), + function(j) summary(stats::lm(y ~ X[, j]))$coefficients[2, 3] + ) + fit <- suppressWarnings(susieR::susie_ser(z = z, n = nObs)) + expect_true(all( + is_in(c("alpha", "mu", "X_column_scale_factors"), names(fit)) + )) + expect_equal(nrow(fit$alpha), 1L) + + w <- serWeights(serFit = fit) + expect_length(w, nVar) + expect_false(all(w == 0)) + expect_equal(which.max(abs(w)), 3L) + + # X is only a dimension cross-check, and optional. + expect_equal(serWeights(X = X, serFit = fit), w) + expect_error( + serWeights(X = X[, 1:5], serFit = fit), + "Dimension mismatch" + ) + # Shares the fit-derived extractors' message, naming its own token. + expect_error(serWeights(), "no 'ser' fit supplied") +}) + +test_that("ser is reachable as a TWAS method", { + # It is fit-derived like susie/mvsusie, so it carries no learner + # arguments and its entry is an empty stub. + expect_true(is_in("ser", names(pecotmr:::.twasMethodMap))) + expect_equal(pecotmr:::.twasMethodMap$ser$impl, "serWeights") + expect_length(pecotmr:::.twasMethodMap$ser$args, 0L) + expect_setequal( + pecotmr:::.twasNormalizeMethods(c("ser", "lasso"))$tokens, + c("ser", "lasso") + ) + # Nothing to configure, same as the other fit-derived methods. + expect_error( + TwasWeightsMethodsParam( + qtlSumStatsMethods = list(ser = list(nope = 1)) + ), + "nothing to configure here" + ) +}) + +test_that(".fmSerScreen: disables on 0, skips no-signal, keeps signal + adaptive", { + skip_if_not_installed("susieR") + set.seed(1) + n <- 150L + p <- 25L + X <- matrix(rnorm(n * p), n, p) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) + yNull <- rnorm(n) # no association + ySig <- X[, 1] * 2 + rnorm(n, sd = 0.3) # strong single effect at v1 + fn <- function(...) suppressMessages(pecotmr:::.fmSerScreen(...)) + expect_true(fn(X, yNull, 0)) # cutoff 0 disables -> always keep + expect_false(fn(X, yNull, 0.5)) # no PIP that high -> skip + expect_true(fn(X, ySig, 0.5)) # strong signal clears 0.5 -> keep + expect_true(fn(X, ySig, -1)) # adaptive 3/p: signal keeps + expect_false(fn(X, yNull, -1)) # adaptive 3/p: null skips + expect_true(fn(X, yNull, NA)) # malformed cutoff -> advisory keep +}) + +test_that(".buildMvsusieReweightedPrior: canonical fallback when no usable fit", { + bp <- function(...) pecotmr:::.buildMvsusieReweightedPrior(...) + # No fit at all -> canonical prior, residualVariance NULL. + p1 <- bp(NULL, c("c1", "c2")) + expect_false(is.null(p1$priorVariance)) + expect_null(p1$residualVariance) + # Fit with no data-driven matrices -> canonical prior, but V carried through. + p2 <- bp(list(dataDrivenPriorMatrices = NULL, V = diag(2)), c("c1", "c2")) + expect_equal(p2$residualVariance, diag(2)) +}) + +test_that(".buildMvsusieReweightedPrior: reweights matrices by rescaleCovW0(w0)", { + ddpm <- list( + U = list(compA = diag(2), compB = diag(2) * 2), + w = c(compA = 0.5, compB = 0.5) + ) + fit <- list( + dataDrivenPriorMatrices = ddpm, + w0 = c(compA_grid1 = 0.3, compB_grid1 = 0.7), + V = diag(2) * 3 + ) + captured <- NULL + # rescaleCovW0 collapses expanded w0 onto the original matrix names; mock it + # so the test asserts the wiring, not rescaleCovW0's internals. + local_mocked_bindings( + rescaleCovW0 = function(w0) c(compA = 0.4, compB = 0.6), + .package = "pecotmr" + ) + local_mocked_bindings( + create_mixture_prior = function(...) { + captured <<- list(...) + "PRIOR" + }, + .package = "mvsusieR" + ) + res <- pecotmr:::.buildMvsusieReweightedPrior( + fit, + c("c1", "c2"), + weightsTol = 1e-8 + ) + expect_identical(res$priorVariance, "PRIOR") + expect_equal(res$residualVariance, diag(2) * 3) + expect_equal(captured$mixture_prior$weights, c(compA = 0.4, compB = 0.6)) + expect_equal(names(captured$mixture_prior$matrices), c("compA", "compB")) + expect_equal(captured$include_indices, c("c1", "c2")) + expect_equal(captured$weights_tol, 1e-8) +}) + +test_that(".buildMvsusieReweightedPrior: overrideU swaps matrices, keeps fit w0/V", { + fit <- list( + dataDrivenPriorMatrices = list(U = list(K = diag(2)), w = c(K = 1)), + w0 = c(K_grid1 = 1), + V = diag(2) * 7 + ) + override <- list(U = list(K = diag(2) * 5)) + captured <- NULL + local_mocked_bindings( + rescaleCovW0 = function(w0) c(K = 1), + .package = "pecotmr" + ) + local_mocked_bindings( + create_mixture_prior = function(...) { + captured <<- list(...) + "PRIOR" + }, + .package = "mvsusieR" + ) + res <- pecotmr:::.buildMvsusieReweightedPrior( + fit, + c("c1", "c2"), + overrideU = override + ) + expect_equal(captured$mixture_prior$matrices$K, diag(2) * 5) # the override U + expect_equal(res$residualVariance, diag(2) * 7) # the fit's own V +}) + +test_that(".fmSerScreen supports absZ / bf / logBf metrics and the legacy pip scalar", { + skip_if_not_installed("susieR") + set.seed(11) + n <- 200L + p <- 6L + X <- matrix(stats::rnorm(n * p), n, p) + yStrong <- X[, 2] * 0.6 + stats::rnorm(n) # column 2 strongly associated + yNull <- stats::rnorm(n) # no association + + # absZ: max marginal |z| (no susie fit). + expect_true(pecotmr:::.fmSerScreen( + X, + yStrong, + list(metric = "absZ", cutoff = 3) + )) + expect_false(pecotmr:::.fmSerScreen( + X, + yNull, + list(metric = "absZ", cutoff = 3) + )) + # bf / logBf from the L = 1 susie lbf_variable. + expect_true(pecotmr:::.fmSerScreen( + X, + yStrong, + list(metric = "logBf", cutoff = 2) + )) + expect_false(pecotmr:::.fmSerScreen( + X, + yNull, + list(metric = "logBf", cutoff = 5) + )) + expect_true(pecotmr:::.fmSerScreen( + X, + yStrong, + list(metric = "bf", cutoff = 10) + )) + # Legacy scalar spec still screens on PIP; 0 disables (always keep). + expect_true(pecotmr:::.fmSerScreen(X, yStrong, 0.5)) + expect_true(pecotmr:::.fmSerScreen(X, yNull, 0)) + # Too few samples -> advisory fallback (keep by default). + expect_true(pecotmr:::.fmSerScreen( + X[1, , drop = FALSE], + yStrong[1], + list(metric = "absZ", cutoff = 3) + )) +}) + +test_that(".fmFitSusieSer calls susieR::susie_ser with z + n and no R / L", { + captured <- new.env(parent = emptyenv()) + local_mocked_bindings( + susie_ser = function(z, n, coverage = 0.95, ...) { + captured$args <- list( + z = z, + n = n, + coverage = coverage, + dots = list(...) + ) + list(pip = rep(0.1, length(z))) + }, + .package = "susieR" + ) + fit <- pecotmr:::.fmFitSusieSer(z = rnorm(5), n = 1000) + expect_equal(captured$args$n, 1000) + expect_length(captured$args$z, 5) + expect_null(captured$args$dots$R) + expect_null(captured$args$dots$L) + expect_true("susieRss" %in% class(fit)) +}) + +test_that(".fmFitSusieIndiv: susieInf branch passes convergence_method='pip', refine=FALSE, model_init=NULL", { + captured <- new.env(parent = emptyenv()) + X <- matrix(rnorm(20), 10, 2) + y <- rnorm(10) + local_mocked_bindings( + susie = .fmp_capturingSusie(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieIndiv(X, y, "susieInf") + expect_equal(captured$lastArgs$convergence_method, "pip") + expect_false(captured$lastArgs$refine) + expect_null(captured$lastArgs$model_init) + expect_equal(captured$lastArgs$unmappable_effects, "inf") +}) + +test_that(".fmFitSusieIndiv: chained branch (chainFromInf) propagates susieInf fit as model_init", { + captured <- new.env(parent = emptyenv()) + X <- matrix(rnorm(20), 10, 2) + y <- rnorm(10) + # Build a stub susieInf fit with a V slot so prepareSusieFromInfArgs can read L. + infFit <- list(V = c(0.1, 0.2)) + local_mocked_bindings( + susie = .fmp_capturingSusie(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieIndiv(X, y, "susie", chainFromInf = infFit) + # prepareSusieFromInfArgs writes the susieInf fit into model_init and + # sets unmappable_effects to "none" for the `susie` token. + expect_identical(captured$lastArgs$model_init, infFit) + expect_equal(captured$lastArgs$unmappable_effects, "none") +}) + +test_that(".fmFitSusieIndiv: chained susieAsh branch sets unmappable_effects='ash'", { + captured <- new.env(parent = emptyenv()) + X <- matrix(rnorm(20), 10, 2) + y <- rnorm(10) + infFit <- list(V = c(0.1, 0.2)) + local_mocked_bindings( + susie = .fmp_capturingSusie(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieIndiv(X, y, "susieAsh", chainFromInf = infFit) + expect_equal(captured$lastArgs$unmappable_effects, "ash") + expect_identical(captured$lastArgs$model_init, infFit) +}) + +test_that(".fmFitSusieIndiv: unchained susieAsh branch sets convergence_method='pip'", { + captured <- new.env(parent = emptyenv()) + X <- matrix(rnorm(20), 10, 2) + y <- rnorm(10) + local_mocked_bindings( + susie = .fmp_capturingSusie(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieIndiv(X, y, "susieAsh") + expect_equal(captured$lastArgs$convergence_method, "pip") + expect_equal(captured$lastArgs$unmappable_effects, "ash") +}) + +test_that(".fmFitSusieIndiv: rejects non-SuSiE-family token", { + expect_error( + pecotmr:::.fmFitSusieIndiv(matrix(0, 2, 2), c(0, 0), "mvsusie"), + "not a SuSiE-family method" + ) + expect_error( + pecotmr:::.fmFitSusieIndiv(matrix(0, 2, 2), c(0, 0), "ghost"), + "not a SuSiE-family method" + ) +}) + +test_that(".fmFitSusieRss: susieInf branch passes convergence_method='pip', refine=FALSE, model_init=NULL", { + captured <- new.env(parent = emptyenv()) + z <- rnorm(3) + R <- diag(3) + n <- 1000 + local_mocked_bindings( + susie_rss = .fmp_capturingSusieRss(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieRss(z, R, n, "susieInf") + expect_equal(captured$lastArgs$convergence_method, "pip") + expect_false(captured$lastArgs$refine) + expect_null(captured$lastArgs$model_init) + expect_equal(captured$lastArgs$unmappable_effects, "inf") +}) + +test_that(".fmFitSusieRss: chained branch (chainFromInf) propagates susieInf fit as model_init", { + captured <- new.env(parent = emptyenv()) + z <- rnorm(3) + R <- diag(3) + n <- 1000 + infFit <- list(V = c(0.1, 0.2)) + local_mocked_bindings( + susie_rss = .fmp_capturingSusieRss(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieRss(z, R, n, "susie", chainFromInf = infFit) + expect_identical(captured$lastArgs$model_init, infFit) + expect_equal(captured$lastArgs$unmappable_effects, "none") +}) + +test_that(".fmFitSusieRss: chained susieAsh branch sets unmappable_effects='ash'", { + captured <- new.env(parent = emptyenv()) + z <- rnorm(3) + R <- diag(3) + n <- 1000 + infFit <- list(V = c(0.1, 0.2)) + local_mocked_bindings( + susie_rss = .fmp_capturingSusieRss(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieRss(z, R, n, "susieAsh", chainFromInf = infFit) + expect_equal(captured$lastArgs$unmappable_effects, "ash") + expect_identical(captured$lastArgs$model_init, infFit) +}) + +test_that(".fmFitSusieRss: unchained susieAsh branch sets convergence_method='pip'", { + captured <- new.env(parent = emptyenv()) + z <- rnorm(3) + R <- diag(3) + n <- 1000 + local_mocked_bindings( + susie_rss = .fmp_capturingSusieRss(captured), + .package = "susieR" + ) + pecotmr:::.fmFitSusieRss(z, R, n, "susieAsh") + expect_equal(captured$lastArgs$convergence_method, "pip") + expect_equal(captured$lastArgs$unmappable_effects, "ash") +}) + +test_that(".fmFitSusieRss: rejects non-SuSiE-family token", { + expect_error( + pecotmr:::.fmFitSusieRss(c(0, 0), diag(2), 1000, "mvsusie"), + "not a SuSiE-family method" + ) +}) + +test_that(".buildMvsusieReweightedPrior: empty reweighted w0 -> canonical(V)", { + local_mocked_bindings( + rescaleCovW0 = function(w0) c(zzz = 1), + .package = "pecotmr" + ) + local_mocked_bindings( + create_mixture_prior = function(...) "PV", + .package = "mvsusieR" + ) + fp <- list( + dataDrivenPriorMatrices = list(U = list(compA = diag(2))), + w0 = c(compA_grid1 = 1), + V = diag(2) + ) + res <- pecotmr:::.buildMvsusieReweightedPrior(fp, c("c1", "c2")) + expect_equal(res$residualVariance, diag(2)) # w0 names disjoint from U (749) +}) + +test_that(".fmSerScreen / .fmScreenActive / .fmSerScreenColumns", { + set.seed(2) + X <- matrix( + rnorm(40), + 20, + 2, + dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) + ) + y <- rnorm(20) + expect_true(pecotmr:::.fmSerScreen(X, y, 0)) # disabled + expect_true(pecotmr:::.fmSerScreen(X, c(1, rep(NA, 19)), 0.5)) # < 2 obs (880) + expect_type(pecotmr:::.fmSerScreen(X, y, 0.5), "logical") # real susie fit + local_mocked_bindings( + susie = function(...) stop("boom"), + .package = "susieR" + ) + expect_true(pecotmr:::.fmSerScreen(X, y, 0.5)) # fit fails -> keep (886) + expect_false(pecotmr:::.fmScreenActive(0)) + expect_true(pecotmr:::.fmScreenActive(0.5)) + expect_length( + pecotmr:::.fmSerScreenColumns(X, matrix(rnorm(40), 20, 2), 0), + 2L + ) +}) + +test_that(".fmFitXBlock fits the susieInf indiv chain + cross-validates (mocked)", { + local_mocked_bindings( + .fmFitSusieIndiv = function(...) list(), + .fmPostprocessOne = function(fit, method, dataX, dataY, ...) { + fineMappingRow( + colnames(dataX), + list(), + data.frame(variant_id = colnames(dataX), pip = 0.5) + ) + }, + .fmFoldWeights = function(token, Xtr, Ytr, ...) { + matrix(0.01, ncol(Xtr), 1L, dimnames = list(colnames(Xtr), NULL)) + }, + .package = "pecotmr" + ) + set.seed(1) + X <- matrix( + rbinom(60, 2, 0.4), + 20, + 3, + dimnames = list( + paste0("s", 1:20), + c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") + ) + ) + y <- rnorm(20) + out <- pecotmr:::.fmFitXBlock( + X, + y, + toRun = "susieInf", + addSusieInf = FALSE, + methodArgs = list(susieInf = list()), + verbose = 1, + ctx = "brain", + tid = "ENSG_A", + cvFolds = 3L, + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.7, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) + ) + expect_named(out, "susieInf") + expect_s4_class(out$susieInf, "FineMappingRow") +}) + +test_that("each fine-mapping constructor checks ONE engine entry point", { + skip_if_not_installed("susieR") + # susie runs susieR::susie on individual data and susieR::susie_rss on + # summary statistics. One constructor each, so a name valid only for the + # other path is rejected where it would have been dropped in silence. + expect_s4_class(SusieOptions(L = 5), "MethodOptions") + expect_equal(SusieOptions(L = 5)$L, 5) + expect_error(SusieOptions(LL = 5), "unknown argument\\(s\\) LL") + expect_output(show(SusieOptions()), "susieR::susie") + expect_output(show(SusieRssOptions()), "susieR::susie_rss") + # `z` belongs to susie_rss alone. + expect_error(SusieOptions(z = 1), "unknown argument\\(s\\) z") + expect_s4_class(SusieRssOptions(z = 1), "MethodOptions") +}) + +test_that("splitting the paths makes the individual mvsusie engine checkable", { + skip_if_not_installed("mvsusieR") + # mvsusieR::mvsusie enumerates its arguments; mvsusieR::mvsusie_rss still + # takes `...`, so only the RSS side goes unchecked. Checking the union of + # the two -- as one MvsusieOptions() used to -- left BOTH unchecked. + expect_error( + MvsusieOptions(nosuchopt = 1), + "unknown argument\\(s\\) nosuchopt" + ) + expect_failure(expect_output(show(MvsusieOptions()), "NOT checked")) + expect_output(show(MvsusieRssOptions()), "NOT checked") + expect_true(is_in("anything", names(MvsusieRssOptions(anything = 1)))) +}) + +test_that("krigingOutlierQc flags an allele switch and spares the rest", { + skip_if_not( + "kriging_rss" %in% getNamespaceExports("susieR"), + "installed susieR has no kriging_rss" + ) + s <- .kr_switchScenario() + kr <- krigingOutlierQc(s$z, s$R, n = 1000, variantIds = s$ids) + expect_true(kr$flip[s$flipped]) + expect_equal(sum(kr$flip), 1L) + expect_equal(nrow(kr$diagnostics), length(s$z)) + expect_true(all( + c("z", "condmean", "z_std_diff", "logLR", "flipped") %in% + colnames(kr$diagnostics) + )) + expect_identical(kr$diagnostics$flipped, kr$flip) +}) + +test_that("krigingOutlierQc flip == susieR's logLR>2 & |z|>2 selection", { + skip_if_not( + "kriging_rss" %in% getNamespaceExports("susieR"), + "installed susieR has no kriging_rss" + ) + set.seed(7) + m <- 10 + R <- cov2cor(crossprod(matrix(rnorm(m * m), m))) + ids <- paste0("1:", seq_len(m) * 100, ":A:G") + rownames(R) <- colnames(R) <- ids + z <- as.numeric(R %*% rnorm(m)) + z[4] <- 9 + kr <- krigingOutlierQc(z, R, n = 5000, variantIds = ids) + ref <- susieR::kriging_rss(z = z, R = R, n = 5000)$conditional_dist + # susieR's own allele-switch rule (susie_rss_utils.R): logLR > 2 & |z| > 2. + expected <- as.numeric(ref$logLR) > 2 & abs(z) > 2 + expect_identical(kr$flip, expected) + expect_equal(kr$diagnostics$logLR, as.numeric(ref$logLR), tolerance = 1e-8) + expect_equal( + kr$diagnostics$z_std_diff, + as.numeric(ref$z_std_diff), + tolerance = 1e-8 + ) + expect_equal( + kr$diagnostics$condmean, + as.numeric(ref$condmean), + tolerance = 1e-8 + ) +}) + +test_that("krigingOutlierQc thresholds are configurable", { + skip_if_not( + "kriging_rss" %in% getNamespaceExports("susieR"), + "installed susieR has no kriging_rss" + ) + s <- .kr_switchScenario() + # The switch fires at the default logLRThreshold = 2 ... + expect_true(krigingOutlierQc(s$z, s$R, n = 1000, variantIds = s$ids)$flip[ + s$flipped + ]) + # ... and an impossibly high logLR threshold suppresses every flip. + expect_false(any( + krigingOutlierQc( + s$z, + s$R, + n = 1000, + variantIds = s$ids, + logLRThreshold = 1e6 + )$flip + )) + # A |z| threshold above the switched z also suppresses it. + expect_false(any( + krigingOutlierQc( + s$z, + s$R, + n = 1000, + variantIds = s$ids, + zThreshold = 1e6 + )$flip + )) +}) + +test_that("krigingOutlierQc requires a positive sample size n", { + expect_error(krigingOutlierQc(c(1, 2, 3), diag(3)), "positive sample size") +}) + +test_that("krigingOutlierQc requires a square LD matrix aligned to zScore", { + expect_error( + krigingOutlierQc(c(1, 2, 3), diag(2), n = 100), + "R \\(LD matrix\\).*Must have exactly 3 rows" + ) +}) + +test_that("krigingOutlierQc defaults variantIds to rownames(R)", { + skip_if_not( + "kriging_rss" %in% getNamespaceExports("susieR"), + "installed susieR has no kriging_rss" + ) + m <- 6 + R <- matrix(0.6, m, m) + diag(R) <- 1 + ids <- paste0("1:", seq_len(m) * 100, ":A:G") + rownames(R) <- colnames(R) <- ids + z <- rep(2, m) + kr <- krigingOutlierQc(z, R, n = 1000) # no variantIds passed + expect_equal(kr$diagnostics$variant_id, ids) +}) + +test_that("KrigingOptions refuses the inputs pecotmr supplies", { + expect_error(KrigingOptions(z = 1), "the caller's `zScore`") + expect_error(KrigingOptions(R = diag(2)), "the caller's `R`") + expect_error(KrigingOptions(n = 100), "the caller's `n`") + expect_error(KrigingOptions(nosuch = 1), "unknown argument") + expect_setequal(names(KrigingOptions(r_tol = 1e-06)), "r_tol") +}) + +test_that("krigingOutlierQc forwards methodArgs to susieR::kriging_rss", { + skip_if_not_installed("susieR") + seen <- NULL + real <- susieR::kriging_rss + set.seed(1) + X <- matrix(rnorm(200), 40, 5) + R <- cor(X) + with_mocked_bindings( + krigingOutlierQc( + zScore = rnorm(5), + R = R, + n = 40, + methodArgs = KrigingOptions(r_tol = 1e-04) + ), + kriging_rss = function(...) { + seen <<- list(...) + real(...) + }, + .package = "susieR" + ) + expect_equal(seen$r_tol, 1e-04) + expect_equal(seen$n, 40) + expect_error( + krigingOutlierQc(rnorm(5), R, 40, methodArgs = list(r_tol = 1)), + "KrigingOptions" + ) +}) + +# Fixtures moved here with the tests that use them. + +# Fixtures moved here with the tests that use them. diff --git a/tests/testthat/test_genotypeHandle.R b/tests/testthat/test_genotypeHandle.R index 2fd480349..4d6a93d36 100644 --- a/tests/testthat/test_genotypeHandle.R +++ b/tests/testthat/test_genotypeHandle.R @@ -125,7 +125,7 @@ test_that(".genotypeHandleFromPlink1Triplet: errors on non-character input", { bim = "x.bim", fam = "x.fam" ), - "must be a single file path" + "Must be of type 'string'" ) }) @@ -325,7 +325,7 @@ test_that("GenotypeHandle constructs and validates correctly", { "GenotypeHandle", path = "/tmp/test.gds", format = "gds", - snpInfo = make_test_snp_info(), + snpInfo = makeTestSnpInfo(), nSamples = 100L, sampleIds = paste0("sample_", 1:100), pgenPtr = NULL @@ -741,7 +741,7 @@ test_that("show(GenotypeHandle) does not error", { "GenotypeHandle", path = "/tmp/test.gds", format = "gds", - snpInfo = make_test_snp_info(), + snpInfo = makeTestSnpInfo(), nSamples = 100L, sampleIds = paste0("s", 1:100), pgenPtr = NULL @@ -919,3 +919,22 @@ test_that("an unresolvable bundled resource reference is an error", { "cannot resolve bundled genotype resource" ) }) + +test_that(".chromMetaPaths answers character(0) for no shards", { + expect_identical(pecotmr:::.chromMetaPaths(list()), character(0)) +}) + +test_that("getPgenPtr returns the handle's pgen pointer", { + # NULL for every non-pgen format: the pointer is opened lazily and only + # by the pgen reader, so the accessor's job is to report its absence. + h <- new( + "GenotypeHandle", + path = "/tmp/test.gds", + format = "gds", + snpInfo = makeTestSnpInfo(), + nSamples = 100L, + sampleIds = paste0("sample_", 1:100), + pgenPtr = NULL + ) + expect_null(getPgenPtr(h)) +}) diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index 97a2f1313..c4b9e734f 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -62,7 +62,7 @@ test_that("findValidFilePath works", { }) -dummy_geno_data <- function( +dummyGenoData <- function( number_of_samples = 10, number_of_snps = 10, sample_start_id = 1, @@ -147,7 +147,7 @@ dummy_geno_data <- function( return(X) } -dummy_pheno_data <- function( +dummyPhenoData <- function( number_of_samples = 10, number_of_phenotypes = 10, randomize = FALSE, @@ -180,13 +180,13 @@ dummy_pheno_data <- function( end_matrix <- end_matrix[sample(nrow(end_matrix)), ] } pheno_data <- t(pheno_data) - pheno_data <- lapply(seq_len(ncol(pheno_data)), function(i) { + pheno_data <- map(seq_len(ncol(pheno_data)), function(i) { pheno_data[, i, drop = FALSE] }) return(pheno_data) } -dummy_covar_data <- function( +dummyCovarData <- function( number_of_samples = 10, number_of_covars = 10, row_na = FALSE, @@ -207,7 +207,7 @@ dummy_covar_data <- function( covar <- covar[sample(nrow(covar)), ] } if (row_na) { - covar[sample(length(covar), 1), 1:number_of_covars] <- NA + covar[sample(length(covar), 1), seq_len(number_of_covars)] <- NA } return(covar) } @@ -533,7 +533,7 @@ test_that(".colocFilterCsByConcentration returns numeric index vector", { alpha_raw <- matrix(runif(n_L * n_vars), nrow = n_L) alpha_norm <- t(apply(alpha_raw, 1, function(x) x / sum(x))) - mock_susie <- list( + mockSusie <- list( alpha = alpha_norm, V = runif(n_L), lbf_variable = matrix(rnorm(n_L * n_vars), nrow = n_L), @@ -549,7 +549,7 @@ test_that(".colocFilterCsByConcentration returns numeric index vector", { ) result <- pecotmr:::.colocFilterCsByConcentration( - mock_susie, + mockSusie, coverage = 0.5, concentration = 0.5 ) @@ -648,7 +648,7 @@ test_that("invertMinmaxScaling preserves correlation structure", { n <- 200 k <- 3 # Simulate U = W'G (G is raw, not standardized, matching rss_ld_sketch) - G <- sapply(c(0.2, 0.4, 0.1), function(p) rbinom(n, 2, p)) + G <- exec(cbind, !!!map(c(0.2, 0.4, 0.1), function(p) rbinom(n, 2, p))) W <- matrix(rnorm(n * n, 0, 1 / sqrt(n)), n, n) U_original <- crossprod(W, G) @@ -1232,7 +1232,7 @@ test_that("format detection supports dotted PLINK2 prefixes", { # Shared helper: validate the output structure from loadGenotypeRegion # (with returnVariantInfo=TRUE) -check_genotype_result <- function( +checkGenotypeResult <- function( result, expected_nrow = n_samples, expected_ncol = n_variants, @@ -1313,7 +1313,7 @@ test_that("loadGenotypeRegion filters plink2 by region", { region = region_sub, returnVariantInfo = TRUE ) - check_genotype_result(result, expected_ncol = 134L, label = "plink2 region") + checkGenotypeResult(result, expected_ncol = 134L, label = "plink2 region") expect_true(all( result$variant_info$pos >= 17513228 & result$variant_info$pos <= 17550000 @@ -1354,7 +1354,7 @@ test_that("loadGenotypeRegion loads VCF via dispatch", { vcf_path, returnVariantInfo = TRUE )) - check_genotype_result(result, label = "dispatch vcf") + checkGenotypeResult(result, label = "dispatch vcf") }) test_that("loadGenotypeRegion filters VCF by region", { @@ -1365,7 +1365,7 @@ test_that("loadGenotypeRegion filters VCF by region", { region = region_sub, returnVariantInfo = TRUE )) - check_genotype_result(result, expected_ncol = 134L, label = "vcf region") + checkGenotypeResult(result, expected_ncol = 134L, label = "vcf region") expect_true(all( result$variant_info$pos >= 17513228 & result$variant_info$pos <= 17550000 @@ -1400,7 +1400,7 @@ test_that("loadGenotypeRegion loads GDS via dispatch", { skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") result <- loadGenotypeRegion(gds_path, returnVariantInfo = TRUE) - check_genotype_result(result, label = "dispatch gds") + checkGenotypeResult(result, label = "dispatch gds") }) test_that("loadGenotypeRegion filters GDS by region", { @@ -1411,7 +1411,7 @@ test_that("loadGenotypeRegion filters GDS by region", { region = region_sub, returnVariantInfo = TRUE ) - check_genotype_result(result, expected_ncol = 134L, label = "gds region") + checkGenotypeResult(result, expected_ncol = 134L, label = "gds region") expect_true(all( result$variant_info$pos >= 17513228 & result$variant_info$pos <= 17550000 @@ -1479,20 +1479,20 @@ test_that("loadGenotypeRegion dispatches to VCF by extension", { vcf_path, returnVariantInfo = TRUE )) - check_genotype_result(result, label = "dispatch vcf") + checkGenotypeResult(result, label = "dispatch vcf") }) test_that("loadGenotypeRegion dispatches to GDS by extension", { skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") result <- loadGenotypeRegion(gds_path, returnVariantInfo = TRUE) - check_genotype_result(result, label = "dispatch gds") + checkGenotypeResult(result, label = "dispatch gds") }) test_that("loadGenotypeRegion dispatches to PLINK2 by prefix", { skip_if_not_installed("pgenlibr") result <- loadGenotypeRegion(plink_prefix, returnVariantInfo = TRUE) - check_genotype_result(result, label = "dispatch plink2") + checkGenotypeResult(result, label = "dispatch plink2") }) test_that("loadGenotypeRegion returns matrix when returnVariantInfo=FALSE", { @@ -1712,6 +1712,27 @@ test_that("single-shard sharded handle equals the single-file handle", { expect_equal(.shardDose(sh, 1:10), .shardDose(ref, 1:10)) }) +test_that("readGenotypes(genoMeta=) forwards `format` to the shard reader", { + skip_if_not_installed("snpStats") + # Regression: the path = "missing" method bound `format` to its own formal + # and then called GenotypeHandle(...) without it, so an explicit format was + # silently dropped and every shard fell back to extension probing. + seen <- new.env(parent = emptyenv()) + seen$fmt <- NA_character_ + local_mocked_bindings( + .resolveGenotypeShard = function(p, format = NULL) { + seen$fmt <- if (is.null(format)) "" else format + pecotmr:::.makePlink1Handle(p) + }, + .package = "pecotmr" + ) + readGenotypes( + genoMeta = c("21" = file.path(test_data_dir, "test_variants")), + format = "plink1" + ) + expect_identical(seen$fmt, "plink1") +}) + test_that("genoMeta meta-file form matches the named-vector form", { skip_if_not_installed("snpStats") td_abs <- normalizePath(test_data_dir) @@ -1762,7 +1783,7 @@ test_that(".makeGdsHandle errors when GDS file is absent", { skip_if_not_installed("gdsfmt") expect_error( pecotmr:::.makeGdsHandle("/no/such/file.gds"), - "GDS file not found" + "GDS file.*File does not exist" ) }) @@ -1770,7 +1791,7 @@ test_that(".makeVcfHandle errors when VCF file is absent", { skip_if_not_installed("VariantAnnotation") expect_error( pecotmr:::.makeVcfHandle("/no/such/file.vcf.gz"), - "VCF file not found" + "VCF file.*File does not exist" ) }) @@ -1781,7 +1802,7 @@ test_that(".makePlink1Handle errors when plink1 trio is absent", { tempdir(), "missingPlink1Prefix" )), - "Plink file not found" + "Plink file.*File does not exist" ) }) @@ -2108,7 +2129,7 @@ test_that("resolvePlink2Paths errors when .psam is missing", { prefix <- .gioMakePlink2Stub(c("pgen", "pvar")) expect_error( pecotmr:::resolvePlink2Paths(prefix), - "PLINK2 .psam file not found" + "PLINK2 .psam file.*File does not exist" ) }) @@ -2679,3 +2700,29 @@ test_that("stochastic inversion is a no-op when no id matches the metadata", { ) expect_identical(out$X, X) }) + +test_that("readGenotypes names its keyword sources, not `...`", { + # The sources used to ride `...` into GenotypeHandle(), so a misspelled + # one was simply unset and the call failed later with "no source given". + expect_error(readGenotypes(plink1Prefx = "x"), "unused argument") + # Every GenotypeHandle source is reachable by name: passing one gets past + # argument matching and fails (if at all) on the source itself, never on + # "unused argument". + sources <- setdiff( + names(formals(pecotmr:::GenotypeHandle)), + c("path", "format", "vcfArgs") + ) + for (nm in sources) { + err <- tryCatch( + { + exec(readGenotypes, !!!set_names(list("nope"), nm)) + NULL + }, + error = function(e) conditionMessage(e) + ) + expect_false( + isTRUE(str_detect(err %||% "", "unused argument")), + label = nm + ) + } +}) diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index f97587903..17fb603ac 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -4,7 +4,7 @@ context("h2_estimate_wrappers") # Helper functions to build test S4 objects # =========================================================================== -make_test_eigen_ref <- function(nSnps = 20, nBlocks = 2) { +makeTestEigenRef <- function(nSnps = 20, nBlocks = 2) { snps_per_block <- nSnps / nBlocks blocks_gr <- GenomicRanges::GRanges( seqnames = rep("chr1", nBlocks), @@ -24,7 +24,7 @@ make_test_eigen_ref <- function(nSnps = 20, nBlocks = 2) { stringsAsFactors = FALSE ) - eigen_list <- lapply(seq_len(nBlocks), function(b) { + eigen_list <- map(seq_len(nBlocks), function(b) { idx <- seq((b - 1) * snps_per_block + 1, b * snps_per_block) p <- length(idx) set.seed(42 + b) @@ -45,7 +45,7 @@ make_test_eigen_ref <- function(nSnps = 20, nBlocks = 2) { ) } -make_test_score_ref <- function( +makeTestScoreRef <- function( nSnps = 20, nBlocks = 2, with_ld_matrices = FALSE @@ -78,7 +78,7 @@ make_test_score_ref <- function( ld_score_weights <- rep(1 / nSnps, nSnps) ld_matrix_list <- if (with_ld_matrices) { - lapply(seq_len(nBlocks), function(b) { + map(seq_len(nBlocks), function(b) { idx <- seq((b - 1) * snps_per_block + 1, b * snps_per_block) p <- length(idx) # AR(1) LD so per-SNP LD scores vary (equicorrelated R gives a @@ -102,7 +102,7 @@ make_test_score_ref <- function( ) } -make_test_annotations <- function(nSnps = 20) { +makeTestAnnotations <- function(nSnps = 20) { set.seed(77) snp_ranges <- GenomicRanges::GRanges( seqnames = rep("chr1", nSnps), @@ -126,7 +126,7 @@ make_test_annotations <- function(nSnps = 20) { AnnotationMatrix(annot_mat, snp_ranges, annotation_meta, genome = "hg19") } -make_test_h2estimate <- function(with_enrichment = TRUE) { +makeTestH2Estimate <- function(with_enrichment = TRUE) { enrich <- if (with_enrichment) { data.frame( annotation = c("annot1", "annot2"), @@ -176,7 +176,7 @@ make_test_h2estimate <- function(with_enrichment = TRUE) { # =========================================================================== test_that(".validate_method_ref errors when method='lder' but ref is LdScore", { - score_ref <- make_test_score_ref() + score_ref <- makeTestScoreRef() expect_error( pecotmr:::.validateMethodRef("lder", score_ref), "requires an LdEigen" @@ -184,7 +184,7 @@ test_that(".validate_method_ref errors when method='lder' but ref is LdScore", { }) test_that(".validate_method_ref errors when method='hdl' but ref is LdScore", { - score_ref <- make_test_score_ref() + score_ref <- makeTestScoreRef() expect_error( pecotmr:::.validateMethodRef("hdl", score_ref), "requires an LdEigen" @@ -192,7 +192,7 @@ test_that(".validate_method_ref errors when method='hdl' but ref is LdScore", { }) test_that(".validate_method_ref errors when method='gldsc' but ref is LdEigen", { - eigen_ref <- make_test_eigen_ref() + eigen_ref <- makeTestEigenRef() expect_error( pecotmr:::.validateMethodRef("gldsc", eigen_ref), "requires an LdScore" @@ -200,8 +200,8 @@ test_that(".validate_method_ref errors when method='gldsc' but ref is LdEigen", }) test_that(".validate_method_ref returns TRUE for valid combinations", { - eigen_ref <- make_test_eigen_ref() - score_ref <- make_test_score_ref() + eigen_ref <- makeTestEigenRef() + score_ref <- makeTestScoreRef() expect_true(pecotmr:::.validateMethodRef("lder", eigen_ref)) expect_true(pecotmr:::.validateMethodRef("hdl", eigen_ref)) @@ -213,7 +213,7 @@ test_that(".validate_method_ref returns TRUE for valid combinations", { # =========================================================================== test_that("computeLdScores LdEigen returns matrix with base_l2 column", { - eigen_ref <- make_test_eigen_ref() + eigen_ref <- makeTestEigenRef() result <- computeLdScores(eigen_ref) expect_true(is.matrix(result)) expect_equal(ncol(result), 1) @@ -222,14 +222,14 @@ test_that("computeLdScores LdEigen returns matrix with base_l2 column", { }) test_that("computeLdScores LdEigen base LD scores are non-negative", { - eigen_ref <- make_test_eigen_ref() + eigen_ref <- makeTestEigenRef() result <- computeLdScores(eigen_ref) expect_true(all(result[, "base_l2"] >= 0)) }) test_that("computeLdScores LdEigen with annotations returns base + annotation columns", { - eigen_ref <- make_test_eigen_ref() - annot <- make_test_annotations() + eigen_ref <- makeTestEigenRef() + annot <- makeTestAnnotations() result <- computeLdScores(eigen_ref, annotations = annot) expect_true(is.matrix(result)) # base_l2 + 2 annotation columns @@ -239,8 +239,8 @@ test_that("computeLdScores LdEigen with annotations returns base + annotation co }) test_that("computeLdScores LdEigen annotation column names match", { - eigen_ref <- make_test_eigen_ref() - annot <- make_test_annotations() + eigen_ref <- makeTestEigenRef() + annot <- makeTestAnnotations() result <- computeLdScores(eigen_ref, annotations = annot) expect_equal(colnames(result), c("base_l2", "annot_A", "annot_B")) }) @@ -250,14 +250,14 @@ test_that("computeLdScores LdEigen annotation column names match", { # =========================================================================== test_that("computeLdScores LdScore without annotations returns stored ld_scores", { - score_ref <- make_test_score_ref() + score_ref <- makeTestScoreRef() result <- computeLdScores(score_ref) expect_identical(result, getLdScores(score_ref)) }) test_that("computeLdScores LdScore with annotations but no ld_matrix_list errors", { - score_ref <- make_test_score_ref(with_ld_matrices = FALSE) - annot <- make_test_annotations() + score_ref <- makeTestScoreRef(with_ld_matrices = FALSE) + annot <- makeTestAnnotations() expect_error( computeLdScores(score_ref, annotations = annot), "ldMatrixList" @@ -293,7 +293,7 @@ test_that("getlocal returns the local slot", { }) test_that("getenrichment returns the enrichment slot", { - h2_obj <- make_test_h2estimate(with_enrichment = TRUE) + h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) result <- getEnrichment(h2_obj) expect_true(is.data.frame(result)) expect_equal(result$annotation, c("annot1", "annot2")) @@ -347,7 +347,7 @@ test_that("accessors return NULL when slots are NULL", { # =========================================================================== test_that("h2EstimateToSldscTrait returns correct list structure", { - h2_obj <- make_test_h2estimate(with_enrichment = TRUE) + h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) result <- h2EstimateToSldscTrait(h2_obj) expected_names <- c( @@ -377,12 +377,12 @@ test_that("h2EstimateToSldscTrait returns correct list structure", { test_that("h2EstimateToSldscTrait errors on non-H2Estimate input", { expect_error( h2EstimateToSldscTrait(list(h2 = 0.3)), - "must be an H2Estimate" + "Must inherit from class 'H2Estimate'" ) }) test_that("h2EstimateToSldscTrait errors when enrichment is NULL", { - h2_obj <- make_test_h2estimate(with_enrichment = FALSE) + h2_obj <- makeTestH2Estimate(with_enrichment = FALSE) expect_error( h2EstimateToSldscTrait(h2_obj), "no enrichment" @@ -390,7 +390,7 @@ test_that("h2EstimateToSldscTrait errors when enrichment is NULL", { }) test_that("h2EstimateToSldscTrait creates 1-row dummy when tauBlocks is NULL", { - h2_obj <- make_test_h2estimate(with_enrichment = TRUE) + h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) h2_obj@tauBlocks <- NULL result <- h2EstimateToSldscTrait(h2_obj) expect_equal(nrow(result$tauBlocks), 1) @@ -402,7 +402,7 @@ test_that("h2EstimateToSldscTrait creates 1-row dummy when tauBlocks is NULL", { # Helper: GwasSumStats matched to a reference panel # =========================================================================== -make_test_gwas_genotype_handle <- function() { +makeTestGwasGenotypeHandle <- function() { new( "GenotypeHandle", path = "/tmp/test.gds", @@ -429,7 +429,7 @@ make_test_gwas_genotype_handle <- function() { gr } -make_test_sumstats_for_ref <- function( +makeTestSumstatsForRef <- function( ref, traitName = "test", varY = NA_real_ @@ -453,7 +453,7 @@ make_test_sumstats_for_ref <- function( study = traitName, entry = list(.dfToGwasGr(df)), genome = "hg19", - ldSketch = make_test_gwas_genotype_handle(), + ldSketch = makeTestGwasGenotypeHandle(), varY = varY ) } @@ -463,8 +463,8 @@ make_test_sumstats_for_ref <- function( # =========================================================================== test_that("estimateh2 with method='lder' returns H2Estimate with correct slots", { - eigen_ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(eigen_ref) + eigen_ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(eigen_ref) result <- estimateH2(ss, eigen_ref, method = "lder") expect_s4_class(result, "H2Estimate") @@ -493,18 +493,18 @@ test_that("estimateh2 with method='lder' returns H2Estimate with correct slots", study = "test", entry = list(gr), genome = "hg19", - ldSketch = make_test_gwas_genotype_handle() + ldSketch = makeTestGwasGenotypeHandle() ) } test_that("estimateH2 rejects a sumstats with a different variant count", { - ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(ref) + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) short <- GwasSumStats( study = "test", entry = list(getSumStats(ss)[1:10]), genome = "hg19", - ldSketch = make_test_gwas_genotype_handle() + ldSketch = makeTestGwasGenotypeHandle() ) expect_error( estimateH2(short, ref, method = "lder"), @@ -513,8 +513,8 @@ test_that("estimateH2 rejects a sumstats with a different variant count", { }) test_that("estimateH2 rejects a sumstats at different coordinates", { - ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(ref) + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) shifted <- .reposition( ss, GenomicRanges::GRanges( @@ -529,8 +529,8 @@ test_that("estimateH2 rejects a sumstats at different coordinates", { }) test_that("estimateH2 rejects a sumstats holding the right variants in the wrong order", { - ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(ref) + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) reordered <- .reposition( ss, GenomicRanges::GRanges( @@ -545,9 +545,9 @@ test_that("estimateH2 rejects a sumstats holding the right variants in the wrong }) test_that("estimateH2 rejects annotations that do not cover the reference", { - ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(ref) - annot <- make_test_annotations(nSnps = 10) + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) + annot <- makeTestAnnotations(nSnps = 10) expect_error( estimateH2(ss, ref, method = "lder", annotations = annot), "`annotations` carries 10 variant\\(s\\)" @@ -555,20 +555,20 @@ test_that("estimateH2 rejects annotations that do not cover the reference", { }) test_that("estimateH2 rejects a genome build mismatch", { - ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(ref) + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) hg38 <- GwasSumStats( study = "test", entry = list(getSumStats(ss)), genome = "hg38", - ldSketch = make_test_gwas_genotype_handle() + ldSketch = makeTestGwasGenotypeHandle() ) expect_error(estimateH2(hg38, ref, method = "lder"), "build mismatch") }) test_that("estimateH2 accepts an LD reference that records no genome build", { - ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(ref) + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) # loadLdMatrix() leaves the build unset, so a reference built from it # names none. An unknown build must not read as a mismatch. GenomeInfoDb::genome(ref) <- NA_character_ @@ -587,8 +587,8 @@ test_that("estimateH2 accepts an LD reference that records no genome build", { test_that("unstratified S-LDSC runs without the per-block LD matrices", { # This is the property that separates it from g-LDSC: a scores-only # LdScore is enough, which is why it is the cheap option. - noMat <- make_test_score_ref(with_ld_matrices = FALSE) - ss <- make_test_sumstats_for_ref(noMat) + noMat <- makeTestScoreRef(with_ld_matrices = FALSE) + ss <- makeTestSumstatsForRef(noMat) expect_error(estimateH2(ss, noMat, method = "gldsc"), "per-block LD") res <- estimateH2(ss, noMat, method = "sldsc") expect_s4_class(res, "H2Estimate") @@ -597,9 +597,9 @@ test_that("unstratified S-LDSC runs without the per-block LD matrices", { }) test_that("stratified S-LDSC needs the per-block LD matrices", { - noMat <- make_test_score_ref(with_ld_matrices = FALSE) - ss <- make_test_sumstats_for_ref(noMat) - annot <- make_test_annotations(nSnps = length(noMat)) + noMat <- makeTestScoreRef(with_ld_matrices = FALSE) + ss <- makeTestSumstatsForRef(noMat) + annot <- makeTestAnnotations(nSnps = length(noMat)) expect_error( estimateH2(ss, noMat, method = "sldsc", annotations = annot), "stratified S-LDSC requires full per-block LD matrices" @@ -607,9 +607,9 @@ test_that("stratified S-LDSC needs the per-block LD matrices", { }) test_that("S-LDSC reports an enrichment table when stratified", { - ref <- make_test_score_ref(with_ld_matrices = TRUE) - ss <- make_test_sumstats_for_ref(ref) - annot <- make_test_annotations(nSnps = length(ref)) + ref <- makeTestScoreRef(with_ld_matrices = TRUE) + ss <- makeTestSumstatsForRef(ref) + annot <- makeTestAnnotations(nSnps = length(ref)) res <- estimateH2(ss, ref, method = "sldsc", annotations = annot) enr <- getEnrichment(res) @@ -632,8 +632,8 @@ test_that("S-LDSC reports an enrichment table when stratified", { }) test_that("S-LDSC requires an LdScore, not an LdEigen", { - eigenRef <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(eigenRef) + eigenRef <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(eigenRef) expect_error( estimateH2(ss, eigenRef, method = "sldsc"), "requires an LdScore" @@ -680,7 +680,7 @@ test_that("the S-LDSC weights reproduce upstream Hsq.weights", { # An LD block with `dup` variants repeated, so R is singular by construction # and eigen() returns a negative-noise tail. .rankDeficientEigenRef <- function(nBlocks = 6L, p = 12L, dup = 4L) { - blocks <- lapply(seq_len(nBlocks), function(b) { + blocks <- map(seq_len(nBlocks), function(b) { base <- 0.5^abs(outer(seq_len(p - dup), seq_len(p - dup), "-")) keep <- c(seq_len(p - dup), seq_len(dup)) R <- base[keep, keep] @@ -700,8 +700,8 @@ test_that("the S-LDSC weights reproduce upstream Hsq.weights", { A2 = "G", stringsAsFactors = FALSE ) - starts <- as.integer(sapply(blocks, function(b) min(b$snpIdx))) * 100L - ends <- as.integer(sapply(blocks, function(b) max(b$snpIdx))) * 100L + starts <- as.integer(map_dbl(blocks, function(b) min(b$snpIdx))) * 100L + ends <- as.integer(map_dbl(blocks, function(b) max(b$snpIdx))) * 100L LdEigen( ldBlocks = GenomicRanges::GRanges( "chr1", @@ -718,14 +718,14 @@ test_that("the S-LDSC weights reproduce upstream Hsq.weights", { test_that("a rank-deficient LD block really does yield negative eigenvalues", { ref <- .rankDeficientEigenRef() - values <- unlist(lapply(getEigenList(ref), function(b) b$values)) + values <- unlist(map(getEigenList(ref), function(b) b$values)) expect_true(any(values < 0)) expect_true(min(values) > -1e-6) # noise, not structure }) test_that("estimateH2 survives negative eigenvalues from rank-deficient LD", { ref <- .rankDeficientEigenRef() - ss <- make_test_sumstats_for_ref(ref) + ss <- makeTestSumstatsForRef(ref) res <- estimateH2(ss, ref, method = "lder") expect_s4_class(res, "H2Estimate") expect_false(is.na(getH2(res))) @@ -759,7 +759,7 @@ test_that("estimateH2 runs on references built by buildLdEigen/buildLdScore", { ld <- makeTestLdDataMultiBlock(sizes = rep(10L, 5), rho = 0.6) eigenRef <- buildLdEigen(ld, genome = "hg19") scoreRef <- buildLdScore(ld, genome = "hg19") - ss <- make_test_sumstats_for_ref(eigenRef) + ss <- makeTestSumstatsForRef(eigenRef) expect_s4_class(estimateH2(ss, eigenRef, method = "lder"), "H2Estimate") suppressWarnings( @@ -773,7 +773,7 @@ test_that("estimateH2 rejects a single-block LD reference", { # a matrix" (LDER, g-LDSC) or return an SE of exactly 0 (HDL). ld <- makeTestLdData(n = 30L, rho = 0.6) eigenRef <- buildLdEigen(ld, genome = "hg19") - ss <- make_test_sumstats_for_ref(eigenRef) + ss <- makeTestSumstatsForRef(eigenRef) expect_error( estimateH2(ss, eigenRef, method = "lder"), "delete-one-block jackknife" @@ -787,7 +787,7 @@ test_that("estimateH2 rejects a single-block LD reference", { test_that("buildLdScore(keepLdMatrices = FALSE) is rejected by g-LDSC", { ld <- makeTestLdDataMultiBlock(sizes = rep(10L, 5)) scoreRef <- buildLdScore(ld, genome = "hg19", keepLdMatrices = FALSE) - ss <- make_test_sumstats_for_ref(scoreRef) + ss <- makeTestSumstatsForRef(scoreRef) expect_error( estimateH2(ss, scoreRef, method = "gldsc"), "requires full per-block LD matrices" @@ -795,9 +795,9 @@ test_that("buildLdScore(keepLdMatrices = FALSE) is rejected by g-LDSC", { }) test_that("estimateH2 accepts a chr-prefix difference between the two sides", { - ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(ref) - # make_test_sumstats_for_ref already strips the prefix ("1" vs "chr1"), + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) + # makeTestSumstatsForRef already strips the prefix ("1" vs "chr1"), # so this pins that the check normalizes rather than rejects it. expect_equal( as.character(GenomicRanges::seqnames(getSumStats(ss)))[[1]], @@ -807,8 +807,8 @@ test_that("estimateH2 accepts a chr-prefix difference between the two sides", { }) test_that("estimateh2 with var_y correction runs without error", { - eigen_ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref( + eigen_ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef( eigen_ref, traitName = "cc_trait", varY = 4.0 @@ -821,8 +821,8 @@ test_that("estimateh2 with var_y correction runs without error", { }) test_that("estimateh2 with method='gldsc' returns H2Estimate", { - score_ref <- make_test_score_ref(with_ld_matrices = TRUE) - ss <- make_test_sumstats_for_ref(score_ref) + score_ref <- makeTestScoreRef(with_ld_matrices = TRUE) + ss <- makeTestSumstatsForRef(score_ref) result <- estimateH2(ss, score_ref, method = "gldsc") expect_s4_class(result, "H2Estimate") @@ -834,8 +834,8 @@ test_that("estimateh2 with method='gldsc' returns H2Estimate", { }) test_that("estimateh2 with method='hdl' returns H2Estimate", { - eigen_ref <- make_test_eigen_ref() - ss <- make_test_sumstats_for_ref(eigen_ref) + eigen_ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(eigen_ref) # HDL likelihood optimization on tiny test data produces NaN warnings # from log() on negative sigma2 during search; these are harmless. suppressWarnings( @@ -855,8 +855,8 @@ test_that("estimateh2 with method='hdl' returns H2Estimate", { # =========================================================================== test_that("computeLdScores LdScore with annotations and ld_matrix_list returns correct matrix", { - score_ref <- make_test_score_ref(with_ld_matrices = TRUE) - annot <- make_test_annotations() + score_ref <- makeTestScoreRef(with_ld_matrices = TRUE) + annot <- makeTestAnnotations() result <- computeLdScores(score_ref, annotations = annot) expect_true(is.matrix(result)) @@ -871,60 +871,6 @@ test_that("computeLdScores LdScore with annotations and ld_matrix_list returns c context("h2_utils") -# ============================================================================= -# weightedLs -# ============================================================================= - -test_that("weightedLs returns correct structure", { - set.seed(42) - n <- 50 - x <- rnorm(n) - X <- cbind(x, 1) - y <- 2 * x + 1 + rnorm(n, sd = 0.1) - w <- rep(1, n) - res <- pecotmr:::weightedLs(y, X, w) - expect_true(is.list(res)) - expect_named(res, c("coef", "se", "residuals", "fitted", "vcov")) - expect_length(res$coef, 2) - expect_length(res$se, 2) - expect_length(res$residuals, n) - expect_length(res$fitted, n) - expect_equal(dim(res$vcov), c(2, 2)) -}) - -test_that("weightedLs recovers coefficients for simple linear model", { - set.seed(42) - n <- 200 - x <- rnorm(n) - X <- cbind(x, 1) - y <- 2 * x + 1 + rnorm(n, sd = 0.1) - w <- rep(1, n) - res <- pecotmr:::weightedLs(y, X, w) - expect_equal(res$coef[1], 2, tolerance = 0.1) - expect_equal(res$coef[2], 1, tolerance = 0.1) -}) - -test_that("weightedLs converts vector X to matrix", { - set.seed(42) - n <- 30 - x <- rnorm(n) - y <- 3 * x + rnorm(n, sd = 0.1) - w <- rep(1, n) - res <- pecotmr:::weightedLs(y, x, w) - expect_length(res$coef, 1) - expect_equal(res$coef[1], 3, tolerance = 0.2) -}) - -test_that("weightedLs fitted + residuals = y", { - set.seed(42) - n <- 30 - X <- cbind(rnorm(n), 1) - y <- rnorm(n) - w <- rep(1, n) - res <- pecotmr:::weightedLs(y, X, w) - expect_equal(res$fitted + res$residuals, y) -}) - # ============================================================================= # jackknifeSe # ============================================================================= @@ -968,7 +914,7 @@ test_that("jackknifeSe computes known case correctly", { full_mean <- mean(vals) n <- length(vals) # Leave-one-out means: remove element i, compute mean of remaining - loo_means <- vapply(seq_len(n), function(i) mean(vals[-i]), numeric(1)) + loo_means <- map_dbl(seq_len(n), function(i) mean(vals[-i])) estimates_loo <- matrix(loo_means, ncol = 1) se <- pecotmr:::jackknifeSe(full_mean, estimates_loo) # Pseudo-values: n * full - (n-1) * loo @@ -977,63 +923,6 @@ test_that("jackknifeSe computes known case correctly", { expect_equal(se, expected_se) }) -# ============================================================================= -# weightedLsRidge -# ============================================================================= - -test_that("weightedLsRidge with lambda=0 matches weightedLs", { - set.seed(42) - n <- 50 - X <- cbind(rnorm(n), rnorm(n), 1) - y <- X %*% c(1, 2, 0.5) + rnorm(n, sd = 0.1) - w <- rep(1, n) - res_ridge <- pecotmr:::weightedLsRidge(y, X, w, lambda = 0) - res_wls <- pecotmr:::weightedLs(y, X, w) - expect_equal(res_ridge$coef, res_wls$coef) - expect_equal(res_ridge$se, res_wls$se) - expect_equal(res_ridge$residuals, res_wls$residuals) - expect_equal(res_ridge$fitted, res_wls$fitted) -}) - -test_that("weightedLsRidge with lambda>0 shrinks coefficients", { - set.seed(42) - n <- 50 - X <- cbind(rnorm(n), rnorm(n), 1) - y <- X %*% c(3, 3, 1) + rnorm(n, sd = 0.5) - w <- rep(1, n) - res_no_ridge <- pecotmr:::weightedLsRidge(y, X, w, lambda = 0) - res_ridge <- pecotmr:::weightedLsRidge(y, X, w, lambda = 10) - # Non-intercept coefficients should be shrunk toward zero - expect_true(abs(res_ridge$coef[1]) < abs(res_no_ridge$coef[1])) - expect_true(abs(res_ridge$coef[2]) < abs(res_no_ridge$coef[2])) -}) - -test_that("weightedLsRidge penalize_intercept=FALSE leaves last column unpenalized", { - set.seed(42) - n <- 100 - X <- cbind(rnorm(n), 1) - y <- X %*% c(5, 3) + rnorm(n, sd = 0.5) - w <- rep(1, n) - # With large lambda but no intercept penalty, intercept should still be reasonable - res <- pecotmr:::weightedLsRidge( - y, - X, - w, - lambda = 100, - penalizeIntercept = FALSE - ) - # Intercept (col 2) should not be shrunk as aggressively as slope (col 1) - res_pen <- pecotmr:::weightedLsRidge( - y, - X, - w, - lambda = 100, - penalizeIntercept = TRUE - ) - # The intercept should differ between the two - expect_false(isTRUE(all.equal(res$coef[2], res_pen$coef[2]))) -}) - # ============================================================================= # computeBaselineEnrichment # ============================================================================= @@ -1424,7 +1313,7 @@ test_that("shrinkLd wen_stephens uses genetic map when provided", { # Result should be symmetric expect_equal(res, t(res)) # Off-diagonal elements should be shrunk (closer to zero than original) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { for (j in (i + 1):p) { expect_true(abs(res[i, j]) <= abs(R[i, j]) + 1e-10) } @@ -1443,7 +1332,7 @@ set.seed(42) # Helpers: simulate test data # ============================================================================= -simulate_h2_data <- function( +simulateH2Data <- function( n_snps = 100, nBlocks = 2, n_gwas = 50000, @@ -1547,7 +1436,7 @@ simulate_h2_data <- function( # Annotation helper: all-ones baseline so the eigenvalue-score column is # simply the eigenvalue itself (avoids singularity with few blocks), plus # one candidate annotation for score-statistic testing. -make_test_annotations <- function(n_snps) { +makeTestAnnotations <- function(n_snps) { set.seed(99) snp_gr <- GenomicRanges::GRanges( seqnames = rep("chr1", n_snps), @@ -1571,7 +1460,7 @@ make_test_annotations <- function(n_snps) { } # Pre-compute shared test data -dat <- simulate_h2_data() +dat <- simulateH2Data() # ============================================================================= # LDER tests (h2Lder.R) @@ -1717,10 +1606,10 @@ test_that("hdlUnivariate with local = TRUE returns local data.frame", { # ============================================================================= # Use 5 blocks and 500 SNPs for annotation tests to avoid singular matrices -dat_annot <- simulate_h2_data(n_snps = 500, nBlocks = 5) +dat_annot <- simulateH2Data(n_snps = 500, nBlocks = 5) test_that("lderUnivariate with annotations returns enrichment data.frame", { - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::lderUnivariate( dat_annot$z, dat_annot$n, @@ -1731,7 +1620,7 @@ test_that("lderUnivariate with annotations returns enrichment data.frame", { }) test_that("lder enrichment has correct columns", { - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::lderUnivariate( dat_annot$z, dat_annot$n, @@ -1752,7 +1641,7 @@ test_that("lder enrichment has correct columns", { }) test_that("lder with annotations returns tauBlocks matrix", { - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::lderUnivariate( dat_annot$z, dat_annot$n, @@ -1765,7 +1654,7 @@ test_that("lder with annotations returns tauBlocks matrix", { }) test_that("lder with annotations returns scoreStats list", { - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::lderUnivariate( dat_annot$z, dat_annot$n, @@ -1782,7 +1671,7 @@ test_that("lder with annotations returns scoreStats list", { test_that("hdlUnivariate with annotations returns enrichment data.frame with correct columns", { set.seed(123) - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::hdlUnivariate( dat_annot$z, dat_annot$n, @@ -1810,7 +1699,7 @@ test_that("hdlUnivariate with annotations returns enrichment data.frame with cor test_that("hdlUnivariate with annotations returns tauBlocks matrix", { set.seed(124) - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::hdlUnivariate( dat_annot$z, dat_annot$n, @@ -1828,7 +1717,7 @@ test_that("hdlUnivariate with annotations returns tauBlocks matrix", { test_that("hdlUnivariate with annotations and local = TRUE returns local data.frame", { set.seed(125) - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::hdlUnivariate( dat_annot$z, dat_annot$n, @@ -1846,7 +1735,7 @@ test_that("hdlUnivariate with annotations and local = TRUE returns local data.fr test_that("hdlUnivariate with annotations returns scoreStats with z and R", { set.seed(126) - annot <- make_test_annotations(dat_annot$n_snps) + annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::hdlUnivariate( dat_annot$z, dat_annot$n, @@ -1874,7 +1763,7 @@ test_that("hdlUnivariate with annotations returns scoreStats with z and R", { # all-ones, because computeldscores with an all-ones baseline produces # LD scores identical to the base L2 column, making the design matrix # singular. A half-on/half-off baseline avoids collinearity. -make_gldsc_annotations <- function(n_snps) { +makeGldscAnnotations <- function(n_snps) { set.seed(77) snp_gr <- GenomicRanges::GRanges( seqnames = rep("chr1", n_snps), @@ -1899,7 +1788,7 @@ make_gldsc_annotations <- function(n_snps) { test_that("gldscUnivariate with annotations returns enrichment data.frame", { set.seed(200) - annot <- make_gldsc_annotations(dat_annot$n_snps) + annot <- makeGldscAnnotations(dat_annot$n_snps) res <- pecotmr:::gldscUnivariate( dat_annot$z, dat_annot$n, @@ -1927,7 +1816,7 @@ test_that("gldscUnivariate with annotations returns enrichment data.frame", { test_that("gldscUnivariate with annotations returns tauBlocks matrix", { set.seed(201) - annot <- make_gldsc_annotations(dat_annot$n_snps) + annot <- makeGldscAnnotations(dat_annot$n_snps) res <- pecotmr:::gldscUnivariate( dat_annot$z, dat_annot$n, @@ -1946,7 +1835,7 @@ test_that("gldscUnivariate with annotations returns tauBlocks matrix", { test_that("gldscUnivariate with annotations returns scoreStats", { set.seed(202) - annot <- make_gldsc_annotations(dat_annot$n_snps) + annot <- makeGldscAnnotations(dat_annot$n_snps) res <- pecotmr:::gldscUnivariate( dat_annot$z, dat_annot$n, @@ -1970,8 +1859,8 @@ test_that("gldscUnivariate with annotations returns scoreStats", { # Coverage-gap tests (appended) # # Targets the specific uncovered branches in R/h2EstimationWrappers.R: -# bplapplyBlocks, checkGenomeBuild (unknown type), weightedLsRidge -# (vector X ridge path), .rmaMeta (length mismatch), .fglsSolve +# bplapplyBlocks, checkGenomeBuild (unknown type), .rmaMeta (length +# mismatch), .fglsSolve # (diagonal path), .gldscLocal (fine-grained blocks), .hdlLocal (p<3 and # tau=NULL), .lderLocalH2 (small block + baseline path), .hdlSeFisher- # Stratified / .hdlJackknifeTau (lambda>0 + singular fallback), the @@ -2009,10 +1898,12 @@ makeCoverageAnnot <- function( stringsAsFactors = FALSE ) if (nCand > 0L) { - cand <- vapply( - seq_len(nCand), - function(k) as.numeric(rbinom(n_snps, 1, 0.3 + 0.1 * k)), - numeric(n_snps) + cand <- exec( + cbind, + !!!map( + seq_len(nCand), + function(k) as.numeric(rbinom(n_snps, 1, 0.3 + 0.1 * k)) + ) ) mat <- cbind(mat, cand) meta <- rbind( @@ -2061,24 +1952,6 @@ test_that("checkGenomeBuild errors on an unrecognized object type", { ) }) -# --------------------------------------------------------------------------- -# weightedLsRidge — vector X inside the ridge (lambda > 0) path -# --------------------------------------------------------------------------- - -test_that("weightedLsRidge converts a vector X to a matrix in the ridge path", { - set.seed(1) - n <- 40 - x <- rnorm(n) - y <- 2 * x + rnorm(n, sd = 0.1) - w <- rep(1, n) - res <- pecotmr:::weightedLsRidge(y, x, w, lambda = 5) - expect_length(res$coef, 1) - expect_true(is.finite(res$coef[1])) - # single column => penalized (p > 1 is FALSE), so coef is shrunk vs OLS - res0 <- pecotmr:::weightedLsRidge(y, x, w, lambda = 0) - expect_true(abs(res$coef[1]) < abs(res0$coef[1])) -}) - # --------------------------------------------------------------------------- # .rmaMeta — length-mismatch error # --------------------------------------------------------------------------- @@ -2199,7 +2072,7 @@ test_that("gldscUnivariate with baseline-only annotations yields NULL scoreStats # --------------------------------------------------------------------------- test_that("h2EstimateToSldscTrait assigns category names to unnamed tauBlocks", { - h2_obj <- make_test_h2estimate(with_enrichment = TRUE) + h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) tb <- getTauBlocks(h2_obj) colnames(tb) <- NULL h2_obj@tauBlocks <- tb @@ -2213,7 +2086,7 @@ test_that("h2EstimateToSldscTrait assigns category names to unnamed tauBlocks", # --------------------------------------------------------------------------- test_that("estimateH2 errors when study is omitted for a multi-study collection", { - eigen_ref <- make_test_eigen_ref() + eigen_ref <- makeTestEigenRef() n_snps <- length(eigen_ref) set.seed(321) df <- data.frame( @@ -2235,7 +2108,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" study = c("studyA", "studyB"), entry = list(gr, gr), genome = "hg19", - ldSketch = make_test_gwas_genotype_handle(), + ldSketch = makeTestGwasGenotypeHandle(), varY = NA_real_ ) expect_error( @@ -2260,7 +2133,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" # references plus a simulator closure. No external dependencies. .h2RecoveryRefs <- function(nBlocks = 30L, p = 40L, N = 80000) { M <- nBlocks * p - blocks <- lapply(seq_len(nBlocks), function(b) { + blocks <- map(seq_len(nBlocks), function(b) { R <- 0.6^abs(outer(seq_len(p), seq_len(p), "-")) e <- eigen(R, symmetric = TRUE) list( @@ -2278,8 +2151,8 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" A2 = "G", stringsAsFactors = FALSE ) - starts <- as.integer(unlist(lapply(blocks, function(b) min(b$idx)))) * 100L - ends <- as.integer(unlist(lapply(blocks, function(b) max(b$idx)))) * 100L + starts <- as.integer(map_dbl(blocks, function(b) min(b$idx))) * 100L + ends <- as.integer(map_dbl(blocks, function(b) max(b$idx))) * 100L gr <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(start = starts, end = ends) @@ -2292,7 +2165,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" inSample = FALSE, genome = "hg19", eigenvalueTruncation = 1.0, - eigenList = lapply(blocks, function(b) { + eigenList = map(blocks, function(b) { list( values = b$values, vectors = b$vectors, @@ -2312,12 +2185,12 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" genome = "hg19", ldScores = matrix(lsv, ncol = 1, dimnames = list(NULL, "base_l2")), ldScoreWeights = rep(1, M), - ldMatrixList = lapply(blocks, function(b) { + ldMatrixList = map(blocks, function(b) { list(R = b$R, snpIdx = as.integer(b$idx)) }) ) simZ <- function(perSnpVar) { - unlist(lapply(blocks, function(b) { + unlist(map(blocks, function(b) { S <- N * (b$R %*% diag(perSnpVar[b$idx], p) %*% b$R) + b$R as.vector(crossprod(chol(S), rnorm(p))) })) @@ -2431,8 +2304,8 @@ test_that("LDER uses the in-sample vs out-of-sample weight switch", { }) test_that("gLDSC requires full LD matrices and gives a positive jackknife SE", { - noMat <- make_test_score_ref(with_ld_matrices = FALSE) - ss <- make_test_sumstats_for_ref(noMat) + noMat <- makeTestScoreRef(with_ld_matrices = FALSE) + ss <- makeTestSumstatsForRef(noMat) expect_error( estimateH2(ss, noMat, method = "gldsc"), "requires full per-block LD matrices" @@ -2736,7 +2609,7 @@ test_that("HDL recovers a known h2 given an adequate reference", { data(ldEigenExample, ldScoreExample) ref <- ldEigenExample ref@nRef <- 20000L - ests <- vapply( + ests <- map_dbl( 1:5, function(seed) { suppressWarnings( @@ -2746,8 +2619,7 @@ test_that("HDL recovers a known h2 given an adequate reference", { ref )$h2 ) - }, - numeric(1) + } ) expect_lt(abs(mean(ests) - 0.4), 0.1) }) @@ -2882,20 +2754,20 @@ test_that("HDL warns only when a parameter sits at its UPPER bound", { # Only upper bounds are diagnostic: an intercept resting at 0 just means # no confounding and is routine, so a lower bound must not warn. f <- pecotmr:::.hdlWarnIfAtBound - expect_silent(f(c(0.1, 0.5), c(0, 0), c(1, 2), 1000, 500)) + expect_silent(f(c(0.1, 0.5), c(1, 2), 1000, 500)) # At a lower bound: still silent. - expect_silent(f(c(0, 0), c(0, 0), c(1, 2), 1000, 500)) + expect_silent(f(c(0, 0), c(1, 2), 1000, 500)) }) test_that("the HDL bound warning names which parameter pinned", { # The last parameter is the intercept; anything else is heritability. f <- pecotmr:::.hdlWarnIfAtBound expect_warning( - f(c(0.1, 2), c(0, 0), c(1, 2), 1000, 500), + f(c(0.1, 2), c(1, 2), 1000, 500), "the fitted intercept sits at the top of its range" ) expect_warning( - f(c(1, 0.5), c(0, 0), c(1, 2), 1000, 500), + f(c(1, 0.5), c(1, 2), 1000, 500), "the fitted heritability sits at the top of its range" ) }) @@ -3035,11 +2907,11 @@ test_that(".sldscBlockIndex errors when no block covers a variant", { mk(GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 10000))) ) expect_error( - suppressWarnings(pecotmr:::.sldscBlockIndex(disjoint, n)), + suppressWarnings(pecotmr:::.sldscBlockIndex(disjoint)), "no LD block covers any reference variant" ) covering <- mk(GenomicRanges::GRanges("chr22", IRanges::IRanges(1, 10000))) - idx <- pecotmr:::.sldscBlockIndex(covering, n) + idx <- pecotmr:::.sldscBlockIndex(covering) expect_equal(unname(lengths(idx)), n) }) @@ -3067,11 +2939,64 @@ test_that(".sldscLocal clamps a negative LD score to zero", { out <- pecotmr:::.sldscLocal( chi2 = c(1.2, 3.4), baseScore = c(10, -2), - fit = list(tau = c(1e-5)), - M = 1000 + fit = list(tau = c(1e-5)) ) expect_equal(out$variantIdx, 1:2) expect_equal(out$ldScore, c(10, -2)) # A negative LD score cannot contribute negative heritability. expect_equal(out$h2Local, c(1e-4, 0)) }) + +test_that("RmaOptions refuses the estimates and the estimator choice", { + expect_error(RmaOptions(yi = 1), "the per-study estimates") + expect_error(RmaOptions(sei = 1), "the per-study standard errors") + expect_error(RmaOptions(method = "REML"), "the caller's `metaMethod`") + # metafor::rma() takes dots, so nothing else can be rejected. + expect_s4_class(RmaOptions(nosuch = 1), "MethodOptions") + expect_equal(RmaOptions(test = "knha")$test, "knha") +}) + +test_that(".rmaMeta forwards metaArgs to metafor::rma", { + seen <- NULL + real <- metafor::rma + means <- c(0.2, 0.3, 0.25, 0.4) + ses <- c(0.1, 0.12, 0.09, 0.15) + suppressWarnings(with_mocked_bindings( + pecotmr:::.rmaMeta(means, ses, metaArgs = RmaOptions(test = "knha")), + rma = function(...) { + seen <<- list(...) + real(...) + }, + .package = "metafor" + )) + expect_equal(seen$test, "knha") + expect_equal(seen$method, "DL") +}) + +test_that("the DL fallback carries metaArgs too", { + seen <- list() + real <- metafor::rma + means <- c(0.2, 0.3, 0.25, 0.4) + ses <- c(0.1, 0.12, 0.09, 0.15) + suppressWarnings(with_mocked_bindings( + pecotmr:::.rmaMeta( + means, + ses, + method = "REML", + metaArgs = RmaOptions(level = 90) + ), + rma = function(...) { + args <- list(...) + seen[[length(seen) + 1L]] <<- args + # Fail the iterative estimator so the DL fallback runs. + if (!identical(args$method, "DL")) { + stop("forced iterative failure") + } + real(...) + }, + .package = "metafor" + )) + expect_length(seen, 2L) + expect_equal(seen[[2]]$method, "DL") + expect_true(all(map_dbl(seen, "level") == 90)) +}) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index 75e630707..6432a76b5 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -76,7 +76,13 @@ test_that(".runJointCell: cross-context FM expands to per-context rows", { set.seed(1) cell <- .je_synthCell(list(.je_mkGroup("G1"), .je_mkGroup("G2"))) - pipe <- new("FmJointPipeline", config = list(coverage = 0.95, cvFolds = 0)) + pipe <- new( + "FmJointPipeline", + config = list( + coverage = 0.95, + crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + ) + ) local_mocked_bindings( create_mixture_prior = function(...) "PRIOR", .package = "mvsusieR" @@ -112,11 +118,16 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { pipe <- new( "FmJointPipeline", config = list( - coverage = 0.95, - cvFolds = 0, - fullFit = TRUE, - fullFitAlphaOnly = FALSE, - includeAllCs = TRUE + credibleSetArgs = CredibleSetParam( + includeAllCs = TRUE, + perCsColumns = "full" + ), + crossValidationArgs = list( + folds = 0, + threads = 1, + maxVariants = -1 + ), + fitRetention = "slim" ) ) local_mocked_bindings( @@ -129,31 +140,25 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { method, dataX, dataY, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, + credibleSetArgs, + fitRetention, csInput = NULL, af = NULL, region = NULL, conditionIdx = NULL, - fullFit = NULL, - fullFitAlphaOnly = NULL, - includeAllCs = NULL, ... ) { - captured$fullFit <- fullFit - captured$fullFitAlphaOnly <- fullFitAlphaOnly - captured$includeAllCs <- includeAllCs + captured$perCsColumns <- credibleSetArgs$perCsColumns + captured$includeAllCs <- credibleSetArgs$includeAllCs .je_mockPostprocess( fit, method, dataX, dataY, - coverage, - secondaryCoverage, - signalCutoff, - minAbsCorr, + credibleSetArgs$coverage, + credibleSetArgs$secondaryCoverage, + credibleSetArgs$signalCutoff, + credibleSetArgs$minAbsCorr, csInput = csInput, af = af, region = region, @@ -172,15 +177,21 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { scope = NULL, tokens = "mvsusie" ) - expect_true(isTRUE(captured$fullFit)) # threaded, not the FALSE default - expect_false(isTRUE(captured$fullFitAlphaOnly)) # widen all four matrices + # "full" widens all four matrices; threaded, not the "none" default. + expect_equal(captured$perCsColumns, "full") 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"))) - pipe <- new("FmJointPipeline", config = list(coverage = 0.95, cvFolds = 2)) + pipe <- new( + "FmJointPipeline", + config = list( + coverage = 0.95, + crossValidationArgs = list(folds = 2, threads = 1, maxVariants = -1) + ) + ) # Prior mr.mash CV payload. Looked up by the FIXED axes (study=S, trait=G1) # with context match-any, so a per-context OR a legacy "joint" row both match. @@ -257,7 +268,7 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", data = NULL, scope = NULL, tokens = "mvsusie", - args = list(twasWeights = tw) + args = list(mrmashPrior = tw) ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) # per-context rows @@ -284,8 +295,7 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", study, context, trait, - retainFits, - retainFitDetail, + fitRetention, standardized, dataType, verbose, @@ -317,7 +327,7 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", fold, samplePartitions = NULL, weightMethods, - retainFits, + fitRetention, ..., verbose ) { @@ -355,7 +365,12 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", test_that(".runJointCell: cross-context twas expands to per-context weight vectors", { set.seed(3) cell <- .je_synthCell(list(.je_mkGroup("G1"))) - pipe <- new("TwasJointPipeline", config = list(cvFolds = 0)) + pipe <- new( + "TwasJointPipeline", + config = list( + crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + ) + ) local_mocked_bindings( learnTwasWeights = .je_mockLearnTwas, .package = "pecotmr" @@ -384,7 +399,12 @@ test_that(".runJointCell: cross-context twas expands to per-context weight vecto test_that(".runJointCell: cross-context twas attaches per-condition CV slices", { set.seed(4) cell <- .je_synthCell(list(.je_mkGroup("G1"))) - pipe <- new("TwasJointPipeline", config = list(cvFolds = 2)) + pipe <- new( + "TwasJointPipeline", + config = list( + crossValidationArgs = list(folds = 2, threads = 1, maxVariants = -1) + ) + ) local_mocked_bindings( learnTwasWeights = .je_mockLearnTwas, twasWeightsCv = .je_mockTwasCv, @@ -413,7 +433,14 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", cell <- .je_synthCell(list(.je_mkGroup("G1"))) pipe <- new( "TwasJointPipeline", - config = list(cvFolds = 2, fitFullData = FALSE) + config = list( + crossValidationArgs = list( + folds = 2, + threads = 1, + maxVariants = -1 + ), + fitFullData = FALSE + ) ) local_mocked_bindings(twasWeightsCv = .je_mockTwasCv, .package = "pecotmr") @@ -439,7 +466,7 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", p, k, dimnames = list( - sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + sprintf("chr1:%d:A:G", 100L * seq_len(p)), paste0("c", seq_len(k)) ) ) @@ -523,7 +550,7 @@ test_that(".runJointCell: cross-context twas sumstats (mr.mash.rss) -> per-conte cell <- .je_ssCell(list(.je_mkSsGroup("G1"))) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, retainFit, fitDetail) { + mrmashRssWeights = function(stat, LD, fitRetention) { W <- matrix( 0.2, nrow(LD), @@ -568,7 +595,7 @@ test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regressi K <- 2L nObs <- 400L X <- matrix(rnorm(nObs * p), nObs, p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) R <- cor(X) Z <- matrix( rnorm(p * K), @@ -589,7 +616,13 @@ test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regressi ) pipe <- new( "TwasJointPipeline", - config = list(retainFitDetail = "slim", cvFolds = 0L) + config = list( + crossValidationArgs = list( + folds = 0L, + threads = 1, + maxVariants = -1 + ) + ) ) entries <- suppressWarnings(suppressMessages( fitJointGroup(group, pipe, "mrmash", list()) @@ -662,7 +695,7 @@ test_that(".runJointCell: cross-study (twas sumstats) -> per-study rows + jointS ) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, retainFit, fitDetail) { + mrmashRssWeights = function(stat, LD, fitRetention) { W <- matrix( 0.2, nrow(LD), @@ -724,7 +757,13 @@ test_that(".runJointCell: composed (context + trait vary) -> per-tuple rows", { enumerate = function(data, scope, args) list(grp), minGroup = 2L ) - pipe <- new("FmJointPipeline", config = list(coverage = 0.95, cvFolds = 0)) + pipe <- new( + "FmJointPipeline", + config = list( + coverage = 0.95, + crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + ) + ) local_mocked_bindings( create_mixture_prior = function(...) "PRIOR", .package = "mvsusieR" @@ -796,7 +835,13 @@ test_that(".runJointCell: composed (context + trait vary) -> per-tuple rows", { test_that(".runJointCell: cross-trait FM -> per-trait rows (context fixed)", { set.seed(8) cell <- .je_traitCell(list(.je_mkTraitGroup("brain"))) - pipe <- new("FmJointPipeline", config = list(coverage = 0.95, cvFolds = 0)) + pipe <- new( + "FmJointPipeline", + config = list( + coverage = 0.95, + crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + ) + ) local_mocked_bindings( create_mixture_prior = function(...) "PRIOR", .package = "mvsusieR" @@ -824,7 +869,12 @@ test_that(".runJointCell: cross-trait FM -> per-trait rows (context fixed)", { test_that(".runJointCell: cross-trait twas -> per-trait weight vectors", { set.seed(9) cell <- .je_traitCell(list(.je_mkTraitGroup("brain"))) - pipe <- new("TwasJointPipeline", config = list(cvFolds = 0)) + pipe <- new( + "TwasJointPipeline", + config = list( + crossValidationArgs = list(folds = 0, threads = 1, maxVariants = -1) + ) + ) local_mocked_bindings( learnTwasWeights = .je_mockLearnTwas, .package = "pecotmr" @@ -963,7 +1013,7 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro ) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, retainFit, fitDetail) { + mrmashRssWeights = function(stat, LD, fitRetention) { W <- matrix( 0.2, nrow(LD), @@ -1026,7 +1076,7 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro .je_ensEntries <- function(group, predCor) { Y <- .jgY(group) vars <- colnames(.jgX(group)) - lapply(seq_len(ncol(Y)), function(r) { + map(seq_len(ncol(Y)), function(r) { pr <- predCor * Y[, r] + rnorm(nrow(Y), sd = 0.3) names(pr) <- rownames(Y) rsq <- stats::cor(Y[, r], pr)^2 @@ -1053,14 +1103,20 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro test_that(".twasEnsembleLayer: >= 2 methods passing -> per-condition ensemble entries", { set.seed(1) g <- .je_ensGroup() - pte <- list(lasso = .je_ensEntries(g, 0.85), enet = .je_ensEntries(g, 0.70)) + pte <- list( + lasso_weights = .je_ensEntries(g, 0.85), + enet = .je_ensEntries(g, 0.70) + ) ens <- pecotmr:::.twasEnsembleLayer( g, pte, list( - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", - ensembleAlpha = 1, + ensembleArgs = list( + enabled = TRUE, + r2Threshold = 0.01, + solver = "quadprog", + alpha = 1 + ), standardized = FALSE ) ) @@ -1075,18 +1131,24 @@ test_that(".twasEnsembleLayer: >= 2 methods passing -> per-condition ensemble en test_that(".twasEnsembleLayer: < 2 methods pass the R^2 cutoff -> NULL (skip)", { set.seed(2) g <- .je_ensGroup() - pte <- list(lasso = .je_ensEntries(g, 0.85), enet = .je_ensEntries(g, 0.70)) + pte <- list( + lasso_weights = .je_ensEntries(g, 0.85), + enet = .je_ensEntries(g, 0.70) + ) ens <- pecotmr:::.twasEnsembleLayer( g, pte, list( - ensembleR2Threshold = 0.999, - ensembleSolver = "quadprog", - ensembleAlpha = 1, + ensembleArgs = list( + enabled = TRUE, + r2Threshold = 0.999, + solver = "quadprog", + alpha = 1 + ), standardized = FALSE ) ) - expect_true(all(vapply(ens, is.null, logical(1)))) + expect_true(all(map_lgl(ens, is.null))) }) # ---- engine twas fitter: orchestration absorbed from .twasWeightsPipelineMatrix @@ -1096,7 +1158,14 @@ test_that("fitJointGroup(twas): leakage warning when a full-data mr.mash prior i g <- .je_mkGroup("G1") pipe <- new( "TwasJointPipeline", - config = list(cvFolds = 2L, ensemble = FALSE) + config = list( + crossValidationArgs = list( + folds = 2L, + threads = 1, + maxVariants = -1 + ), + ensembleArgs = list(enabled = FALSE) + ) ) local_mocked_bindings( learnTwasWeights = .je_mockLearnTwas, @@ -1127,9 +1196,12 @@ test_that("fitJointGroup(twas): spike-and-slab pi is estimated from an internal rnorm(n * 3), n, 3, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:3))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * (1:3)) + ) ) - Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", 1:n), "c1")) + Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", seq_len(n)), "c1")) g <- new( "IndividualJointGroup", conditions = data.frame( @@ -1143,7 +1215,15 @@ test_that("fitJointGroup(twas): spike-and-slab pi is estimated from an internal ) pipe <- new( "TwasJointPipeline", - config = list(cvFolds = 0L, ensemble = FALSE, estimatePi = TRUE) + config = list( + crossValidationArgs = list( + folds = 0L, + threads = 1, + maxVariants = -1 + ), + ensembleArgs = list(enabled = FALSE), + estimatePi = TRUE + ) ) capturedPi <- NULL local_mocked_bindings( @@ -1173,7 +1253,14 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand g <- .je_mkGroup("G1") # 2 conditions (c1, c2) pipe <- new( "TwasJointPipeline", - config = list(cvFolds = 2L, ensemble = FALSE) + config = list( + crossValidationArgs = list( + folds = 2L, + threads = 1, + maxVariants = -1 + ), + ensembleArgs = list(enabled = FALSE) + ) ) samp <- rownames(.jgX(g)) fmCv <- list( @@ -1225,7 +1312,7 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand pipe, "mvsusie", list( - methodList = list(mvsusie_weights = list()), + methodList = list(mvsusie = list()), fittedModels = list(mvsusie = list(dummy = TRUE)), fineMappingCv = fmCv ) @@ -1270,12 +1357,12 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand p, length(colLabels), dimnames = list( - sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + sprintf("chr1:%d:A:G", 100L * seq_len(p)), colLabels ) ), nVec = rep(100, length(colLabels)), - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) } .je_mockLd <- function(sketch, vids, ...) { @@ -1320,7 +1407,8 @@ test_that(".enumCrossContextIndividual: one group per trait in >= 2 contexts", { cisWindow, verbose, label, - region = NULL + region = NULL, + ... ) { if (tid == "G2") { return(NULL) @@ -1432,7 +1520,8 @@ test_that(".enumCrossTraitIndividual: one group per context with >= 2 traits + p verbose, label, study, - region = NULL + region = NULL, + ... ) { if (cx == "c2") { return(NULL) @@ -1536,7 +1625,8 @@ test_that(".enumComposedIndividual: one group joining every (context, trait) tup cisWindow, verbose, label, - region = NULL + region = NULL, + ... ) { Y <- matrix( 0, @@ -1605,7 +1695,13 @@ test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait) local_mocked_bindings( getStudy = function(data) "S", getPhenotypes = function(data, contexts) .je_mkSe(c("G1", "G2")), - .fmResidPheno = function(data, contexts, traitId, naAction = "drop") { + .fmResidPheno = function( + data, + contexts, + traitId, + naAction = "drop", + ... + ) { matrix(0, 5, 1, dimnames = list(samp, traitId)) }, .fmResidGeno = function( @@ -1613,7 +1709,8 @@ test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait) contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -1627,7 +1724,7 @@ test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait) g <- pecotmr:::.enumUnivariateIndividual(NULL, scope) expect_length(g, 4L) # 2 ctx x 2 traits expect_true(all( - vapply(g, function(x) nrow(.jgConditions(x)), integer(1)) == 1L + map_int(g, function(x) nrow(.jgConditions(x))) == 1L )) }) @@ -1640,7 +1737,13 @@ test_that(".enumUnivariateIndividual: too few shared samples skips the tuple", { local_mocked_bindings( getStudy = function(data) "S", getPhenotypes = function(data, contexts) .je_mkSe("G1"), - .fmResidPheno = function(data, contexts, traitId, naAction = "drop") { + .fmResidPheno = function( + data, + contexts, + traitId, + naAction = "drop", + ... + ) { matrix(0, 1, 1, dimnames = list("s1", traitId)) }, # one sample .fmResidGeno = function( @@ -1648,7 +1751,8 @@ test_that(".enumUnivariateIndividual: too few shared samples skips the tuple", { contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -1751,13 +1855,16 @@ test_that("fitJointGroup(Individual, Fm): fsusie honest per-fold CV is attached" rnorm(n * 2), n, 2, - dimnames = list(paste0("s", 1:n), c("chr1:100:A:G", "chr1:200:A:G")) + dimnames = list( + paste0("s", seq_len(n)), + c("chr1:100:A:G", "chr1:200:A:G") + ) ) Y <- matrix( rnorm(n * 2), n, 2, - dimnames = list(paste0("s", 1:n), c("G1", "G2")) + dimnames = list(paste0("s", seq_len(n)), c("G1", "G2")) ) grp <- new( "IndividualJointGroup", @@ -1771,7 +1878,13 @@ test_that("fitJointGroup(Individual, Fm): fsusie honest per-fold CV is attached" Y = Y, traitPos = c(100, 200) ) - pipe <- new("FmJointPipeline", config = list(coverage = 0.95, cvFolds = 3)) + pipe <- new( + "FmJointPipeline", + config = list( + coverage = 0.95, + crossValidationArgs = list(folds = 3, threads = 1, maxVariants = -1) + ) + ) cvCalled <- FALSE local_mocked_bindings( fitFsusie = function(...) list(), @@ -1802,7 +1915,7 @@ test_that("fitJointGroup(Individual, Fm): SER pre-screen skips when < 2 survivor pecotmr:::fitJointGroup(g, pipe, "mvsusie", list(pipCutoffToSkip = 0.8)) ) expect_length(entries, 2L) # one per ORIGINAL cond - expect_true(all(vapply(entries, is.null, logical(1)))) # all-NULL (skipped) + expect_true(all(map_lgl(entries, is.null))) # all-NULL (skipped) }) test_that("fitJointGroup(Individual, Fm): SER pre-screen keeps a subset of conditions", { @@ -1812,13 +1925,16 @@ test_that("fitJointGroup(Individual, Fm): SER pre-screen keeps a subset of condi rnorm(n * 2), n, 2, - dimnames = list(paste0("s", 1:n), c("chr1:100:A:G", "chr1:200:A:G")) + dimnames = list( + paste0("s", seq_len(n)), + c("chr1:100:A:G", "chr1:200:A:G") + ) ) Y <- matrix( rnorm(n * 3), n, 3, - dimnames = list(paste0("s", 1:n), c("c1", "c2", "c3")) + dimnames = list(paste0("s", seq_len(n)), c("c1", "c2", "c3")) ) g <- new( "IndividualJointGroup", @@ -1904,9 +2020,12 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { rnorm(n * 3), n, 3, - dimnames = list(paste0("s", 1:n), sprintf("chr1:%d:A:G", 100L * (1:3))) + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * (1:3)) + ) ) - Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", 1:n), "c1")) + Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", seq_len(n)), "c1")) g <- new( "IndividualJointGroup", conditions = data.frame( @@ -1920,7 +2039,15 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { ) pipe <- new( "TwasJointPipeline", - config = list(cvFolds = 0L, ensemble = FALSE, estimatePi = TRUE) + config = list( + crossValidationArgs = list( + folds = 0L, + threads = 1, + maxVariants = -1 + ), + ensembleArgs = list(enabled = FALSE), + estimatePi = TRUE + ) ) capturedProbIn <- NULL local_mocked_bindings( @@ -1953,7 +2080,7 @@ test_that("fitJointGroup(SumStats, twas): a vector weight without rownames falls grp <- .je_mkSsGroup("G1", p = 3L, k = 2L) pipe <- new("TwasJointPipeline", config = list()) local_mocked_bindings( - mrmashRssWeights = function(stat, LD, retainFit, fitDetail) { + mrmashRssWeights = function(stat, LD, fitRetention) { # Return a bare numeric vector (one column collapsed) with no names. w <- as.numeric(rep(0.2, nrow(LD) * ncol(stat$z))) attr(w, "fit") <- .je_fakeMrmashFit() @@ -2014,11 +2141,17 @@ test_that(".runJointCell: twas ensemble layer adds 'ensemble' rows on top of >= pipe <- new( "TwasJointPipeline", config = list( - cvFolds = 2L, - ensemble = TRUE, - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", - ensembleAlpha = 1, + crossValidationArgs = list( + folds = 2L, + threads = 1, + maxVariants = -1 + ), + ensembleArgs = list( + enabled = TRUE, + r2Threshold = 0.01, + solver = "quadprog", + alpha = 1 + ), standardized = FALSE ) ) @@ -2054,19 +2187,25 @@ test_that(".twasEnsembleLayer: entries lacking CV predictions are skipped", { g, list(a = good, b = noCv, c = NULL), list( - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", - ensembleAlpha = 1, + ensembleArgs = list( + enabled = TRUE, + r2Threshold = 0.01, + solver = "quadprog", + alpha = 1 + ), standardized = FALSE ) ) - expect_true(all(vapply(ens, is.null, logical(1)))) # < 2 usable -> NULL + expect_true(all(map_lgl(ens, is.null))) # < 2 usable -> NULL }) test_that(".twasEnsembleLayer: ensembleWeights returning NULL -> NULL entry", { set.seed(32) g <- .je_ensGroup(nCond = 1L) - pte <- list(lasso = .je_ensEntries(g, 0.85), enet = .je_ensEntries(g, 0.70)) + pte <- list( + lasso_weights = .je_ensEntries(g, 0.85), + enet = .je_ensEntries(g, 0.70) + ) local_mocked_bindings( ensembleWeights = function(...) NULL, .package = "pecotmr" @@ -2075,19 +2214,25 @@ test_that(".twasEnsembleLayer: ensembleWeights returning NULL -> NULL entry", { g, pte, list( - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", - ensembleAlpha = 1, + ensembleArgs = list( + enabled = TRUE, + r2Threshold = 0.01, + solver = "quadprog", + alpha = 1 + ), standardized = FALSE ) ) - expect_true(all(vapply(ens, is.null, logical(1)))) + expect_true(all(map_lgl(ens, is.null))) }) test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's variant ids", { set.seed(33) g <- .je_ensGroup(nCond = 1L) - pte <- list(lasso = .je_ensEntries(g, 0.85), enet = .je_ensEntries(g, 0.70)) + pte <- list( + lasso_weights = .je_ensEntries(g, 0.85), + enet = .je_ensEntries(g, 0.70) + ) local_mocked_bindings( ensembleWeights = function( cvResults, @@ -2109,9 +2254,12 @@ test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's g, pte, list( - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", - ensembleAlpha = 1, + ensembleArgs = list( + enabled = TRUE, + r2Threshold = 0.01, + solver = "quadprog", + alpha = 1 + ), standardized = FALSE ) ) @@ -2200,7 +2348,16 @@ test_that(".runJointSpecs: no methods or no specs -> NULL", { test_that(".twasGroupArgs: takes the CV partition from the fine-mapping CV when none is set", { g <- .je_mkGroup("G1") # IndividualJointGroup - pipe <- new("TwasJointPipeline", config = list(cvFolds = 2L)) + pipe <- new( + "TwasJointPipeline", + config = list( + crossValidationArgs = list( + folds = 2L, + threads = 1, + maxVariants = -1 + ) + ) + ) sp <- data.frame( Sample = rownames(.jgX(g)), Fold = rep(1:2, length.out = nrow(.jgX(g))), @@ -2525,8 +2682,14 @@ test_that(".runJointSpecs row-binds TWAS results across specs", { .package = "pecotmr" ) out <- pecotmr:::.runJointSpecs( - list("s1", "s2", "s3"), NULL, "individual", - NULL, "lasso", NULL, NULL, list() + list("s1", "s2", "s3"), + NULL, + "individual", + NULL, + "lasso", + NULL, + NULL, + list() ) # The first spec seeds `out`; later ones are bound onto it. expect_equal(out, "R1+R2+R3") @@ -2547,8 +2710,14 @@ test_that(".runJointSpecs row-binds fine-mapping results across specs", { ) # The pipeline class, not the data, picks which rbind is used. out <- pecotmr:::.runJointSpecs( - list("s1", "s2"), NULL, "individual", - new("FmJointPipeline"), "susie", NULL, NULL, list() + list("s1", "s2"), + NULL, + "individual", + new("FmJointPipeline"), + "susie", + NULL, + NULL, + list() ) expect_equal(out, "F1&F2") }) @@ -2565,8 +2734,14 @@ test_that(".runJointSpecs skips a spec that produced nothing", { # A NULL spec must not seed `out`, or the bind would carry a NULL. expect_equal( pecotmr:::.runJointSpecs( - list("s1", "s2"), NULL, "individual", - NULL, "lasso", NULL, NULL, list() + list("s1", "s2"), + NULL, + "individual", + NULL, + "lasso", + NULL, + NULL, + list() ), "KEPT" ) @@ -2575,8 +2750,9 @@ test_that(".runJointSpecs skips a spec that produced nothing", { test_that(".twasGroupArgs yields no fitted models when the fit is absent", { local_mocked_bindings( .jpConfig = function(p) list(), - .jgConditions = function(g) list(study = "s", context = "c", - trait = "t"), + .jgConditions = function(g) { + list(study = "s", context = "c", trait = "t") + }, .twasFineMappingFits = function(...) NULL, .twasCvResultFor = function(...) NULL, .package = "pecotmr" @@ -2605,9 +2781,12 @@ test_that(".twasEnsembleLayer falls back to its documented config defaults", { "grp", list(), list( - ensembleR2Threshold = 0.2, - ensembleSolver = "nnls", - ensembleAlpha = 0.5 + ensembleArgs = list( + enabled = TRUE, + r2Threshold = 0.2, + solver = "nnls", + alpha = 0.5 + ) ) ) expect_length(explicit, 0L) @@ -2618,9 +2797,19 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { local_mocked_bindings( .twasFmHandoffCv = function(...) NULL, .jointTwasLeakageWarn = function(...) invisible(NULL), - twasWeightsCv = function(X, Y, fold, samplePartitions, weightMethods, - retainFits, maxNumVariants, numThreads, - data_driven_priorMatricesCv, verbose, seed) { + twasWeightsCv = function( + X, + Y, + fold, + samplePartitions, + weightMethods, + fitRetention, + maxNumVariants, + numThreads, + dataDrivenPriorMatricesCv, + verbose, + seed + ) { seen <<- list(sp = samplePartitions, mcv = maxNumVariants) "CV" }, @@ -2633,11 +2822,24 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { dataDrivenPriorMatricesCv = NULL ) cfg <- list( - cvFolds = 5L, samplePartition = "CFG_SP", maxCvVariants = 77L, - cvThreads = 1, seed = 1L, verbose = 0 + crossValidationArgs = list( + folds = 5L, + samplePartition = "CFG_SP", + maxVariants = 77L, + threads = 1 + ), + seed = 1L, + verbose = 0 ) pecotmr:::.jointTwasCv( - NULL, NULL, "lasso", NULL, c(1, 2), args, cfg, "lasso" + NULL, + NULL, + "lasso", + NULL, + c(1, 2), + args, + cfg, + "lasso" ) expect_equal(seen$sp, "ARGS_SP") expect_equal(seen$mcv, 77L) @@ -2646,9 +2848,16 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { argsBare <- args argsBare$samplePartition <- NULL cfgUncapped <- cfg - cfgUncapped$maxCvVariants <- 0 + cfgUncapped$crossValidationArgs$maxVariants <- 0 pecotmr:::.jointTwasCv( - NULL, NULL, "lasso", NULL, c(1, 2), argsBare, cfgUncapped, "lasso" + NULL, + NULL, + "lasso", + NULL, + c(1, 2), + argsBare, + cfgUncapped, + "lasso" ) expect_equal(seen$sp, "CFG_SP") expect_equal(seen$mcv, Inf) @@ -2665,13 +2874,22 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { local_mocked_bindings( getStudy = function(data) "S1", getPhenotypes = function(data, contexts) phenotypes, - .fmResidPheno = function(data, contexts, traitId, naAction) { + .fmResidPheno = function(data, contexts, traitId, naAction, ...) { matrix(1, 2L, 1L, dimnames = list(c("s1", "s2"), "t1")) }, - .fmResidGeno = function(data, contexts, traitId = NULL, - cisWindow = NULL, region = NULL) { - seen <<- list(traitId = traitId, cisWindow = cisWindow, - region = region) + .fmResidGeno = function( + data, + contexts, + traitId = NULL, + cisWindow = NULL, + region = NULL, + ... + ) { + seen <<- list( + traitId = traitId, + cisWindow = cisWindow, + region = region + ) matrix(0, 2L, 2L, dimnames = list(c("s1", "s2"), c("v1", "v2"))) }, .package = "pecotmr" @@ -2682,7 +2900,9 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { traits = list(S1 = "t1") ) pecotmr:::.enumUnivariateIndividual( - NULL, scope, list(region = "chr1:1-1000") + NULL, + scope, + list(region = "chr1:1-1000") ) # An explicit region replaces the trait-anchored cis window entirely -- # neither traitId nor cisWindow is passed down. @@ -2690,3 +2910,210 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { expect_null(seen$cisWindow) expect_null(seen$traitId) }) + +# --------------------------------------------------------------------------- +# cvWeightMethods: the override and the all-zero notice. Both were amputated +# by 693e6d63 (the parameter stayed, its read path did not), so they are +# covered here to stop the same silent loss happening twice. +# --------------------------------------------------------------------------- + +test_that(".jointTwasCvRequested: NULL means every method", { + expect_true(pecotmr:::.jointTwasCvRequested(NULL, "susie")) + expect_true(pecotmr:::.jointTwasCvRequested(NULL, "lasso")) +}) + +test_that(".jointTwasCvRequested accepts tokens and method keys alike", { + expect_true(pecotmr:::.jointTwasCvRequested(c("susie", "lasso"), "susie")) + expect_false(pecotmr:::.jointTwasCvRequested(c("susie", "lasso"), "mrash")) + # the `_weights` spelling used by weightMethods lists + expect_true( + pecotmr:::.jointTwasCvRequested(c("susie_weights"), "susie") + ) + # and a named method list, not just a character vector + expect_true( + pecotmr:::.jointTwasCvRequested(list(lasso = list()), "lasso") + ) + expect_false( + pecotmr:::.jointTwasCvRequested(list(lasso = list()), "susie") + ) + # a multi-word token: `susie_inf_weights` strips to `susie_inf`, which is + # not the canonical `susieInf`, so suffix-stripping alone misses it + expect_true( + pecotmr:::.jointTwasCvRequested(c("susie_inf_weights"), "susieInf") + ) + expect_true( + pecotmr:::.jointTwasCvRequested( + list(susieInfWeights = list()), + "susieInf" + ) + ) + expect_false( + pecotmr:::.jointTwasCvRequested(c("susie_inf_weights"), "susie") + ) +}) + +test_that(".jointTwasCv skips a method excluded by cvWeightMethods", { + cfg <- list( + crossValidationArgs = list( + folds = 5L, + threads = 1, + maxVariants = -1, + weightMethods = c("lasso") + ) + ) + out <- pecotmr:::.jointTwasCv( + Xc = NULL, + Yc = NULL, + wm = NULL, + ma = NULL, + W = matrix(1, 2, 1), + args = list(), + cfg = cfg, + token = "susie" + ) + expect_null(out) +}) + +test_that(".jointTwasCv warns when a method is all-zero, not silently", { + cfg <- list( + crossValidationArgs = list( + folds = 5L, + threads = 1, + maxVariants = -1, + weightMethods = NULL + ) + ) + expect_warning( + out <- pecotmr:::.jointTwasCv( + Xc = NULL, + Yc = NULL, + wm = NULL, + ma = NULL, + W = matrix(0, 3, 1), + args = list(), + cfg = cfg, + token = "susie" + ), + "all of its weights are zero" + ) + expect_null(out) +}) + +test_that(".jointTwasCv refuses a fine-mapping method with no per-fold fits", { + # Without a CV handoff from the FineMappingResult there is no fold fit, + # and this layer never fine-maps -- so it refuses rather than re-fitting. + cfg <- list( + crossValidationArgs = list( + folds = 5L, + threads = 1, + maxVariants = -1, + weightMethods = NULL + ) + ) + expect_error( + pecotmr:::.jointTwasCv( + Xc = NULL, + Yc = NULL, + wm = NULL, + ma = NULL, + W = matrix(1, 3, 1), + args = list(), + cfg = cfg, + token = "susie" + ), + "needs each fold's own fine-mapping fit" + ) +}) + +test_that(".jointCvPartition lets the fine-mapping folds govern the group", { + sp <- data.frame( + Sample = c("s1", "s2", "s3", "s4"), + Fold = c(1L, 1L, 2L, 2L) + ) + ids <- c("s1", "s2", "s3", "s4") + # the fine-mapping CV's own partition is what every method is scored on + expect_equal( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = NULL, + sampleIds = ids, + cvFolds = 2L + ), + sp + ) + # an identical explicit partition is no conflict + expect_equal( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = sp, + sampleIds = ids, + cvFolds = 2L + ), + sp + ) + # with no fine-mapping CV the explicit partition still wins + expect_equal( + pecotmr:::.jointCvPartition( + fmCv = NULL, + userSp = sp, + sampleIds = ids, + cvFolds = 2L + ), + sp + ) + # and with neither, no partition is fixed here: an integer `cvFolds` only + # validates, leaving twasWeightsCv() to draw the folds downstream + expect_null( + pecotmr:::.jointCvPartition( + fmCv = NULL, + userSp = NULL, + sampleIds = ids, + cvFolds = 2L + ) + ) +}) + +test_that(".jointCvPartition rejects fold samples absent from the dataset", { + sp <- data.frame( + Sample = c("s1", "s2", "ghost1", "ghost2"), + Fold = c(1L, 1L, 2L, 2L) + ) + expect_error( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = NULL, + sampleIds = c("s1", "s2", "s3"), + cvFolds = 2L + ), + "ghost1, ghost2" + ) +}) + +test_that(".jointCvPartition rejects a partition conflicting with the CV's", { + sp <- data.frame( + Sample = c("s1", "s2", "s3", "s4"), + Fold = c(1L, 1L, 2L, 2L) + ) + other <- data.frame( + Sample = c("s1", "s2", "s3", "s4"), + Fold = c(2L, 2L, 1L, 1L) + ) + expect_error( + pecotmr:::.jointCvPartition( + fmCv = list(samplePartition = sp), + userSp = other, + sampleIds = c("s1", "s2", "s3", "s4"), + cvFolds = 2L + ), + "differs from the fine-mapping" + ) +}) + +test_that(".twasEnsembleCollect answers empty parts when no token contributes", { + # No tokens means nothing to gather, which is empty containers of the + # right shape rather than NULL. + out <- pecotmr:::.twasEnsembleCollect(NULL, list(), character(0)) + expect_identical(out$preds, list()) + expect_identical(out$wts, list()) + expect_identical(out$rsq, c()) +}) diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index feeb07cc1..fba884e74 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -59,7 +59,7 @@ traits = c("ENSG1", "ENSG2") ) { phenos <- setNames( - lapply(contexts, function(cx) .js_makeSe(traits = traits)), + map(contexts, function(cx) .js_makeSe(traits = traits)), contexts ) QtlDataset( @@ -81,7 +81,7 @@ trait = traits, stringsAsFactors = FALSE ) - entries <- lapply(seq_len(nrow(rows)), function(i) { + entries <- map(seq_len(nrow(rows)), function(i) { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges(start = c(100L, 200L), width = 1L) @@ -718,7 +718,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") path = "/tmp/jd.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -803,7 +803,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") study = rows$study, context = rows$context, trait = rows$trait, - entry = lapply(seq_len(nrow(rows)), function(.) makeGr()), + entry = map(seq_len(nrow(rows)), function(.) makeGr()), genome = "hg19", ldSketch = .jd_makeHandle(), qcInfo = list(step1 = "ok") @@ -1113,7 +1113,7 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", traits = c("t1", "t2") ) { phen <- setNames( - lapply(contexts, function(.) .jd_makeSe(traits = traits)), + map(contexts, function(.) .jd_makeSe(traits = traits)), contexts ) QtlDataset( @@ -1573,7 +1573,7 @@ test_that("parseMethods: split-form and leaf validation errors", { caps = caps, multivariateMethods = "mrmash" ), - "non-empty character vector" + "Must have length >= 1" ) expect_error( pecotmr:::parseMethods( @@ -1584,7 +1584,7 @@ test_that("parseMethods: split-form and leaf validation errors", { caps = caps, multivariateMethods = "mrmash" ), - "non-empty character vector" + "Must have length >= 1" ) expect_error( pecotmr:::parseMethods( @@ -1731,7 +1731,8 @@ test_that(".buildIndividualCrossContextXy: region path + complete-case skip", { contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -1769,7 +1770,8 @@ test_that(".buildIndividualCrossContextXy: too few shared samples skips", { contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -1831,7 +1833,8 @@ test_that(".buildIndividualCrossTraitXy: skip branches (< 2 traits, region, comp contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -1870,7 +1873,8 @@ test_that(".buildComposedIndividualXy: skip branches and single-context wrap", { contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -2116,11 +2120,13 @@ test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components contexts = NULL, traitIds = NULL, cisWindow = NULL, - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5, - verbose = 1 + verbose = 1, + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.5, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) )) expect_s4_class(out, "QtlFineMappingResult") expect_equal(nrow(out), 2L) # indA row + ssC row @@ -2147,11 +2153,13 @@ test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot mes contexts = NULL, traitIds = NULL, cisWindow = NULL, - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5, - verbose = 1 + verbose = 1, + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.5, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) ), "no sumStats slot" ) @@ -2272,7 +2280,8 @@ test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip the context", contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -2312,7 +2321,8 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -2323,7 +2333,7 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA }, .fmResidPheno = function(x, contexts, traitId = NULL, ...) { setNames( - lapply(c("c1", "c2"), function(.) { + map(c("c1", "c2"), function(.) { matrix( rnorm(12), 6, @@ -2352,7 +2362,8 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -2385,7 +2396,8 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA contexts, traitId = NULL, cisWindow = NULL, - region = NULL + region = NULL, + ... ) { matrix( 0, @@ -2482,12 +2494,14 @@ test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { contexts = NULL, traitIds = NULL, cisWindow = NULL, - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5, verbose = 0, - xRegions = list(r1, r2) + xRegions = list(r1, r2), + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.5, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) # 907-910 @@ -2517,11 +2531,13 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al contexts = NULL, traitIds = NULL, cisWindow = 1000L, - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5, - verbose = 0 + verbose = 0, + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.5, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) ) expect_identical(out, res1) # length-1 short-circuit (909) local_mocked_bindings( @@ -2535,11 +2551,13 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al contexts = NULL, traitIds = NULL, cisWindow = 1000L, - coverage = 0.95, - secondaryCoverage = 0.5, - signalCutoff = 0.1, - minAbsCorr = 0.5, - verbose = 0 + verbose = 0, + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = 0.5, + signalCutoff = 0.1, + minAbsCorr = 0.5 + ) )) # all-NULL (908) }) @@ -2593,7 +2611,7 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes as.character(ss$context), "probe", ldSketch = getLdSketch(ss), - cutoffs = .panelCutoffs(list(...)) + cutoffs = .panelCutoffs(PanelFilterParam(...)) )) } @@ -2624,7 +2642,7 @@ test_that(".buildJointSumstatZMatrix agrees with .panelVariantFilter", { length(.panelVariantFilter( getLdSketch(ss), ids, - mafCutoff = cut + PanelFilterParam(mafCutoff = cut) )), label = str_c("mafCutoff ", cut) ) @@ -2651,3 +2669,12 @@ test_that(".buildJointSumstatZMatrix honours a missingness cutoff", { length(.bjz_build(ss)$variantIds) ) }) + +test_that(".fmScopeUserLimit answers NULL for an absent limit", { + expect_null(pecotmr:::.fmScopeUserLimit(NULL, "s1", TRUE)) +}) + +test_that(".msFoldStudyResults answers NULL when every fold is empty", { + expect_null(pecotmr:::.msFoldStudyResults(list(), NULL)) + expect_null(pecotmr:::.msFoldStudyResults(list(NULL, NULL), NULL)) +}) diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index 7084e066a..c0ec411e5 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -2,7 +2,7 @@ context("LD") library(tidyverse) # Helper: build an LdData S4 object from variant IDs and optional correlation matrix -make_test_ld_data <- function(variant_ids, R = NULL, blockMetadata = NULL) { +makeTestLdData <- function(variant_ids, R = NULL, blockMetadata = NULL) { if (is.null(R)) { p <- length(variant_ids) R <- diag(p) @@ -30,7 +30,7 @@ make_test_ld_data <- function(variant_ids, R = NULL, blockMetadata = NULL) { ) } -generate_dummy_data <- function() { +generateDummyData <- function() { region <- data.frame( chrom = "chr1", start = c(1000), @@ -52,7 +52,7 @@ generate_dummy_data <- function() { } # Generate a wider region that spans multiple blocks for partition testing -generate_multi_block_data <- function() { +generateMultiBlockData <- function() { region <- data.frame( chrom = "chr1", start = c(1000), @@ -73,8 +73,41 @@ generate_multi_block_data <- function() { return(list(region = region, meta = meta_df)) } +# LdData stores block metadata as a GRanges, and the block internals read it +# as one (mcols via `$`, blocks via `[` and length()). The fixtures below are +# index-only tables, so a span is synthesised from whatever they carry -- the +# merge and validation logic reads chrom, size and the index range, not the +# span. +.ld_bmGr <- function(df) { + has <- function(n) n %in% names(df) + st <- if (has("blockStart")) { + df$blockStart + } else if (has("startIdx")) { + df$startIdx + } else { + rep(1L, nrow(df)) + } + en <- if (has("blockEnd")) { + df$blockEnd + } else if (has("endIdx")) { + df$endIdx + } else { + rep(1L, nrow(df)) + } + gr <- GenomicRanges::GRanges( + seqnames = as.character(df$chrom), + ranges = IRanges::IRanges(start = as.integer(st), end = as.integer(en)) + ) + keep <- intersect(c("blockId", "size", "startIdx", "endIdx"), names(df)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + as.data.frame(df[, keep, drop = FALSE]) + ) + gr +} + + test_that("Check that we correctly retrieve the names from the matrix", { - data <- generate_dummy_data() + data <- generateDummyData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -100,7 +133,7 @@ test_that("Check that we correctly retrieve the names from the matrix", { }) test_that("Check that the LD block contains the correct information", { - data <- generate_dummy_data() + data <- generateDummyData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -138,7 +171,7 @@ test_that("Check that the LD block contains the correct information", { # ---- partitionLdMatrix ---- test_that("partitionLdMatrix correctly partitions a single block", { - data <- generate_dummy_data() + data <- generateDummyData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -173,7 +206,7 @@ test_that("partitionLdMatrix correctly partitions a single block", { }) test_that("partitionLdMatrix correctly partitions multiple blocks", { - data <- generate_multi_block_data() + data <- generateMultiBlockData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -202,14 +235,14 @@ test_that("partitionLdMatrix correctly partitions multiple blocks", { # Check if block IDs are correct expect_setequal( unique(partitioned$variantIndices$blockId), - 1:expected_block_count + seq_len(expected_block_count) ) file.remove(LD_meta_file_path) }) test_that("partitionLdMatrix properly merges small blocks", { - data <- generate_multi_block_data() + data <- generateMultiBlockData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -242,7 +275,7 @@ test_that("partitionLdMatrix properly merges small blocks", { ) # Check if merged blocks are larger than min_block_size - block_sizes <- sapply(partitioned$ldMatrices, nrow) + block_sizes <- map_int(partitioned$ldMatrices, nrow) expect_true(all( block_sizes >= min_block_size | block_sizes == length(getVariantIds(ld_data)) @@ -252,7 +285,7 @@ test_that("partitionLdMatrix properly merges small blocks", { }) test_that("partitionLdMatrix respects max_merged_block_size", { - data <- generate_multi_block_data() + data <- generateMultiBlockData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -277,7 +310,7 @@ test_that("partitionLdMatrix respects max_merged_block_size", { ) # Check if no block exceeds max_block_size - block_sizes <- sapply(partitioned$ldMatrices, nrow) + block_sizes <- map_int(partitioned$ldMatrices, nrow) expect_true(all(block_sizes <= max_block_size)) file.remove(LD_meta_file_path) @@ -300,12 +333,12 @@ test_that("partitionLdMatrix handles empty matrix gracefully", { # Expect the S4 type-check error expect_error( partitionLdMatrix(empty_ld_data), - "ldData must be an LdData object" + "Assertion on 'ldData'.*Must inherit from class 'LdData'" ) }) test_that("partitionLdMatrix validates block structure properly", { - data <- generate_multi_block_data() + data <- generateMultiBlockData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -323,7 +356,7 @@ test_that("partitionLdMatrix validates block structure properly", { ldmat <- getCorrelation(ld_data) # Assuming we have at least 2 blocks: - if (nrow(bm) >= 2) { + if (length(bm) >= 2) { # Create overlapping blocks with invalid start/end indices bm$startIdx[2] <- bm$startIdx[1] bm$endIdx[1] <- bm$endIdx[2] @@ -360,7 +393,7 @@ test_that("partitionLdMatrix validates block structure properly", { }) test_that("partitionLdMatrix properly maps variants to blocks", { - data <- generate_multi_block_data() + data <- generateMultiBlockData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -393,7 +426,7 @@ test_that("partitionLdMatrix properly maps variants to blocks", { }) test_that("partitionLdMatrix handles row/column name mismatches", { - data <- generate_dummy_data() + data <- generateDummyData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -433,7 +466,7 @@ test_that("partitionLdMatrix handles row/column name mismatches", { }) test_that("partitionLdMatrix correctly extracts blocks based on metadata", { - data <- generate_multi_block_data() + data <- generateMultiBlockData() region <- data$region LD_meta_file_path <- gsub( "//", @@ -508,7 +541,7 @@ test_that("partitionLdMatrix partitions correctly with synthetic data", { stringsAsFactors = FALSE ) - ld_data <- make_test_ld_data(variant_ids, R = mat, blockMetadata = bm) + ld_data <- makeTestLdData(variant_ids, R = mat, blockMetadata = bm) result <- pecotmr:::partitionLdMatrix(ld_data, mergeSmallBlocks = FALSE) @@ -685,7 +718,7 @@ test_that("partitionLdMatrix handles blocks with different chromosomes", { stringsAsFactors = FALSE ) - test_ld_data <- make_test_ld_data( + test_ld_data <- makeTestLdData( variant_ids, R = test_matrix, blockMetadata = blockMetadata @@ -760,7 +793,7 @@ test_that("partitionLdMatrix works with edge case block structures", { stringsAsFactors = FALSE ) - test_ld_data <- make_test_ld_data( + test_ld_data <- makeTestLdData( variantNames, R = test_matrix, blockMetadata = blockMetadata @@ -995,7 +1028,7 @@ test_that("validateBlockStructure passes for proper block structure", { expect_silent(pecotmr:::validateBlockStructure( mat, - block_meta, + .ld_bmGr(block_meta), variant_ids )) }) @@ -1016,7 +1049,11 @@ test_that("validateBlockStructure errors on non-block structure", { ) expect_error( - pecotmr:::validateBlockStructure(mat, block_meta, variant_ids), + pecotmr:::validateBlockStructure( + mat, + .ld_bmGr(block_meta), + variant_ids + ), "Matrix lacks expected block structure" ) }) @@ -1049,7 +1086,7 @@ test_that("mergeBlocks properly handles blocks at chromosome boundaries", { stringsAsFactors = FALSE ) - test_ld_data <- make_test_ld_data( + test_ld_data <- makeTestLdData( variantNames, R = test_matrix, blockMetadata = blockMetadata @@ -1090,8 +1127,12 @@ test_that("mergeBlocks merges small adjacent blocks", { startIdx = c(1, 51, 101), endIdx = c(50, 100, 200) ) - result <- pecotmr:::mergeBlocks(block_meta, minSize = 100, maxSize = 10000) - expect_true(nrow(result) < 3) + result <- pecotmr:::mergeBlocks( + .ld_bmGr(block_meta), + minSize = 100, + maxSize = 10000 + ) + expect_true(length(result) < 3) }) test_that("mergeBlocks does not merge cross-chromosome", { @@ -1102,8 +1143,12 @@ test_that("mergeBlocks does not merge cross-chromosome", { startIdx = c(1, 11), endIdx = c(10, 20) ) - result <- pecotmr:::mergeBlocks(block_meta, minSize = 50, maxSize = 10000) - expect_equal(nrow(result), 2) # Cannot merge across chromosomes + result <- pecotmr:::mergeBlocks( + .ld_bmGr(block_meta), + minSize = 50, + maxSize = 10000 + ) + expect_equal(length(result), 2) # Cannot merge across chromosomes }) test_that("mergeBlocks returns single block unchanged", { @@ -1114,8 +1159,12 @@ test_that("mergeBlocks returns single block unchanged", { startIdx = 1, endIdx = 10 ) - result <- pecotmr:::mergeBlocks(block_meta, minSize = 100, maxSize = 10000) - expect_equal(nrow(result), 1) + result <- pecotmr:::mergeBlocks( + .ld_bmGr(block_meta), + minSize = 100, + maxSize = 10000 + ) + expect_equal(length(result), 1) }) # ---- canMerge ---- @@ -1127,10 +1176,10 @@ test_that("canMerge checks chromosome and size", { stringsAsFactors = FALSE ) # rows 1 and 2: same chrom, combined size 300 - expect_true(pecotmr:::canMerge(bm, 1, 2, maxSize = 500)) - expect_false(pecotmr:::canMerge(bm, 1, 2, maxSize = 200)) + expect_true(pecotmr:::canMerge(.ld_bmGr(bm), 1, 2, maxSize = 500)) + expect_false(pecotmr:::canMerge(.ld_bmGr(bm), 1, 2, maxSize = 200)) # rows 1 and 3: different chromosome - expect_false(pecotmr:::canMerge(bm, 1, 3, maxSize = 500)) + expect_false(pecotmr:::canMerge(.ld_bmGr(bm), 1, 3, maxSize = 500)) }) # =========================================================================== @@ -1230,10 +1279,14 @@ test_that("extractBlockMatrices warns and skips out-of-range blocks", { stringsAsFactors = FALSE ) expect_warning( - result <- pecotmr:::extractBlockMatrices(mat, blockMetadata, vnames), + result <- pecotmr:::extractBlockMatrices( + mat, + .ld_bmGr(blockMetadata), + vnames + ), "outside the range" ) - valid_blocks <- result$ldMatrices[!sapply(result$ldMatrices, is.null)] + valid_blocks <- compact(result$ldMatrices) expect_equal(length(valid_blocks), 1) expect_equal(nrow(valid_blocks[[1]]), 2) }) @@ -1312,7 +1365,7 @@ test_that("resolveLdSource detects precomputed from metadata", { test_that("resolveLdSource errors on missing file", { expect_error( pecotmr:::resolveLdSource("/nonexistent/file.tsv"), - "not found" + "LD metadata file: File does not exist" ) }) @@ -1383,8 +1436,8 @@ test_that("loadLdFromGenotype returns LD matrix with .afreq", { expect_true(all(S4Vectors::mcols(getVariantInfo(result))$allele_freq > 0)) expect_true(all(S4Vectors::mcols(getVariantInfo(result))$allele_freq < 1)) # blockMetadata - expect_true(is.data.frame(getBlockMetadata(result))) - expect_equal(nrow(getBlockMetadata(result)), 1L) + expect_true(is(getBlockMetadata(result), "GRanges")) + expect_equal(length(getBlockMetadata(result)), 1L) }) test_that("loadLdFromGenotype returns genotype matrix when requested", { @@ -1603,7 +1656,7 @@ test_that("loadLdMatrix loads single precomputed block", { expect_true(all(grepl("^chr1:", getVariantIds(result)))) expect_false(hasGenotypes(result)) # blockMetadata should have one block - expect_equal(nrow(getBlockMetadata(result)), 1L) + expect_equal(length(getBlockMetadata(result)), 1L) # ref_panel (now GRanges) should have variant info via mcols ref_mcols <- S4Vectors::mcols(getVariantInfo(result)) expect_true("variant_id" %in% names(ref_mcols)) @@ -1642,7 +1695,7 @@ test_that("loadLdMatrix loads multiple precomputed blocks", { # Should span blocks 1-3: 5 + 5 + 5 = 15 unique variants (no overlap in variant IDs) expect_true(nrow(getCorrelation(result)) >= 10) expect_true(isSymmetric(getCorrelation(result))) - expect_true(nrow(getBlockMetadata(result)) >= 2) + expect_true(length(getBlockMetadata(result)) >= 2) }) test_that("loadLdMatrix with n_sample for precomputed blocks with freq data", { @@ -1949,7 +2002,7 @@ test_that("enforceDesignFullRank fallback to correlation pruning works", { X[, 3] + rnorm(n, sd = 1e-10), X[, 1] + X[, 2] + rnorm(n, sd = 1e-10) ) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(ncol(X)))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(ncol(X))) C <- matrix(rnorm(n), n, 1) result <- enforceDesignFullRank( X, @@ -1994,7 +2047,7 @@ test_that("ldClumpByScore errors on mismatched score length", { X <- matrix(rnorm(20), 5, 4) expect_error( ldClumpByScore(X, score = c(1, 2), chr = rep(1L, 4), pos = 1:4), - "length\\(score\\)" + "score.*Must have length 4" ) }) @@ -2004,7 +2057,7 @@ test_that("ldClumpByScore errors on mismatched chr/pos length", { X <- matrix(rnorm(20), 5, 4) expect_error( ldClumpByScore(X, score = runif(4), chr = rep(1L, 2), pos = 1:4), - "chr and pos" + "chr.*Must have length 4" ) }) @@ -2096,7 +2149,7 @@ test_that("ldPruneByCorrelation removes highly correlated columns", { n <- 50 p <- 10 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) X[, 2] <- X[, 1] + rnorm(n, sd = 0.01) result <- ldPruneByCorrelation(X, corThres = 0.9) expect_true(ncol(result$X.new) < p) @@ -2108,10 +2161,10 @@ test_that("ldPruneByCorrelation keeps all columns when uncorrelated", { n <- 100 p <- 5 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) result <- ldPruneByCorrelation(X, corThres = 0.99) expect_equal(ncol(result$X.new), p) - expect_equal(result$filter.id, 1:p) + expect_equal(result$filter.id, seq_len(p)) }) test_that("ldPruneByCorrelation preserves colnames for single remaining column", { @@ -2139,7 +2192,7 @@ test_that("ldPruneByCorrelation strict threshold removes at least as many as len n <- 100 p <- 5 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:p)) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) X[, 2] <- X[, 1] + rnorm(n, sd = 0.1) X[, 3] <- X[, 1] + rnorm(n, sd = 0.1) X[, 5] <- X[, 4] + rnorm(n, sd = 0.1) @@ -2391,7 +2444,7 @@ test_that("ldClumpByScore validates input lengths", { chr = rep(1L, 2), pos = seq_len(3) * 1000L ), - "chr and pos" + "chr.*Must have length 3" ) }) @@ -3683,7 +3736,7 @@ test_that("validateBlockStructure flags out-of-range block indices", { endIdx = c(2L, 12L) ) expect_error( - pecotmr:::validateBlockStructure(mat, bm, vnames), + pecotmr:::validateBlockStructure(mat, .ld_bmGr(bm), vnames), "Block indices out of range" ) }) @@ -3702,8 +3755,8 @@ test_that("extractBlockMatrices skips blocks where endIdx < startIdx", { size = c(2L, 1L), stringsAsFactors = FALSE ) - result <- pecotmr:::extractBlockMatrices(mat, bm, vnames) - valid <- result$ldMatrices[!sapply(result$ldMatrices, is.null)] + result <- pecotmr:::extractBlockMatrices(mat, .ld_bmGr(bm), vnames) + valid <- compact(result$ldMatrices) expect_length(valid, 1) expect_equal(nrow(valid[[1]]), 2L) }) @@ -3720,7 +3773,7 @@ test_that("ldPruneByCorrelation snprelate backend prunes correlated columns", { p <- 6 X <- matrix(rbinom(n * p, 2, 0.3), n, p) X[, 2] <- X[, 1] # perfect LD between columns 1 and 2 - colnames(X) <- paste0("snp", 1:p) + colnames(X) <- paste0("snp", seq_len(p)) result <- suppressMessages( ldPruneByCorrelation( X, @@ -3906,7 +3959,10 @@ test_that("ldClumpByScore accepts a pre-built FBM and reports retained count (ve # ============================================================================= test_that("extractLdMatrix errors on non-LdData input", { - expect_error(pecotmr:::extractLdMatrix(list()), "must be an LdData object") + expect_error( + pecotmr:::extractLdMatrix(list()), + "Must inherit from class 'LdData'" + ) }) test_that("extractLdMatrix returns the genotype matrix when wantGenotype=TRUE", { @@ -3982,6 +4038,9 @@ test_that("computeLd errors when a non-internal backend is paired with non-sampl # ldPruneByCorrelation's `cor.X <- cor(X)`) are reachable by mocking the *base* # `requireNamespace` (so it reports Rfast missing) for the duration of the call. test_that("ldPruneByCorrelation and computeLd fall back to base cor() when Rfast is absent", { + # Captured BEFORE the rebinding: inside the mock, `base::requireNamespace` + # resolves to the mock itself, so delegating through it recurses. + realRequireNamespace <- base::requireNamespace with_mocked_bindings( { set.seed(1) @@ -4001,7 +4060,7 @@ test_that("ldPruneByCorrelation and computeLd fall back to base cor() when Rfast if (identical(package, "Rfast")) { FALSE } else { - base::requireNamespace(package, ...) + realRequireNamespace(package, ...) } }, .package = "base" @@ -4026,7 +4085,7 @@ test_that("ldPruneByCorrelation and computeLd fall back to base cor() when Rfast set.seed(11) nS <- 100L af <- c(rep(0.35, 5L), rep(0.004, 5L)) - d <- vapply(af, function(f) rbinom(nS, 2L, f), numeric(nS)) + d <- exec(cbind, !!!map(af, function(f) rbinom(nS, 2L, f))) colnames(d) <- sprintf("chr1:%d:A:G", 1000L * seq_along(af)) d[1:80, 2] <- NA d @@ -4073,8 +4132,16 @@ test_that(".panelVariantFilter drops panel-rare variants", { data(qtlDatasetExample) handle <- getGenotypeHandle(qtlDatasetExample) ids <- normalizeVariantId(getSnpInfo(handle)$SNP) - loose <- .panelVariantFilter(handle, ids, mafCutoff = 0.05) - tight <- .panelVariantFilter(handle, ids, mafCutoff = 0.2) + loose <- .panelVariantFilter( + handle, + ids, + PanelFilterParam(mafCutoff = 0.05) + ) + tight <- .panelVariantFilter( + handle, + ids, + PanelFilterParam(mafCutoff = 0.2) + ) expect_lt(length(loose), length(ids)) expect_lt(length(tight), length(loose)) # Kept sets are nested as the cutoff rises, and order is the caller's. @@ -4088,13 +4155,25 @@ test_that(".panelVariantFilter treats MAC as a MAF equivalent", { ids <- normalizeVariantId(getSnpInfo(handle)$SNP) nSamp <- getNSamples(handle) # macCutoff / (2 * nSamples) is the same threshold as mafCutoff. - byMac <- .panelVariantFilter(handle, ids, macCutoff = 0.1 * 2 * nSamp) - byMaf <- .panelVariantFilter(handle, ids, mafCutoff = 0.1) + byMac <- .panelVariantFilter( + handle, + ids, + PanelFilterParam(macCutoff = 0.1 * 2 * nSamp) + ) + byMaf <- .panelVariantFilter( + handle, + ids, + PanelFilterParam(mafCutoff = 0.1) + ) expect_identical(byMac, byMaf) # The stricter of the two wins. expect_identical( - .panelVariantFilter(handle, ids, mafCutoff = 0.2, macCutoff = 2), - .panelVariantFilter(handle, ids, mafCutoff = 0.2) + .panelVariantFilter( + handle, + ids, + PanelFilterParam(mafCutoff = 0.2, macCutoff = 2) + ), + .panelVariantFilter(handle, ids, PanelFilterParam(mafCutoff = 0.2)) ) }) @@ -4102,10 +4181,17 @@ test_that(".panelVariantFilter drops high-missingness variants", { data(qtlDatasetExample) handle <- getGenotypeHandle(qtlDatasetExample) ids <- normalizeVariantId(getSnpInfo(handle)$SNP) - strict <- .panelVariantFilter(handle, ids, imissCutoff = 0) + strict <- .panelVariantFilter( + handle, + ids, + PanelFilterParam(imissCutoff = 0) + ) expect_lt(length(strict), length(ids)) # A cutoff above the panel's worst variant keeps everything. - expect_identical(.panelVariantFilter(handle, ids, imissCutoff = 1), ids) + expect_identical( + .panelVariantFilter(handle, ids, PanelFilterParam(imissCutoff = 1)), + ids + ) }) test_that(".panelVariantFilter passes through ids absent from the panel", { @@ -4118,7 +4204,11 @@ test_that(".panelVariantFilter passes through ids absent from the panel", { withGhost <- c("chr9:999:A:G", ids) expect_true(is_in( "chr9:999:A:G", - .panelVariantFilter(handle, withGhost, mafCutoff = 0.001) + .panelVariantFilter( + handle, + withGhost, + PanelFilterParam(mafCutoff = 0.001) + ) )) }) @@ -4126,11 +4216,19 @@ test_that(".panelVariantFilter handles empty and NULL input", { data(qtlDatasetExample) handle <- getGenotypeHandle(qtlDatasetExample) expect_length( - .panelVariantFilter(handle, character(0), mafCutoff = 0.1), + .panelVariantFilter( + handle, + character(0), + PanelFilterParam(mafCutoff = 0.1) + ), 0L ) expect_identical( - .panelVariantFilter(NULL, "chr1:1:A:G", mafCutoff = 0.1), + .panelVariantFilter( + NULL, + "chr1:1:A:G", + PanelFilterParam(mafCutoff = 0.1) + ), "chr1:1:A:G" ) }) @@ -4139,14 +4237,20 @@ test_that(".panelVariantFilter handles empty and NULL input", { test_that(".panelCutoffs short-circuits when no cutoff is set", { # NULL means the panel is never touched, which is what keeps the default # path free of an extra dosage read. - expect_null(.panelCutoffs(list())) - expect_null(.panelCutoffs(list( + expect_null(.panelCutoffs()) + expect_null(.panelCutoffs(PanelFilterParam( mafCutoff = 0, macCutoff = 0, imissCutoff = 1 ))) - expect_equal(.panelCutoffs(list(mafCutoff = 0.01))$mafCutoff, 0.01) - expect_equal(.panelCutoffs(list(imissCutoff = 0.5))$imissCutoff, 0.5) + expect_equal( + .panelCutoffs(PanelFilterParam(mafCutoff = 0.01))$mafCutoff, + 0.01 + ) + expect_equal( + .panelCutoffs(PanelFilterParam(imissCutoff = 0.5))$imissCutoff, + 0.5 + ) }) @@ -4193,13 +4297,21 @@ test_that(".panelVariantFilter: .afreq and dosage agree on what to drop", { skip_if_not_installed("pgenlibr") handle <- .pvfAfreqHandle() ids <- as.character(getSnpInfo(handle)$SNP) - viaAfreq <- .panelVariantFilter(handle, ids, mafCutoff = 0.2) + viaAfreq <- .panelVariantFilter( + handle, + ids, + PanelFilterParam(mafCutoff = 0.2) + ) # Force the dosage path by hiding the sidecar from the fast path. local_mocked_bindings( .panelAfreqMaf = function(handle, variantIds) NULL, .package = "pecotmr" ) - viaDosage <- .panelVariantFilter(handle, ids, mafCutoff = 0.2) + viaDosage <- .panelVariantFilter( + handle, + ids, + PanelFilterParam(mafCutoff = 0.2) + ) expect_lt(length(viaAfreq), length(ids)) expect_identical(viaAfreq, viaDosage) }) @@ -4217,7 +4329,11 @@ test_that(".panelVariantFilter uses dosage whenever missingness is capped", { .package = "pecotmr" ) expect_no_error( - .panelVariantFilter(handle, ids, mafCutoff = 0.2, imissCutoff = 0.5) + .panelVariantFilter( + handle, + ids, + PanelFilterParam(mafCutoff = 0.2, imissCutoff = 0.5) + ) ) }) @@ -4588,7 +4704,7 @@ test_that("a block-indexed source must be addressable by block", { # or a list of them; anything else is refused rather than silently # returning the wrong block. expect_error( - pecotmr:::.loadLdFromIndexed("a string", 1L, FALSE), + pecotmr:::.loadLdFromIndexed("a string", 1L), "cannot address a character by block" ) }) @@ -4596,9 +4712,9 @@ test_that("a block-indexed source must be addressable by block", { test_that("a matrix and a list of matrices both address by block", { R <- diag(3) dimnames(R) <- list(c("v1", "v2", "v3"), c("v1", "v2", "v3")) - expect_s4_class(pecotmr:::.loadLdFromIndexed(R, 1L, FALSE), "LdData") + expect_s4_class(pecotmr:::.loadLdFromIndexed(R, 1L), "LdData") # The list form picks the requested element. - both <- pecotmr:::.loadLdFromIndexed(list(R, R), 2L, FALSE) + both <- pecotmr:::.loadLdFromIndexed(list(R, R), 2L) expect_s4_class(both, "LdData") expect_equal(length(both), 3L) }) @@ -4784,11 +4900,19 @@ test_that(".panelVariantFilter is a no-op without a sketch", { # An active cutoff still cannot filter anything with no panel to read # frequencies from. expect_equal( - pecotmr:::.panelVariantFilter(NULL, v, mafCutoff = 0.01), + pecotmr:::.panelVariantFilter( + NULL, + v, + PanelFilterParam(mafCutoff = 0.01) + ), v ) expect_equal( - pecotmr:::.panelVariantFilter(NULL, character(0), mafCutoff = 0.01), + pecotmr:::.panelVariantFilter( + NULL, + character(0), + PanelFilterParam(mafCutoff = 0.01) + ), character(0) ) }) @@ -4807,7 +4931,11 @@ test_that(".panelVariantFilter is a no-op when nothing matches the panel", { # The sketch exists but shares no variant with the request, so there is # no frequency to filter on and the ids pass through untouched. expect_equal( - pecotmr:::.panelVariantFilter(sketch, ids, mafCutoff = 0.01), + pecotmr:::.panelVariantFilter( + sketch, + ids, + PanelFilterParam(mafCutoff = 0.01) + ), ids ) }) @@ -4925,10 +5053,19 @@ test_that("computeLd(onDisk) applies shrinkage toward the identity", { format = "gds" ) idx <- 1:6 - plain <- computeLd(handle, snpIdx = idx, backend = "snprelate", - onDisk = TRUE) - shrunk <- computeLd(handle, snpIdx = idx, backend = "snprelate", - onDisk = TRUE, shrinkage = 0.5) + plain <- computeLd( + handle, + snpIdx = idx, + backend = "snprelate", + onDisk = TRUE + ) + shrunk <- computeLd( + handle, + snpIdx = idx, + backend = "snprelate", + onDisk = TRUE, + shrinkage = 0.5 + ) # (1 - s) * R + s * I: off-diagonals halve, the diagonal stays 1. expect_equal(unname(diag(shrunk)), rep(1, length(idx))) expect_equal( @@ -5054,3 +5191,131 @@ test_that(".panelAfreqMaf returns NULL when no sidecar exists at all", { ) ) }) + +test_that(".ldConcatChr answers character(0) for no pieces", { + expect_identical(pecotmr:::.ldConcatChr(list()), character(0)) +}) + +test_that(".ldTrimTrailingNull answers an empty list when nothing is filled", { + expect_identical(pecotmr:::.ldTrimTrailingNull(list(NULL, NULL)), list()) +}) + +test_that("the ldSketch cross-checks are no-ops when a side has no variants", { + # A zero-variant panel -- what an emptied object carries -- contradicts + # nothing, so there is nothing to compare and the check returns quietly. + local_mocked_bindings(.ldSketchA1 = function(x) character(0)) + expect_null(pecotmr:::.ldSketchCheckAlleleCoding( + NULL, + NULL, + integer(0), + integer(0), + "testPipeline", + "" + )) +}) + +test_that(".ldSketchCheckOverlap is a no-op when a side has no variants", { + local_mocked_bindings(.ldSketchVariantKeys = function(x) character(0)) + expect_null( + pecotmr:::.ldSketchCheckOverlap(NULL, NULL, "testPipeline", "") + ) +}) + +test_that("LdPruningOptions refuses what the snprelate backend owns", { + expect_error(LdPruningOptions(gdsobj = 1), "the temporary GDS") + expect_error(LdPruningOptions(method = "r"), "fixed at 'corr'") + expect_error( + LdPruningOptions(ld.threshold = 0.5), + "the caller's `corThres`" + ) + expect_error(LdPruningOptions(verbose = TRUE), "the caller's `verbose`") + expect_error(LdPruningOptions(nosuch = 1), "unknown argument") + expect_equal(LdPruningOptions(slide.max.bp = 1e6)$slide.max.bp, 1e6) +}) + +test_that("ldPruneByCorrelation refuses options its backend never uses", { + set.seed(1) + X <- matrix(rnorm(100 * 5), 100, 5) + expect_error( + ldPruneByCorrelation( + X, + backend = "hclust", + methodArgs = LdPruningOptions(slide.max.n = 10L) + ), + "backend 'hclust' does not call" + ) + # No options is the default, so the hclust path still works untouched. + expect_length(ldPruneByCorrelation(X, corThres = 0.9)$filter.id, 5L) + expect_error( + ldPruneByCorrelation(X, methodArgs = list(slide.max.n = 10L)), + "LdPruningOptions" + ) +}) + +test_that("ldPruneByCorrelation forwards methodArgs to SNPRelate", { + skip_if_not_installed("SNPRelate") + skip_if_not_installed("gdsfmt") + seen <- NULL + real <- SNPRelate::snpgdsLDpruning + set.seed(2) + X <- matrix(sample(0:2, 100 * 6, replace = TRUE), 100, 6) + colnames(X) <- str_c("snp", seq_len(6)) + suppressMessages(with_mocked_bindings( + ldPruneByCorrelation( + X, + corThres = 0.9, + backend = "snprelate", + methodArgs = LdPruningOptions(slide.max.n = 3L) + ), + snpgdsLDpruning = function(...) { + seen <<- list(...) + real(...) + }, + .package = "SNPRelate" + )) + expect_equal(seen$slide.max.n, 3L) + expect_equal(seen$method, "corr") + expect_equal(seen$ld.threshold, 0.9) +}) + +test_that(".panelCutoffs answers NULL for a filter that keeps everything", { + expect_null(pecotmr:::.panelCutoffs(PanelFilterParam())) + expect_equal( + pecotmr:::.panelCutoffs(PanelFilterParam(mafCutoff = 0.01))$mafCutoff, + 0.01 + ) +}) + +test_that("validateBlockStructure rejects overlapping blocks", { + # The merge logic only considers i - 1 / i + 1, so a block's position in + # the table has to mean its position on the chromosome. As a data.frame + # nothing checked that; as a GRanges isDisjoint() does. + mat <- diag(4) + vnames <- sprintf("chr1:%d:A:G", 100L * (1:4)) + rownames(mat) <- colnames(mat) <- vnames + overlapping <- data.frame( + blockId = c(1L, 2L), + chrom = c("1", "1"), + blockStart = c(100L, 150L), + blockEnd = c(300L, 400L), + size = c(2L, 2L), + startIdx = c(1L, 3L), + endIdx = c(2L, 4L) + ) + expect_error( + pecotmr:::validateBlockStructure( + mat, + .ld_bmGr(overlapping), + vnames + ), + "each block must cover a span of its own" + ) + # The same blocks, made disjoint, pass. + disjoint <- overlapping + disjoint$blockStart <- c(100L, 301L) + expect_silent(pecotmr:::validateBlockStructure( + mat, + .ld_bmGr(disjoint), + vnames + )) +}) diff --git a/tests/testthat/test_ldData.R b/tests/testthat/test_ldData.R index 7373effd6..ef8b79948 100644 --- a/tests/testthat/test_ldData.R +++ b/tests/testthat/test_ldData.R @@ -10,7 +10,7 @@ context("LdData accessors") path = path, format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -34,7 +34,25 @@ context("LdData accessors") S4Vectors::mcols(gr) <- S4Vectors::DataFrame( A1 = rep("A", snp_n), A2 = rep("G", snp_n), - variant_id = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))) + variant_id = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)) + ) + gr +} + +# new("LdData", ...) skips the constructor, so those tests have to supply +# the block columns the slot now guarantees. +.ld_makeBlockMetadata <- function(snp_n = 4L) { + # new("LdData", ...) skips the constructor, so these tests supply the + # stored shape directly: a GRanges whose mcols carry the index payload. + gr <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges(start = 100L, end = 100L * snp_n) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + blockId = 1L, + size = snp_n, + startIdx = 1L, + endIdx = snp_n ) gr } @@ -153,7 +171,7 @@ test_that("getCorrelation: mixture handles produce a weighted-average R", { }, .package = "pecotmr" ) - R_each <- lapply(list(gh1, gh2), function(h) { + R_each <- map(list(gh1, gh2), function(h) { geno <- extractBlockGenotypes(h, 1:4) Xt <- t(SummarizedExperiment::assay(geno, "dosage")) computeLd(Xt, method = "sample") @@ -171,7 +189,7 @@ test_that("getCorrelation: mixture handles without mixtureWeights errors", { correlation = NULL, genotypeHandle = list(gh, gh), snpIdx = 1:4, - blockMetadata = S4Vectors::DataFrame(x = 1), + blockMetadata = .ld_makeBlockMetadata(), nRef = 0L, mixtureWeights = NULL ) @@ -190,7 +208,7 @@ test_that("getCorrelation: mixture panels of differing dim error", { correlation = NULL, genotypeHandle = list(gh_small, gh), snpIdx = 1:3, - blockMetadata = S4Vectors::DataFrame(x = 1), + blockMetadata = .ld_makeBlockMetadata(), nRef = 0L, mixtureWeights = c(0.5, 0.5) ) @@ -243,7 +261,7 @@ test_that("getGenotypes: matrix handle is returned unchanged", { correlation = NULL, genotypeHandle = X, snpIdx = NULL, - blockMetadata = S4Vectors::DataFrame(x = 1), + blockMetadata = .ld_makeBlockMetadata(), nRef = 0L, mixtureWeights = NULL ) @@ -327,12 +345,20 @@ test_that("getVariantIds returns the variant_id mcol", { expect_equal(getVariantIds(ld), sprintf("chr1:%d:A:G", 100L * (1:4))) }) -test_that("getVariantInfo / getBlockMetadata return slots verbatim", { +test_that("getVariantInfo returns the variants verbatim", { vars <- .ld_makeVariants() bm <- S4Vectors::DataFrame(region = "chr1:100-400") ld <- LdData(correlation = diag(4), variants = vars, blockMetadata = bm) expect_identical(getVariantInfo(ld), vars) - expect_identical(getBlockMetadata(ld), bm) + # blockMetadata is NOT verbatim: the constructor normalises it to the + # columns consumers read. A column the caller added is carried through. + got <- getBlockMetadata(ld) + expect_s4_class(got, "GRanges") + expect_true(all( + c("blockId", "size", "startIdx", "endIdx") %in% + names(S4Vectors::mcols(got)) + )) + expect_equal(got$region, "chr1:100-400") }) test_that("getRefPanel: assembles the chrom/pos/A1/A2/variant_id data.frame", { @@ -379,7 +405,7 @@ test_that("LdData constructor works with correlation matrix", { expect_false(hasGenotypes(ld)) expect_true(is.matrix(getCorrelation(ld))) expect_equal(getVariantIds(ld), c("chr1:100:A:G", "chr1:200:C:T")) - expect_equal(nrow(getBlockMetadata(ld)), 1L) + expect_equal(length(getBlockMetadata(ld)), 1L) expect_null(getGenotypes(ld)) }) @@ -870,3 +896,153 @@ test_that("an LdData refuses to be subset", { expect_error(ld[1:2], "an LdData cannot be subset") expect_error(ld[1:2, ], "an LdData cannot be subset") }) + +# =========================================================================== +# blockMetadata normalisation +# --------------------------------------------------------------------------- +# Five construction paths used to emit five different column sets, so +# consumers read startIdx / size / chrom that were present by luck. The +# constructor now fills whatever is absent and stores ONE shape: a GRanges +# whose seqnames/ranges are the block's chromosome and span, with the index +# payload the matrix is addressed by in mcols. +# =========================================================================== + +.ld_bmMcols <- c("blockId", "size", "startIdx", "endIdx") + +test_that("blockMetadata: a bare genomic span is completed from variants", { + ld <- LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = S4Vectors::DataFrame( + chrom = "chr1", + start = 100L, + end = 400L + ) + ) + bm <- getBlockMetadata(ld) + expect_s4_class(bm, "GRanges") + expect_true(all(.ld_bmMcols %in% names(S4Vectors::mcols(bm)))) + expect_equal(length(bm), 1L) + expect_equal(bm$startIdx, 1L) + expect_equal(bm$endIdx, 4L) + expect_equal(bm$size, 4L) + # start/end name the BLOCK's span, so they become the range itself + # rather than colliding with a variant position. + expect_equal(as.character(GenomicRanges::seqnames(bm)), "chr1") + expect_equal(GenomicRanges::start(bm), 100L) + expect_equal(GenomicRanges::end(bm), 400L) +}) + +test_that("blockMetadata: a placeholder table means one block, not none", { + ld <- LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = data.frame() + ) + bm <- getBlockMetadata(ld) + expect_equal(length(bm), 1L) + expect_true(all(.ld_bmMcols %in% names(S4Vectors::mcols(bm)))) + expect_equal(bm$size, 4L) +}) + +test_that("blockMetadata: a GRanges keeps its mcols over its ranges", { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = c(100L, 300L), end = c(200L, 400L)) + ) + # An LdBlocks-style GRanges carries these in mcols AND in the ranges. + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + blockId = c(1L, 2L), + chrom = c("1", "1"), + size = c(2L, 2L), + startIdx = c(1L, 3L), + endIdx = c(2L, 4L) + ) + ld <- LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = gr + ) + bm <- getBlockMetadata(ld) + expect_equal(length(bm), 2L) + # chrom is the seqnames now, and must not ALSO linger as an mcol: + # binding the ranges and the mcols both would duplicate it. + expect_equal(as.character(GenomicRanges::seqnames(bm)), c("1", "1")) + expect_false(is_in("chrom", names(S4Vectors::mcols(bm)))) + expect_equal(as.character(GenomicRanges::seqnames(bm)), c("1", "1")) + expect_equal(bm$startIdx, c(1L, 3L)) +}) + +test_that("blockMetadata: several blocks take their ranges from size", { + ld <- LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = tibble(blockId = 1:2, size = c(3L, 1L)) + ) + bm <- getBlockMetadata(ld) + expect_equal(bm$startIdx, c(1L, 4L)) + expect_equal(bm$endIdx, c(3L, 4L)) + expect_equal( + as.character(GenomicRanges::seqnames(bm)), + c("chr1", "chr1") + ) +}) + +test_that("blockMetadata: several blocks with no size and no range error", { + expect_error( + LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = tibble(blockId = 1:2) + ), + "cannot be determined" + ) +}) + +test_that("blockMetadata: half an index range is refused", { + expect_error( + LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = tibble(blockId = 1L, startIdx = 1L) + ), + "both or neither" + ) +}) + +test_that("blockMetadata: supplied indices are never replaced", { + # partitionLdMatrix() has to reject an out-of-range block, so the + # normaliser must not quietly substitute valid indices. + ld <- LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = tibble( + blockId = 1L, + size = 4L, + startIdx = 10L, + endIdx = 20L + ) + ) + bm <- getBlockMetadata(ld) + expect_equal(bm$startIdx, 10L) + expect_equal(bm$endIdx, 20L) + # An out-of-range block has no span to derive, and a GRanges cannot + # hold an NA one -- it gets a width-0 range, which is visibly not an + # interval. partitionLdMatrix() still rejects it on its indices. + expect_equal(GenomicRanges::width(bm), 0L) +}) + +test_that("blockMetadata: a caller's own columns are carried through", { + ld <- LdData( + correlation = diag(4), + variants = .ld_makeVariants(), + blockMetadata = tibble(region = "chr1:100-400", note = "kept") + ) + bm <- getBlockMetadata(ld) + expect_equal(bm$region, "chr1:100-400") + expect_equal(bm$note, "kept") + # The index payload comes first so the mcols read the same way whatever + # the caller supplied. + got <- names(S4Vectors::mcols(bm)) + expect_equal(got[seq_along(.ld_bmMcols)], .ld_bmMcols) +}) diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index 0c7cf0083..bf271b0cf 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -87,7 +87,7 @@ test_that(".canonManifestCols errors on missing required columns", { required = c("study", "sumStatsPath"), label = "GwasSumStats" ), - "missing required column" + "manifest.*Colnames must include the elements" ) }) @@ -829,10 +829,13 @@ test_that(".readManifest handles CSV, missing files, and bad input", { readr::write_csv(data.frame(study = "s1", sumStatsPath = ssPath), csv) m <- pecotmr:::.readManifest(csv) expect_true(is.data.frame(m) && m$study == "s1") - expect_error(pecotmr:::.readManifest("/no/such/manifest.tsv"), "not found") + expect_error( + pecotmr:::.readManifest("/no/such/manifest.tsv"), + "File does not exist" + ) expect_error( pecotmr:::.readManifest(42L), - "data.frame or a single file path" + "Must be of type 'string'" ) }) @@ -1041,7 +1044,10 @@ test_that(".asGRegion coerces strings, GRanges, and data.frames", { test_that(".readColumnMapping errors on bad inputs", { tmp <- withr::local_tempdir() - expect_error(pecotmr:::.readColumnMapping("/no/map.yaml"), "not found") + expect_error( + pecotmr:::.readColumnMapping("/no/map.yaml"), + "File does not exist" + ) bad <- file.path(tmp, "bad.yaml") yaml::write_yaml(list("a", "b"), bad) # unnamed sequence expect_error(pecotmr:::.readColumnMapping(bad), "standardName: sourceName") @@ -1264,7 +1270,7 @@ test_that("QtlDataset builder errors on inconsistent per-context paths", { collapse = "\t" ) ) - rows <- vapply( + rows <- map_chr( seq_len(n), function(i) { vals <- c( @@ -1291,8 +1297,7 @@ test_that("QtlDataset builder errors on inconsistent per-context paths", { ), collapse = "\t" ) - }, - character(1) + } ) writeLines(c(meta, rows), path) path @@ -1745,8 +1750,11 @@ test_that(".readTabixRegion returns a bare tibble for a headerless file", { dir <- withr::local_tempdir() plain <- file.path(dir, "noheader.tsv") writeLines(c("chr1\t100\t200\tA", "chr1\t300\t400\tB"), plain) - bgz <- Rsamtools::bgzip(plain, file.path(dir, "noheader.tsv.bgz"), - overwrite = TRUE) + bgz <- Rsamtools::bgzip( + plain, + file.path(dir, "noheader.tsv.bgz"), + overwrite = TRUE + ) Rsamtools::indexTabix(bgz, seq = 1L, start = 2L, end = 3L) # With no "#" header line there are no column names to build an empty # frame from, so the miss returns a column-less tibble. @@ -1756,3 +1764,55 @@ test_that(".readTabixRegion returns a bare tibble for a headerless file", { expect_equal(nrow(out), 0L) expect_equal(ncol(out), 0L) }) + +test_that("manifest loaders guard the QtlDataset pass-through arguments", { + mf <- system.file("extdata", "manifests", package = "pecotmr") + skip_if(mf == "", "manifest fixtures unavailable") + expect_error( + loadQtlDatasetFromManifest( + data.frame(), + genotypeFilterArgs = GenotypeFilterParam(mafCutoff = -1) + ), + "mafCutoff.*is not >= 0" + ) + expect_error( + loadQtlDatasetFromManifest( + data.frame(), + genotypeFilterArgs = GenotypeFilterParam(keepIndel = NA) + ), + "keepIndel.*May not be NA" + ) + # A bare list cannot be checked, so it is refused outright. + expect_error( + loadQtlDatasetFromManifest( + data.frame(), + genotypeFilterArgs = list(mafCutoff = 0.01) + ), + "must be built with GenotypeFilterParam" + ) + expect_error( + loadQtlDatasetFromManifest( + data.frame(), + scaleResiduals = c(TRUE, TRUE) + ), + "scaleResiduals.*Must have length 1" + ) + expect_error( + loadQtlDatasetFromManifest(data.frame(), study = 1L), + "study.*Must be of type 'string'" + ) + expect_error( + loadMultiStudyQtlDatasetFromManifest( + data.frame(), + minLdOverlapWarn = 2 + ), + "minLdOverlapWarn.*is not <= 1" + ) + expect_error( + loadMultiStudyQtlDatasetFromManifest( + data.frame(), + genotypeFilterArgs = GenotypeFilterParam(xvarCutoff = -1) + ), + "xvarCutoff.*is not >= 0" + ) +}) diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index 09b9a6907..3daf8df25 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -3,6 +3,145 @@ # require mashr / flashier installs: # sanitizeMashData, makePairwiseContrastCol, sliceMashData, # metaAnalysisPerCondition + +# Fixtures for the input-preparation tests, moved here with them. + +# Helper: tiny QtlSumStats with 2 contexts on one trait. The mcols +# layout is controlled so each test can vary which columns are present. +.mssm_makeQtlSumStats <- function( + mcolsBuilder, + contexts = c("brain", "liver"), + nSnp = 5L +) { + set.seed(13L) + gh <- new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(nSnp)), + CHR = "1", + BP = seq(100L, by = 100L, length.out = nSnp), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 50L, + sampleIds = paste0("s", seq_len(50L)), + pgenPtr = NULL + ) + ranges <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges( + start = seq(100L, by = 100L, length.out = nSnp), + width = 1L + ) + ) + entries <- map(seq_along(contexts), function(i) { + gr <- ranges + S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcolsBuilder(i, nSnp)) + gr + }) + QtlSumStats( + study = rep("s1", length(contexts)), + context = contexts, + trait = rep("g1", length(contexts)), + entry = entries, + genome = "hg19", + ldSketch = gh, + qcInfo = list(prebuilt = "synthetic") + ) +} + +.qszm_gh <- function() { + new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = "chr1:100:A:G", + CHR = "1", + BP = 100L, + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 10L, + sampleIds = paste0("s", seq_len(10L)), + pgenPtr = NULL + ) +} + +.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) + ) + ) +} + +# 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 <- fineMappingRow( + variantIds = vids, + susieFit = list(x = 1), + topLoci = mkTL(c(0.5, -1, 6.0, 0.2, 1.1, -0.3), c(3, 2)) + ) + e2 <- fineMappingRow( + 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) + ) +} + # ============================================================================= # --------------------------------------------------------------------------- @@ -239,10 +378,9 @@ test_that("updateMashModelCov drops dropped conditions + resizes remaining cov m samples = c("brain", "blood") ) expect_false("muscle" %in% names(m2$fitted_g$Ulist)) - expect_true(all(vapply( + expect_true(all(map_lgl( m2$fitted_g$Ulist, - function(x) all(dim(x) == c(2L, 2L)), - logical(1) + function(x) all(dim(x) == c(2L, 2L)) ))) expect_false(any(grepl("muscle", names(m2$fitted_g$pi)))) # Brain matrix has a single 1 at the brain position (the first of the @@ -333,14 +471,13 @@ test_that("fitMashContrast: 3-tested-conditions yields deviation + pairwise cont test_that("mashPipeline runs end-to-end on qtlSumStatsMulticontextExample", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # Use the same fixture for strong/random; nPcs <= ncol - 1 (3 contexts). res <- suppressMessages(suppressWarnings( mashPipeline( sumStatsList = list(strong = ss, random = ss), alpha = 0, - nPcs = 2L, + prior = MashPriorParam(nPcs = 2L), setSeed = 1L ) )) @@ -348,10 +485,9 @@ test_that("mashPipeline runs end-to-end on qtlSumStatsMulticontextExample", { expect_type(res$U, "list") expect_gt(length(res$U), 0L) # Every covariance matrix is 3x3 (one row/col per context) - expect_true(all(vapply( + expect_true(all(map_lgl( res$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_type(res$w, "double") expect_equal(sum(res$w), 1, tolerance = 1e-6) @@ -495,8 +631,7 @@ test_that("mashPipeline coerces a SimpleList before validating its names", { test_that("mashPipeline rejects priorCovariances not a non-empty named list", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() vhat <- diag(3) # Empty list. expect_error( @@ -505,7 +640,7 @@ test_that("mashPipeline rejects priorCovariances not a non-empty named list", { list(strong = ss), alpha = 0, residualCorrelation = vhat, - priorCovariances = list() + prior = MashPriorParam(priorCovariances = list()) ) )), "non-empty named" @@ -517,7 +652,7 @@ test_that("mashPipeline rejects priorCovariances not a non-empty named list", { list(strong = ss), alpha = 0, residualCorrelation = vhat, - priorCovariances = list(diag(3)) + prior = MashPriorParam(priorCovariances = list(diag(3))) ) )), "non-empty named" @@ -527,8 +662,7 @@ test_that("mashPipeline rejects priorCovariances not a non-empty named list", { test_that("mashPipeline rejects priorCovariances with wrong dimensions", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() vhat <- diag(3) expect_error( suppressMessages(suppressWarnings( @@ -536,7 +670,7 @@ test_that("mashPipeline rejects priorCovariances with wrong dimensions", { list(strong = ss), alpha = 0, residualCorrelation = vhat, - priorCovariances = list(myU = diag(2)) + prior = MashPriorParam(priorCovariances = list(myU = diag(2))) ) )), "3 x 3 matrix" @@ -546,8 +680,7 @@ test_that("mashPipeline rejects priorCovariances with wrong dimensions", { test_that("mashPipeline passes supplied residualCorrelation + priorCovariances through", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() vhat <- diag(3) U0 <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) res <- suppressMessages(suppressWarnings( @@ -555,7 +688,7 @@ test_that("mashPipeline passes supplied residualCorrelation + priorCovariances t list(strong = ss), alpha = 0, residualCorrelation = vhat, - priorCovariances = U0 + prior = MashPriorParam(priorCovariances = U0) ) )) expect_named(res, c("U", "w")) @@ -573,8 +706,7 @@ test_that("mashPipeline passes supplied residualCorrelation + priorCovariances t test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # `residualCorrelationMethod = "simple"` runs # estimate_null_correlation_simple on the null set; leaving nPcs NULL # exercises the `nPcs <- ncol(Bhat) - 1` default in the cov_* chain. @@ -588,10 +720,9 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { )) expect_named(res, c("U", "w")) expect_gt(length(res$U), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( res$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_equal(sum(res$w), 1, tolerance = 1e-6) }) @@ -607,42 +738,47 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { test_that("the default is identity regardless of which partitions are given", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() + prior <- mashTinyPrior() # The default must not depend on data shape -- that was the old silent - # behaviour this argument replaced. + # behaviour this argument replaced. `w` is what carries the evidence: it + # is fitted against V, so an identical `w` across the three calls is the + # same V reaching mash() each time. (`U` is the supplied prior passed + # through, so comparing it would prove nothing here.) withNull <- suppressMessages(suppressWarnings(mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, + prior = MashPriorParam(priorCovariances = prior), setSeed = 1L ))) withoutNull <- suppressMessages(suppressWarnings(mashPipeline( list(strong = ss, random = ss), alpha = 0, + prior = MashPriorParam(priorCovariances = prior), setSeed = 1L ))) explicit <- suppressMessages(suppressWarnings(mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, residualCorrelationMethod = "identity", + prior = MashPriorParam(priorCovariances = prior), setSeed = 1L ))) - expect_equal(withNull$U, withoutNull$U) expect_equal(withNull$w, withoutNull$w) - expect_equal(withNull$U, explicit$U) + expect_equal(withNull$w, explicit$w) }) test_that("an unused null partition is reported", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # Assembling a null set and still getting identity is more often an # oversight than an intent, so it must not pass silently. expect_message( suppressWarnings(mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, + prior = MashPriorParam(priorCovariances = mashTinyPrior()), setSeed = 1L )), "does not use it" @@ -653,6 +789,7 @@ test_that("an unused null partition is reported", { list(strong = ss, random = ss, null = ss), alpha = 0, residualCorrelationMethod = "identity", + prior = MashPriorParam(priorCovariances = mashTinyPrior()), setSeed = 1L )), "'null' partition" @@ -662,12 +799,12 @@ test_that("an unused null partition is reported", { test_that("no unused-null notice when there is nothing to ignore", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() noNull <- function() { suppressWarnings(mashPipeline( list(strong = ss, random = ss), alpha = 0, + prior = MashPriorParam(priorCovariances = mashTinyPrior()), setSeed = 1L )) } @@ -678,6 +815,7 @@ test_that("no unused-null notice when there is nothing to ignore", { list(strong = ss, random = ss, null = ss), alpha = 0, residualCorrelationMethod = "simple", + prior = MashPriorParam(priorCovariances = mashTinyPrior()), setSeed = 1L )) } @@ -687,19 +825,21 @@ test_that("no unused-null notice when there is nothing to ignore", { test_that("mashPipeline honours a data-driven residualCorrelationMethod", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() sl <- list(strong = ss, random = ss, null = ss) + prior <- mashTinyPrior() identityFit <- suppressMessages(suppressWarnings(mashPipeline( sl, alpha = 0, residualCorrelationMethod = "identity", + prior = MashPriorParam(priorCovariances = prior), setSeed = 1L ))) simpleFit <- suppressMessages(suppressWarnings(mashPipeline( sl, alpha = 0, residualCorrelationMethod = "simple", + prior = MashPriorParam(priorCovariances = prior), setSeed = 1L ))) # A different V has to move the fit, or the argument is not reaching it. @@ -707,8 +847,7 @@ test_that("mashPipeline honours a data-driven residualCorrelationMethod", { }) test_that("mashPipeline rejects an unknown residualCorrelationMethod", { - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPipeline( list(strong = ss, random = ss), @@ -721,8 +860,7 @@ test_that("mashPipeline rejects an unknown residualCorrelationMethod", { test_that("a method needing a partition it lacks errors through mashPipeline", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPipeline( list(strong = ss, random = ss), @@ -736,8 +874,7 @@ test_that("a method needing a partition it lacks errors through mashPipeline", { test_that("a supplied residualCorrelation wins over the method", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # 'simple' would error without a null set; the supplied matrix means the # estimator is never consulted. res <- suppressMessages(suppressWarnings(mashPipeline( @@ -745,6 +882,7 @@ test_that("a supplied residualCorrelation wins over the method", { alpha = 0, residualCorrelation = diag(3), residualCorrelationMethod = "simple", + prior = MashPriorParam(priorCovariances = mashTinyPrior()), setSeed = 1L ))) expect_named(res, c("U", "w")) @@ -756,8 +894,7 @@ test_that("a supplied residualCorrelation wins over the method", { test_that("mashResidualCorrelation(identity) is an identity of the right size", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- mashResidualCorrelation( list(strong = ss), alpha = 0, @@ -769,8 +906,7 @@ test_that("mashResidualCorrelation(identity) is an identity of the right size", test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -785,8 +921,7 @@ test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { test_that("mashResidualCorrelation(simple) errors without a null entry", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashResidualCorrelation( list(strong = ss), @@ -799,8 +934,7 @@ test_that("mashResidualCorrelation(simple) errors without a null entry", { test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -815,8 +949,7 @@ test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", { skip_if_not_installed("mashr") skip_if_not_installed("CorShrink") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -830,8 +963,7 @@ test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, random = ss), @@ -848,8 +980,7 @@ test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { test_that("mashResidualCorrelation errors when a method's inputs are missing", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashResidualCorrelation( list(strong = ss), @@ -877,8 +1008,7 @@ test_that("mashResidualCorrelation errors when a method's inputs are missing", { test_that("mashPriorCovariances computes the default (all-but-udr) prior", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() pc <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -890,10 +1020,9 @@ test_that("mashPriorCovariances computes the default (all-but-udr) prior", { )) expect_named(pc, c("U", "w", "loglik")) expect_gt(length(pc$U), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( pc$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_equal(sum(pc$w), 1, tolerance = 1e-6) expect_null(pc$loglik) @@ -902,8 +1031,7 @@ test_that("mashPriorCovariances computes the default (all-but-udr) prior", { test_that("mashPriorCovariances passes a supplied prior through unchanged", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() U0 <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) pc <- suppressMessages(suppressWarnings( mashPriorCovariances( @@ -920,8 +1048,7 @@ test_that("mashPriorCovariances passes a supplied prior through unchanged", { test_that("mashPriorCovariances validates a supplied prior", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( suppressMessages(suppressWarnings( mashPriorCovariances( @@ -949,8 +1076,7 @@ test_that("mashPriorCovariances validates a supplied prior", { test_that("mashPriorCovariances(flashNonneg) adds components vs flash-only", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() base <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -978,8 +1104,7 @@ 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() # A toy-sized udr config: `n_unconstrained` dominates the cost, and the default # (50, sized for many-condition data) is pathological on a 3-condition fixture # (it drove a 5+ minute fit). 2 unconstrained matrices suffice to exercise the @@ -989,33 +1114,35 @@ test_that("mashPriorCovariances engine 'ud' (udr) produces U + weights", { list(strong = ss), alpha = 0, vhat = diag(3), - engine = "ud", - udControl = list(n_unconstrained = 2L, maxiter = 20L), + engine = CovUdrOptions( + init = UdInitOptions(n_unconstrained = 2L), + fit = UdFitOptions(maxiter = 20L) + ), setSeed = 1L ) )) expect_gt(length(pc$U), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( pc$U, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) expect_equal(sum(pc$w), 1, tolerance = 1e-6) }) -test_that("mashPriorCovariances engine 'ud_ted' errors clearly on non-i.i.d. data", { +test_that("mashPriorCovariances TED update errors clearly on non-i.i.d. data", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") skip_if_not_installed("udr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), alpha = 0, vhat = diag(3), - engine = "ud_ted", + engine = CovUdrOptions( + fit = UdFitOptions(unconstrained.update = "ted") + ), setSeed = 1L ) )), @@ -1026,8 +1153,7 @@ test_that("mashPriorCovariances engine 'ud_ted' errors clearly on non-i.i.d. dat test_that("mashPriorCovariances rejects an unknown component", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPriorCovariances( list(strong = ss), @@ -1046,8 +1172,7 @@ test_that("mashPriorCovariances rejects an unknown component", { test_that("mashCovarianceComponents builds a single requested component", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() fl <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1058,18 +1183,16 @@ test_that("mashCovarianceComponents builds a single requested component", { ) )) expect_gt(length(fl), 0L) - expect_true(all(vapply( + expect_true(all(map_lgl( fl, - function(m) all(dim(m) == c(3L, 3L)), - logical(1) + function(m) all(dim(m) == c(3L, 3L)) ))) }) test_that("mashCovarianceComponents default builds all non-udr components", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() one <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1094,8 +1217,7 @@ test_that("mashCovarianceComponents default builds all non-udr components", { test_that("mashCovarianceComponents feeds mashPriorCovariances (same components)", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() comps <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1114,15 +1236,34 @@ test_that("mashCovarianceComponents feeds mashPriorCovariances (same components) setSeed = 1L ) )) - # mashPriorCovariances refines these components, so its U contains them all. - expect_true(all(names(comps) %in% names(prior$U))) + # Canonical components are structural hypotheses and reach the prior + # unrefined, so their names survive verbatim. The data-driven ones are + # replaced by their Extreme Deconvolution refinements (mashr names those + # "ED_"), rather than appearing twice as they used to. + # Derived rather than pattern-matched: mashr names singleton components + # after the conditions themselves (brain, blood, ...), so only a + # canonical-only build says reliably which names are canonical. + canonicalNames <- names(suppressMessages(suppressWarnings( + mashCovarianceComponents( + list(strong = ss), + alpha = 0, + vhat = diag(3), + components = "canonical", + setSeed = 1L + ) + ))) + expect_true(length(canonicalNames) > 0L) + expect_true(all(canonicalNames %in% names(prior$U))) + dataDrivenNames <- setdiff(names(comps), canonicalNames) + expect_true(length(dataDrivenNames) > 0L) + expect_false(any(dataDrivenNames %in% names(prior$U))) + expect_true(any(grepl("^ED", names(prior$U)))) }) test_that("mashCovarianceComponents rejects unknown components", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashCovarianceComponents( list(strong = ss), @@ -1136,8 +1277,7 @@ test_that("mashCovarianceComponents rejects unknown components", { test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode)", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() comps <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1153,20 +1293,22 @@ test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode) alpha = 0, vhat = diag(3), priorComponents = comps, - engine = "cov_ed", + engine = "covEd", setSeed = 1L ) )) - # the supplied components are refined into the returned U (not rebuilt) - expect_true(all(names(comps) %in% names(pr$U))) + # Supplied components are treated as the engine's input, so what comes + # back are their refinements, not the originals. + expect_false(any(names(comps) %in% names(pr$U))) + expect_true(any(grepl("^ED", names(pr$U)))) + expect_equal(length(pr$U), length(comps)) 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashPriorCovariances( list(strong = ss), @@ -1180,8 +1322,7 @@ test_that("mashPriorCovariances validates priorComponents", { test_that("mashPipeline result == composing the two extracted building blocks", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() full <- suppressMessages(suppressWarnings( mashPipeline( list(strong = ss, random = ss, null = ss), @@ -1216,48 +1357,6 @@ test_that("mashPipeline result == composing the two extracted building blocks", # 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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" - ) -}) - # --------------------------------------------------------------------------- # Prior-shape normalisation (.mashAsUlist) # @@ -1283,29 +1382,9 @@ test_that(".mashAsUlist does not mistake a covariance named U for the wrapper", expect_equal(pecotmr:::.mashAsUlist(ulist), ulist) }) -test_that("mashModelFit accepts either prior shape and fits identically", { - skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) - wrapped <- list(U = ulist, w = NULL, loglik = NULL) - - fit <- function(prior) { - suppressMessages(suppressWarnings(mashModelFit( - list(random = ss), - alpha = 0, - priorCovariances = prior, - vhat = diag(3), - setSeed = 1L - ))) - } - expect_equal(fit(wrapped)$loglik, fit(ulist)$loglik) -}) - test_that("mashPriorCovariances accepts either shape for its two prior args", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() sl <- list(strong = ss, random = ss) ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) wrapped <- list(U = ulist, w = NULL, loglik = NULL) @@ -1326,76 +1405,9 @@ test_that("mashPriorCovariances accepts either shape for its two prior args", { expect_equal(wrap$w, bare$w) }) -test_that("mashPosterior returns posterior matrices with covariance", { - skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() post <- suppressMessages(suppressWarnings( mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)) )) @@ -1672,8 +1684,7 @@ test_that("mashPosteriorContrast: empty frame when every feature is dropped", { test_that("mashResidualCorrelation(mle): errors without a 'random' entry", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() expect_error( mashResidualCorrelation(list(strong = ss), alpha = 0, method = "mle"), "requires a 'random' entry" @@ -1682,8 +1693,7 @@ test_that("mashResidualCorrelation(mle): errors without a 'random' entry", { test_that("mashResidualCorrelation accepts a SimpleList sumStatsList", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() V <- suppressMessages(suppressWarnings( mashResidualCorrelation( S4Vectors::SimpleList(null = ss), @@ -1696,8 +1706,7 @@ test_that("mashResidualCorrelation accepts a SimpleList sumStatsList", { test_that("mashCovarianceComponents: SimpleList input + default (NULL) vhat", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() cc <- suppressMessages(suppressWarnings( mashCovarianceComponents( S4Vectors::SimpleList(strong = ss), @@ -1711,8 +1720,7 @@ test_that("mashCovarianceComponents: SimpleList input + default (NULL) vhat", { test_that("mashPriorCovariances: SimpleList input (canonical only)", { skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample + ss <- mashFixture() pc <- suppressMessages(suppressWarnings( mashPriorCovariances( S4Vectors::SimpleList(strong = ss), @@ -1724,44 +1732,6 @@ test_that("mashPriorCovariances: SimpleList input (canonical only)", { expect_named(pc, c("U", "w", "loglik")) }) -test_that("mashModelFit: SimpleList input + default (NULL) vhat", { - skip_if_not_installed("mashr") - data(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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" - ) -}) - - test_that("contrast rows fall back to the positional index when unnamed", { # posteriorMean usually carries feature rownames, but an unnamed matrix # still needs a feature_id -- the position, not NA, so the contrast table @@ -1789,20 +1759,2159 @@ test_that("contrast rows fall back to the positional index when unnamed", { expect_equal(d2$feature_id, "f2") }) -test_that(".mashUdFit re-raises an unrelated udr failure unchanged", { - skip_if_not_installed("udr") - local_mocked_bindings(.mashUdControl = function(...) list(), - .package = "pecotmr") - # Only the ud_ted i.i.d. incompatibility is rewrapped; anything else must - # surface as itself rather than being swallowed into a NULL fit. +test_that("mashPipeline helpers: argument guards fire", { expect_error( - with_mocked_bindings( - pecotmr:::.mashUdFit( - NULL, list(Bhat = matrix(0, 2L, 2L)), "ud_ted", list() - ), - ud_fit = function(...) stop("totally unrelated failure"), - .package = "udr" + fitMashContrast( + 0L, + matrix(0, 2, 2), + matrix(0, 2, 2), + array(0, c(2, 2, 2)) ), - "totally unrelated failure" + "index.*Must be >= 1" + ) + expect_error( + updateMashModelCov(list(), allSamples = 1L, samples = "a"), + "allSamples.*Must be of type 'character'" + ) + expect_error( + sliceMashData("not-a-list", vhat = diag(2), snps = 1L, samples = NULL), + "data.*Must be of type 'list'" + ) + expect_error( + calculateFeatureScores(data.frame(), metaMethod = 1L), + "metaMethod.*Must be of type 'string'" + ) + expect_error( + nSignificantScore(data.frame(), pCutoff = 2), + "pCutoff.*is not <= 1" ) + expect_error( + makePairwiseContrastCol(c("a", "b", "c"), template = c(a = 0)), + "pair.*Must have length 2" + ) + expect_error(sanitizeMashData("nope"), "data.*Must be of type 'list'") +}) + +test_that("MashComponentParam takes plain lists or constructors per entry", { + skip_if_not_installed("mashr") + ca <- MashComponentParam( + pca = list(subset = 1:5), + canonical = CovCanonicalOptions() + ) + expect_s4_class(ca, "MashComponentParam") + expect_s4_class(ca, "MethodParam") + # Naming a component selects it. The entries live in one named-list + # slot rather than one nullable slot per component: a record selecting + # pca used to show three NULL slots, which told a reader nothing. + expect_setequal(names(ca$components), c("canonical", "pca")) + expect_null(ca$components$flash) + expect_setequal(names(ca), "components") + # Each entry is still an engine argument bag, whichever form it arrived + # in: a plain list is spliced into that component's constructor. + expect_s4_class(ca$components$pca, "MethodOptions") + expect_equal(ca$components$pca$subset, 1:5) + expect_error(MashComponentParam(pca = list(nope = 1)), "unknown argument") + expect_error( + MashComponentParam(pca = CovCanonicalOptions()), + "was built with the constructor for 'canonical'" + ) + # The four components are formals now, so a misspelled one is R's own + # error rather than a hand-rolled "unknown method" check. + expect_error(MashComponentParam(nosuch = list()), "unused argument") +}) + +test_that("MashPriorParam takes only a MashComponentParam for components", { + skip_if_not_installed("mashr") + # The slot was a character|MethodOptions union while the aggregator was + # still a MethodOptions, so any engine bag was accepted there. Now it is + # exact: a component record, or the component names. + expect_s4_class( + MashPriorParam(components = MashComponentParam(pca = list())), + "MashPriorParam" + ) + expect_s4_class( + MashPriorParam(components = c("canonical", "pca")), + "MashPriorParam" + ) + expect_error( + MashPriorParam(components = CovPcaOptions()), + "must be component names or a MashComponentParam" + ) +}) + +test_that("mashPriorCovariances takes components as names or a record", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + ss <- mashFixture() + byRecord <- suppressMessages(suppressWarnings( + mashPriorCovariances( + list(strong = ss), + alpha = 0, + vhat = diag(3), + components = MashComponentParam(canonical = CovCanonicalOptions()), + engine = "none", + setSeed = 1L + ) + )) + # Naming a component in the record selects it, so canonical-only here. + expect_true(length(byRecord$U) > 0L) + expect_false(any(grepl("^ED", names(byRecord$U)))) +}) + +test_that("engine 'none' leaves the data-driven components unrefined", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + ss <- mashFixture() + raw <- suppressMessages(suppressWarnings( + mashPriorCovariances( + list(strong = ss), + alpha = 0, + vhat = diag(3), + components = c("pca"), + engine = "none", + nPcs = 2L, + setSeed = 1L + ) + )) + # mashr supports using generator output directly as the prior; pecotmr + # used to refine unconditionally. + expect_true(any(grepl("^PCA", names(raw$U)))) + expect_false(any(grepl("^ED", names(raw$U)))) +}) + +test_that("mashPriorCovariances rejects an unknown engine", { + skip_if_not_installed("mashr") + ss <- mashFixture() + expect_error( + mashPriorCovariances( + list(strong = ss), + alpha = 0, + vhat = diag(3), + engine = "ud_ted" + ), + "`engine` must be one of" + ) +}) + +test_that("mashPipeline forwards mashDataArgs and mashArgs downstream", { + skip_if_not_installed("mashr") + dataSeen <- list() + mashSeen <- list() + realData <- mashr::mash_set_data + realMash <- mashr::mash + ss <- mashFixture(20L) + suppressMessages(suppressWarnings(with_mocked_bindings( + mashPipeline( + list(strong = ss, random = ss, null = ss), + alpha = 0, + residualCorrelationMethod = "simple", + prior = MashPriorParam(priorCovariances = mashTinyPrior()), + mashDataArgs = MashDataOptions(zero_Shat_reset = 0.25), + mashArgs = MashOptions(nullweight = 3) + ), + mash_set_data = function(...) { + dataSeen[[length(dataSeen) + 1L]] <<- list(...) + realData(...) + }, + mash = function(...) { + mashSeen[[length(mashSeen) + 1L]] <<- list(...) + realMash(...) + }, + .package = "mashr" + ))) + # Both the Vhat estimator and the prior/weight fit build mash data, and + # every one of those calls must carry the caller's settings. + expect_gte(length(dataSeen), 2L) + expect_true(all(map_dbl(dataSeen, "zero_Shat_reset") == 0.25)) + expect_gte(length(mashSeen), 1L) + expect_true(all(map_dbl(mashSeen, "nullweight") == 3)) +}) + +test_that("mashResidualCorrelation takes method as a name or a constructor", { + skip_if_not_installed("mashr") + seen <- NULL + real <- mashr::estimate_null_correlation_simple + ss <- mashFixture(20L) + byName <- suppressMessages(suppressWarnings(mashResidualCorrelation( + list(strong = ss, null = ss), + alpha = 0, + method = "simple" + ))) + byCtor <- suppressMessages(suppressWarnings(with_mocked_bindings( + mashResidualCorrelation( + list(strong = ss, null = ss), + alpha = 0, + method = MashCorSimpleOptions(z_thresh = 1) + ), + estimate_null_correlation_simple = function(...) { + seen <<- list(...) + real(...) + }, + .package = "mashr" + ))) + expect_equal(seen$z_thresh, 1) + expect_equal(dim(byName), dim(byCtor)) + expect_error( + mashResidualCorrelation( + list(strong = ss), + alpha = 0, + method = MashOptions() + ), + "unknown engine 'mash'" + ) +}) + +test_that("mashResidualCorrelation routes CorShrinkOptions to CorShrink", { + skip_if_not_installed("mashr") + skip_if_not_installed("CorShrink") + seen <- NULL + real <- CorShrink::CorShrinkData + ss <- mashFixture(20L) + suppressMessages(suppressWarnings(with_mocked_bindings( + mashResidualCorrelation( + list(strong = ss, null = ss), + alpha = 0, + method = CorShrinkOptions(cor_method = "pearson") + ), + CorShrinkData = function(...) { + seen <<- list(...) + real(...) + }, + .package = "CorShrink" + ))) + expect_equal(seen$cor_method, "pearson") + # The pecotmr defaults ride along. + expect_equal(seen$image, "null") + expect_equal(seen$ash.control, list(mixcompdist = "halfuniform")) +}) + +test_that(".mashUdControl defers to udr only where udr chooses well", { + skip_if_not_installed("udr") + # udr resolves its NA default as ifelse(is.matrix(fit$V), "ted", "none"). + # On the z scale that is TED, which is what we want, so the field is + # omitted and udr decides. + iid <- pecotmr:::.mashUdControl(UdFitOptions(), 3L, iid = TRUE) + expect_false(is_in("unconstrained.update", names(iid))) + expect_equal( + udr::ud_fit_control_default()$unconstrained.update, + NA + ) + # On the beta scale ud_init() leaves a per-variant V, so udr would pick + # "none" and never refine the unconstrained components. Pin ED, which + # does not need i.i.d. data. + beta <- pecotmr:::.mashUdControl(UdFitOptions(), 3L, iid = FALSE) + expect_equal(beta$unconstrained.update, "ed") + # Either way the caller's own value wins. + expect_equal( + pecotmr:::.mashUdControl( + UdFitOptions(unconstrained.update = "ed"), + 3L, + iid = TRUE + )$unconstrained.update, + "ed" + ) + expect_equal( + pecotmr:::.mashUdControl( + UdFitOptions(unconstrained.update = "ted"), + 3L, + iid = FALSE + )$unconstrained.update, + "ted" + ) + # The settings pecotmr owns outright are unaffected by the scale. + expect_equal(iid$scaled.update, "fa") + expect_equal(iid$lambda, 3L) +}) + +test_that("the mash region partitions forward every cfg field", { + # mashInput() builds the record inline before handing it on. + fields <- .cfgFieldNames("mashInput") + accepted <- setdiff( + names(formals(get( + ".mashObjectPartitions", + envir = asNamespace("pecotmr") + ))), + c("...", "obj") + ) + passed <- .argNamesPassed(".mashRegionPartitions") + expect_equal(setdiff(intersect(fields, accepted), passed), character(0)) +}) + +test_that("filterInvalidSummaryStat replaces NaN/Inf in bhat", { + dat <- list( + bhat = data.frame(a = c(1, NaN, 3), b = c(Inf, 2, -Inf)), + sbhat = data.frame(a = c(0.1, 0.2, 0.3), b = c(0.1, NA, 0.3)) + ) + result <- filterInvalidSummaryStat(dat, bhat = "bhat", sbhat = "sbhat") + expect_true(all(!is.nan(result$bhat))) + expect_true(all(!is.infinite(result$bhat))) + # NaN/Inf in bhat replaced with 0 + expect_equal(unname(result$bhat[1, 2]), 0) # Inf -> 0 +}) + +test_that("filterInvalidSummaryStat replaces NaN/Inf in sbhat", { + dat <- list( + bhat = data.frame(a = c(1, 2, 3)), + sbhat = data.frame(a = c(0.1, NaN, Inf)) + ) + result <- filterInvalidSummaryStat(dat, bhat = "bhat", sbhat = "sbhat") + # NaN/Inf in sbhat replaced with 1000 + expect_equal(unname(result$sbhat[1, "a"]), 0.1) + expect_equal(unname(result$sbhat[2, "a"]), 1000) + expect_equal(unname(result$sbhat[3, "a"]), 1000) +}) + +test_that("filterInvalidSummaryStat filters by missing_rate when null.b present", { + dat <- list( + bhat = data.frame(a = c(0, 0, 1, 2), b = c(0, 0, 0, 3)), + sbhat = data.frame(a = c(1, 1, 1, 1), b = c(1, 1, 1, 1)), + null.b = TRUE + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "bhat", + sbhat = "sbhat", + filterByMissingRate = 0.5 + ) + expect_equal(nrow(result$bhat), 2) # rows 3 and 4 survive +}) + +test_that("filterInvalidSummaryStat filters by missing_rate when random.b present", { + dat <- list( + bhat = data.frame(a = c(0, 1, 2), b = c(0, 1, 3)), + sbhat = data.frame(a = c(1, 1, 1), b = c(1, 1, 1)), + random.b = TRUE + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "bhat", + sbhat = "sbhat", + filterByMissingRate = 0.5 + ) + expect_true(nrow(result$bhat) < 3) +}) + +test_that("filterInvalidSummaryStat btoz with .b and .s pattern creates condition.z", { + dat <- list( + strong.b = data.frame(a = c(1, 2), b = c(3, 4)), + strong.s = data.frame(a = c(0.1, 0.2), b = c(0.3, 0.4)) + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "strong.b", + sbhat = "strong.s", + btoz = TRUE, + sigPCutoff = NULL + ) + expect_true("strong.z" %in% names(result)) + expect_true(is.matrix(result$strong.z)) + expect_equal(nrow(result$strong.z), 2) + expect_equal(ncol(result$strong.z), 2) + expect_equal( + as.numeric(result$strong.z), + c(10, 10, 10, 10), + tolerance = 1e-10 + ) +}) + +test_that("filterInvalidSummaryStat btoz when bhat/sbhat data is NULL creates NULL z", { + dat <- list( + strong.b = NULL, + strong.s = data.frame(a = c(0.1)) + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "strong.b", + sbhat = "strong.s", + btoz = TRUE, + sigPCutoff = NULL + ) + expect_true("strong.z" %in% names(result)) + expect_null(result$strong.z) +}) + +test_that("filterInvalidSummaryStat btoz without .b/.s pattern creates generic z", { + dat <- list( + bhat = data.frame(a = c(1, 2, 3)), + sbhat = data.frame(a = c(0.5, 1, 0.5)) + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "bhat", + sbhat = "sbhat", + btoz = TRUE + ) + expect_true("z" %in% names(result)) + expect_equal(as.numeric(result$z[, 1]), c(2, 2, 6)) +}) + +test_that("filterInvalidSummaryStat btoz creates NULL z when bhat is NULL (no .b suffix)", { + dat <- list( + bhat = NULL, + sbhat = data.frame(a = c(0.1)) + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "bhat", + sbhat = "sbhat", + btoz = TRUE + ) + expect_true("z" %in% names(result)) + expect_null(result$z) +}) + +test_that("filterInvalidSummaryStat btoz filters strong.z by significance cutoff", { + dat <- list( + strong.b = data.frame( + a = c(1, 0.01, 0.02, 2), + b = c(0.01, 0.01, 0.01, 0.01) + ), + strong.s = data.frame( + a = c(0.1, 0.1, 0.1, 0.1), + b = c(0.1, 0.1, 0.1, 0.1) + ), + strong.z = NULL + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "strong.b", + sbhat = "strong.s", + btoz = TRUE, + sigPCutoff = 1E-6 + ) + expect_true("strong.z" %in% names(result)) + expect_equal(nrow(result$strong.z), 2) + expect_equal(nrow(result$strong.b), 2) + expect_equal(nrow(result$strong.s), 2) +}) + +test_that("filterInvalidSummaryStat processes z directly with null component", { + dat <- list( + strong = list(z = data.frame(a = c(5, NaN, 0.1), b = c(1, 2, Inf))), + random = list(z = data.frame(a = c(0.5, 0.2), b = c(0.3, 0.4))), + null = list(z = data.frame(a = c(0.01, NaN), b = c(Inf, 0.02))) + ) + result <- filterInvalidSummaryStat(dat, z = "z") + expect_true(all(!is.nan(result$strong$z))) + expect_true(all(!is.infinite(result$strong$z))) + expect_true(all(!is.nan(result$null$z))) + expect_true(all(!is.infinite(result$null$z))) +}) + +test_that("filterInvalidSummaryStat z path applies significance cutoff to strong.z", { + dat <- list( + strong = list( + z = data.frame(a = c(10, 0.1, 0.2), b = c(0.1, 0.1, 0.1)) + ), + random = list( + z = data.frame(a = c(0.5, 0.2, 0.3), b = c(0.3, 0.4, 0.2)) + ) + ) + result <- filterInvalidSummaryStat(dat, z = "z", sigPCutoff = 1E-6) + expect_equal(nrow(result$strong$z), 1) +}) + +test_that("filterInvalidSummaryStat z path with filterByMissingRate", { + dat <- list( + random = list(z = data.frame(a = c(0, 0, 5), b = c(0, 3, 4))) + ) + result <- filterInvalidSummaryStat(dat, z = "z", filterByMissingRate = 0.5) + expect_equal(nrow(result$random$z), 2) +}) + +test_that("filterInvalidSummaryStat processes bhat/sbhat without filterByMissingRate when no null.b/random.b", { + dat <- list( + bhat = data.frame(a = c(1, NaN, 3), b = c(Inf, 2, -Inf)), + sbhat = data.frame(a = c(0.1, NA, 0.3), b = c(0.1, 0.2, NaN)) + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "bhat", + sbhat = "sbhat", + filterByMissingRate = 0.5 + ) + expect_equal(nrow(result$bhat), 3) + expect_equal(unname(result$bhat[2, "a"]), 0) + expect_equal(unname(result$sbhat[3, "b"]), 1000) +}) + +test_that("filterInvalidSummaryStat with filterByMissingRate=NULL keeps all rows even with null.b", { + dat <- list( + bhat = data.frame(a = c(0, 0, 1), b = c(0, 0, 1)), + sbhat = data.frame(a = c(1, 1, 1), b = c(1, 1, 1)), + null.b = TRUE + ) + result <- filterInvalidSummaryStat( + dat, + bhat = "bhat", + sbhat = "sbhat", + filterByMissingRate = NULL + ) + expect_equal(nrow(result$bhat), 3) +}) + +test_that("filterInvalidSummaryStat z path handles NULL strong component", { + dat <- list( + strong = NULL, + random = list(z = data.frame(a = c(0.5, 0.2), b = c(0.3, 0.4))) + ) + result <- filterInvalidSummaryStat(dat, z = "z") + expect_null(result$strong) + expect_true(!is.null(result$random$z)) +}) + +test_that("filterMixtureComponents removes zero matrices", { + U <- list( + comp1 = matrix( + c(1, 0, 0, 2), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + comp2 = matrix( + c(0, 0, 0, 0), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + A = matrix( + c(3, 0, 0, 4), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + w <- c(comp1 = 0.5, comp2 = 0.3, A = 0.2) + result <- filterMixtureComponents(c("A", "B"), U, w) + expect_false("comp2" %in% names(result$U)) +}) + +test_that("filterMixtureComponents removes matrices below weight cutoff", { + U <- list( + comp1 = matrix( + c(1, 0, 0, 2), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + comp2 = matrix( + c(0.1, 0, 0, 0.1), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + w <- c(comp1 = 0.9, comp2 = 0.00001) + result <- filterMixtureComponents(c("A", "B"), U, w, wCutoff = 1e-4) + expect_false("comp2" %in% names(result$U)) +}) + +test_that("filterMixtureComponents errors on missing conditions", { + U <- list( + comp1 = matrix( + c(1, 0, 0, 2), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + expect_error( + filterMixtureComponents(c("A", "C"), U), + "not found in matrix" + ) +}) + +test_that("filterMixtureComponents removes components named as filtered conditions", { + U <- list( + comp1 = matrix( + c(1, 0, 0, 0, 2, 0, 0, 0, 3), + 3, + 3, + dimnames = list(c("A", "B", "C"), c("A", "B", "C")) + ), + C = matrix( + c(4, 0, 0, 0, 5, 0, 0, 0, 6), + 3, + 3, + dimnames = list(c("A", "B", "C"), c("A", "B", "C")) + ) + ) + w <- c(comp1 = 0.6, C = 0.4) + result <- filterMixtureComponents(c("A", "B"), U, w) + expect_false("C" %in% names(result$U)) + expect_equal(nrow(result$U$comp1), 2) + expect_equal(ncol(result$U$comp1), 2) +}) + +test_that("filterMixtureComponents renormalizes weights to preserve original sum", { + U <- list( + comp1 = matrix( + c(1, 0, 0, 2), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + comp2 = matrix( + c(3, 0, 0, 4), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + comp3 = matrix( + c(0, 0, 0, 0), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + w <- c(comp1 = 0.5, comp2 = 0.3, comp3 = 0.2) + original_sum <- sum(w) + + result <- filterMixtureComponents(c("A", "B"), U, w) + expect_false("comp3" %in% names(result$U)) + expect_equal(sum(result$w), original_sum, tolerance = 1e-10) + expect_true(result$w["comp1"] > 0.5) + expect_true(result$w["comp2"] > 0.3) +}) + +test_that("filterMixtureComponents subsets 3x3 matrices to 2x2 and removes filtered condition names", { + U <- list( + comp1 = matrix( + c(1, 0.1, 0, 0.1, 2, 0, 0, 0, 3), + 3, + 3, + dimnames = list(c("A", "B", "C"), c("A", "B", "C")) + ), + B = matrix( + c(4, 0, 0, 0, 5, 0, 0, 0, 6), + 3, + 3, + dimnames = list(c("A", "B", "C"), c("A", "B", "C")) + ) + ) + w <- c(comp1 = 0.7, B = 0.3) + + result <- filterMixtureComponents(c("A", "C"), U, w) + expect_false("B" %in% names(result$U)) + expect_equal(nrow(result$U$comp1), 2) + expect_equal(ncol(result$U$comp1), 2) + expect_equal(rownames(result$U$comp1), c("A", "C")) +}) + +test_that("filterMixtureComponents handles NULL weights gracefully", { + U <- list( + comp1 = matrix( + c(1, 0, 0, 2), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + comp2 = matrix( + c(0, 0, 0, 0), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + result <- filterMixtureComponents(c("A", "B"), U, w = NULL) + expect_false("comp2" %in% names(result$U)) + expect_true("comp1" %in% names(result$U)) +}) + +test_that("mergeMashData combines two datasets with identical columns", { + d1 <- list( + random = data.frame( + a = 1:3, + b = 4:6, + row.names = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") + ) + ) + d2 <- list( + random = data.frame( + a = 7:8, + b = 9:10, + row.names = c("chr1:400:A:G", "chr1:500:A:G") + ) + ) + result <- mergeMashData(d1, d2) + expect_equal(nrow(result$random), 5) + expect_equal(ncol(result$random), 2) + expect_equal(colnames(result$random), c("a", "b")) + expect_equal(result$random$a, c(1, 2, 3, 7, 8)) +}) + +test_that("mergeMashData handles NULL input", { + d1 <- NULL + d2 <- list(random = data.frame(a = 1:3)) + result <- mergeMashData(d1, d2) + expect_equal(nrow(result$random), 3) +}) + +test_that("mergeMashData aligns different column names correctly", { + d1 <- list( + random = data.frame( + a = 1:2, + b = 3:4, + row.names = c("chr1:100:A:G", "chr1:200:A:G") + ) + ) + d2 <- list( + random = data.frame( + a = 5:6, + c = 7:8, + row.names = c("chr1:300:A:G", "chr1:400:A:G") + ) + ) + result <- mergeMashData(d1, d2) + expect_equal(nrow(result$random), 4) + expect_true(all(c("a", "b", "c") %in% colnames(result$random))) + expect_true(is.nan(result$random[3, "b"])) + expect_true(is.nan(result$random[1, "c"])) +}) + +test_that("mergeMashData preserves data when one side is empty data.frame", { + d1 <- list(random = data.frame(a = 1:3)) + d2 <- list(random = data.frame()) + result <- mergeMashData(d1, d2) + expect_equal(nrow(result$random), 3) +}) + +test_that("mergeMashData preserves data when one side is NULL element", { + d1 <- list(random = NULL) + d2 <- list(random = data.frame(a = 1:3)) + result <- mergeMashData(d1, d2) + expect_equal(nrow(result$random), 3) +}) + +test_that("mergeMashData handles multiple named elements", { + d1 <- list( + random = data.frame( + a = 1:2, + b = 3:4, + row.names = c("chr1:100:A:G", "chr1:200:A:G") + ), + null = data.frame(x = 10:11, row.names = c("n1", "n2")) + ) + d2 <- list( + random = data.frame( + a = 5:6, + b = 7:8, + row.names = c("chr1:300:A:G", "chr1:400:A:G") + ), + null = data.frame(x = 12:13, row.names = c("n3", "n4")) + ) + result <- mergeMashData(d1, d2) + expect_equal(nrow(result$random), 4) + expect_equal(nrow(result$null), 4) +}) + +test_that("mergeMashData errors on duplicate variant ids across sides", { + d1 <- list( + random = data.frame( + a = 1:2, + row.names = c("chr1:100:A:G", "chr1:200:A:G") + ) + ) + d2 <- list( + random = data.frame( + a = 3:4, + row.names = c("chr1:200:A:G", "chr1:900:A:G") + ) + ) + expect_error(mergeMashData(d1, d2), "duplicate variant ids") +}) + +test_that("mergeMashData uses one_data when res_data element has zero rows", { + d1 <- list(random = data.frame(a = numeric(0), b = numeric(0))) + d2 <- list(random = data.frame(a = 1:3, b = 4:6)) + result <- mergeMashData(d1, d2) + expect_true(nrow(result$random) >= 3) +}) + +test_that("mashRandNullSample with z scores returns random and null", { + set.seed(42) + dat <- list( + z = data.frame( + cond1 = c(5, 0.1, 0.2, 0.3, 0.5, 6, 0.1, 0.2, 0.4, 0.3), + cond2 = c(0.2, 0.3, 0.1, 0.5, 0.4, 0.1, 0.3, 0.2, 0.1, 0.5) + ) + ) + result <- mashRandNullSample( + dat, + nRandom = 5, + nNull = 3, + excludeCondition = c(), + seed = 123 + ) + expect_type(result, "list") + expect_true("random" %in% names(result)) + expect_true("null" %in% names(result)) + expect_true("z" %in% names(result$random)) + expect_equal(nrow(result$random$z), 5) +}) + +test_that("mashRandNullSample with seed is reproducible", { + dat <- list( + z = data.frame( + cond1 = c(0.1, 0.2, 0.3, 0.4, 0.5), + cond2 = c(0.5, 0.4, 0.3, 0.2, 0.1) + ) + ) + result1 <- mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = c(), + seed = 42 + ) + result2 <- mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = c(), + seed = 42 + ) + expect_equal(result1$random$z, result2$random$z) +}) + +test_that("mashRandNullSample NULL input returns NULL", { + result <- mashRandNullSample( + NULL, + nRandom = 5, + nNull = 3, + excludeCondition = c() + ) + expect_null(result) +}) + +test_that("mashRandNullSample warns when no null variants found (all abs_z > 2)", { + dat <- list( + z = data.frame( + cond1 = c(5, 6, 7, 8, 9), + cond2 = c(5, 6, 7, 8, 9) + ) + ) + expect_warning( + result <- mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = c(), + seed = 42 + ), + "no variants are included in the null" + ) + expect_equal(length(result$null), 0) +}) + +test_that("mashRandNullSample warns when not enough null data", { + dat <- list( + z = data.frame( + cond1 = c(5, 6, 0.1), + cond2 = c(5, 6, 0.1), + cond3 = c(5, 6, 0.1) + ) + ) + expect_warning( + result <- mashRandNullSample( + dat, + nRandom = 2, + nNull = 1, + excludeCondition = c(), + seed = 42 + ), + "not enough null data" + ) + expect_equal(length(result$null), 0) +}) + +test_that("mashRandNullSample with bhat/sbhat processes random and null samples", { + dat <- list( + bhat = data.frame( + cond1 = c(0.1, 0.05, 0.02, 0.01, 0.03), + cond2 = c(0.02, 0.01, 0.03, 0.05, 0.04) + ), + sbhat = data.frame( + cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1), + cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1) + ) + ) + result <- mashRandNullSample( + dat, + nRandom = 3, + nNull = 3, + excludeCondition = c(), + seed = 42 + ) + expect_equal(ncol(result$random$bhat), 2) + expect_equal(nrow(result$random$bhat), 3) + expect_true(length(result$null) > 0) +}) + +test_that("mashRandNullSample errors when excludeCondition not found (z path)", { + dat <- list( + z = data.frame(cond1 = 1:5, cond2 = 1:5) + ) + expect_error( + mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = "nonexistent", + seed = 42 + ), + "excludeCondition are not present" + ) +}) + +test_that("mashRandNullSample errors when excludeCondition not found (bhat path)", { + dat <- list( + bhat = data.frame(cond1 = 1:5, cond2 = 1:5), + sbhat = data.frame(cond1 = rep(1, 5), cond2 = rep(1, 5)) + ) + expect_error( + mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = "nonexistent", + seed = 42 + ), + "excludeCondition are not present" + ) +}) + +test_that("mashRandNullSample drops excluded condition by column name", { + dat <- list( + z = data.frame( + cond1 = c(0.1, 0.2, 0.3, 0.4, 0.5), + cond2 = c(0.5, 0.4, 0.3, 0.2, 0.1), + cond3 = c(0.3, 0.3, 0.3, 0.3, 0.3) + ) + ) + result <- mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = "cond3", + seed = 42 + ) + expect_equal(colnames(result$random$z), c("cond1", "cond2")) + expect_equal(colnames(result$null$z), c("cond1", "cond2")) + expect_false("cond3" %in% colnames(result$random$z)) +}) + +test_that("mashRandNullSample extracts null data with z scores when enough null variants exist", { + dat <- list( + z = data.frame( + cond1 = c(0.1, 0.3, 0.2, 0.5, 0.4, 0.1, 0.3, 0.2, 0.5, 0.4), + cond2 = c(0.2, 0.1, 0.4, 0.3, 0.5, 0.2, 0.1, 0.4, 0.3, 0.5) + ) + ) + result <- mashRandNullSample( + dat, + nRandom = 5, + nNull = 4, + excludeCondition = c(), + seed = 42 + ) + expect_true("null" %in% names(result)) + expect_true("z" %in% names(result$null)) + expect_equal(nrow(result$null$z), 4) + expect_equal(ncol(result$null$z), 2) + expect_equal(nrow(result$random$z), 5) +}) + +test_that("mashRandNullSample null data capped at available null variants", { + dat <- list( + z = data.frame( + cond1 = c(0.1, 0.2, 0.3), + cond2 = c(0.1, 0.2, 0.3) + ) + ) + result <- mashRandNullSample( + dat, + nRandom = 2, + nNull = 100, + excludeCondition = c(), + seed = 42 + ) + expect_true(length(result$null) > 0) + expect_equal(nrow(result$null$z), 3) +}) + +test_that("mashRandNullSample extracts null data with bhat/sbhat when enough null variants", { + dat <- list( + bhat = data.frame( + cond1 = c(0.01, 0.02, 0.01, 0.03, 0.02, 0.01), + cond2 = c(0.02, 0.01, 0.03, 0.01, 0.02, 0.01) + ), + sbhat = data.frame( + cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1), + cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1) + ) + ) + result <- mashRandNullSample( + dat, + nRandom = 3, + nNull = 4, + excludeCondition = c(), + seed = 42 + ) + expect_true("null" %in% names(result)) + expect_true("bhat" %in% names(result$null)) + expect_true("sbhat" %in% names(result$null)) + expect_equal(nrow(result$null$bhat), 4) + expect_equal(nrow(result$null$sbhat), 4) +}) + +test_that("mashRandNullSample excludeCondition with numeric index errors on z path", { + dat <- list( + z = data.frame( + cond1 = c(0.1, 0.2, 0.3, 0.4, 0.5), + cond2 = c(0.5, 0.4, 0.3, 0.2, 0.1), + cond3 = c(0.3, 0.3, 0.3, 0.3, 0.3) + ) + ) + expect_error( + mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = 3, + seed = 42 + ), + "excludeCondition are not present" + ) +}) + +test_that("mashRandNullSample excludeCondition with numeric index errors on bhat path", { + dat <- list( + bhat = data.frame( + cond1 = c(0.01, 0.02, 0.01, 0.03, 0.02), + cond2 = c(0.02, 0.01, 0.03, 0.01, 0.02), + cond3 = c(0.01, 0.01, 0.01, 0.01, 0.01) + ), + sbhat = data.frame( + cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1), + cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1), + cond3 = c(0.1, 0.1, 0.1, 0.1, 0.1) + ) + ) + expect_error( + mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = 3, + seed = 42 + ), + "excludeCondition are not present" + ) +}) + +test_that("mashRandNullSample caps random sample at available rows", { + dat <- list( + z = data.frame( + cond1 = c(0.1, 0.2, 0.3), + cond2 = c(0.2, 0.1, 0.3) + ) + ) + result <- mashRandNullSample( + dat, + nRandom = 100, + nNull = 2, + excludeCondition = c(), + seed = 42 + ) + expect_equal(nrow(result$random$z), 3) +}) + +test_that("filterMixtureComponents filters zero matrices", { + U <- list( + mat1 = matrix( + c(1, 0.5, 0.5, 1), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + mat2 = matrix(0, 2, 2, dimnames = list(c("A", "B"), c("A", "B"))), + mat3 = matrix( + c(0.8, 0.3, 0.3, 0.9), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + w <- c(mat1 = 0.5, mat2 = 0.3, mat3 = 0.2) + conditions_to_keep <- c("A", "B") + + result <- filterMixtureComponents(conditions_to_keep, U, w) + + # mat2 should be removed (all zeros) + expect_true(!"mat2" %in% names(result$U)) + # weights should be rescaled to maintain sum + expect_equal(sum(result$w), sum(w), tolerance = 1e-10) +}) + +test_that("filterMixtureComponents removes low weight components", { + U <- list( + mat1 = matrix( + c(1, 0.5, 0.5, 1), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ), + mat2 = matrix( + c(0.8, 0.3, 0.3, 0.9), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + w <- c(mat1 = 0.999, mat2 = 0.00001) # mat2 below default cutoff + conditions_to_keep <- c("A", "B") + + result <- filterMixtureComponents(conditions_to_keep, U, w, wCutoff = 1e-04) + expect_true(!"mat2" %in% names(result$U)) +}) + +test_that("filterMixtureComponents errors on missing condition", { + U <- list( + mat1 = matrix( + c(1, 0.5, 0.5, 1), + 2, + 2, + dimnames = list(c("A", "B"), c("A", "B")) + ) + ) + w <- c(mat1 = 1.0) + expect_error( + filterMixtureComponents(c("A", "C"), U, w), + "not found in matrix" + ) +}) + +test_that("filterMixtureComponents subsets conditions", { + U <- list( + mat1 = matrix( + c(1, 0.5, 0.2, 0.5, 1, 0.3, 0.2, 0.3, 1), + 3, + 3, + dimnames = list(c("A", "B", "C"), c("A", "B", "C")) + ) + ) + w <- c(mat1 = 1.0) + + result <- filterMixtureComponents(c("A", "B"), U, w) + expect_equal(nrow(result$U[[1]]), 2) + expect_equal(ncol(result$U[[1]]), 2) +}) + +test_that(".mashSumStatsToMatrices: auto picks BETA+SE when present", { + ss <- .mssm_makeQtlSumStats(function(i, n) { + list( + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), + A1 = "A", + A2 = "G", + Z = rnorm(n), + BETA = rnorm(n, sd = 0.1), + SE = abs(rnorm(n, sd = 0.05)) + 0.01 + ) + }) + out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") + expect_equal(ncol(out$b), 2L) # 2 contexts + # On BETA scale, Shat values should be the small SEs we generated. + expect_true(all(out$s[out$s < 1000] < 1)) +}) + +test_that(".mashSumStatsToMatrices: auto falls back to Z when no BETA/SE", { + ss <- .mssm_makeQtlSumStats(function(i, n) { + list( + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), + A1 = "A", + A2 = "G", + Z = rnorm(n) + ) + }) + out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") + # Shat should be 1 on the Z scale. + expect_true(all(out$s == 1 | out$s == 1000)) +}) + +test_that(".mashSumStatsToMatrices: inputScale='beta' errors when BETA missing", { + ss <- .mssm_makeQtlSumStats(function(i, n) { + list( + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), + A1 = "A", + A2 = "G", + Z = rnorm(n) + ) + }) + expect_error( + pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "beta"), + "BETA and SE" + ) +}) + +test_that(".mashSumStatsToMatrices: inputScale='z' forces Z+1 even when BETA present", { + ss <- .mssm_makeQtlSumStats(function(i, n) { + list( + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), + A1 = "A", + A2 = "G", + Z = rnorm(n), + BETA = rnorm(n, sd = 0.1), + SE = abs(rnorm(n, sd = 0.05)) + 0.01 + ) + }) + out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "z") + # Forced Z scale: Shat must be 1 everywhere except the NA fill (1000). + expect_true(all(out$s == 1 | out$s == 1000)) +}) + +test_that(".mashSumStatsToMatrices: errors when no usable scale", { + ss <- .mssm_makeQtlSumStats(function(i, n) { + list( + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), + A1 = "A", + A2 = "G", + N = rep(1000L, n) + ) + }) # only N — no Z, no BETA/SE + expect_error( + pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto"), + "no usable scale" + ) +}) + +test_that(".mashSumStatsToMatrices: inputScale='z' errors when Z missing", { + ss <- .mssm_makeQtlSumStats(function(i, n) { + list( + SNP = sprintf("chr1:%d:A:G", 100L * 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" + ) +}) + +test_that(".mashObjectMatrices errors when marginal effects lack the required columns", { + res <- QtlFineMappingResult( + study = "s", + context = "brain", + trait = "t", + method = "susie", + entry = list(.sc_makeFineMappingRow(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_makeFineMappingRow(3), .sc_makeFineMappingRow(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 = sprintf("chr1:%d:A:G", 100L * 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 = sprintf("chr1:%d:A:G", 100L * 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" + ) +}) + +test_that(".mashSumStatsToMatrices on bundled multicontext fixture: shape and rowname format", { + data(qtlSumStatsMulticontextExample) + out <- pecotmr:::.mashSumStatsToMatrices( + qtlSumStatsMulticontextExample, + "strong", + inputScale = "auto" + ) + expect_equal(ncol(out$b), 3L) + expect_equal(colnames(out$b), c("brain", "blood", "muscle")) + # One (study, trait) block, 200 variants -> 200 rows + expect_equal(nrow(out$b), 200L) + # Rownames are disambiguated by (study::trait::variant) + expect_true(all(grepl("^study1::ENSG_example::", rownames(out$b)))) + # On the BETA scale, sbhat values are small; no NA fill needed since every + # context has every variant + expect_true(all(out$s < 1)) +}) + +test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=1000", { + set.seed(42L) + gh <- new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), + CHR = "1", + BP = seq(100L, by = 100L, length.out = 5L), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 50L, + sampleIds = paste0("s", seq_len(50L)), + pgenPtr = NULL + ) + mkGr <- function(snpIds) { + gr <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges( + start = seq(100L, by = 100L, length.out = length(snpIds)), + width = 1L + ) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = snpIds, + A1 = "A", + A2 = "G", + Z = rnorm(length(snpIds)), + BETA = rnorm(length(snpIds), sd = 0.1), + SE = rep(0.05, length(snpIds)) + ) + gr + } + # ctx1 has all 5 variants; ctx2 has only the first 3 + ss <- QtlSumStats( + study = c("s1", "s1"), + context = c("ctx1", "ctx2"), + trait = c("g1", "g1"), + entry = list( + mkGr(sprintf("chr1:%d:A:G", 100L * (1:5))), + mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) + ), + genome = "hg19", + ldSketch = gh, + qcInfo = list(prebuilt = "synthetic") + ) + out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") + expect_equal(dim(out$b), c(5L, 2L)) + expect_setequal(colnames(out$b), c("ctx1", "ctx2")) + # In ctx2, the last 2 variants are missing -> bhat NA -> 0, shat NA -> 1000 + expect_equal(unname(out$b[4:5, "ctx2"]), c(0, 0)) + expect_equal(unname(out$s[4:5, "ctx2"]), c(1000, 1000)) + # ctx1 has them present + expect_true(all(abs(out$b[, "ctx1"]) < 1)) + expect_true(all(out$s[, "ctx1"] < 1)) +}) + +test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) blocks", { + set.seed(7L) + gh <- new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), + CHR = "1", + BP = c(100L, 200L, 300L), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 50L, + sampleIds = paste0("s", seq_len(50L)), + pgenPtr = NULL + ) + mkGr <- function(snpIds) { + gr <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges( + start = seq(100L, by = 100L, length.out = length(snpIds)), + width = 1L + ) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = snpIds, + A1 = "A", + A2 = "G", + Z = rnorm(length(snpIds)), + BETA = rnorm(length(snpIds), sd = 0.1), + SE = rep(0.05, length(snpIds)) + ) + gr + } + # Two (study, trait) blocks but they share SNP IDs v1, v2, v3 — without + # the prefix the rbind would silently merge them. + ss <- QtlSumStats( + study = c("s1", "s1"), + context = c("ctx1", "ctx1"), + trait = c("g1", "g2"), + entry = list( + mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))), + mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) + ), + genome = "hg19", + ldSketch = gh, + qcInfo = list(prebuilt = "synthetic") + ) + out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") + # 3 variants per block × 2 blocks = 6 rows + expect_equal(nrow(out$b), 6L) + expect_setequal( + rownames(out$b), + c( + paste0("s1::g1::", sprintf("chr1:%d:A:G", 100L * (1:3))), + paste0("s1::g2::", sprintf("chr1:%d:A:G", 100L * (1:3))) + ) + ) +}) + +test_that(".mashSumStatsToMatrices errors when entry lacks SNP mcol", { + set.seed(8L) + gh <- new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), + CHR = "1", + BP = c(100L, 200L, 300L), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 50L, + sampleIds = paste0("s", seq_len(50L)), + pgenPtr = NULL + ) + gr <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) + ) + # NO SNP mcol — should trigger the variant-alignment error + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + A1 = "A", + A2 = "G", + Z = rnorm(3), + BETA = rnorm(3, sd = 0.1), + SE = rep(0.05, 3) + ) + ss <- QtlSumStats( + study = "s1", + context = "ctx1", + trait = "g1", + entry = list(gr), + genome = "hg19", + ldSketch = gh, + qcInfo = list(prebuilt = "synthetic") + ) + expect_error( + pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto"), + "SNP" + ) +}) + +test_that(".mashSumStatsToMatrices on GwasSumStats: studies become columns", { + set.seed(11L) + gh <- new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), + CHR = "1", + BP = c(100L, 200L, 300L), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 50L, + sampleIds = paste0("s", seq_len(50L)), + pgenPtr = NULL + ) + mkGr <- function(snpIds) { + gr <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges( + start = seq(100L, by = 100L, length.out = length(snpIds)), + width = 1L + ) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = snpIds, + A1 = "A", + A2 = "G", + Z = rnorm(length(snpIds)), + BETA = rnorm(length(snpIds), sd = 0.1), + SE = rep(0.05, length(snpIds)) + ) + gr + } + # Each study is its own (study) block; columns of the mash matrix are the + # studies, so the result is block-diagonal with NA-fill off the diagonal. + ss <- GwasSumStats( + study = c("studyA", "studyB"), + entry = list( + mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))), + mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) + ), + genome = "hg19", + ldSketch = gh, + qcInfo = list(prebuilt = "synthetic") + ) + out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") + expect_equal(ncol(out$b), 2L) + expect_equal(colnames(out$b), c("studyA", "studyB")) + # 2 studies x 3 variants = 6 rows; rownames prefixed by the study block key. + expect_equal(nrow(out$b), 6L) + expect_setequal( + rownames(out$b), + c( + paste0("studyA::", sprintf("chr1:%d:A:G", 100L * (1:3))), + paste0("studyB::", sprintf("chr1:%d:A:G", 100L * (1:3))) + ) + ) + # studyA's rows are absent from studyB's column -> bhat 0 / shat 1000 fill. + studyArows <- grep("^studyA::", rownames(out$b)) + expect_equal(unname(out$b[studyArows, "studyB"]), rep(0, 3)) + expect_equal(unname(out$s[studyArows, "studyB"]), rep(1000, 3)) + # On the BETA scale, the present cells carry the small generated SEs. + expect_true(all(out$s[studyArows, "studyA"] < 1)) +}) + +test_that(".mashSumStatsToMatrices errors on a non-SumStats input", { + expect_error( + pecotmr:::.mashSumStatsToMatrices(list(a = 1), "strong"), + "must be a QtlSumStats or GwasSumStats" + ) +}) + +test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { + gh <- new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), + CHR = "1", + BP = c(100L, 200L, 300L), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 50L, + sampleIds = paste0("s", seq_len(50L)), + pgenPtr = NULL + ) + gr <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), + A1 = "A", + A2 = "G", + Z = rnorm(3), + BETA = rnorm(3, sd = 0.1), + SE = rep(0.05, 3) + ) + ss <- QtlSumStats( + study = "s1", + context = "c1", + trait = "g1", + entry = list(gr), + genome = "hg19", + ldSketch = gh, + qcInfo = list() + ) # empty QC info + expect_error( + pecotmr:::.mashSumStatsToMatrices(ss, "strong"), + "no QC info" + ) +}) + +test_that(".mashSumStatsToMatrices errors when SumStats has zero entries", { + gh <- new( + "GenotypeHandle", + path = "/tmp/sketch.gds", + format = "gds", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), + CHR = "1", + BP = c(100L, 200L, 300L), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 50L, + sampleIds = paste0("s", seq_len(50L)), + pgenPtr = NULL + ) + ss <- QtlSumStats( + study = character(0), + context = character(0), + trait = character(0), + entry = list(), + genome = "hg19", + ldSketch = gh, + varY = numeric(0), + qcInfo = list(prebuilt = "synthetic") + ) + expect_error( + pecotmr:::.mashSumStatsToMatrices(ss, "strong"), + "no entries" + ) +}) + +test_that("mergeMashData returns resData when oneData is NULL", { + d1 <- list(random = data.frame(a = 1:3, b = 4:6)) + expect_equal(mergeMashData(d1, NULL), d1) +}) + +test_that("mergeMashData returns resData when oneData is an empty list", { + d1 <- list(random = data.frame(a = 1:3)) + expect_equal(mergeMashData(d1, list()), d1) +}) + +test_that("qtlSumStatsFromZMatrix: one row per context, Z preserved verbatim", { + z <- matrix( + c(1.1, -2.2, 0.3, 0.4, -0.5, 0.6), + nrow = 3, + dimnames = list( + c("chr1:100:A:G", "chr1:200:C:T", "chr2:50:A:T"), + c("brain", "liver") + ) + ) + qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) + expect_s4_class(qss, "QtlSumStats") + # The variants span chr1 and chr2, so each context becomes one ELEMENT per + # chromosome. The tuple is what stays 1:1 with a matrix column. + expect_equal(nrow(qss), 4L) + expect_setequal(as.character(qss$context), c("brain", "liver")) + expect_equal(unique(as.character(qss$study)), "s1") + expect_equal(unique(as.character(qss$trait)), "mash") + # getSumStats stitches a tuple's elements back together, so the Z column + # still matches the input matrix column verbatim (values only; the mcols + # column is unnamed whereas z[, j] carries the row ids as names). + brain <- getSumStats(qss, study = "s1", context = "brain", trait = "mash") + liver <- getSumStats(qss, study = "s1", context = "liver", trait = "mash") + expect_equal(S4Vectors::mcols(brain)$Z, unname(z[, 1])) + expect_equal(S4Vectors::mcols(liver)$Z, unname(z[, 2])) +}) + +test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when they don't parse", { + z <- matrix( + rnorm(2), + ncol = 1, + dimnames = list(c("chr1:250:A:G", "not_a_variant"), "ctx") + ) + qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) + # Stitched across whatever seqnames the ids decoded to, so the variant + # order still matches the matrix rows. + e <- getSumStats(qss, study = "s1", context = "ctx", trait = "mash") + expect_equal(GenomicRanges::start(e)[1], 250L) # decoded + expect_true(GenomicRanges::start(e)[2] >= 1L) # synthetic fallback + # un-parseable chrom falls back to chr1 (never NA) + expect_false(any(is.na(as.character(GenomicRanges::seqnames(e))))) + # SNP ids are carried through unchanged + expect_equal(S4Vectors::mcols(e)$SNP, rownames(z)) +}) + +test_that("qtlSumStatsFromZMatrix: NULL rownames get synthetic variant ids", { + z <- matrix(rnorm(4), nrow = 2, dimnames = list(NULL, c("a", "b"))) + qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) + expect_equal(S4Vectors::mcols(qss[[1]])$SNP, c("var1", "var2")) +}) + +test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcInfo are set", { + z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("x", "y"))) + qss <- qtlSumStatsFromZMatrix( + z, + study = "s1", + ldSketch = .qszm_gh(), + n = 500L, + a1 = "T", + a2 = "C", + role = "strong" + ) + mc <- S4Vectors::mcols(qss[[1]]) + expect_equal(unique(mc$A1), "T") + expect_equal(unique(mc$A2), "C") + expect_equal(unique(mc$N), 500L) + expect_equal(getQcInfo(qss)$role, "strong") + expect_equal(length(getQcInfo(qss)$entryAudit), 2L) # one slot per context +}) + +test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait pairs", { + z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("geneA", "geneB"))) + # columns as traits: constant context, one trait per column + qss <- qtlSumStatsFromZMatrix( + z, + study = "s1", + ldSketch = .qszm_gh(), + context = "brain", + trait = colnames(z) + ) + expect_equal(as.character(qss$context), c("brain", "brain")) + expect_equal(as.character(qss$trait), c("geneA", "geneB")) + # columns as (context, trait) pairs + qss2 <- qtlSumStatsFromZMatrix( + z, + study = "s1", + ldSketch = .qszm_gh(), + context = c("brain", "liver"), + trait = c("geneA", "geneA") + ) + expect_equal(as.character(qss2$context), c("brain", "liver")) + expect_equal(as.character(qss2$trait), c("geneA", "geneA")) +}) + +test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors", { + z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("a", "b"))) + expect_error( + qtlSumStatsFromZMatrix( + z, + study = "s1", + ldSketch = .qszm_gh(), + trait = c("t1", "t2", "t3") + ), + "must be length 1 or ncol" + ) +}) + +test_that("qtlSumStatsFromZMatrix: rejects non-matrix input and unlabelled conditions", { + expect_error( + qtlSumStatsFromZMatrix(1:5, study = "s1", ldSketch = .qszm_gh()), + "variants x conditions matrix" + ) + # no colnames -> the default context = colnames(z) is NULL + z <- matrix(rnorm(4), nrow = 2) + expect_error( + qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()), + "column names" + ) +}) + +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_setequal(as.character(qss$context), c("brain", "liver")) + # One element per (context, chromosome); getSumStats stitches a context + # back into the single GRanges matching the matrix column. + mc <- S4Vectors::mcols( + getSumStats(qss, study = "s1", context = "brain", trait = "mash") + ) + 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[[1]]) + expect_equal(mc$SNP, c("var1", "var2")) + expect_equal(unique(mc$A1), "T") + expect_equal(unique(mc$N), 500L) + expect_equal(getQcInfo(qss)$role, "strong") +}) + +test_that("mashInput: QtlSumStats path returns the flat b/s/z + XtX contract", { + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + 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 <- fineMappingRow( + variantIds = vids, + susieFit = list(x = 1), + topLoci = noCsTL(rnorm(6)) + ) + e2 <- fineMappingRow( + 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(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + 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"))) +}) + +test_that("a NULL partition passes through as NULL", { + expect_null(pecotmr:::.mashAsDataFrameOrNull(NULL)) + # A matrix becomes a base data.frame, keeping the variant-id rownames the + # downstream combine step relies on. + m <- matrix( + 1:4, + 2L, + 2L, + dimnames = list(c("v1", "v2"), c("a", "b")) + ) + out <- pecotmr:::.mashAsDataFrameOrNull(m) + expect_s3_class(out, "data.frame") + expect_equal(rownames(out), c("v1", "v2")) +}) + +test_that(".qtlSumStatsFromMatrix synthesises coords for unparseable ids", { + local_mocked_bindings( + parseVariantId = function(...) stop("bad"), + .package = "pecotmr" + ) + out <- pecotmr:::.qtlSumStatsFromMatrix( + vids = c("weird1", "weird2"), + nCond = 1L, + study = "s1", + ldSketch = NULL, + context = "cA", + trait = "g1", + genome = "hg19", + role = "input", + mcolFn = function(i, k) list(Z = c(1, 2)) + ) + expect_s4_class(out, "QtlSumStats") + gr <- out[[1L]] + # Ids that carry no coordinates land on chr1 at their own row index, so + # the object stays well-formed instead of failing to build. + expect_equal(as.character(GenomicRanges::seqnames(gr)), c("chr1", "chr1")) + expect_equal(GenomicRanges::start(gr), c(1L, 2L)) +}) + +test_that("mashWrapper: argument guards fire", { + expect_error( + filterInvalidSummaryStat("not-a-list"), + "datList.*Must be of type 'list'" + ) + expect_error( + filterInvalidSummaryStat(list(), sigPCutoff = 2), + "sigPCutoff.*is not <= 1" + ) + expect_error( + filterInvalidSummaryStat(list(), filterByMissingRate = -1), + "filterByMissingRate.*is not >= 0" + ) + expect_error( + filterMixtureComponents(conditionsToKeep = 1L, U = list()), + "conditionsToKeep.*Must be of type 'character'" + ) + expect_error( + filterMixtureComponents("a", U = list(), wCutoff = -1), + "wCutoff.*is not >= 0" + ) + expect_error(mergeMashData("nope", list()), "Must be of type 'list'") +}) + +test_that(".mashConcatChr answers character(0) for no pieces", { + expect_identical(pecotmr:::.mashConcatChr(list()), character(0)) +}) + +test_that(".mashPrefixRownames leaves an absent or empty matrix alone", { + expect_null(pecotmr:::.mashPrefixRownames(NULL, "ctx")) + empty <- matrix(numeric(0), nrow = 0L, ncol = 1L) + expect_identical(pecotmr:::.mashPrefixRownames(empty, "ctx"), empty) +}) + +test_that(".mashProcessZ skips the missing-rate filter when none is asked for", { + # A NULL filterByMissingRate means "clean the values, keep every row". + z <- matrix(c(1, NA, 3, 4), nrow = 2, dimnames = list(c("v1", "v2"), NULL)) + out <- pecotmr:::.mashProcessZ(z, NULL) + expect_equal(nrow(out), 2L) + expect_equal(unname(out[2, 1]), 0) # NA replaced by 0, row retained +}) + +test_that(".mashFilterZ leaves a list with no z-carrying partition alone", { + # list_assign() would CREATE an absent component as NULL, so a list with + # nothing to rewrite has to come back identical. + datList <- list(other = list(bhat = matrix(1))) + expect_identical(pecotmr:::.mashFilterZ(datList, 0.5, NULL), datList) }) diff --git a/tests/testthat/test_mashWrapper.R b/tests/testthat/test_mashWrapper.R index f678c030f..cb2e6fc6d 100644 --- a/tests/testthat/test_mashWrapper.R +++ b/tests/testthat/test_mashWrapper.R @@ -1,828 +1,21 @@ context("mash_wrapper") -# Build a minimal FineMappingRow for unit-testing find_nested / -# extractFlattenSumstatsFromNested. Note: the legacy FineMappingResult -# constructor (with `variantNames`/`method` args) has been removed; the new -# per-entry payload class is `FineMappingRow`, and method identity now -# lives on the parent `FineMappingResult` collection row. -.testFineMappingRow <- function(variantNames) { - fineMappingRow( - variantIds = variantNames, - susieFit = list(pip = rep(0.5, length(variantNames))), - topLoci = data.frame( - variant_id = character(0), - pip = numeric(0), - stringsAsFactors = FALSE - ) - ) -} - # =========================================================================== # filterInvalidSummaryStat # =========================================================================== -test_that("filterInvalidSummaryStat replaces NaN/Inf in bhat", { - dat <- list( - bhat = data.frame(a = c(1, NaN, 3), b = c(Inf, 2, -Inf)), - sbhat = data.frame(a = c(0.1, 0.2, 0.3), b = c(0.1, NA, 0.3)) - ) - result <- filterInvalidSummaryStat(dat, bhat = "bhat", sbhat = "sbhat") - expect_true(all(!is.nan(result$bhat))) - expect_true(all(!is.infinite(result$bhat))) - # NaN/Inf in bhat replaced with 0 - expect_equal(unname(result$bhat[1, 2]), 0) # Inf -> 0 -}) - -test_that("filterInvalidSummaryStat replaces NaN/Inf in sbhat", { - dat <- list( - bhat = data.frame(a = c(1, 2, 3)), - sbhat = data.frame(a = c(0.1, NaN, Inf)) - ) - result <- filterInvalidSummaryStat(dat, bhat = "bhat", sbhat = "sbhat") - # NaN/Inf in sbhat replaced with 1000 - expect_equal(unname(result$sbhat[1, "a"]), 0.1) - expect_equal(unname(result$sbhat[2, "a"]), 1000) - expect_equal(unname(result$sbhat[3, "a"]), 1000) -}) - -test_that("filterInvalidSummaryStat filters by missing_rate when null.b present", { - dat <- list( - bhat = data.frame(a = c(0, 0, 1, 2), b = c(0, 0, 0, 3)), - sbhat = data.frame(a = c(1, 1, 1, 1), b = c(1, 1, 1, 1)), - null.b = TRUE - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "bhat", - sbhat = "sbhat", - filterByMissingRate = 0.5 - ) - expect_equal(nrow(result$bhat), 2) # rows 3 and 4 survive -}) - -test_that("filterInvalidSummaryStat filters by missing_rate when random.b present", { - dat <- list( - bhat = data.frame(a = c(0, 1, 2), b = c(0, 1, 3)), - sbhat = data.frame(a = c(1, 1, 1), b = c(1, 1, 1)), - random.b = TRUE - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "bhat", - sbhat = "sbhat", - filterByMissingRate = 0.5 - ) - expect_true(nrow(result$bhat) < 3) -}) - -test_that("filterInvalidSummaryStat btoz with .b and .s pattern creates condition.z", { - dat <- list( - strong.b = data.frame(a = c(1, 2), b = c(3, 4)), - strong.s = data.frame(a = c(0.1, 0.2), b = c(0.3, 0.4)) - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "strong.b", - sbhat = "strong.s", - btoz = TRUE, - sigPCutoff = NULL - ) - expect_true("strong.z" %in% names(result)) - expect_true(is.matrix(result$strong.z)) - expect_equal(nrow(result$strong.z), 2) - expect_equal(ncol(result$strong.z), 2) - expect_equal( - as.numeric(result$strong.z), - c(10, 10, 10, 10), - tolerance = 1e-10 - ) -}) - -test_that("filterInvalidSummaryStat btoz when bhat/sbhat data is NULL creates NULL z", { - dat <- list( - strong.b = NULL, - strong.s = data.frame(a = c(0.1)) - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "strong.b", - sbhat = "strong.s", - btoz = TRUE, - sigPCutoff = NULL - ) - expect_true("strong.z" %in% names(result)) - expect_null(result$strong.z) -}) - -test_that("filterInvalidSummaryStat btoz without .b/.s pattern creates generic z", { - dat <- list( - bhat = data.frame(a = c(1, 2, 3)), - sbhat = data.frame(a = c(0.5, 1, 0.5)) - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "bhat", - sbhat = "sbhat", - btoz = TRUE - ) - expect_true("z" %in% names(result)) - expect_equal(as.numeric(result$z[, 1]), c(2, 2, 6)) -}) - -test_that("filterInvalidSummaryStat btoz creates NULL z when bhat is NULL (no .b suffix)", { - dat <- list( - bhat = NULL, - sbhat = data.frame(a = c(0.1)) - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "bhat", - sbhat = "sbhat", - btoz = TRUE - ) - expect_true("z" %in% names(result)) - expect_null(result$z) -}) - -test_that("filterInvalidSummaryStat btoz filters strong.z by significance cutoff", { - dat <- list( - strong.b = data.frame( - a = c(1, 0.01, 0.02, 2), - b = c(0.01, 0.01, 0.01, 0.01) - ), - strong.s = data.frame( - a = c(0.1, 0.1, 0.1, 0.1), - b = c(0.1, 0.1, 0.1, 0.1) - ), - strong.z = NULL - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "strong.b", - sbhat = "strong.s", - btoz = TRUE, - sigPCutoff = 1E-6 - ) - expect_true("strong.z" %in% names(result)) - expect_equal(nrow(result$strong.z), 2) - expect_equal(nrow(result$strong.b), 2) - expect_equal(nrow(result$strong.s), 2) -}) - -test_that("filterInvalidSummaryStat processes z directly with null component", { - dat <- list( - strong = list(z = data.frame(a = c(5, NaN, 0.1), b = c(1, 2, Inf))), - random = list(z = data.frame(a = c(0.5, 0.2), b = c(0.3, 0.4))), - null = list(z = data.frame(a = c(0.01, NaN), b = c(Inf, 0.02))) - ) - result <- filterInvalidSummaryStat(dat, z = "z") - expect_true(all(!is.nan(result$strong$z))) - expect_true(all(!is.infinite(result$strong$z))) - expect_true(all(!is.nan(result$null$z))) - expect_true(all(!is.infinite(result$null$z))) -}) - -test_that("filterInvalidSummaryStat z path applies significance cutoff to strong.z", { - dat <- list( - strong = list( - z = data.frame(a = c(10, 0.1, 0.2), b = c(0.1, 0.1, 0.1)) - ), - random = list( - z = data.frame(a = c(0.5, 0.2, 0.3), b = c(0.3, 0.4, 0.2)) - ) - ) - result <- filterInvalidSummaryStat(dat, z = "z", sigPCutoff = 1E-6) - expect_equal(nrow(result$strong$z), 1) -}) - -test_that("filterInvalidSummaryStat z path with filterByMissingRate", { - dat <- list( - random = list(z = data.frame(a = c(0, 0, 5), b = c(0, 3, 4))) - ) - result <- filterInvalidSummaryStat(dat, z = "z", filterByMissingRate = 0.5) - expect_equal(nrow(result$random$z), 2) -}) - -test_that("filterInvalidSummaryStat processes bhat/sbhat without filterByMissingRate when no null.b/random.b", { - dat <- list( - bhat = data.frame(a = c(1, NaN, 3), b = c(Inf, 2, -Inf)), - sbhat = data.frame(a = c(0.1, NA, 0.3), b = c(0.1, 0.2, NaN)) - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "bhat", - sbhat = "sbhat", - filterByMissingRate = 0.5 - ) - expect_equal(nrow(result$bhat), 3) - expect_equal(unname(result$bhat[2, "a"]), 0) - expect_equal(unname(result$sbhat[3, "b"]), 1000) -}) - -test_that("filterInvalidSummaryStat with filterByMissingRate=NULL keeps all rows even with null.b", { - dat <- list( - bhat = data.frame(a = c(0, 0, 1), b = c(0, 0, 1)), - sbhat = data.frame(a = c(1, 1, 1), b = c(1, 1, 1)), - null.b = TRUE - ) - result <- filterInvalidSummaryStat( - dat, - bhat = "bhat", - sbhat = "sbhat", - filterByMissingRate = NULL - ) - expect_equal(nrow(result$bhat), 3) -}) - -test_that("filterInvalidSummaryStat z path handles NULL strong component", { - dat <- list( - strong = NULL, - random = list(z = data.frame(a = c(0.5, 0.2), b = c(0.3, 0.4))) - ) - result <- filterInvalidSummaryStat(dat, z = "z") - expect_null(result$strong) - expect_true(!is.null(result$random$z)) -}) - # =========================================================================== # filterMixtureComponents # =========================================================================== -test_that("filterMixtureComponents removes zero matrices", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 2), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - comp2 = matrix( - c(0, 0, 0, 0), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - A = matrix( - c(3, 0, 0, 4), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(comp1 = 0.5, comp2 = 0.3, A = 0.2) - result <- filterMixtureComponents(c("A", "B"), U, w) - expect_false("comp2" %in% names(result$U)) -}) - -test_that("filterMixtureComponents removes matrices below weight cutoff", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 2), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - comp2 = matrix( - c(0.1, 0, 0, 0.1), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(comp1 = 0.9, comp2 = 0.00001) - result <- filterMixtureComponents(c("A", "B"), U, w, wCutoff = 1e-4) - expect_false("comp2" %in% names(result$U)) -}) - -test_that("filterMixtureComponents errors on missing conditions", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 2), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - expect_error( - filterMixtureComponents(c("A", "C"), U), - "not found in matrix" - ) -}) - -test_that("filterMixtureComponents removes components named as filtered conditions", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 0, 2, 0, 0, 0, 3), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ), - C = matrix( - c(4, 0, 0, 0, 5, 0, 0, 0, 6), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ) - ) - w <- c(comp1 = 0.6, C = 0.4) - result <- filterMixtureComponents(c("A", "B"), U, w) - expect_false("C" %in% names(result$U)) - expect_equal(nrow(result$U$comp1), 2) - expect_equal(ncol(result$U$comp1), 2) -}) - -test_that("filterMixtureComponents renormalizes weights to preserve original sum", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 2), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - comp2 = matrix( - c(3, 0, 0, 4), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - comp3 = matrix( - c(0, 0, 0, 0), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(comp1 = 0.5, comp2 = 0.3, comp3 = 0.2) - original_sum <- sum(w) - - result <- filterMixtureComponents(c("A", "B"), U, w) - expect_false("comp3" %in% names(result$U)) - expect_equal(sum(result$w), original_sum, tolerance = 1e-10) - expect_true(result$w["comp1"] > 0.5) - expect_true(result$w["comp2"] > 0.3) -}) - -test_that("filterMixtureComponents subsets 3x3 matrices to 2x2 and removes filtered condition names", { - U <- list( - comp1 = matrix( - c(1, 0.1, 0, 0.1, 2, 0, 0, 0, 3), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ), - B = matrix( - c(4, 0, 0, 0, 5, 0, 0, 0, 6), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ) - ) - w <- c(comp1 = 0.7, B = 0.3) - - result <- filterMixtureComponents(c("A", "C"), U, w) - expect_false("B" %in% names(result$U)) - expect_equal(nrow(result$U$comp1), 2) - expect_equal(ncol(result$U$comp1), 2) - expect_equal(rownames(result$U$comp1), c("A", "C")) -}) - -test_that("filterMixtureComponents handles NULL weights gracefully", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 2), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - comp2 = matrix( - c(0, 0, 0, 0), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - result <- filterMixtureComponents(c("A", "B"), U, w = NULL) - expect_false("comp2" %in% names(result$U)) - expect_true("comp1" %in% names(result$U)) -}) - # =========================================================================== # mergeMashData # =========================================================================== -test_that("mergeMashData combines two datasets with identical columns", { - d1 <- list( - random = data.frame( - a = 1:3, - b = 4:6, - row.names = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") - ) - ) - d2 <- list( - random = data.frame( - a = 7:8, - b = 9:10, - row.names = c("chr1:400:A:G", "chr1:500:A:G") - ) - ) - result <- mergeMashData(d1, d2) - expect_equal(nrow(result$random), 5) - expect_equal(ncol(result$random), 2) - expect_equal(colnames(result$random), c("a", "b")) - expect_equal(result$random$a, c(1, 2, 3, 7, 8)) -}) - -test_that("mergeMashData handles NULL input", { - d1 <- NULL - d2 <- list(random = data.frame(a = 1:3)) - result <- mergeMashData(d1, d2) - expect_equal(nrow(result$random), 3) -}) - -test_that("mergeMashData aligns different column names correctly", { - d1 <- list( - random = data.frame( - a = 1:2, - b = 3:4, - row.names = c("chr1:100:A:G", "chr1:200:A:G") - ) - ) - d2 <- list( - random = data.frame( - a = 5:6, - c = 7:8, - row.names = c("chr1:300:A:G", "chr1:400:A:G") - ) - ) - result <- mergeMashData(d1, d2) - expect_equal(nrow(result$random), 4) - expect_true(all(c("a", "b", "c") %in% colnames(result$random))) - expect_true(is.nan(result$random[3, "b"])) - expect_true(is.nan(result$random[1, "c"])) -}) - -test_that("mergeMashData preserves data when one side is empty data.frame", { - d1 <- list(random = data.frame(a = 1:3)) - d2 <- list(random = data.frame()) - result <- mergeMashData(d1, d2) - expect_equal(nrow(result$random), 3) -}) - -test_that("mergeMashData preserves data when one side is NULL element", { - d1 <- list(random = NULL) - d2 <- list(random = data.frame(a = 1:3)) - result <- mergeMashData(d1, d2) - expect_equal(nrow(result$random), 3) -}) - -test_that("mergeMashData handles multiple named elements", { - d1 <- list( - random = data.frame( - a = 1:2, - b = 3:4, - row.names = c("chr1:100:A:G", "chr1:200:A:G") - ), - null = data.frame(x = 10:11, row.names = c("n1", "n2")) - ) - d2 <- list( - random = data.frame( - a = 5:6, - b = 7:8, - row.names = c("chr1:300:A:G", "chr1:400:A:G") - ), - null = data.frame(x = 12:13, row.names = c("n3", "n4")) - ) - result <- mergeMashData(d1, d2) - expect_equal(nrow(result$random), 4) - expect_equal(nrow(result$null), 4) -}) - -test_that("mergeMashData errors on duplicate variant ids across sides", { - d1 <- list( - random = data.frame( - a = 1:2, - row.names = c("chr1:100:A:G", "chr1:200:A:G") - ) - ) - d2 <- list( - random = data.frame( - a = 3:4, - row.names = c("chr1:200:A:G", "chr1:900:A:G") - ) - ) - expect_error(mergeMashData(d1, d2), "duplicate variant ids") -}) - -test_that("mergeMashData uses one_data when res_data element has zero rows", { - d1 <- list(random = data.frame(a = numeric(0), b = numeric(0))) - d2 <- list(random = data.frame(a = 1:3, b = 4:6)) - result <- mergeMashData(d1, d2) - expect_true(nrow(result$random) >= 3) -}) - # =========================================================================== # mashRandNullSample # =========================================================================== -test_that("mashRandNullSample with z scores returns random and null", { - set.seed(42) - dat <- list( - z = data.frame( - cond1 = c(5, 0.1, 0.2, 0.3, 0.5, 6, 0.1, 0.2, 0.4, 0.3), - cond2 = c(0.2, 0.3, 0.1, 0.5, 0.4, 0.1, 0.3, 0.2, 0.1, 0.5) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 5, - nNull = 3, - excludeCondition = c(), - seed = 123 - ) - expect_type(result, "list") - expect_true("random" %in% names(result)) - expect_true("null" %in% names(result)) - expect_true("z" %in% names(result$random)) - expect_equal(nrow(result$random$z), 5) -}) - -test_that("mashRandNullSample with seed is reproducible", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.2, 0.3, 0.4, 0.5), - cond2 = c(0.5, 0.4, 0.3, 0.2, 0.1) - ) - ) - result1 <- mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = c(), - seed = 42 - ) - result2 <- mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = c(), - seed = 42 - ) - expect_equal(result1$random$z, result2$random$z) -}) - -test_that("mashRandNullSample NULL input returns NULL", { - result <- mashRandNullSample( - NULL, - nRandom = 5, - nNull = 3, - excludeCondition = c() - ) - expect_null(result) -}) - -test_that("mashRandNullSample warns when no null variants found (all abs_z > 2)", { - dat <- list( - z = data.frame( - cond1 = c(5, 6, 7, 8, 9), - cond2 = c(5, 6, 7, 8, 9) - ) - ) - expect_warning( - result <- mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = c(), - seed = 42 - ), - "no variants are included in the null" - ) - expect_equal(length(result$null), 0) -}) - -test_that("mashRandNullSample warns when not enough null data", { - dat <- list( - z = data.frame( - cond1 = c(5, 6, 0.1), - cond2 = c(5, 6, 0.1), - cond3 = c(5, 6, 0.1) - ) - ) - expect_warning( - result <- mashRandNullSample( - dat, - nRandom = 2, - nNull = 1, - excludeCondition = c(), - seed = 42 - ), - "not enough null data" - ) - expect_equal(length(result$null), 0) -}) - -test_that("mashRandNullSample with bhat/sbhat processes random and null samples", { - dat <- list( - bhat = data.frame( - cond1 = c(0.1, 0.05, 0.02, 0.01, 0.03), - cond2 = c(0.02, 0.01, 0.03, 0.05, 0.04) - ), - sbhat = data.frame( - cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1), - cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 3, - nNull = 3, - excludeCondition = c(), - seed = 42 - ) - expect_equal(ncol(result$random$bhat), 2) - expect_equal(nrow(result$random$bhat), 3) - expect_true(length(result$null) > 0) -}) - -test_that("mashRandNullSample errors when excludeCondition not found (z path)", { - dat <- list( - z = data.frame(cond1 = 1:5, cond2 = 1:5) - ) - expect_error( - mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = "nonexistent", - seed = 42 - ), - "excludeCondition are not present" - ) -}) - -test_that("mashRandNullSample errors when excludeCondition not found (bhat path)", { - dat <- list( - bhat = data.frame(cond1 = 1:5, cond2 = 1:5), - sbhat = data.frame(cond1 = rep(1, 5), cond2 = rep(1, 5)) - ) - expect_error( - mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = "nonexistent", - seed = 42 - ), - "excludeCondition are not present" - ) -}) - -test_that("mashRandNullSample drops excluded condition by column name", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.2, 0.3, 0.4, 0.5), - cond2 = c(0.5, 0.4, 0.3, 0.2, 0.1), - cond3 = c(0.3, 0.3, 0.3, 0.3, 0.3) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = "cond3", - seed = 42 - ) - expect_equal(colnames(result$random$z), c("cond1", "cond2")) - expect_equal(colnames(result$null$z), c("cond1", "cond2")) - expect_false("cond3" %in% colnames(result$random$z)) -}) - -test_that("mashRandNullSample extracts null data with z scores when enough null variants exist", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.3, 0.2, 0.5, 0.4, 0.1, 0.3, 0.2, 0.5, 0.4), - cond2 = c(0.2, 0.1, 0.4, 0.3, 0.5, 0.2, 0.1, 0.4, 0.3, 0.5) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 5, - nNull = 4, - excludeCondition = c(), - seed = 42 - ) - expect_true("null" %in% names(result)) - expect_true("z" %in% names(result$null)) - expect_equal(nrow(result$null$z), 4) - expect_equal(ncol(result$null$z), 2) - expect_equal(nrow(result$random$z), 5) -}) - -test_that("mashRandNullSample null data capped at available null variants", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.2, 0.3), - cond2 = c(0.1, 0.2, 0.3) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 2, - nNull = 100, - excludeCondition = c(), - seed = 42 - ) - expect_true(length(result$null) > 0) - expect_equal(nrow(result$null$z), 3) -}) - -test_that("mashRandNullSample extracts null data with bhat/sbhat when enough null variants", { - dat <- list( - bhat = data.frame( - cond1 = c(0.01, 0.02, 0.01, 0.03, 0.02, 0.01), - cond2 = c(0.02, 0.01, 0.03, 0.01, 0.02, 0.01) - ), - sbhat = data.frame( - cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1), - cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 3, - nNull = 4, - excludeCondition = c(), - seed = 42 - ) - expect_true("null" %in% names(result)) - expect_true("bhat" %in% names(result$null)) - expect_true("sbhat" %in% names(result$null)) - expect_equal(nrow(result$null$bhat), 4) - expect_equal(nrow(result$null$sbhat), 4) -}) - -test_that("mashRandNullSample excludeCondition with numeric index errors on z path", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.2, 0.3, 0.4, 0.5), - cond2 = c(0.5, 0.4, 0.3, 0.2, 0.1), - cond3 = c(0.3, 0.3, 0.3, 0.3, 0.3) - ) - ) - expect_error( - mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = 3, - seed = 42 - ), - "excludeCondition are not present" - ) -}) - -test_that("mashRandNullSample excludeCondition with numeric index errors on bhat path", { - dat <- list( - bhat = data.frame( - cond1 = c(0.01, 0.02, 0.01, 0.03, 0.02), - cond2 = c(0.02, 0.01, 0.03, 0.01, 0.02), - cond3 = c(0.01, 0.01, 0.01, 0.01, 0.01) - ), - sbhat = data.frame( - cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1), - cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1), - cond3 = c(0.1, 0.1, 0.1, 0.1, 0.1) - ) - ) - expect_error( - mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = 3, - seed = 42 - ), - "excludeCondition are not present" - ) -}) - -test_that("mashRandNullSample caps random sample at available rows", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.2, 0.3), - cond2 = c(0.2, 0.1, 0.3) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 100, - nNull = 2, - excludeCondition = c(), - seed = 42 - ) - expect_equal(nrow(result$random$z), 3) -}) - # mashPipeline integration tests were removed in the S4 refactor: the # legacy matrix-list input (strong.b/strong.s/random.b/random.s/null.b/null.s) # is no longer accepted. The new API takes a named list of QtlSumStats / @@ -832,90 +25,6 @@ test_that("mashRandNullSample caps random sample at available rows", { # === Tests migrated from test_mrmashWrapper.R (filterMixtureComponents) === -test_that("filterMixtureComponents filters zero matrices", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - mat2 = matrix(0, 2, 2, dimnames = list(c("A", "B"), c("A", "B"))), - mat3 = matrix( - c(0.8, 0.3, 0.3, 0.9), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(mat1 = 0.5, mat2 = 0.3, mat3 = 0.2) - conditions_to_keep <- c("A", "B") - - result <- filterMixtureComponents(conditions_to_keep, U, w) - - # mat2 should be removed (all zeros) - expect_true(!"mat2" %in% names(result$U)) - # weights should be rescaled to maintain sum - expect_equal(sum(result$w), sum(w), tolerance = 1e-10) -}) - - -test_that("filterMixtureComponents removes low weight components", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - mat2 = matrix( - c(0.8, 0.3, 0.3, 0.9), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(mat1 = 0.999, mat2 = 0.00001) # mat2 below default cutoff - conditions_to_keep <- c("A", "B") - - result <- filterMixtureComponents(conditions_to_keep, U, w, wCutoff = 1e-04) - expect_true(!"mat2" %in% names(result$U)) -}) - - -test_that("filterMixtureComponents errors on missing condition", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(mat1 = 1.0) - expect_error( - filterMixtureComponents(c("A", "C"), U, w), - "not found in matrix" - ) -}) - - -test_that("filterMixtureComponents subsets conditions", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.2, 0.5, 1, 0.3, 0.2, 0.3, 1), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ) - ) - w <- c(mat1 = 1.0) - - result <- filterMixtureComponents(c("A", "B"), U, w) - expect_equal(nrow(result$U[[1]]), 2) - expect_equal(ncol(result$U[[1]]), 2) -}) - # =========================================================================== # Tests from test_misc_round3.R (mrmashWrapper coverage boost) # =========================================================================== @@ -928,1128 +37,415 @@ test_that("filterMixtureComponents subsets conditions", { # .mashSumStatsToMatrices — inputScale resolution # =========================================================================== -# Helper: tiny QtlSumStats with 2 contexts on one trait. The mcols -# layout is controlled so each test can vary which columns are present. -.mssm_makeQtlSumStats <- function( - mcolsBuilder, - contexts = c("brain", "liver"), - nSnp = 5L -) { - set.seed(13L) - gh <- new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(nSnp))), - CHR = "1", - BP = seq(100L, by = 100L, length.out = nSnp), - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 50L, - sampleIds = paste0("s", seq_len(50L)), - pgenPtr = NULL - ) - ranges <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges( - start = seq(100L, by = 100L, length.out = nSnp), - width = 1L - ) - ) - entries <- lapply(seq_along(contexts), function(i) { - gr <- ranges - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcolsBuilder(i, nSnp)) - gr - }) - QtlSumStats( - study = rep("s1", length(contexts)), - context = contexts, - trait = rep("g1", length(contexts)), - entry = entries, - genome = "hg19", - ldSketch = gh, - qcInfo = list(prebuilt = "synthetic") - ) -} - -test_that(".mashSumStatsToMatrices: auto picks BETA+SE when present", { - ss <- .mssm_makeQtlSumStats(function(i, n) { - list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), - A1 = "A", - A2 = "G", - Z = rnorm(n), - BETA = rnorm(n, sd = 0.1), - SE = abs(rnorm(n, sd = 0.05)) + 0.01 - ) - }) - out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") - expect_equal(ncol(out$b), 2L) # 2 contexts - # On BETA scale, Shat values should be the small SEs we generated. - expect_true(all(out$s[out$s < 1000] < 1)) -}) - -test_that(".mashSumStatsToMatrices: auto falls back to Z when no BETA/SE", { - ss <- .mssm_makeQtlSumStats(function(i, n) { - list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), - A1 = "A", - A2 = "G", - Z = rnorm(n) - ) - }) - out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") - # Shat should be 1 on the Z scale. - expect_true(all(out$s == 1 | out$s == 1000)) -}) - -test_that(".mashSumStatsToMatrices: inputScale='beta' errors when BETA missing", { - ss <- .mssm_makeQtlSumStats(function(i, n) { - list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), - A1 = "A", - A2 = "G", - Z = rnorm(n) - ) - }) - expect_error( - pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "beta"), - "BETA and SE" - ) -}) - -test_that(".mashSumStatsToMatrices: inputScale='z' forces Z+1 even when BETA present", { - ss <- .mssm_makeQtlSumStats(function(i, n) { - list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), - A1 = "A", - A2 = "G", - Z = rnorm(n), - BETA = rnorm(n, sd = 0.1), - SE = abs(rnorm(n, sd = 0.05)) + 0.01 - ) - }) - out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "z") - # Forced Z scale: Shat must be 1 everywhere except the NA fill (1000). - expect_true(all(out$s == 1 | out$s == 1000)) -}) - -test_that(".mashSumStatsToMatrices: errors when no usable scale", { - ss <- .mssm_makeQtlSumStats(function(i, n) { - list( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), - A1 = "A", - A2 = "G", - N = rep(1000L, n) - ) - }) # only N — no Z, no BETA/SE - expect_error( - pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto"), - "no usable scale" - ) -}) - -test_that(".mashSumStatsToMatrices: inputScale='z' errors when Z missing", { - ss <- .mssm_makeQtlSumStats(function(i, n) { - list( - SNP = sprintf("chr1:%d:A:G", 100L * (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_makeFineMappingRow(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_makeFineMappingRow(3), .sc_makeFineMappingRow(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 = sprintf("chr1:%d:A:G", 100L * (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 = sprintf("chr1:%d:A:G", 100L * (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 # and on hand-built partial-coverage data. # =========================================================================== -test_that(".mashSumStatsToMatrices on bundled multicontext fixture: shape and rowname format", { - data(qtlSumStatsMulticontextExample) - out <- pecotmr:::.mashSumStatsToMatrices( - qtlSumStatsMulticontextExample, - "strong", - inputScale = "auto" - ) - expect_equal(ncol(out$b), 3L) - expect_equal(colnames(out$b), c("brain", "blood", "muscle")) - # One (study, trait) block, 200 variants -> 200 rows - expect_equal(nrow(out$b), 200L) - # Rownames are disambiguated by (study::trait::variant) - expect_true(all(grepl("^study1::ENSG_example::", rownames(out$b)))) - # On the BETA scale, sbhat values are small; no NA fill needed since every - # context has every variant - expect_true(all(out$s < 1)) -}) - -test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=1000", { - set.seed(42L) - gh <- new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), - CHR = "1", - BP = seq(100L, by = 100L, length.out = 5L), - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 50L, - sampleIds = paste0("s", seq_len(50L)), - pgenPtr = NULL - ) - mkGr <- function(snpIds) { - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges( - start = seq(100L, by = 100L, length.out = length(snpIds)), - width = 1L - ) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = snpIds, - A1 = "A", - A2 = "G", - Z = rnorm(length(snpIds)), - BETA = rnorm(length(snpIds), sd = 0.1), - SE = rep(0.05, length(snpIds)) - ) - gr - } - # ctx1 has all 5 variants; ctx2 has only the first 3 - ss <- QtlSumStats( - study = c("s1", "s1"), - context = c("ctx1", "ctx2"), - trait = c("g1", "g1"), - entry = list( - mkGr(sprintf("chr1:%d:A:G", 100L * (1:5))), - mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) - ), - genome = "hg19", - ldSketch = gh, - qcInfo = list(prebuilt = "synthetic") - ) - out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") - expect_equal(dim(out$b), c(5L, 2L)) - expect_setequal(colnames(out$b), c("ctx1", "ctx2")) - # In ctx2, the last 2 variants are missing -> bhat NA -> 0, shat NA -> 1000 - expect_equal(unname(out$b[4:5, "ctx2"]), c(0, 0)) - expect_equal(unname(out$s[4:5, "ctx2"]), c(1000, 1000)) - # ctx1 has them present - expect_true(all(abs(out$b[, "ctx1"]) < 1)) - expect_true(all(out$s[, "ctx1"] < 1)) -}) - -test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) blocks", { - set.seed(7L) - gh <- new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", - BP = c(100L, 200L, 300L), - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 50L, - sampleIds = paste0("s", seq_len(50L)), - pgenPtr = NULL - ) - mkGr <- function(snpIds) { - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges( - start = seq(100L, by = 100L, length.out = length(snpIds)), - width = 1L - ) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = snpIds, - A1 = "A", - A2 = "G", - Z = rnorm(length(snpIds)), - BETA = rnorm(length(snpIds), sd = 0.1), - SE = rep(0.05, length(snpIds)) - ) - gr - } - # Two (study, trait) blocks but they share SNP IDs v1, v2, v3 — without - # the prefix the rbind would silently merge them. - ss <- QtlSumStats( - study = c("s1", "s1"), - context = c("ctx1", "ctx1"), - trait = c("g1", "g2"), - entry = list( - mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))), - mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) - ), - genome = "hg19", - ldSketch = gh, - qcInfo = list(prebuilt = "synthetic") - ) - out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") - # 3 variants per block × 2 blocks = 6 rows - expect_equal(nrow(out$b), 6L) - expect_setequal( - rownames(out$b), - c( - paste0("s1::g1::", sprintf("chr1:%d:A:G", 100L * (1:3))), - paste0("s1::g2::", sprintf("chr1:%d:A:G", 100L * (1:3))) - ) - ) -}) - -test_that(".mashSumStatsToMatrices errors when entry lacks SNP mcol", { - set.seed(8L) - gh <- new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", - BP = c(100L, 200L, 300L), - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 50L, - sampleIds = paste0("s", seq_len(50L)), - pgenPtr = NULL - ) - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) - ) - # NO SNP mcol — should trigger the variant-alignment error - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - A1 = "A", - A2 = "G", - Z = rnorm(3), - BETA = rnorm(3, sd = 0.1), - SE = rep(0.05, 3) - ) - ss <- QtlSumStats( - study = "s1", - context = "ctx1", - trait = "g1", - entry = list(gr), - genome = "hg19", - ldSketch = gh, - qcInfo = list(prebuilt = "synthetic") - ) - expect_error( - pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto"), - "SNP" - ) -}) - # =========================================================================== # .mashSumStatsToMatrices — GwasSumStats path + input-validation errors # =========================================================================== -test_that(".mashSumStatsToMatrices on GwasSumStats: studies become columns", { - set.seed(11L) - gh <- new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", - BP = c(100L, 200L, 300L), - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 50L, - sampleIds = paste0("s", seq_len(50L)), - pgenPtr = NULL - ) - mkGr <- function(snpIds) { - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges( - start = seq(100L, by = 100L, length.out = length(snpIds)), - width = 1L - ) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = snpIds, - A1 = "A", - A2 = "G", - Z = rnorm(length(snpIds)), - BETA = rnorm(length(snpIds), sd = 0.1), - SE = rep(0.05, length(snpIds)) - ) - gr - } - # Each study is its own (study) block; columns of the mash matrix are the - # studies, so the result is block-diagonal with NA-fill off the diagonal. - ss <- GwasSumStats( - study = c("studyA", "studyB"), - entry = list( - mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))), - mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) - ), - genome = "hg19", - ldSketch = gh, - qcInfo = list(prebuilt = "synthetic") - ) - out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") - expect_equal(ncol(out$b), 2L) - expect_equal(colnames(out$b), c("studyA", "studyB")) - # 2 studies x 3 variants = 6 rows; rownames prefixed by the study block key. - expect_equal(nrow(out$b), 6L) - expect_setequal( - rownames(out$b), - c( - paste0("studyA::", sprintf("chr1:%d:A:G", 100L * (1:3))), - paste0("studyB::", sprintf("chr1:%d:A:G", 100L * (1:3))) - ) - ) - # studyA's rows are absent from studyB's column -> bhat 0 / shat 1000 fill. - studyArows <- grep("^studyA::", rownames(out$b)) - expect_equal(unname(out$b[studyArows, "studyB"]), rep(0, 3)) - expect_equal(unname(out$s[studyArows, "studyB"]), rep(1000, 3)) - # On the BETA scale, the present cells carry the small generated SEs. - expect_true(all(out$s[studyArows, "studyA"] < 1)) -}) - -test_that(".mashSumStatsToMatrices errors on a non-SumStats input", { - expect_error( - pecotmr:::.mashSumStatsToMatrices(list(a = 1), "strong"), - "must be a QtlSumStats or GwasSumStats" - ) -}) - -test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { - gh <- new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", - BP = c(100L, 200L, 300L), - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 50L, - sampleIds = paste0("s", seq_len(50L)), - pgenPtr = NULL - ) - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - A1 = "A", - A2 = "G", - Z = rnorm(3), - BETA = rnorm(3, sd = 0.1), - SE = rep(0.05, 3) - ) - ss <- QtlSumStats( - study = "s1", - context = "c1", - trait = "g1", - entry = list(gr), - genome = "hg19", - ldSketch = gh, - qcInfo = list() - ) # empty QC info - expect_error( - pecotmr:::.mashSumStatsToMatrices(ss, "strong"), - "no QC info" - ) -}) - -test_that(".mashSumStatsToMatrices errors when SumStats has zero entries", { - gh <- new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", - BP = c(100L, 200L, 300L), - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 50L, - sampleIds = paste0("s", seq_len(50L)), - pgenPtr = NULL - ) - ss <- QtlSumStats( - study = character(0), - context = character(0), - trait = character(0), - entry = list(), - genome = "hg19", - ldSketch = gh, - varY = numeric(0), - qcInfo = list(prebuilt = "synthetic") - ) - expect_error( - pecotmr:::.mashSumStatsToMatrices(ss, "strong"), - "no entries" - ) -}) - # =========================================================================== # mergeMashData — oneData-empty branch (returns resData unchanged) # =========================================================================== -test_that("mergeMashData returns resData when oneData is NULL", { - d1 <- list(random = data.frame(a = 1:3, b = 4:6)) - expect_equal(mergeMashData(d1, NULL), d1) -}) - -test_that("mergeMashData returns resData when oneData is an empty list", { - d1 <- list(random = data.frame(a = 1:3)) - expect_equal(mergeMashData(d1, list()), d1) -}) - # =========================================================================== # qtlSumStatsFromZMatrix # =========================================================================== -.qszm_gh <- function() { - new( - "GenotypeHandle", - path = "/tmp/sketch.gds", - format = "gds", - snpInfo = data.frame( - SNP = "chr1:100:A:G", - CHR = "1", - BP = 100L, - A1 = "A", - A2 = "G", - stringsAsFactors = FALSE - ), - nSamples = 10L, - sampleIds = paste0("s", seq_len(10L)), - pgenPtr = NULL - ) -} - -test_that("qtlSumStatsFromZMatrix: one row per context, Z preserved verbatim", { - z <- matrix( - c(1.1, -2.2, 0.3, 0.4, -0.5, 0.6), - nrow = 3, - dimnames = list( - c("chr1:100:A:G", "chr1:200:C:T", "chr2:50:A:T"), - c("brain", "liver") - ) - ) - qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) - expect_s4_class(qss, "QtlSumStats") - # The variants span chr1 and chr2, so each context becomes one ELEMENT per - # chromosome. The tuple is what stays 1:1 with a matrix column. - expect_equal(nrow(qss), 4L) - expect_setequal(as.character(qss$context), c("brain", "liver")) - expect_equal(unique(as.character(qss$study)), "s1") - expect_equal(unique(as.character(qss$trait)), "mash") - # getSumStats stitches a tuple's elements back together, so the Z column - # still matches the input matrix column verbatim (values only; the mcols - # column is unnamed whereas z[, j] carries the row ids as names). - brain <- getSumStats(qss, study = "s1", context = "brain", trait = "mash") - liver <- getSumStats(qss, study = "s1", context = "liver", trait = "mash") - expect_equal(S4Vectors::mcols(brain)$Z, unname(z[, 1])) - expect_equal(S4Vectors::mcols(liver)$Z, unname(z[, 2])) -}) - -test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when they don't parse", { - z <- matrix( - rnorm(2), - ncol = 1, - dimnames = list(c("chr1:250:A:G", "not_a_variant"), "ctx") - ) - qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) - # Stitched across whatever seqnames the ids decoded to, so the variant - # order still matches the matrix rows. - e <- getSumStats(qss, study = "s1", context = "ctx", trait = "mash") - expect_equal(GenomicRanges::start(e)[1], 250L) # decoded - expect_true(GenomicRanges::start(e)[2] >= 1L) # synthetic fallback - # un-parseable chrom falls back to chr1 (never NA) - expect_false(any(is.na(as.character(GenomicRanges::seqnames(e))))) - # SNP ids are carried through unchanged - expect_equal(S4Vectors::mcols(e)$SNP, rownames(z)) -}) - -test_that("qtlSumStatsFromZMatrix: NULL rownames get synthetic variant ids", { - z <- matrix(rnorm(4), nrow = 2, dimnames = list(NULL, c("a", "b"))) - qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) - expect_equal(S4Vectors::mcols(qss[[1]])$SNP, c("var1", "var2")) -}) - -test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcInfo are set", { - z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("x", "y"))) - qss <- qtlSumStatsFromZMatrix( - z, - study = "s1", - ldSketch = .qszm_gh(), - n = 500L, - a1 = "T", - a2 = "C", - role = "strong" - ) - mc <- S4Vectors::mcols(qss[[1]]) - expect_equal(unique(mc$A1), "T") - expect_equal(unique(mc$A2), "C") - expect_equal(unique(mc$N), 500L) - expect_equal(getQcInfo(qss)$role, "strong") - expect_equal(length(getQcInfo(qss)$entryAudit), 2L) # one slot per context -}) - -test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait pairs", { - z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("geneA", "geneB"))) - # columns as traits: constant context, one trait per column - qss <- qtlSumStatsFromZMatrix( - z, - study = "s1", - ldSketch = .qszm_gh(), - context = "brain", - trait = colnames(z) - ) - expect_equal(as.character(qss$context), c("brain", "brain")) - expect_equal(as.character(qss$trait), c("geneA", "geneB")) - # columns as (context, trait) pairs - qss2 <- qtlSumStatsFromZMatrix( - z, - study = "s1", - ldSketch = .qszm_gh(), - context = c("brain", "liver"), - trait = c("geneA", "geneA") - ) - expect_equal(as.character(qss2$context), c("brain", "liver")) - expect_equal(as.character(qss2$trait), c("geneA", "geneA")) -}) - -test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors", { - z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("a", "b"))) - expect_error( - qtlSumStatsFromZMatrix( - z, - study = "s1", - ldSketch = .qszm_gh(), - trait = c("t1", "t2", "t3") - ), - "must be length 1 or ncol" - ) -}) - -test_that("qtlSumStatsFromZMatrix: rejects non-matrix input and unlabelled conditions", { - expect_error( - qtlSumStatsFromZMatrix(1:5, study = "s1", ldSketch = .qszm_gh()), - "variants x conditions matrix" - ) - # no colnames -> the default context = colnames(z) is NULL - z <- matrix(rnorm(4), nrow = 2) - 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_setequal(as.character(qss$context), c("brain", "liver")) - # One element per (context, chromosome); getSumStats stitches a context - # back into the single GRanges matching the matrix column. - mc <- S4Vectors::mcols( - getSumStats(qss, study = "s1", context = "brain", trait = "mash") - ) - 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])) -}) +# =========================================================================== +# mashInput (unified strong/random/null assembly from S4 objects) +# =========================================================================== -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("mashModelFit returns a fitted mash model", { + skip_if_not_installed("mashr") + ss <- mashFixture() + m <- .mashTestModel(ss) + expect_s3_class(m, "mash") + expect_false(is.null(m$fitted_g)) }) -test_that("qtlSumStatsFromBetaMatrix: validates matrices and matching dimensions", { - d <- .qszmBeta() +test_that("mashModelFit validates the prior and the fitOn entry", { + skip_if_not_installed("mashr") + ss <- mashFixture() expect_error( - qtlSumStatsFromBetaMatrix(1:5, d$shat, "s1", .qszm_gh()), - "`bhat` must be a numeric" + mashModelFit(list(random = ss), alpha = 0, priorCovariances = list()), + "non-empty named list" ) 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" + mashModelFit( + list(strong = ss), + alpha = 0, + priorCovariances = list(identity = diag(3)) + ), + "no 'random' entry" ) - mc <- S4Vectors::mcols(qss[[1]]) - expect_equal(mc$SNP, c("var1", "var2")) - expect_equal(unique(mc$A1), "T") - expect_equal(unique(mc$N), 500L) - expect_equal(getQcInfo(qss)$role, "strong") }) -# =========================================================================== -# mashInput (unified strong/random/null assembly from S4 objects) -# =========================================================================== +test_that("mashModelFit accepts either prior shape and fits identically", { + skip_if_not_installed("mashr") + ss <- mashFixture() + ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) + wrapped <- list(U = ulist, w = NULL, loglik = NULL) -# 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 - ) + fit <- function(prior) { + suppressMessages(suppressWarnings(mashModelFit( + list(random = ss), + alpha = 0, + priorCovariances = prior, + vhat = diag(3), + setSeed = 1L + ))) } - vids <- paste0("chr1:", 100 * seq_len(6), ":A:G") - e1 <- fineMappingRow( - variantIds = vids, - susieFit = list(x = 1), - topLoci = mkTL(c(0.5, -1, 6.0, 0.2, 1.1, -0.3), c(3, 2)) - ) - e2 <- fineMappingRow( - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - 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 + expect_equal(fit(wrapped)$loglik, fit(ulist)$loglik) +}) + +test_that("mashPosterior returns posterior matrices with covariance", { + skip_if_not_installed("mashr") + ss <- mashFixture() + post <- suppressMessages(suppressWarnings( + mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)) + )) + 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") + ss <- mashFixture() + 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") + ss <- mashFixture() + conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) + post <- suppressMessages(suppressWarnings( + mashPosterior( + .mashTestModel(ss), + ss, + alpha = 0, + vhat = diag(3), + excludeCondition = conds[3] ) - } - e1 <- fineMappingRow( - variantIds = vids, - susieFit = list(x = 1), - topLoci = noCsTL(rnorm(6)) - ) - e2 <- fineMappingRow( - 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) + )) + expect_equal(ncol(post$PosteriorMean), 2L) + expect_false(conds[3] %in% colnames(post$PosteriorMean)) }) -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 +test_that("mashPosterior errors on an unknown excludeCondition", { + skip_if_not_installed("mashr") + ss <- mashFixture() + expect_error( + mashPosterior( + .mashTestModel(ss), + ss, + alpha = 0, + vhat = diag(3), + excludeCondition = "not_a_condition" + ), + "not found in the target" + ) +}) + +test_that("mashModelFit: SimpleList input + default (NULL) vhat", { + skip_if_not_installed("mashr") + ss <- mashFixture() + 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") + ss <- mashFixture() + 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" ) - 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 +test_that(".mashUdFit re-raises an unrelated udr failure unchanged", { + skip_if_not_installed("udr") + local_mocked_bindings( + .mashUdControl = function(...) list(), + .package = "pecotmr" ) - 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(qtlSumStatsMulticontextExample) - ss <- qtlSumStatsMulticontextExample - out <- mashInput( - list(g = ss), - nRandom = 4, - nNull = 4, - excludeCondition = "muscle", - seed = 7 + # Only the TED i.i.d. incompatibility is rewrapped; anything else must + # surface as itself rather than being swallowed into a NULL fit. + expect_error( + with_mocked_bindings( + pecotmr:::.mashUdFit( + NULL, + UdFitOptions(unconstrained.update = "ted"), + 2L + ), + ud_fit = function(...) stop("totally unrelated failure"), + .package = "udr" + ), + "totally unrelated failure" ) - 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", { +test_that("mash covariance constructors validate against their mashr callee", { + skip_if_not_installed("mashr") + expect_s4_class(CovPcaOptions(subset = 1:5), "MethodOptions") + expect_equal( + CovFlashOptions(remove_singleton = TRUE)$remove_singleton, + TRUE + ) + expect_error(CovPcaOptions(subsett = 1:5), "unknown argument") + # A genuinely unmatched name; note `cov_method` would be accepted by R's + # partial matching, resolving to `cov_methods`. expect_error( - mashInput(list(1L)), - "must be a QtlSumStats, GwasSumStats, or FineMappingResult" + CovCanonicalOptions(covMethods = "identity"), + "unknown argument" + ) + # mashr::cov_ed takes `...`, so its names cannot be checked; the record + # says so rather than pretending otherwise. + expect_output(show(CovEdOptions()), "NOT checked") +}) + +test_that("CovUdrOptions splits udr's two functions into their own bundles", { + skip_if_not_installed("udr") + a <- CovUdrOptions( + init = UdInitOptions(n_unconstrained = 20L), + fit = UdFitOptions(unconstrained.update = "ted", maxiter = 500) + ) + expect_equal(a$init$n_unconstrained, 20L) + expect_equal(a$fit$unconstrained.update, "ted") + expect_equal(a$fit$maxiter, 500) + # Each half is checked against its own live source: ud_init's formals + # for one, ud_fit_control_default()'s names for the other. udr's tunables + # live in a control list, not in ud_fit's formals, which is why the two + # sources differ. + expect_error(UdFitOptions(maxitr = 5), "unknown argument") + expect_error(UdInitOptions(n_unconstraind = 5), "unknown argument") + # And neither accepts the other's names, which one flat bag could not + # distinguish. + expect_error(UdInitOptions(maxiter = 5), "unknown argument") + expect_error(UdFitOptions(n_unconstrained = 5), "unknown argument") + # udr's own spellings throughout: the pecotmr relabelling is gone. + expect_error( + CovUdrOptions(unconstrainedUpdate = "ted"), + "unused argument" ) - 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 +test_that("the mash constructors refuse the arguments pecotmr owns", { + expect_error(MashOptions(seed = 1L), "`seed`") + expect_error(MashOptions(data = 1L), "the sumstats pecotmr assembles") + expect_error(MashOptions(Ulist = list()), "the prior covariances") + expect_error(MashOptions(outputlevel = 2L), "fixed by the calling entry") + expect_error(MashDataOptions(Bhat = 1), "the effect-size matrix") + expect_error(MashDataOptions(alpha = 0), "the caller's `alpha`") + expect_error(MashDataOptions(V = diag(2)), "the caller's `vhat`") + expect_error(MashPosteriorOptions(seed = 1L), "`seed`") + expect_error(MashPosteriorOptions(g = 1L), "the fitted mash model") + expect_error( + MashPosteriorOptions(output_posterior_cov = TRUE), + "the caller's `outputPosteriorCov`" ) - # 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) + expect_error(MashCorSimpleOptions(data = 1L), "the null-partition data") + expect_error(MashCorEmOptions(max_iter = 2L), "the caller's `maxIter`") + expect_error(CorShrinkOptions(data = 1L), "the null z-matrix") }) -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"))) +test_that("the mash constructors validate against their engine's formals", { + expect_error(MashOptions(nosuch = 1), "unknown argument") + expect_error(MashDataOptions(nosuch = 1), "unknown argument") + expect_error(MashPosteriorOptions(nosuch = 1), "unknown argument") + expect_error(MashCorSimpleOptions(nosuch = 1), "unknown argument") + expect_error(CorShrinkOptions(nosuch = 1), "unknown argument") + # mashr::mash_estimate_corr_em takes dots, so nothing can be checked. + expect_s4_class(MashCorEmOptions(nosuch = 1), "MethodOptions") }) +test_that("the mash constructors carry their pecotmr defaults", { + expect_equal(MashDataOptions()$zero_Bhat_Shat_reset, 1000) + expect_setequal(names(CorShrinkOptions()), c("ash.control", "image")) + expect_equal(CorShrinkOptions()$image, "null") + # An explicit value wins over the default. + expect_equal( + MashDataOptions(zero_Bhat_Shat_reset = 1)$zero_Bhat_Shat_reset, + 1 + ) + expect_length(MashOptions(), 0L) +}) + +test_that("mashDataArgs reaches mashr::mash_set_data", { + skip_if_not_installed("mashr") + seen <- NULL + real <- mashr::mash_set_data + ss <- mashFixture(20L) + suppressMessages(suppressWarnings(with_mocked_bindings( + mashModelFit( + list(random = ss), + alpha = 0, + priorCovariances = mashTinyPrior(), + vhat = diag(3), + mashDataArgs = MashDataOptions(zero_Shat_reset = 0.5), + setSeed = 1L + ), + mash_set_data = function(...) { + seen <<- list(...) + real(...) + }, + .package = "mashr" + ))) + expect_equal(seen$zero_Shat_reset, 0.5) + # The pecotmr default rides along unless the caller overrides it. + expect_equal(seen$zero_Bhat_Shat_reset, 1000) +}) + +test_that("mashArgs reaches mashr::mash", { + skip_if_not_installed("mashr") + seen <- NULL + real <- mashr::mash + ss <- mashFixture(20L) + suppressMessages(suppressWarnings(with_mocked_bindings( + mashModelFit( + list(random = ss), + alpha = 0, + priorCovariances = mashTinyPrior(), + vhat = diag(3), + mashArgs = MashOptions(nullweight = 7, verbose = FALSE), + setSeed = 1L + ), + mash = function(...) { + seen <<- list(...) + real(...) + }, + .package = "mashr" + ))) + expect_equal(seen$nullweight, 7) + expect_false(seen$verbose) + # The entry point keeps owning outputlevel and the data/prior pair. + expect_equal(seen$outputlevel, 4L) +}) + +test_that("mashPosterior forwards posteriorArgs", { + skip_if_not_installed("mashr") + seen <- NULL + real <- mashr::mash_compute_posterior_matrices + ss <- mashFixture(20L) + model <- suppressMessages(suppressWarnings(mashModelFit( + list(random = ss), + alpha = 0, + priorCovariances = mashTinyPrior(), + vhat = diag(3), + setSeed = 1L + ))) + suppressMessages(suppressWarnings(with_mocked_bindings( + mashPosterior( + model, + ss, + alpha = 0, + vhat = diag(3), + posteriorArgs = MashPosteriorOptions(pi_thresh = 1e-8) + ), + mash_compute_posterior_matrices = function(...) { + seen <<- list(...) + real(...) + }, + .package = "mashr" + ))) + expect_equal(seen$pi_thresh, 1e-8) +}) + +test_that("the udr engine runs on the z scale, where udr picks TED", { + skip_if_not_installed("mashr") + skip_if_not_installed("udr") + # The companion to the alpha = 0 run above: both existing udr tests were + # on the beta scale, so the branch that lets udr choose was unexercised. + ss <- mashFixture() + pc <- suppressMessages(suppressWarnings( + mashPriorCovariances( + list(strong = ss), + alpha = 1, + vhat = diag(3), + engine = CovUdrOptions( + init = UdInitOptions(n_unconstrained = 2L), + fit = UdFitOptions(maxiter = 20L) + ), + setSeed = 1L + ) + )) + expect_gt(length(pc$U), 0L) + expect_true(all(map_lgl(pc$U, function(m) all(dim(m) == c(3L, 3L))))) + expect_equal(sum(pc$w), 1, tolerance = 1e-6) +}) + +test_that("UdFitOptions checks unconstrained.update's value, not just its name", { + skip_if_not_installed("udr") + # udr validates the NAME but not the value: compute_penalty() is two + # `if (update.type == ...)` branches with no else, so an unrecognised + # value assigns nothing and it dies on `object 'log_penalty' not found` + # -- a variable the caller never set. It runs whenever lambda is + # non-zero, which .mashUdControl always makes it. + for (v in c("ed", "ted", "none")) { + expect_s4_class( + UdFitOptions(unconstrained.update = v), + "MethodOptions" + ) + } + # NA is udr's own default and means "choose from the data". + expect_s4_class(UdFitOptions(unconstrained.update = NA), "MethodOptions") + expect_equal(udr::ud_fit_control_default()$unconstrained.update, NA) -test_that("a NULL partition passes through as NULL", { - expect_null(pecotmr:::.mashAsDataFrameOrNull(NULL)) - # A matrix becomes a base data.frame, keeping the variant-id rownames the - # downstream combine step relies on. - m <- matrix( - 1:4, - 2L, - 2L, - dimnames = list(c("v1", "v2"), c("a", "b")) - ) - out <- pecotmr:::.mashAsDataFrameOrNull(m) - expect_s3_class(out, "data.frame") - expect_equal(rownames(out), c("v1", "v2")) -}) - -test_that(".qtlSumStatsFromMatrix synthesises coords for unparseable ids", { - local_mocked_bindings( - parseVariantId = function(...) stop("bad"), - .package = "pecotmr" - ) - out <- pecotmr:::.qtlSumStatsFromMatrix( - vids = c("weird1", "weird2"), - nCond = 1L, - study = "s1", - ldSketch = NULL, - context = "cA", - trait = "g1", - genome = "hg19", - role = "input", - mcolFn = function(i, k) list(Z = c(1, 2)) - ) - expect_s4_class(out, "QtlSumStats") - gr <- out[[1L]] - # Ids that carry no coordinates land on chr1 at their own row index, so - # the object stays well-formed instead of failing to build. - expect_equal(as.character(GenomicRanges::seqnames(gr)), c("chr1", "chr1")) - expect_equal(GenomicRanges::start(gr), c(1L, 2L)) + expect_error( + UdFitOptions(unconstrained.update = "TED"), + "must be 'ed', 'ted', 'none' or NA" + ) + expect_error(UdFitOptions(unconstrained.update = 1), "must be 'ed'") + + # The sibling updates have their OWN vocabularies (scaled.update is + # fa/none), which this does not police -- guessing at them would risk + # rejecting something udr accepts. + expect_s4_class(UdFitOptions(scaled.update = "fa"), "MethodOptions") + expect_s4_class(UdFitOptions(maxiter = 500), "MethodOptions") + # Name checking is unchanged. + expect_error(UdFitOptions(maxitr = 5), "unknown argument") }) diff --git a/tests/testthat/test_pvalCombine.R b/tests/testthat/test_pvalCombineWrappers.R similarity index 72% rename from tests/testthat/test_pvalCombine.R rename to tests/testthat/test_pvalCombineWrappers.R index d8af516d5..779ec4ea9 100644 --- a/tests/testthat/test_pvalCombine.R +++ b/tests/testthat/test_pvalCombineWrappers.R @@ -143,10 +143,9 @@ test_that("combinePValues: runs multiple methods at once", { p <- c(0.01, 0.1, 0.4) res <- combinePValues(pvals = p, methods = c("acat", "bonferroni")) expect_equal(names(res$results), c("acat", "bonferroni")) - expect_true(all(vapply( + expect_true(all(map_lgl( res$results, - function(r) is.finite(r$pval), - logical(1) + function(r) is.finite(r$pval) ))) }) @@ -234,7 +233,7 @@ test_that("pvalAcat returns NA when the Cauchy statistic is non-finite", { test_that(".combinePvalAlignR rejects a non-matrix R", { expect_error( pecotmr:::.combinePvalAlignR(5, c("a", "b")), - "must be a matrix" + "Must be of type 'matrix'" ) }) @@ -580,3 +579,194 @@ test_that("waldTestPval with very large se gives p near 1", { # ============================================================================= # parseRegion # ============================================================================= + +test_that("pvalCombine: argument guards fire", { + expect_error(waldTestPval("a", 1, 10), "beta.*Must be of type 'numeric'") + expect_error(waldTestPval(1, "a", 10), "se.*Must be of type 'numeric'") + expect_error(waldTestPval(1, 1, "a"), "n.*Must be of type 'numeric'") + expect_error( + combinePValues(pvals = 0.5, methods = "fisher", naRm = NA), + "naRm.*May not be NA" + ) +}) + +test_that("the p-value constructors refuse the arguments pecotmr owns", { + expect_error(GbjOptions(test_stats = 1), "the caller's `zScores`") + expect_error(GbjOptions(cor_mat = diag(2)), "the caller's `R`") + expect_error(GbjOmniOptions(test_stats = 1), "the caller's `zScores`") + expect_error(AspuOptions(Zs = 1), "the caller's `zScores`") + expect_error(AspuOptions(corSNP = diag(2)), "the caller's `R`") + expect_error(PoolrOptions(p = 0.1), "the caller's `pvals`") + expect_error(PoolrOptions(R = diag(2)), "the caller's `R`") +}) + +test_that("the p-value constructors check what their engines accept", { + expect_error(GbjOptions(nosuch = 1), "unknown argument") + expect_error(GbjOmniOptions(pairwise_cors = 1), "unknown argument") + expect_error(AspuOptions(nosuch = 1), "unknown argument") + # poolr's tests all end in `...`, so no name can be rejected. + expect_s4_class(PoolrOptions(nosuch = 1), "MethodOptions") + # The adjustment pecotmr has always used stays the default. + expect_equal(PoolrOptions()$adjust, "generalized") + expect_equal(PoolrOptions(adjust = "empirical")$adjust, "empirical") +}) + +test_that("PvalMethodsParam pairs each method with its own constructor", { + rec <- PvalMethodsParam( + aspu = AspuOptions(n.perm = 100), + gbj = GbjOptions(pairwise_cors = 0.1), + fisher = list(side = 1) + ) + # The entries live in one named-list slot rather than ten nullable + # ones: a record configuring aspu used to show nine NULL slots. + expect_setequal(names(rec$methods), c("aspu", "gbj", "fisher")) + expect_setequal(names(rec), "methods") + # A plain list is routed through that method's constructor, so it picks + # up the pecotmr default the constructor carries. + expect_equal(rec$methods$fisher$adjust, "generalized") + expect_error( + PvalMethodsParam(gbj = AspuOptions()), + "was built with the constructor for 'aspu'" + ) + # The five GBJ tests share one engine, so one constructor serves them all. + expect_s4_class(PvalMethodsParam(minp = GbjOptions()), "PvalMethodsParam") + expect_s4_class(PvalMethodsParam(minp = GbjOptions()), "MethodParam") + # Each entry is still an engine argument bag; only the container changed. + expect_s4_class(rec$methods$aspu, "MethodOptions") + expect_null(rec$methods$minp) + # acat / hmp / bonferroni / gates are real combinePValues methods but + # take no options, so they are not formals. The ten that do are, which + # is why R rejects these before the constructor body runs -- the + # hand-rolled "unknown method" check is no longer reachable. + expect_error(PvalMethodsParam(acat = list()), "unused argument") + expect_error(PvalMethodsParam(gates = list()), "unused argument") + expect_setequal( + names(formals(PvalMethodsParam)), + names(pecotmr:::.pvalMethodCtors()) + ) +}) + +test_that("combinePValues finds a configured method by name, not position", { + # .combinePvalMethodArgs reads the entries out of the `methods` slot + # and matches by name, so every configured method must resolve to its + # own entry -- and a plain list() must still work as "no settings". + rec <- PvalMethodsParam( + aspu = AspuOptions(n.perm = 100), + fisher = PoolrOptions(side = 1) + ) + for (m in names(rec$methods)) { + expect_identical( + pecotmr:::.combinePvalMethodArgs(rec, m), + rec$methods[[m]], + info = m + ) + } + expect_equal( + pecotmr:::.combinePvalMethodArgs(list(), "fisher")$adjust, + "generalized" + ) + # An unconfigured method falls back to its own constructor's defaults, + # not to an empty list. + expect_equal( + pecotmr:::.combinePvalMethodArgs(rec, "stouffer")$adjust, + "generalized" + ) +}) + +test_that("combinePValues refuses options for a method it will not run", { + expect_error( + combinePValues( + pvals = c(0.01, 0.2, 0.5), + methods = "fisher", + R = diag(3), + methodArgs = PvalMethodsParam(stouffer = PoolrOptions(side = 1)) + ), + "configures stouffer, which `methods` does not request" + ) + expect_error( + combinePValues( + pvals = c(0.01, 0.2), + methods = "acat", + methodArgs = list(fisher = list()) + ), + "PvalMethodsParam" + ) +}) + +test_that("combinePValues forwards each method's options to its engine", { + skip_if_not_installed("poolr") + seen <- NULL + real <- poolr::stouffer + with_mocked_bindings( + combinePValues( + pvals = c(0.01, 0.2, 0.5), + methods = "stouffer", + R = diag(3), + methodArgs = PvalMethodsParam( + stouffer = PoolrOptions(adjust = "empirical", size = 1000) + ) + ), + stouffer = function(...) { + seen <<- list(...) + real(...) + }, + .package = "poolr" + ) + expect_equal(seen$adjust, "empirical") + expect_equal(seen$size, 1000) +}) + +test_that("an unconfigured method still gets its constructor's defaults", { + skip_if_not_installed("poolr") + seen <- NULL + real <- poolr::fisher + with_mocked_bindings( + combinePValues( + pvals = c(0.01, 0.2, 0.5), + methods = "fisher", + R = diag(3) + ), + fisher = function(...) { + seen <<- list(...) + real(...) + }, + .package = "poolr" + ) + # The adjustment pecotmr hard-coded before `methodArgs` existed. + expect_equal(seen$adjust, "generalized") +}) + +test_that("combinePValues forwards GBJ and aSPU options", { + skip_if_not_installed("GBJ") + skip_if_not_installed("aSPU") + gbjSeen <- NULL + aspuSeen <- NULL + realGbj <- GBJ::GBJ + realAspu <- aSPU::aSPUs + z <- c(2.5, -0.3, 1.1) + suppressWarnings(with_mocked_bindings( + with_mocked_bindings( + combinePValues( + zScores = z, + methods = c("gbj", "aspu"), + R = diag(3), + methodArgs = PvalMethodsParam( + gbj = GbjOptions(pairwise_cors = rep(0, 3)), + aspu = AspuOptions(n.perm = 200) + ) + ), + aSPUs = function(...) { + aspuSeen <<- list(...) + realAspu(...) + }, + .package = "aSPU" + ), + GBJ = function(...) { + gbjSeen <<- list(...) + realGbj(...) + }, + .package = "GBJ" + )) + expect_equal(gbjSeen$pairwise_cors, rep(0, 3)) + expect_equal(aspuSeen$n.perm, 200) +}) diff --git a/tests/testthat/test_qtlAssociationPostprocess.R b/tests/testthat/test_qtlAssociationPostprocess.R index 83653d2bd..bb00ebbe0 100644 --- a/tests/testthat/test_qtlAssociationPostprocess.R +++ b/tests/testthat/test_qtlAssociationPostprocess.R @@ -26,7 +26,7 @@ context("qtlAssociationPostprocess") # 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) { + entries <- map(seq_len(G), function(i) { if (i %in% emptyIdx) { return(GenomicRanges::GRanges()) } # no variants @@ -56,23 +56,32 @@ context("qtlAssociationPostprocess") }) shape1 <- rep(1, G) shape1[naShapeIdx] <- NA_real_ + extra <- list( + n_variants = rep(nVar, G), + n_variants_filtered = rep(nVarFilt, G), + p_beta = pBeta, + beta_shape1 = shape1, + beta_shape2 = rep(200, G) + ) args <- list( study = rep("s", G), context = rep("brain", G), trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", - n_variants = rep(nVar, G), - n_variants_filtered = rep(nVarFilt, G), - p_beta = pBeta, - beta_shape1 = shape1, - beta_shape2 = rep(200, G) + extraCols = extra[setdiff(names(extra), drop)] ) - do.call(QtlSumStats, args[setdiff(names(args), drop)]) + exec(QtlSumStats, !!!args[setdiff(names(args), drop)]) } +# The default fixture is 60 genes of GRanges + mcols and costs ~0.5s to build, +# which is most of this file's runtime when every test rebuilds it. S4 objects +# are copy-on-modify, so one shared instance is safe; tests needing a variant +# still call .qapFixture() with arguments. +.qapDefaultFixture <- .qapFixture() + test_that("qtlAssociationPostprocess enriches with package-computed columns", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, fdrThreshold = 0.1, @@ -84,7 +93,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { expect_false(is.null(getQcInfo(r)$associationPostprocess)) # recipe stashed # Bonferroni original == min over variants of p.adjust(P, "bonferroni", n). - expP <- vapply( + expP <- map_dbl( seq_len(nrow(x)), function(i) { min(stats::p.adjust( @@ -92,8 +101,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { "bonferroni", n = 50 )) - }, - numeric(1) + } ) expect_equal(as.numeric(r$p_bonferroni_min_original), expP) expect_equal( @@ -118,7 +126,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { test_that("q-values come from qvalue::qvalue, not a hand-rolled fallback", { skip_if_not_installed("qvalue") - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, methods = "permutation") expect_equal( as.numeric(r$q_beta), @@ -131,7 +139,7 @@ test_that("q-values come from qvalue::qvalue, not a hand-rolled fallback", { }) test_that("permutation nominal threshold == stats::qbeta of the empirical cutoff", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, fdrThreshold = 0.1, @@ -150,7 +158,7 @@ test_that("permutation nominal threshold == stats::qbeta of the empirical cutoff }) test_that("getSignificantQtls (bonferroni) matches the derived threshold rule", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, mafCutoff = 0.01, cisWindow = 1e6) sig <- getSignificantQtls(r, "bonferroni_original", threshold = 0.5) expect_s4_class(sig, "GRanges") @@ -161,18 +169,17 @@ test_that("getSignificantQtls (bonferroni) matches the derived threshold rule", sigGenes <- which(fdr < 0.5) expect_gt(length(sigGenes), 0) varThr <- max(as.numeric(r$p_bonferroni_min_original)[sigGenes]) - expN <- sum(vapply( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { sum(pmin(1, S4Vectors::mcols(r[[i]])$P * 50) <= varThr) - }, - integer(1) + } )) expect_equal(length(sig), expN) }) test_that("getSumStats(annotateSignificance=) adds a derived logical mcol", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, methods = "permutation") gr <- getSumStats( r, @@ -194,7 +201,7 @@ test_that("getSumStats(annotateSignificance=) adds a derived logical mcol", { }) test_that("significance accessors require a postprocessed object", { - x <- .qapFixture() # not postprocessed + x <- .qapDefaultFixture # not postprocessed expect_error( getSignificantQtls(x, "bonferroni_original"), "qtlAssociationPostprocess" @@ -218,7 +225,7 @@ test_that(".qapSafeQvalue retries with lambda=0 on qvalue 'missing or infinite'" }, .package = "qvalue" ) - r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") + r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") expect_true(all(as.numeric(r$q_beta) == 0.111)) }) @@ -233,7 +240,7 @@ test_that(".qapSafeQvalue retries with bootstrap pi0 on qvalue 'pi0 <= 0'", { }, .package = "qvalue" ) - r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") + r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") expect_true(all(as.numeric(r$q_beta) == 0.222)) }) @@ -244,7 +251,7 @@ test_that(".qapSafeQvalue re-raises a non-native qvalue error (no hand-rolled q) .package = "qvalue" ) expect_error( - qtlAssociationPostprocess(.qapFixture(), methods = "permutation"), + qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation"), "qvalue::qvalue failed" ) }) @@ -253,7 +260,7 @@ 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(), + .qapDefaultFixture, fdrThreshold = 1e-300, methods = "permutation" ) @@ -264,7 +271,7 @@ test_that("permutation nominal threshold is NA for every gene when none pass FDR test_that("getSignificantQtls (permutation) uses each gene's nominal threshold", { r <- qtlAssociationPostprocess( - .qapFixture(), + .qapDefaultFixture, fdrThreshold = 0.1, methods = "permutation" ) @@ -273,15 +280,14 @@ test_that("getSignificantQtls (permutation) uses each gene's nominal threshold", 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( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { if (is.na(thr[i])) { return(0L) } sum(S4Vectors::mcols(r[[i]])$P < thr[i]) - }, - integer(1) + } )) expect_gt(expN, 0) expect_equal(length(sig), expN) @@ -301,15 +307,14 @@ test_that("getSignificantQtls (permutation) skips genes with an NA threshold", { 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( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { if (is.na(thr[i])) { return(0L) } sum(S4Vectors::mcols(r[[i]])$P < thr[i]) - }, - integer(1) + } )) expect_equal(length(sig), expN) }) @@ -326,7 +331,7 @@ test_that("getSignificantQtls (permutation) errors without a nominal threshold", test_that("getSignificantQtls (bonferroni_filtered) applies the MAF/cis keep filter", { r <- qtlAssociationPostprocess( - .qapFixture(), + .qapDefaultFixture, mafCutoff = 0.01, cisWindow = 1e6 ) @@ -343,7 +348,7 @@ test_that("getSignificantQtls (bonferroni_filtered) applies the MAF/cis keep fil }) test_that("getSignificantQtls (bonferroni) errors when its columns are absent", { - r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") # no bonferroni + r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") # no bonferroni expect_error(getSignificantQtls(r, "bonferroni_original"), "columns absent") }) @@ -360,12 +365,11 @@ test_that("getSignificantQtls (qvalue) selects variants by their qvalue mcol", { qb <- as.numeric(r$q_beta) sigGenes <- which(qb < 0.1) expect_gt(length(sigGenes), 0) - expN <- sum(vapply( + expN <- sum(map_int( sigGenes, function(i) { sum(S4Vectors::mcols(r[[i]])$qvalue < 0.1) - }, - integer(1) + } )) expect_gt(expN, 0) expect_equal(length(sig), expN) @@ -385,7 +389,7 @@ test_that("getSignificantQtls (qvalue) errors when no event q column exists", { test_that("getSignificantQtls returns an empty GRanges when nothing is significant", { r <- qtlAssociationPostprocess( - .qapFixture(), + .qapDefaultFixture, mafCutoff = 0.01, cisWindow = 1e6 ) @@ -431,16 +435,16 @@ test_that("FILTERED Bonferroni drops MAF/cis-failing variants + uses n_variants_ # 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() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, mafCutoff = 0.01, cisWindow = 1e6, methods = "bonferroni" ) - P <- lapply(seq_len(nrow(x)), function(i) S4Vectors::mcols(x[[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 + P <- map(seq_len(nrow(x)), function(i) S4Vectors::mcols(x[[i]])$P) + expFilt <- map_dbl(P, function(p) min(pmin(1, p[1:2] * 30))) # v1,v2 @ n=30 + expOrig <- map_dbl(P, function(p) min(pmin(1, p * 50))) # 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. @@ -450,7 +454,7 @@ test_that("FILTERED Bonferroni drops MAF/cis-failing variants + uses n_variants_ }) test_that("getSignificantQtls(bonferroni_filtered) applies the derived rule on the filtered set", { - x <- .qapFixture() + x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, mafCutoff = 0.01, @@ -464,13 +468,12 @@ test_that("getSignificantQtls(bonferroni_filtered) applies the derived rule on t 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( + expN <- sum(map_int( seq_len(nrow(r)), function(i) { p <- S4Vectors::mcols(r[[i]])$P[1:2] sum(pmin(1, p * 30) <= varThr) - }, - integer(1) + } )) expect_equal(length(sig), expN) }) @@ -488,15 +491,20 @@ test_that(".qapSignificanceMask returns empty masks for an unknown method", { S4Vectors::mcols(g)$Z <- c(1, 2) S4Vectors::mcols(g)$N <- c(10L, 10L) qss <- QtlSumStats( - study = "s1", context = "c1", trait = "g1", - entry = list(g), genome = "hg19" + study = "s1", + context = "c1", + trait = "g1", + entry = list(g), + genome = "hg19" ) local_mocked_bindings( getQcInfo = function(x) { - list(associationPostprocess = list( - fdrThreshold = 0.05, - pvalueCol = "pval_nominal" - )) + list( + associationPostprocess = list( + fdrThreshold = 0.05, + pvalueCol = "pval_nominal" + ) + ) }, .qapEmptyMask = function(i, x, pcol) str_c("EMPTY", i), .package = "pecotmr" @@ -519,3 +527,56 @@ test_that(".qapPermutationCols reuses a supplied q_beta", { # q_beta is already present, so it is not recomputed or re-added. expect_setequal(names(cols), c("fdr_beta", "p_nominal_threshold")) }) + +test_that("QvalueOptions refuses the p-value vector", { + expect_error(QvalueOptions(p = 0.1), "the p-value vector") + # qvalue::qvalue() takes dots, so nothing else can be rejected. + expect_s4_class(QvalueOptions(nosuch = 1), "MethodOptions") + expect_equal( + QvalueOptions(pi0.method = "bootstrap")$pi0.method, + "bootstrap" + ) +}) + +test_that(".qapSafeQvalue forwards qvalueArgs to qvalue::qvalue", { + skip_if_not_installed("qvalue") + seen <- NULL + real <- qvalue::qvalue + set.seed(4) + p <- c(runif(200, 0, 0.05), runif(800)) + with_mocked_bindings( + pecotmr:::.qapSafeQvalue(p, QvalueOptions(pfdr = TRUE)), + qvalue = function(...) { + seen <<- list(...) + real(...) + }, + .package = "qvalue" + ) + expect_true(seen$pfdr) +}) + +test_that("the qvalue degenerate-case retries keep the caller's options", { + skip_if_not_installed("qvalue") + seen <- list() + real <- qvalue::qvalue + set.seed(5) + p <- runif(200) + res <- with_mocked_bindings( + pecotmr:::.qapSafeQvalue(p, QvalueOptions(pfdr = TRUE)), + qvalue = function(...) { + args <- list(...) + seen[[length(seen) + 1L]] <<- args + # Force the first attempt into qvalue's own "pi0 <= 0" case. + if (is.null(args$pi0.method)) { + stop("ERROR: The estimated pi0 <= 0.") + } + real(...) + }, + .package = "qvalue" + ) + expect_length(seen, 2L) + # The retry sets lambda/pi0.method but must not drop what the caller set. + expect_equal(seen[[2]]$pi0.method, "bootstrap") + expect_true(seen[[2]]$pfdr) + expect_length(res, length(p)) +}) diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index 6ebe5006c..bde52cb01 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -29,7 +29,7 @@ context("qtlEnrichmentPipeline") path = path, format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -192,7 +192,7 @@ test_that("qtlEnrichmentPipeline: the real estimator fills the value columns", { out <- qtlEnrichmentPipeline( gwasFineMappingResult = gfmr, qtlFineMappingResult = qfmr, - impN = 5, + methodArgs = QtlEnrichmentParam(impN = 5), seed = 1L ) )) @@ -282,7 +282,7 @@ test_that("qtlEnrichmentPipeline: rejects non-GwasFineMappingResult gwasFmr", { gwasFineMappingResult = "no", qtlFineMappingResult = qfmr ), - "must be a GwasFineMappingResult" + "Must inherit from class 'GwasFineMappingResult'" ) }) @@ -293,7 +293,7 @@ test_that("qtlEnrichmentPipeline: rejects non-QtlFineMappingResult qtlFmr", { gwasFineMappingResult = gfmr, qtlFineMappingResult = "no" ), - "must be a QtlFineMappingResult" + "Must inherit from class 'GwasFineMappingResult'" ) }) @@ -556,7 +556,9 @@ test_that(".enrBuildQtlRegionsList: returns empty list when the (study, context) seed = 42, nSnps = 50, causalIdx = c(5, 20, 35), - causalPips = c(0.8, 0.6, 0.9), + # Trimmed to the number of causal variants actually asked for; callers + # that pass a shorter causalIdx would otherwise warn on the assignment. + causalPips = c(0.8, 0.6, 0.9)[seq_along(causalIdx)], L = 2L ) { set.seed(seed) @@ -1068,7 +1070,15 @@ test_that(".enrRunEnrichment turns a stored alignment failure into a warning", { 1L, gwasPip = NULL, k = 1L, - p = list(alignedByTuple = list(cnd)) + alignedByTuple = list(cnd), + methodArgs = QtlEnrichmentParam(), + numThreads = 1L, + seed = NULL, + verbose = FALSE, + gwasFineMappingResult = NULL, + gwasTuples = data.frame(study = "g"), + qtlFineMappingResult = NULL, + qtlTuples = data.frame(study = "q") ), "qtlEnrichment failed" ) @@ -1097,3 +1107,55 @@ test_that(".enrBuildQtlRegionsList reads prior variance under either name", { ) expect_length(run(base), 0L) }) + +# ============================================================================= +# QtlEnrichmentParam() +# ============================================================================= + +test_that("QtlEnrichmentParam carries the estimator's tunable settings", { + a <- QtlEnrichmentParam() + expect_s4_class(a, "QtlEnrichmentParam") + # NULL defaults mean "estimate from the data", which qtlEnrichment says by + # the argument being absent rather than explicitly NULL. + expect_equal( + names(a), + c("lambda", "impN", "doubleShrinkage", "besselCorrection") + ) + expect_equal(a$lambda, 1.0) + expect_equal(a$impN, 25) + expect_false(a$doubleShrinkage) + expect_true(a$besselCorrection) +}) + +test_that("QtlEnrichmentParam forwards numGwas and piQtl once set", { + a <- QtlEnrichmentParam(numGwas = 5000, piQtl = 0.01) + expect_equal(a$numGwas, 5000) + expect_equal(a$piQtl, 0.01) +}) + +test_that("QtlEnrichmentParam rejects a name the estimator has no formal for", { + # No `...`: R's own argument matching is the check for a bundle pecotmr + # owns outright. + expect_error(QtlEnrichmentParam(shrinkage = 2), "unused argument") + # alignNames is the pipeline's invariant, not a user setting. + expect_error(QtlEnrichmentParam(alignNames = TRUE), "unused argument") +}) + +test_that("every QtlEnrichmentParam field is a qtlEnrichment formal", { + # The bundle is spliced straight into qtlEnrichment, so a field it has no + # formal for would be an error at a call site far from the constructor. + expect_true(all( + names(formals(QtlEnrichmentParam)) %in% names(formals(qtlEnrichment)) + )) +}) + +test_that("qtlEnrichmentPipeline refuses a bare list for methodArgs", { + expect_error( + qtlEnrichmentPipeline( + gwasFineMappingResult = NULL, + qtlFineMappingResult = NULL, + methodArgs = list(impN = 5) + ), + "must be built with QtlEnrichmentParam" + ) +}) diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index efd2c5770..b6ee724c6 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -279,9 +279,22 @@ test_that("QtlSumStats: accepts and stores extra per-tuple columns via ...", { entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), genome = "hg19", ldSketch = .qtlMakeGenotypeHandle(), - cohort = c("UKB", "FinnGen") + extraCols = list(cohort = c("UKB", "FinnGen")) ) expect_equal(as.character(obj$cohort), c("UKB", "FinnGen")) + # Not variadic: the base class's GRangesList(...) means ELEMENTS, + # so a bare `cohort =` here would read as adding an entry. + expect_error( + QtlSumStats( + study = "s1", + context = "c1", + trait = "t1", + entry = list(), + genome = "hg19", + cohort = "UKB" + ), + "unused argument" + ) }) # =========================================================================== @@ -366,7 +379,7 @@ test_that("accessors require length-1 selection args", { obj <- .qtlMakeOne() expect_error( getSumStats(obj, study = c("s1", "s2"), context = "c1", trait = "t1"), - "must each be length 1" + "Must have length 1" ) }) @@ -649,11 +662,11 @@ test_that("validity names the identity columns that are missing", { data(qtlSumStatsExample) bad <- qtlSumStatsExample S4Vectors::mcols(bad)$trait <- NULL - expect_equal( - pecotmr:::.qssCheckRequiredCols(bad), - "missing columns: trait" + expect_error( + methods::validObject(bad), + "missing elements \\{'trait'\\}" ) - expect_null(pecotmr:::.qssCheckRequiredCols(qtlSumStatsExample)) + expect_true(methods::validObject(qtlSumStatsExample)) }) test_that(".appendTraitDistances is a no-op without a trait position", { @@ -663,3 +676,11 @@ test_that(".appendTraitDistances is a no-op without a trait position", { # No anchor to measure TSS/TES distance from, so entries pass through. expect_identical(pecotmr:::.appendTraitDistances(entry, NULL), entry) }) + +test_that(".qssAppendTraitDist returns an empty entry untouched", { + # A variant set with no ranges has no positions to take a distance from. + empty <- GenomicRanges::GRanges() + out <- pecotmr:::.qssAppendTraitDist(1L, list(empty), NULL) + expect_s4_class(out, "GRanges") + expect_length(out, 0L) +}) diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index 18007f5ac..d3882f149 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -23,7 +23,7 @@ context("SS-TWAS: weights, pipeline, and omnibus combination") # SuSiE-RSS weight extraction # ============================================================================= -test_that("mrmashWeights fitDetail: slim default omits the full fit, full keeps it", { +test_that("mrmashWeights fitRetention: slim omits the full fit, full keeps it", { skip_if_not_installed("mr.mashr") fakeFit <- list(w0 = c(a_1 = 0.5, a_2 = 0.5), V = diag(2)) ddpm <- list(U = list(a = diag(2))) @@ -36,7 +36,7 @@ test_that("mrmashWeights fitDetail: slim default omits the full fit, full keeps fitSlim <- attr( mrmashWeights( mrmashFit = fakeFit, - retainFit = TRUE, + fitRetention = "slim", dataDrivenPriorMatrices = ddpm ), "fit" @@ -49,8 +49,7 @@ test_that("mrmashWeights fitDetail: slim default omits the full fit, full keeps fitFull <- attr( mrmashWeights( mrmashFit = fakeFit, - retainFit = TRUE, - fitDetail = "full", + fitRetention = "full", dataDrivenPriorMatrices = ddpm ), "fit" @@ -72,7 +71,7 @@ test_that("fitSusieInfThenSusieRss returns two fits", { n <- 500 R <- diag(p) z <- rnorm(p) - fits <- fitSusieInfThenSusieRss(z, R, n, args = list(L = 5)) + fits <- fitSusieInfThenSusieRss(z, R, n, args = SusieOptions(L = 5)) expect_true(is.list(fits)) expect_true("susie" %in% names(fits)) expect_true("susieInf" %in% names(fits)) @@ -153,40 +152,28 @@ test_that("rescaleCovW0 groups correctly by prior group prefix", { }) # ========================================================================= -# mrmashWrapper.R: compute_grid, grid_min, grid_max, autoselect_mixsd -# (lines 333-372) +# mrmashWrapper.R: computeGrid (mr.mash's own exported grid builder) # ========================================================================= -test_that("grid_max returns scaled grid_min when bhat^2 <= sbhat^2", { - bhat <- c(0.1, 0.2) - sbhat <- c(1.0, 1.0) - result <- pecotmr:::gridMax(bhat, sbhat) - expect_equal(result, 8 * pecotmr:::gridMin(bhat, sbhat)) -}) - - -test_that("grid_max returns 2*sqrt(max(bhat^2 - sbhat^2)) otherwise", { - bhat <- c(5, 1) - sbhat <- c(0.5, 0.5) - expected <- 2 * sqrt(max(bhat^2 - sbhat^2)) - result <- pecotmr:::gridMax(bhat, sbhat) - expect_equal(result, expected) -}) - - -test_that("autoselect_mixsd returns 2-element vector when mult == 0", { - result <- pecotmr:::autoselectMixsd(0.01, 1.0, mult = 0) - expect_equal(result, c(0, 0.5)) -}) - - -test_that("autoselect_mixsd returns valid grid with sqrt(2) mult", { - result <- pecotmr:::autoselectMixsd(0.01, 1.0, mult = sqrt(2)) - expect_true(length(result) > 1) - expect_equal(result[length(result)], 1.0) # last element is gmax - # All elements should be positive - - expect_true(all(result > 0)) +test_that("computeGrid is mr.mash's grid, not a reimplementation of it", { + skip_if_not_installed("mr.mashr") + # gridMin/gridMax/autoselectMixsd used to be ported copies here, and + # gridMin had drifted: upstream grid_min() is min(Shat)/10, the port + # dropped the /10, so every grid started ten times too high. + set.seed(3) + bhat <- matrix(rnorm(20, sd = 2), nrow = 10, ncol = 2) + sbhat <- matrix(abs(rnorm(20, mean = 0.5, sd = 0.1)), nrow = 10, ncol = 2) + expect_equal( + pecotmr:::computeGrid(bhat, sbhat), + mr.mashr::autoselect.mixsd( + list(Bhat = bhat, Shat = sbhat), + mult = sqrt(2) + )^2 + ) + # The ported floor would have been 10^2 times this one, since the grid + # scales variances. + ported <- min(sbhat) + expect_lt(min(pecotmr:::computeGrid(bhat, sbhat)), ported^2) }) @@ -235,19 +222,21 @@ test_that("mrmashWrapper errors when X and Y row counts differ", { matrix(1:6, nrow = 3, ncol = 2), matrix(1:8, nrow = 4, ncol = 2) ), - "same number of rows" + "Assertion on 'Y'.*Must have exactly 3 rows" ) }) -test_that("mrmashWrapper errors when prior_grid is not a vector", { - skip_if_not_installed("glmnet") - skip_if_not_installed("mr.mashr") - X <- matrix(rnorm(12), nrow = 3, ncol = 4) - Y <- matrix(rnorm(6), nrow = 3, ncol = 2) +test_that("MrmashPriorParam refuses a priorGrid that is not a vector", { + # The typed slot catches this when the record is built, so the wrapper's + # own is.vector() guard became unreachable and was deleted. expect_error( - mrmashWrapper(X, Y, priorGrid = matrix(1:4, nrow = 2)), - "priorGrid must be a vector" + MrmashPriorParam(priorGrid = matrix(1:4, nrow = 2)), + 'invalid object for slot "priorGrid"' + ) + expect_equal( + MrmashPriorParam(priorGrid = c(0.1, 0.2))$priorGrid, + c(0.1, 0.2) ) }) @@ -262,7 +251,7 @@ test_that("mrmashWrapper errors when no prior matrices and canonical_priorMatric X, Y, dataDrivenPriorMatrices = NULL, - canonicalPriorMatrices = FALSE + prior = MrmashPriorParam(canonicalPriorMatrices = FALSE) ), "dataDrivenPriorMatrices" ) @@ -290,7 +279,7 @@ test_that("mrmashWrapper warns when Y has missing and B_init_method is glasso", Y, bInitMethod = "glasso", dataDrivenPriorMatrices = list(U = list(matrix(1, 2, 2))), - canonicalPriorMatrices = FALSE + prior = MrmashPriorParam(canonicalPriorMatrices = FALSE) ), error = function(e) NULL ), @@ -310,12 +299,12 @@ test_that("computeCoefficientsGlasso runs without Xnew", { r <- 3 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) result <- pecotmr:::computeCoefficientsGlasso( X, Y, standardize = FALSE, - nthreads = 1, + numThreads = 1, Xnew = NULL ) expect_true("Bhat" %in% names(result)) @@ -334,13 +323,13 @@ test_that("computeCoefficientsGlasso runs with Xnew", { r <- 3 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) Xnew <- matrix(rnorm(10 * p), nrow = 10, ncol = p) result <- pecotmr:::computeCoefficientsGlasso( X, Y, standardize = FALSE, - nthreads = 1, + numThreads = 1, Xnew = Xnew ) expect_true("Yhat_new" %in% names(result)) @@ -361,13 +350,12 @@ test_that("computeCoefficientsUnivGlmnet runs without Xnew", { r <- 2 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) result <- pecotmr:::computeCoefficientsUnivGlmnet( X, Y, alpha = 0.5, standardize = FALSE, - nthreads = 1, Xnew = NULL ) expect_true("Bhat" %in% names(result)) @@ -386,14 +374,13 @@ test_that("computeCoefficientsUnivGlmnet runs with Xnew", { r <- 2 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) Xnew <- matrix(rnorm(8 * p), nrow = 8, ncol = p) result <- pecotmr:::computeCoefficientsUnivGlmnet( X, Y, alpha = 0.5, standardize = FALSE, - nthreads = 1, Xnew = Xnew ) expect_true("Yhat_new" %in% names(result)) @@ -411,14 +398,13 @@ test_that("computeCoefficientsUnivGlmnet handles NA in Y", { r <- 2 X <- matrix(rnorm(n * p), nrow = n, ncol = p) Y <- matrix(rnorm(n * r), nrow = n, ncol = r) - colnames(Y) <- paste0("cond", 1:r) + colnames(Y) <- paste0("cond", seq_len(r)) Y[1:5, 1] <- NA # introduce missing values in one condition result <- pecotmr:::computeCoefficientsUnivGlmnet( X, Y, alpha = 0.5, standardize = FALSE, - nthreads = 1, Xnew = NULL ) expect_true("Bhat" %in% names(result)) @@ -439,7 +425,7 @@ test_that("computeCoefficientsUnivGlmnet handles NA in Y", { # The fine-mapping / TWAS pipelines MOCK these wrappers, so their bodies are # otherwise untested. Here we drive each wrapper on a SMALL real fixture and # assert the return shape (weight length == #variants; matrix for multivariate; -# attr(.,"fit") when retainFit = TRUE). Bayesian/MCMC iterations are kept tiny. +# attr(.,"fit") unless fitRetention is "none"). MCMC iterations kept tiny. # fsusieWeights and the mock-based mrmash/mvsusie payload tests live in # test_rrMrmashMvsusie.R and are not duplicated here. # ============================================================================= @@ -473,7 +459,7 @@ test_that("mrashWeights returns length-p weights and can retain the fit", { skip_if_not_installed("susieR") skip_if_not_installed("glmnet") f <- .rrwXy() - w <- mrashWeights(f$X, f$y, retainFit = TRUE) + w <- mrashWeights(f$X, f$y, fitRetention = "slim") expect_length(w, f$p) expect_false(is.null(attr(w, "fit"))) }) @@ -481,12 +467,67 @@ test_that("mrashWeights returns length-p weights and can retain the fit", { test_that("qgg Bayes-alphabet weights (N/L/A/C/R) return length-p weights", { skip_if_not_installed("qgg") f <- .rrwXy() - mc <- list(nit = 200, nburn = 20, nthin = 1) - expect_length(do.call(bayesNWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesLWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesAWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesCWeights, c(list(f$X, f$y), mc)), f$p) - expect_length(do.call(bayesRWeights, c(list(f$X, f$y), mc)), f$p) + mc <- list(methodArgs = QggOptions(nit = 200, nburn = 20, nthin = 1)) + expect_length(exec(bayesNWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesLWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesAWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesCWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesRWeights, !!!c(list(f$X, f$y), mc)), f$p) +}) + +test_that("buildMrmashPriorMatrices exposes expand_covs' zeromat", { + skip_if_not_installed("mr.mashr") + # compute_canonical_covs() was already fully exposed (singletons, + # hetgrid) but expand_covs()'s `zeromat` was hardcoded TRUE, so the + # null component could not be dropped. + seen <- NULL + # The default must match the real expand_covs(): pecotmr no longer + # passes zeromat unless the caller set it, so an omitted argument has to + # fall through to the engine's own default here too. + local_mocked_bindings( + expand_covs = function(mats, grid, zeromat = TRUE) { + seen <<- zeromat + mats + }, + .package = "mr.mashr" + ) + set.seed(5) + Bhat <- matrix(rnorm(12), 6, 2) + Shat <- matrix(abs(rnorm(12, 0.5, 0.1)), 6, 2) + invisible(buildMrmashPriorMatrices( + Bhat, + Shat, + expandCovs = MrmashExpandCovsOptions(zeromat = FALSE) + )) + expect_false(seen) + invisible(buildMrmashPriorMatrices(Bhat, Shat)) + expect_true(seen) +}) + +test_that("bayesAlphabetWeights forwards every MCMC control to gbayes", { + # `nthin` was declared and documented (default 5) but never put in + # callArgs, so every fit silently ran at gbayes's own nthin = 1 while + # its siblings nit and nburn were forwarded. + seen <- NULL + local_mocked_bindings( + gbayes = function(...) { + seen <<- list(...) + list(bm = rep(0, 5)) + }, + .package = "qgg" + ) + f <- .rrwXy(p = 5) + invisible(bayesAlphabetWeights( + f$X, + f$y, + method = "bayesN", + nit = 300, + nburn = 30, + nthin = 7 + )) + expect_equal(seen$nit, 300) + expect_equal(seen$nburn, 30) + expect_equal(seen$nthin, 7) }) test_that("bayesAlphabetWeights validates matching row counts before fitting", { @@ -494,7 +535,7 @@ test_that("bayesAlphabetWeights validates matching row counts before fitting", { f <- .rrwXy() expect_error( bayesAlphabetWeights(f$X, f$y[-1], method = "bayesN"), - "same number of rows" + "y.*Must have length 50" ) expect_error( bayesAlphabetWeights( @@ -503,7 +544,7 @@ test_that("bayesAlphabetWeights validates matching row counts before fitting", { method = "bayesN", Z = matrix(1, f$n - 1, 1) ), - "same number of rows" + "Z.*Must have exactly 50 rows" ) }) @@ -523,7 +564,7 @@ test_that("bayesBWeights / bLassoWeights (BGLR) return length-p weights", { test_that("dprVbWeights returns length-p weights and retains the fit", { skip_if_not_installed("RcppDPR") f <- .rrwXy() - w <- dprVbWeights(f$X, f$y, retainFit = TRUE) + w <- dprVbWeights(f$X, f$y, fitRetention = "slim") expect_length(w, f$p) expect_false(is.null(attr(w, "fit"))) }) @@ -539,7 +580,11 @@ test_that("dprAdaptiveGibbsWeights returns length-p weights", { skip_if_not_installed("RcppDPR") f <- .rrwXy() invisible(capture.output( - w <- dprAdaptiveGibbsWeights(f$X, f$y, s_step = 100) + w <- dprAdaptiveGibbsWeights( + f$X, + f$y, + methodArgs = DprOptions(s_step = 100) + ) )) expect_length(w, f$p) }) @@ -552,7 +597,7 @@ test_that("mrmashWeights fits from (X, Y) and returns p x K weights", { w <- suppressMessages(mrmashWeights( X = m$X, Y = m$Y, - canonicalPriorMatrices = TRUE + methodArgs = MrmashOptions(canonicalPriorMatrices = TRUE) )) expect_equal(dim(w), c(m$p, m$K)) expect_true(all(is.finite(w))) @@ -614,8 +659,8 @@ test_that("RSS solvers validate their R-matrix / sample-size / length inputs", { expect_error(lassosumRss(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") expect_error(penalizedRss(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") expect_error(prsCs(f$stat$b, f$LD, -1), "sample size") - expect_error(prsCs(f$stat$b[-1], f$LD, f$n), "number of rows of 'R'") - expect_error(sdpr(f$stat$b[-1], f$LD, f$n), "number of rows of 'R'") + expect_error(prsCs(f$stat$b[-1], f$LD, f$n), "bhat.*Must have length 6") + expect_error(sdpr(f$stat$b[-1], f$LD, f$n), "bhat.*Must have length 6") expect_error(sdpr(f$stat$b, f$LD, f$n, M = 2), "at least 4") }) @@ -642,17 +687,23 @@ test_that("scadRssWeights / mcpRssWeights / l0learnRssWeights return length-p we test_that("prsCsWeights and sdprWeights follow the (stat, LD) contract", { f <- .rrwStatLd() expect_length( - prsCsWeights(f$stat, f$LD, nIter = 100, nBurnin = 20, thin = 1), + prsCsWeights( + f$stat, + f$LD, + methodArgs = PrsCsOptions(nIter = 100, nBurnin = 20, thin = 1) + ), f$p ) expect_length( sdprWeights( f$stat, f$LD, - iter = 100, - burn = 20, - thin = 1, - verbose = FALSE + methodArgs = SdprOptions( + iter = 100, + burn = 20, + thin = 1, + verbose = FALSE + ) ), f$p ) @@ -764,15 +815,6 @@ test_that("computeCovDiag returns a diagonal condition covariance", { expect_equal(unname(diag(cv)), unname(apply(m$Y, 2, var))) }) -test_that("computeCovFlash returns a finite K x K covariance from FLASH", { - skip_if_not_installed("flashier") - skip_if_not_installed("ebnm") - m <- .rrwMulti(n = 80, p = 6, K = 3) - cv <- computeCovFlash(m$Y) - expect_equal(dim(cv), c(m$K, m$K)) - expect_true(all(is.finite(cv))) -}) - test_that("buildMrmashPriorMatrices builds an expanded S0 list and a prior grid", { skip_if_not_installed("mr.mashr") set.seed(9) @@ -784,10 +826,9 @@ test_that("buildMrmashPriorMatrices builds an expanded S0 list and a prior grid" expect_true(is.list(res$S0)) expect_gt(length(res$S0), 1) expect_true(is.numeric(res$priorGrid)) - expect_true(all(vapply( + expect_true(all(map_lgl( res$S0, - function(s) all(dim(s) == c(3, 3)), - logical(1) + function(s) all(dim(s) == c(3, 3)) ))) }) @@ -837,7 +878,7 @@ test_that("mrmashWeights errors when X and Y are NULL and fit is NULL", { ) }) -test_that("mrmashWeights(retainFit=TRUE) attaches {dataDrivenPriorMatrices, w0, V}", { +test_that("mrmashWeights retaining attaches {dataDrivenPriorMatrices, w0, V}", { skip_if_not( requireNamespace("mr.mashr", quietly = TRUE), "mr.mashr not installed" @@ -858,16 +899,172 @@ test_that("mrmashWeights(retainFit=TRUE) attaches {dataDrivenPriorMatrices, w0, w <- mrmashWeights( mrmashFit = fakeFit, dataDrivenPriorMatrices = ddpm, - retainFit = TRUE + fitRetention = "slim" ) fit <- attr(w, "fit") expect_true(is.list(fit)) expect_identical(fit$dataDrivenPriorMatrices, ddpm) expect_identical(fit$w0, fakeFit$w0) expect_identical(fit$V, fakeFit$V) - # Default (retainFit = FALSE) leaves the weights free of the fit attribute. + # The default ("none") leaves the weights free of the fit attribute. expect_null(attr( mrmashWeights(mrmashFit = fakeFit, dataDrivenPriorMatrices = ddpm), "fit" )) }) + +test_that("MCMC / optimiser control arguments are guarded", { + expect_error( + bayesBWeights(NULL, NULL, nIter = 0), + "nIter.*Must be >= 1" + ) + expect_error( + bayesBWeights(NULL, NULL, thin = 0), + "thin.*Must be >= 1" + ) + expect_error( + bayesBWeights(NULL, NULL, probIn = 2), + "probIn.*is not <= 1" + ) + expect_error( + bLassoWeights(NULL, NULL, burnIn = -1), + "burnIn.*Must be >= 0" + ) + expect_error( + dprGibbsWeights(NULL, NULL, sStep = 0), + "sStep.*Must be >= 1" + ) + expect_error( + dprAdaptiveGibbsWeights(NULL, NULL, fitRetention = "sometimes"), + "must be one of" + ) + expect_error( + ncvregWeights(NULL, NULL, penalty = "SCAD", nfolds = 0), + "nfolds.*Must be >= 1" + ) + expect_error( + mrashWeights(NULL, NULL, initPriorSd = NA), + "initPriorSd.*May not be NA" + ) + expect_error( + computeCoefficientsGlasso(NULL, NULL, standardize = NA, numThreads = 1), + "standardize.*May not be NA" + ) + expect_error( + computeCoefficientsGlasso( + NULL, + NULL, + standardize = TRUE, + numThreads = 1.5 + ), + "numThreads.*integerish" + ) +}) + +test_that("RSS solver control arguments are guarded", { + expect_error( + lassosumRss(NULL, NULL, NULL, thr = -1), + "thr.*is not >= 0" + ) + expect_error( + lassosumRss(NULL, NULL, NULL, maxiter = 0), + "maxiter.*Must be >= 1" + ) + expect_error( + scadRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + scadRssWeights(stat = list(), LD = NULL, s = -1), + "s.*is not >= 0" + ) + expect_error( + mcpRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + mrashRssWeights(stat = "nope", LD = NULL, NULL, NULL, NULL, NULL), + "stat.*Must be of type 'list'" + ) + expect_error( + mrmashRssWeights(stat = "nope", LD = NULL), + "stat.*Must be of type 'list'" + ) +}) + +test_that("MrmashPriorParam carries prior options and rejects a typo", { + pa <- MrmashPriorParam(canonicalPriorMatrices = TRUE) + expect_s4_class(pa, "MrmashPriorParam") + expect_true(pa$canonicalPriorMatrices) + # pecotmr's own builder, so no `...`: R rejects an unknown name. Note + # `canonicalPrior` would be ACCEPTED, by R's partial matching. + expect_error( + MrmashPriorParam(canonicalPriorMatrix = TRUE), + "unused argument" + ) + expect_true(MrmashPriorParam(canonicalPrior = TRUE)$canonicalPriorMatrices) +}) + +test_that("MrmashPriorParam nests each engine function's own arguments", { + skip_if_not_installed("mr.mashr") + # hetgrid and singletons belong to compute_canonical_covs, zeromat to + # expand_covs. Nesting them says where each goes AND gets each checked + # against that function's live formals rather than a transcribed list. + pa <- MrmashPriorParam( + canonicalCovs = MrmashCanonicalCovsOptions( + hetgrid = c(0, 0.5), + singletons = FALSE + ), + expandCovs = MrmashExpandCovsOptions(zeromat = FALSE) + ) + expect_equal(pa$canonicalCovs$hetgrid, c(0, 0.5)) + expect_false(pa$canonicalCovs$singletons) + expect_false(pa$expandCovs$zeromat) + # Each bundle rejects the other's name, which a single flat bag could not. + expect_error( + MrmashCanonicalCovsOptions(zeromat = FALSE), + "unknown argument" + ) + expect_error( + MrmashExpandCovsOptions(singletons = FALSE), + "unknown argument" + ) + # Neither carries a default: pecotmr used to copy the engine's own. + expect_length(MrmashCanonicalCovsOptions(), 0L) + expect_length(MrmashExpandCovsOptions(), 0L) +}) + +test_that("mrmashWrapper forwards methodArgs under mr.mash's own names", { + skip_if_not_installed("mr.mashr") + ma <- MrmashOptions(max_iter = 10, tol = 0.5) + expect_equal(ma$max_iter, 10) + # The renamed pecotmr spellings are gone; mr.mash's names are the contract. + expect_error(MrmashOptions(maxIter = 10), "unknown argument") +}) + +test_that("mrmashWrapper refuses to let methodArgs override derived values", { + skip_if_not_installed("mr.mashr") + skip_if_not_installed("glmnet") + set.seed(1) + X <- matrix(rnorm(60 * 4), 60, 4) + Y <- matrix(rnorm(60 * 2), 60, 2) + expect_error( + mrmashWrapper( + X, + Y, + dataDrivenPriorMatrices = list(U = list(diag(2))), + methodArgs = MrmashOptions(S0 = list(diag(2))) + ), + "derived by the wrapper" + ) +}) + +test_that("a flat prior name is routed into the prior group", { + # The pipeline spells per-token kwargs flat, so mrmashWeights routes + # prior-construction names into mrmashWrapper's `prior` record. + split <- pecotmr:::.mrmashSplitPriorArgs( + list(canonicalPriorMatrices = TRUE, max_iter = 5) + ) + expect_equal(names(split$prior), "canonicalPriorMatrices") + expect_equal(names(split$rest), "max_iter") +}) diff --git a/tests/testthat/test_relatednessQc.R b/tests/testthat/test_relatednessQc.R index 50388c3ee..f78614d0f 100644 --- a/tests/testthat/test_relatednessQc.R +++ b/tests/testthat/test_relatednessQc.R @@ -1,7 +1,7 @@ context("filterRelatedness") # Helper: check no remaining pairs in the kept set exceed threshold -no_related_pairs_remain <- function( +noRelatedPairsRemain <- function( relatedness, excluded, threshold, @@ -37,7 +37,7 @@ test_that("maximizeUnrelated removes related individuals and leaves clean set", expect_type(result, "character") expect_true(length(result) > 0) - expect_true(no_related_pairs_remain(rel, result, threshold)) + expect_true(noRelatedPairsRemain(rel, result, threshold)) }) test_that("no related pairs returns empty exclusion vector", { @@ -70,7 +70,7 @@ test_that("large component pre-pruning removes individuals", { n <- 30 ids <- paste0("IND", seq_len(n)) rel <- data.frame( - IID1 = ids[1:(n - 1)], + IID1 = ids[seq_len(n - 1)], IID2 = ids[2:n], PI_HAT = rep(0.20, n - 1), stringsAsFactors = FALSE @@ -83,14 +83,14 @@ test_that("large component pre-pruning removes individuals", { relatedness = rel, relatednessThreshold = threshold, analysisType = "maximizeUnrelated", - maxComponentSize = 10, + pruning = RelatednessPruningParam(maxComponentSize = 10), verbose = TRUE ) expect_type(result, "character") expect_true(length(result) > 0) # The remaining kept individuals should have no related pairs - expect_true(no_related_pairs_remain(rel, result, threshold)) + expect_true(noRelatedPairsRemain(rel, result, threshold)) }) test_that("maximizeCases preferentially retains cases", { @@ -130,7 +130,7 @@ test_that("maximizeCases preferentially retains cases", { retained_controls <- intersect(retained, pheno$IID[pheno$pheno == 0]) # We expect at least 2 of 3 cases kept, and controls sacrificed expect_true(length(retained_cases) >= 2) - expect_true(no_related_pairs_remain(rel, result, threshold)) + expect_true(noRelatedPairsRemain(rel, result, threshold)) }) test_that("maximizeCases errors without phenoData", { @@ -215,7 +215,7 @@ test_that("iterative cleanup loops and warns when related pairs persist", { relatedness = rel, relatednessThreshold = 0.125, analysisType = "maximizeUnrelated", - maxIterations = 2L, + pruning = RelatednessPruningParam(maxIterations = 2L), verbose = TRUE ), "related pairs remain" @@ -224,3 +224,80 @@ test_that("iterative cleanup loops and warns when related pairs persist", { expect_type(result, "character") expect_equal(length(result), 0L) }) + +test_that(".relatednessLargestComponent guards an empty component list", { + # max(integer(0)) warns and returns -Inf; with no related pairs the + # pruning loop must simply not run, without emitting that warning. + expect_identical( + pecotmr:::.relatednessLargestComponent(list(csize = integer(0))), + 0L + ) + expect_identical( + pecotmr:::.relatednessLargestComponent(list(csize = c(3L, 7L))), + 7L + ) +}) + +test_that("RelatednessColumnsParam carries the defaults and rejects a typo", { + cols <- RelatednessColumnsParam() + expect_s4_class(cols, "RelatednessColumnsParam") + expect_equal(cols$iid1, "IID1") + expect_equal(cols$value, "PI_HAT") + # No `...`, so R's own argument matching is the check. + expect_error(RelatednessColumnsParam(vlaue = "X"), "unused argument") +}) + +test_that("RelatednessColumnsParam drops NULL family-ID columns", { + cols <- RelatednessColumnsParam() + # A NULL default means "the table has none", so it is not carried as an + # explicit NULL into plinkQC's argument list. + expect_false(is_in("fid1", names(cols))) + expect_null(cols$fid1) + expect_true(is_in("fid1", names(RelatednessColumnsParam(fid1 = "FID1")))) +}) + +test_that("RelatednessPruningParam carries the defaults and rejects a typo", { + pr <- RelatednessPruningParam(maxComponentSize = 50L) + expect_s4_class(pr, "RelatednessPruningParam") + expect_equal(pr$maxComponentSize, 50L) + expect_equal(pr$maxIterations, 20L) + expect_error(RelatednessPruningParam(maxComponents = 5L), "unused argument") +}) + +test_that("PlinkQcOptions validates extras against plinkQC's live formals", { + skip_if_not_installed("plinkQC") + pq <- PlinkQcOptions(otherCriterionThDirection = "le") + expect_s4_class(pq, "MethodOptions") + expect_equal(pq$otherCriterionThDirection, "le") + # The check comes from names(formals(plinkQC::relatednessFilter)), so it + # cannot drift from the upstream signature. + expect_error( + PlinkQcOptions(otherCriterionThreshold = 1), + "unknown argument" + ) +}) + +test_that("PlinkQcOptions refuses the arguments filterRelatedness derives", { + skip_if_not_installed("plinkQC") + # relatednessTh is legal for plinkQC, so the constructor accepts it, but + # filterRelatedness injects its own and the duplicate is caught there. + expect_error( + filterRelatedness( + data.frame(IID1 = "a", IID2 = "b", PI_HAT = 0.5), + plinkQcArgs = PlinkQcOptions(relatednessTh = 0.5) + ), + "derived from `relatednessThreshold` and `columns`" + ) +}) + +test_that("filterRelatedness refuses a bare list where a constructor is due", { + rel <- data.frame(IID1 = "a", IID2 = "b", PI_HAT = 0.5) + expect_error( + filterRelatedness(rel, columns = list(iid1 = "IID1")), + "must be built with RelatednessColumnsParam\\(\\)" + ) + expect_error( + filterRelatedness(rel, pruning = list(maxIterations = 2L)), + "must be built with RelatednessPruningParam\\(\\)" + ) +}) diff --git a/tests/testthat/test_rrBayesAlphabet.R b/tests/testthat/test_rrBayesAlphabet.R index a1f6f0047..79a0d8758 100644 --- a/tests/testthat/test_rrBayesAlphabet.R +++ b/tests/testthat/test_rrBayesAlphabet.R @@ -7,7 +7,7 @@ test_that("bayesAlphabetWeights errors on dimension mismatch", { y <- rnorm(5) expect_error( bayesAlphabetWeights(X, y, method = "bayesN"), - "same number of rows" + "y.*Must have length 10" ) }) @@ -18,7 +18,7 @@ test_that("bayesAlphabetWeights errors on covariate dimension mismatch", { Z <- matrix(rnorm(15), nrow = 5) expect_error( bayesAlphabetWeights(X, y, method = "bayesN", Z = Z), - "same number of rows" + "Z.*Must have exactly 10 rows" ) }) @@ -71,7 +71,11 @@ test_that("bayesNWeights dispatches to bayesAlphabetWeights with bayesN", { p <- 10 X <- matrix(rnorm(n * p), nrow = n) y <- X[, 1] * 0.5 + rnorm(n) - result <- bayesNWeights(X, y, nit = 50, nburn = 10) + result <- bayesNWeights( + X, + y, + methodArgs = QggOptions(nit = 50, nburn = 10) + ) expect_equal(length(result), p) expect_true(is.numeric(result)) expect_true(all(is.finite(result))) diff --git a/tests/testthat/test_rrDispatch.R b/tests/testthat/test_rrDispatch.R index 8e2e53ea5..aa4891614 100644 --- a/tests/testthat/test_rrDispatch.R +++ b/tests/testthat/test_rrDispatch.R @@ -6,6 +6,18 @@ context("regularized_regression - dispatch verification") # correct values. They catch silent dispatch bugs (wrong method, wrong penalty, # dropped argument) that the shape-only tests above would not. +test_that("susie-family weight wrappers never fit; they demand the fit", { + # Fitting belongs to fineMappingPipeline(); these wrappers extract only. + # The susie dispatch arguments they used to build are covered in + # test_fineMappingWrappers.R and test_fineMappingPipeline.R. + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:20] + y <- eqtlRegionExample$yRes + expect_error(susieWeights(X = X, y = y), "no 'susie' fit supplied") + expect_error(susieAshWeights(X = X, y = y), "no 'susieAsh' fit supplied") + expect_error(susieInfWeights(X = X, y = y), "no 'susieInf' fit supplied") +}) + test_that("prsCsWeights dispatches to prsCs with correct arguments", { set.seed(42) p <- 10 @@ -25,7 +37,11 @@ test_that("prsCsWeights dispatches to prsCs with correct arguments", { list(betaEst = seq_len(length(bhat)) * 0.01) } ) - result <- prsCsWeights(stat = stat, LD = R, maf = rep(0.3, p), nIter = 17) + result <- prsCsWeights( + stat = stat, + LD = R, + methodArgs = PrsCsOptions(maf = rep(0.3, p), nIter = 17) + ) expect_equal(captured$bhat, bhat) expect_equal(captured$R, R) expect_equal(captured$n, 55) # median of stat$n, NOT mean (145) @@ -50,7 +66,11 @@ test_that("sdprWeights dispatches to sdpr with correct arguments", { list(betaEst = seq_len(length(bhat)) * 0.02) } ) - result <- sdprWeights(stat = stat, LD = R, iter = 19, burn = 3) + result <- sdprWeights( + stat = stat, + LD = R, + methodArgs = SdprOptions(iter = 19, burn = 3) + ) expect_equal(captured$bhat, bhat) expect_equal(captured$R, R) expect_equal(captured$n, 456) @@ -64,7 +84,7 @@ test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.4 R[i + 1, i] <- 0.4 } @@ -292,8 +312,14 @@ test_that("lassoWeights and enetWeights dispatch to glmnetWeights with correct a for (d in dispatchers) { captured <- new.env(parent = emptyenv()) local_mocked_bindings( - glmnetWeights = function(X, y, alpha) { + glmnetWeights = function( + X, + y, + alpha, + methodArgs = GlmnetOptions() + ) { captured$alpha <- alpha + captured$methodArgs <- methodArgs matrix(0, nrow = ncol(X), ncol = 1) } ) @@ -306,83 +332,6 @@ test_that("lassoWeights and enetWeights dispatch to glmnetWeights with correct a } }) -test_that("susieWeights actually calls susie when fit is NULL", { - set.seed(42) - p <- 5 - X <- matrix(rnorm(10 * p), nrow = 10) - y <- rnorm(10) - captured <- new.env(parent = emptyenv()) - captured$called <- FALSE - local_mocked_bindings( - susie = function(X, y, ...) { - captured$called <- TRUE - captured$X <- X - captured$y <- y - list(pip = rep(0.1, ncol(X))) - }, - .package = "susieR" - ) - susieWeights(X = X, y = y) - expect_true(captured$called) - expect_identical(captured$X, X) - expect_identical(captured$y, y) -}) - -test_that("susieAshWeights calls susie with ash dispatch arguments", { - set.seed(42) - p <- 5 - X <- matrix(rnorm(10 * p), nrow = 10) - y <- rnorm(10) - captured <- new.env(parent = emptyenv()) - captured$called <- FALSE - local_mocked_bindings( - susie = function( - X, - y, - unmappable_effects = NULL, - convergence_method = NULL, - ... - ) { - captured$called <- TRUE - captured$unmappable_effects <- unmappable_effects - captured$convergence_method <- convergence_method - list(pip = rep(0.1, ncol(X))) - }, - .package = "susieR" - ) - susieAshWeights(X = X, y = y) - expect_true(captured$called) - expect_equal(captured$unmappable_effects, "ash") - expect_equal(captured$convergence_method, "pip") -}) - -test_that("susieInfWeights calls susie with inf dispatch arguments", { - set.seed(42) - p <- 5 - X <- matrix(rnorm(10 * p), nrow = 10) - y <- rnorm(10) - captured <- new.env(parent = emptyenv()) - captured$called <- FALSE - local_mocked_bindings( - susie = function( - X, - y, - unmappable_effects = NULL, - convergence_method = NULL, - ... - ) { - captured$called <- TRUE - captured$unmappable_effects <- unmappable_effects - captured$convergence_method <- convergence_method - list(pip = rep(0.1, ncol(X))) - }, - .package = "susieR" - ) - susieInfWeights(X = X, y = y) - expect_true(captured$called) - expect_equal(captured$unmappable_effects, "inf") - expect_equal(captured$convergence_method, "pip") -}) test_that("mrashWeights actually calls lassoWeights for default beta.init", { skip_if_not_installed("glmnet") diff --git a/tests/testthat/test_rrGlmnet.R b/tests/testthat/test_rrGlmnet.R index e87779abd..75650e1d4 100644 --- a/tests/testthat/test_rrGlmnet.R +++ b/tests/testthat/test_rrGlmnet.R @@ -55,7 +55,7 @@ test_that("glmnetWeights errors when all columns are constant", { set.seed(42) n <- 50 p <- 5 - X <- matrix(rep(1:p, each = n), nrow = n, ncol = p) + X <- matrix(rep(seq_len(p), each = n), nrow = n, ncol = p) y <- rnorm(n) expect_error( diff --git a/tests/testthat/test_rrLassosum.R b/tests/testthat/test_rrLassosum.R index dd4b226ee..1dcf44c9f 100644 --- a/tests/testthat/test_rrLassosum.R +++ b/tests/testthat/test_rrLassosum.R @@ -18,7 +18,7 @@ test_that("lassosumRss errors on non-positive sample size", { test_that("lassosumRss errors on mismatched bhat and R dimensions", { expect_error( lassosumRss(bhat = rnorm(10), R = diag(5), n = 100), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -28,7 +28,7 @@ test_that("lassosumRss runs successfully with valid input", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -58,7 +58,7 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } diff --git a/tests/testthat/test_rrMrAshRss.R b/tests/testthat/test_rrMrAshRss.R index 0c7d9eb69..24c6d098a 100644 --- a/tests/testthat/test_rrMrAshRss.R +++ b/tests/testthat/test_rrMrAshRss.R @@ -1,4 +1,4 @@ -context("regularized_regression - mr_ash_rss") +context("regularized_regression - mrashRss") # ============================================================================ # mrashRssWeights - dispatch + smoke test @@ -54,7 +54,7 @@ test_that("mrashRssWeights forwards arguments to susieR::mr.ash.rss", { s0 = c(0, 0.1, 0.2), w0 = c(0.5, 0.3, 0.2), z = z_vec, - tol = 1e-6 + methodArgs = MrashOptions(tol = 1e-6) ) expect_equal(captured$bhat, bhat) expect_equal(captured$shat, shat) diff --git a/tests/testthat/test_rrMrash.R b/tests/testthat/test_rrMrash.R index a6c80d455..f253730b9 100644 --- a/tests/testthat/test_rrMrash.R +++ b/tests/testthat/test_rrMrash.R @@ -42,7 +42,11 @@ test_that("mrashWeights subsets a user-supplied beta.init of length ncol(X) by k y <- X[, 1] * 0.5 + rnorm(n) user_beta_init <- seq(0.01, by = 0.01, length.out = p) expect_warning( - result <- mrashWeights(X, y, beta.init = user_beta_init), + result <- mrashWeights( + X, + y, + methodArgs = MrashOptions(beta.init = user_beta_init) + ), "mrashWeights: dropping 1 zero-variance column" ) expect_equal(length(result), p) diff --git a/tests/testthat/test_rrPenalizedRss.R b/tests/testthat/test_rrPenalizedRss.R index fa59bc9bc..1ef2f337b 100644 --- a/tests/testthat/test_rrPenalizedRss.R +++ b/tests/testthat/test_rrPenalizedRss.R @@ -24,7 +24,7 @@ test_that("penalizedRss errors on non-positive sample size", { test_that("penalizedRss errors on mismatched bhat and R dimensions", { expect_error( penalizedRss(bhat = rnorm(10), R = diag(5), n = 100, penalty = "MCP"), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -80,7 +80,7 @@ test_that("penalizedRss runs with MCP and returns correct structure", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } diff --git a/tests/testthat/test_rrPrsCs.R b/tests/testthat/test_rrPrsCs.R index 221ec1923..fb5e478ca 100644 --- a/tests/testthat/test_rrPrsCs.R +++ b/tests/testthat/test_rrPrsCs.R @@ -25,7 +25,7 @@ test_that("prsCs errors on mismatched maf length", { test_that("prsCs errors on mismatched bhat and R dimensions", { expect_error( prsCs(bhat = rnorm(10), R = diag(5), n = 100), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -35,7 +35,7 @@ test_that("prsCs runs successfully with valid input", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -194,7 +194,7 @@ test_that("prsCsWeights calls prsCs and returns betaEst", { n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - for (i in 1:(p - 1)) { + for (i in seq_len(p - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -202,10 +202,12 @@ test_that("prsCsWeights calls prsCs and returns betaEst", { result <- prsCsWeights( stat = stat, LD = R, - maf = rep(0.3, p), - nIter = 50, - nBurnin = 10, - thin = 2 + methodArgs = PrsCsOptions( + maf = rep(0.3, p), + nIter = 50, + nBurnin = 10, + thin = 2 + ) ) expect_equal(length(result), p) expect_true(is.numeric(result)) diff --git a/tests/testthat/test_rrSdpr.R b/tests/testthat/test_rrSdpr.R index e7352f53e..a96930b62 100644 --- a/tests/testthat/test_rrSdpr.R +++ b/tests/testthat/test_rrSdpr.R @@ -4,7 +4,7 @@ context("regularized_regression - sdpr") test_that("sdpr errors on mismatched bhat and R dimensions", { expect_error( sdpr(bhat = rnorm(10), R = diag(5), n = 100), - "number of rows of 'R'" + "bhat.*Must have length" ) }) @@ -223,10 +223,12 @@ test_that("sdprWeights calls sdpr and returns beta_est", { result <- sdprWeights( stat = stat, LD = R, - iter = 50, - burn = 10, - thin = 2, - verbose = FALSE + methodArgs = SdprOptions( + iter = 50, + burn = 10, + thin = 2, + verbose = FALSE + ) ) expect_equal(length(result), p) expect_true(is.numeric(result)) diff --git a/tests/testthat/test_rrSignalRecovery.R b/tests/testthat/test_rrSignalRecovery.R index e7221fbad..a76b4377c 100644 --- a/tests/testthat/test_rrSignalRecovery.R +++ b/tests/testthat/test_rrSignalRecovery.R @@ -10,7 +10,7 @@ context("regularized_regression - signal recovery") # ============================================================================ # Helper: simulate a small sparse linear model with binomial genotypes. -.simulate_sparse_xy <- function( +.simulateSparseXY <- function( n = 200, p = 20, signal_idx = c(3, 10, 15), @@ -27,7 +27,7 @@ context("regularized_regression - signal recovery") test_that("lassoWeights recovers signal direction on simulated data", { skip_if_not_installed("glmnet") - sim <- .simulate_sparse_xy() + sim <- .simulateSparseXY() w <- lassoWeights(sim$X, sim$y) expect_equal(length(w), ncol(sim$X)) expect_true(all(is.finite(w))) @@ -36,7 +36,7 @@ test_that("lassoWeights recovers signal direction on simulated data", { test_that("scadWeights recovers signal indices on simulated data", { skip_if_not_installed("ncvreg") - sim <- .simulate_sparse_xy() + sim <- .simulateSparseXY() w <- scadWeights(sim$X, sim$y, nfolds = 5) expect_equal(length(w), ncol(sim$X)) expect_true(all(is.finite(w))) @@ -47,7 +47,7 @@ test_that("scadWeights recovers signal indices on simulated data", { test_that("l0learnWeights with default L0 penalty recovers signal indices", { skip_if_not_installed("L0Learn") - sim <- .simulate_sparse_xy() + sim <- .simulateSparseXY() w <- l0learnWeights(sim$X, sim$y, penalty = "L0", nFolds = 5) expect_equal(length(w), ncol(sim$X)) expect_true(all(is.finite(w))) @@ -57,7 +57,7 @@ test_that("l0learnWeights with default L0 penalty recovers signal indices", { test_that("l0learnWeights with L0L2 penalty recovers signal direction", { skip_if_not_installed("L0Learn") - sim <- .simulate_sparse_xy() + sim <- .simulateSparseXY() w <- l0learnWeights(sim$X, sim$y, penalty = "L0L2", nFolds = 5) expect_equal(length(w), ncol(sim$X)) expect_true(all(is.finite(w))) @@ -67,7 +67,7 @@ test_that("l0learnWeights with L0L2 penalty recovers signal direction", { test_that("dprWeights with VB fitting recovers signal direction", { skip_if_not_installed("RcppDPR") - sim <- .simulate_sparse_xy() + sim <- .simulateSparseXY() w <- dprWeights(sim$X, sim$y, fittingMethod = "VB") expect_equal(length(w), ncol(sim$X)) expect_true(all(is.finite(w))) diff --git a/tests/testthat/test_rrSusie.R b/tests/testthat/test_rrSusie.R index 5fa961107..4d56df314 100644 --- a/tests/testthat/test_rrSusie.R +++ b/tests/testthat/test_rrSusie.R @@ -86,13 +86,7 @@ test_that("susieWeights calls susie when susie_fit is NULL", { n <- 50 X <- matrix(rnorm(n * p), nrow = n) y <- rnorm(n) - local_mocked_bindings( - susie = function(...) { - list(pip = rep(0.1, p)) - }, - .package = "susieR" - ) - result <- susieWeights(X = X, y = y) + result <- susieWeights(susieFit = list(pip = rep(0.1, p))) expect_equal(result, rep(0, p)) }) @@ -134,13 +128,7 @@ test_that("susieAshWeights calls susie when fit is NULL", { n <- 30 X <- matrix(rnorm(n * p), nrow = n) y <- rnorm(n) - local_mocked_bindings( - susie = function(...) { - list(pip = rep(0.1, p)) - }, - .package = "susieR" - ) - result <- susieAshWeights(X = X, y = y) + result <- susieAshWeights(susieAshFit = list(pip = rep(0.1, p))) expect_equal(result, rep(0, p)) }) @@ -182,12 +170,6 @@ test_that("susieInfWeights calls susie when fit is NULL", { n <- 30 X <- matrix(rnorm(n * p), nrow = n) y <- rnorm(n) - local_mocked_bindings( - susie = function(...) { - list(pip = rep(0.1, p)) - }, - .package = "susieR" - ) - result <- susieInfWeights(X = X, y = y) + result <- susieInfWeights(susieInfFit = list(pip = rep(0.1, p))) expect_equal(result, rep(0, p)) }) diff --git a/tests/testthat/test_sldscPostprocessingPipeline.R b/tests/testthat/test_sldscPostprocessingPipeline.R index ba7fa176b..855ccadac 100644 --- a/tests/testthat/test_sldscPostprocessingPipeline.R +++ b/tests/testthat/test_sldscPostprocessingPipeline.R @@ -324,3 +324,20 @@ test_that(".sldscFallbackMessage says '(none)' with no baseline categories", { "baseline \\(0\\): \\(none\\)" ) }) + +test_that(".sldscRelabelMetaEntry passes through what it cannot relabel", { + # No entry, or an entry with no `target` column, has nothing to relabel. + expect_null(pecotmr:::.sldscRelabelMetaEntry(NULL, c(a = "b"))) + noTarget <- data.frame(other = "x", stringsAsFactors = FALSE) + expect_identical( + pecotmr:::.sldscRelabelMetaEntry(noTarget, c(a = "b")), + noTarget + ) +}) + +test_that(".sldscRelabelOneTrait relabels nothing without a target summary", { + # No summary, or a summary with no `target` column, contributes no + # relabelled summary to the result. + out <- pecotmr:::.sldscRelabelOneTrait(list(), c(a = "b")) + expect_false(is_in("summary", names(out))) +}) diff --git a/tests/testthat/test_sldscWrapper.R b/tests/testthat/test_sldscWrapper.R index a9fe37eb7..ef8353a91 100644 --- a/tests/testthat/test_sldscWrapper.R +++ b/tests/testthat/test_sldscWrapper.R @@ -1,7 +1,7 @@ # Tests for R/sldscWrapper.R # -# File-based fixture builders (.make_annot_gz / .make_frq / .make_polyfun_single -# / .make_polyfun_joint / .make_sldsc_fixtures) and the in-memory SldscData +# File-based fixture builders (.makeAnnotGz / .make_frq / .makePolyfunSingle +# / .makePolyfunJoint / .makeSldscFixtures) and the in-memory SldscData # builders (.sldscMkRun / .sldscMkData) live in helper-sldsc.R. # # The reader functions (readSldscTrait/readSldscAnnot/readSldscFrq) do file I/O @@ -15,7 +15,7 @@ test_that(".sldscDetectAnnotCols finds non-standard columns", { dir <- withr::local_tempdir() - .make_annot_gz(dir, 1) + .makeAnnotGz(dir, 1) f <- file.path(dir, "target.1.annot.gz") cols <- pecotmr:::.sldscDetectAnnotCols(f) expect_true("annot_A" %in% cols) @@ -32,7 +32,7 @@ test_that(".sldscDetectAnnotCols finds non-standard columns", { test_that("readSldscTrait reads polyfun outputs correctly", { dir <- withr::local_tempdir() prefix <- file.path(dir, "test_trait") - .make_polyfun_single(dir, prefix, "myannot", nBlocks = 5, h2g = 0.25) + .makePolyfunSingle(dir, prefix, "myannot", nBlocks = 5, h2g = 0.25) result <- readSldscTrait(prefix) expect_true(is.list(result)) @@ -47,13 +47,16 @@ test_that("readSldscTrait reads polyfun outputs correctly", { }) test_that("readSldscTrait errors on missing files", { - expect_error(readSldscTrait("/nonexistent/prefix"), "missing file") + expect_error( + readSldscTrait("/nonexistent/prefix"), + "File does not exist" + ) }) test_that("readSldscTrait errors when h2 not in log", { dir <- withr::local_tempdir() prefix <- file.path(dir, "bad_log") - .make_polyfun_single(dir, prefix, "a", nBlocks = 3) + .makePolyfunSingle(dir, prefix, "a", nBlocks = 3) writeLines("No heritability here", paste0(prefix, ".log")) expect_error(readSldscTrait(prefix), "Total Observed scale h2") }) @@ -61,7 +64,7 @@ test_that("readSldscTrait errors when h2 not in log", { test_that("readSldscTrait errors on column mismatch in part_delete", { dir <- withr::local_tempdir() prefix <- file.path(dir, "bad_delete") - .make_polyfun_single(dir, prefix, "a", nBlocks = 3) + .makePolyfunSingle(dir, prefix, "a", nBlocks = 3) vroom::vroom_write( data.frame(x = 1:3, y = 4:6, z = 7:9, w = 10:12), paste0(prefix, ".part_delete"), @@ -73,7 +76,7 @@ test_that("readSldscTrait errors on column mismatch in part_delete", { test_that("readSldscTrait errors when the h2g value is non-numeric", { dir <- withr::local_tempdir() prefix <- file.path(dir, "bad_h2") - .make_polyfun_single(dir, prefix, "a", nBlocks = 3) + .makePolyfunSingle(dir, prefix, "a", nBlocks = 3) writeLines( c("start", "Total Observed scale h2: abc (0.05)", "end"), paste0(prefix, ".log") @@ -89,7 +92,7 @@ test_that("readSldscTrait errors when the h2g value is non-numeric", { test_that("readSldscAnnot stacks per-chromosome .annot.gz into one table", { dir <- withr::local_tempdir() for (chr in 1:2) { - .make_annot_gz(dir, chr) + .makeAnnotGz(dir, chr) } df <- readSldscAnnot(dir) expect_s3_class(df, "data.frame") @@ -101,7 +104,7 @@ test_that("readSldscAnnot stacks per-chromosome .annot.gz into one table", { test_that("readSldscAnnot respects annotCols", { dir <- withr::local_tempdir() for (chr in 1:2) { - .make_annot_gz(dir, chr) + .makeAnnotGz(dir, chr) } df <- readSldscAnnot(dir, annotCols = "annot_A") expect_true("annot_A" %in% names(df)) @@ -116,7 +119,7 @@ test_that("readSldscAnnot errors on missing dir / no files", { test_that("readSldscAnnot errors when annotCols resolves to nothing", { dir <- withr::local_tempdir() - .make_annot_gz(dir, 1) + .makeAnnotGz(dir, 1) expect_error( readSldscAnnot(dir, annotCols = character(0)), "no annotation columns" @@ -225,7 +228,10 @@ test_that("computeSldscAnnotSd errors when there are no annotation columns", { }) test_that("computeSldscAnnotSd errors on non-SldscData input", { - expect_error(computeSldscAnnotSd(list(a = 1)), "must be an SldscData") + expect_error( + computeSldscAnnotSd(list(a = 1)), + "Must inherit from class 'SldscData'" + ) }) test_that("computeSldscAnnotSd errors with zero degrees of freedom", { @@ -298,7 +304,10 @@ test_that("computeSldscMRef errors when mafCutoff > 0 but no frq data", { }) test_that("computeSldscMRef errors on non-SldscData input", { - expect_error(computeSldscMRef(list(a = 1)), "must be an SldscData") + expect_error( + computeSldscMRef(list(a = 1)), + "Must inherit from class 'SldscData'" + ) }) @@ -327,7 +336,10 @@ test_that("isBinarySldscAnnot respects annotCols (numeric)", { }) test_that("isBinarySldscAnnot errors on non-SldscData input", { - expect_error(isBinarySldscAnnot(list(a = 1)), "must be an SldscData") + expect_error( + isBinarySldscAnnot(list(a = 1)), + "Must inherit from class 'SldscData'" + ) }) @@ -336,7 +348,7 @@ test_that("isBinarySldscAnnot errors on non-SldscData input", { # ============================================================================= # Build a readSldscTrait-shaped run with specific values the tests assert on. -.make_trait_data <- function(cats = c("A_0", "B_0"), nBlocks = 10, h2g = 0.3) { +.makeTraitData <- function(cats = c("A_0", "B_0"), nBlocks = 10, h2g = 0.3) { n <- length(cats) taus <- rep(1e-7, n) blocks <- matrix( @@ -375,7 +387,7 @@ test_that("isBinarySldscAnnot errors on non-SldscData input", { } test_that("standardizeSldscTrait works in single mode", { - td <- .make_trait_data() + td <- .makeTraitData() result <- standardizeSldscTrait( .wrapRun(td), "t", @@ -411,7 +423,7 @@ test_that("standardizeSldscTrait works in single mode", { }) test_that("standardizeSldscTrait works in joint mode", { - td <- .make_trait_data() + td <- .makeTraitData() result <- standardizeSldscTrait( .wrapRun(td), "t", @@ -425,7 +437,7 @@ test_that("standardizeSldscTrait works in joint mode", { }) test_that("standardizeSldscTrait auto-detects target categories", { - td <- .make_trait_data() + td <- .makeTraitData() result <- standardizeSldscTrait( .wrapRun(td), "t", @@ -438,7 +450,7 @@ test_that("standardizeSldscTrait auto-detects target categories", { }) test_that("standardizeSldscTrait errors on empty categories", { - td <- .make_trait_data() + td <- .makeTraitData() expect_error( standardizeSldscTrait( .wrapRun(td), @@ -453,7 +465,7 @@ test_that("standardizeSldscTrait errors on empty categories", { }) test_that("standardizeSldscTrait errors on missing categories", { - td <- .make_trait_data(cats = "A_0") + td <- .makeTraitData(cats = "A_0") expect_error( standardizeSldscTrait( .wrapRun(td), @@ -469,7 +481,7 @@ test_that("standardizeSldscTrait errors on missing categories", { }) test_that("standardizeSldscTrait warns on zero sd", { - td <- .make_trait_data(cats = "A_0") + td <- .makeTraitData(cats = "A_0") expect_warning( standardizeSldscTrait( .wrapRun(td), @@ -483,7 +495,7 @@ test_that("standardizeSldscTrait warns on zero sd", { }) test_that("standardizeSldscTrait enrichstatSe handles p = 0", { - td <- .make_trait_data(cats = "A_0") + td <- .makeTraitData(cats = "A_0") td$enrichmentP <- c(A_0 = 0) # p = 0 -> abs_z = Inf -> SE = NA result <- standardizeSldscTrait( .wrapRun(td), @@ -497,7 +509,7 @@ test_that("standardizeSldscTrait enrichstatSe handles p = 0", { }) test_that("standardizeSldscTrait errors when the requested run is absent", { - td <- .make_trait_data() + td <- .makeTraitData() expect_error( standardizeSldscTrait( .wrapRun(td), @@ -521,7 +533,7 @@ test_that("standardizeSldscTrait errors on non-SldscData input", { sdAnnot = c(A_0 = 0.5), MRef = 1000L ), - "must be an SldscData" + "Must inherit from class 'SldscData'" ) }) @@ -530,7 +542,7 @@ test_that("standardizeSldscTrait errors on non-SldscData input", { # metaSldscRandom (unchanged: operates on standardized per-trait estimates) # ============================================================================= -.make_per_trait_meta <- function( +.makePerTraitMeta <- function( nTraits = 3, category = "A_0", means = NULL, @@ -561,7 +573,7 @@ test_that("standardizeSldscTrait errors on non-SldscData input", { } test_that("metaSldscRandom works for tauStar", { - pt <- .make_per_trait_meta(nTraits = 4) + pt <- .makePerTraitMeta(nTraits = 4) result <- metaSldscRandom(pt, "A_0", quantity = "tauStar") expect_true(is.list(result)) expect_equal(result$nTraits, 4L) @@ -573,14 +585,14 @@ test_that("metaSldscRandom works for tauStar", { }) test_that("metaSldscRandom works for enrichment", { - pt <- .make_per_trait_meta(nTraits = 3) + pt <- .makePerTraitMeta(nTraits = 3) result <- metaSldscRandom(pt, "A_0", quantity = "enrichment") expect_equal(result$nTraits, 3L) expect_true(is.finite(result$mean)) }) test_that("metaSldscRandom works for enrichstat", { - pt <- .make_per_trait_meta(nTraits = 3) + pt <- .makePerTraitMeta(nTraits = 3) result <- metaSldscRandom(pt, "A_0", quantity = "enrichstat") expect_equal(result$nTraits, 3L) expect_true(is.finite(result$mean)) @@ -645,7 +657,7 @@ test_that("sldscSubsetMeta defaults categories from params and validates traits" }) test_that("metaSldscRandom returns NA with < 2 traits", { - pt <- .make_per_trait_meta(nTraits = 1) + pt <- .makePerTraitMeta(nTraits = 1) result <- metaSldscRandom(pt, "A_0", "tauStar") expect_true(is.na(result$mean)) expect_true(is.na(result$se)) @@ -654,7 +666,7 @@ test_that("metaSldscRandom returns NA with < 2 traits", { }) test_that("metaSldscRandom skips traits with missing category", { - pt <- .make_per_trait_meta(nTraits = 3) + pt <- .makePerTraitMeta(nTraits = 3) pt$trait2$summary$target <- "other" result <- metaSldscRandom(pt, "A_0", "tauStar") expect_equal(result$nTraits, 2L) @@ -662,7 +674,7 @@ test_that("metaSldscRandom skips traits with missing category", { }) test_that("metaSldscRandom skips traits with NA or zero SE", { - pt <- .make_per_trait_meta(nTraits = 3) + pt <- .makePerTraitMeta(nTraits = 3) pt$trait2$summary$tauStarSe <- NA pt$trait3$summary$tauStarSe <- 0 result <- metaSldscRandom(pt, "A_0", "tauStar") @@ -671,21 +683,21 @@ test_that("metaSldscRandom skips traits with NA or zero SE", { }) test_that("metaSldscRandom skips NULL entries", { - pt <- .make_per_trait_meta(nTraits = 3) + pt <- .makePerTraitMeta(nTraits = 3) pt$trait2 <- NULL result <- metaSldscRandom(pt, "A_0", "tauStar") expect_equal(result$nTraits, 2L) }) test_that("metaSldscRandom generates names for unnamed list", { - pt <- .make_per_trait_meta(nTraits = 2) + pt <- .makePerTraitMeta(nTraits = 2) names(pt) <- NULL result <- metaSldscRandom(pt, "A_0", "tauStar") expect_equal(result$traitsUsed, c("1", "2")) }) test_that("metaSldscRandom skips NULL entries and NULL summaries", { - valid <- .make_per_trait_meta( + valid <- .makePerTraitMeta( nTraits = 2, means = c(1e-5, 2e-5), ses = c(1e-6, 1e-6) @@ -698,7 +710,7 @@ test_that("metaSldscRandom skips NULL entries and NULL summaries", { }) test_that("metaSldscRandom skips a trait whose summary lacks the quantity columns", { - valid <- .make_per_trait_meta( + valid <- .makePerTraitMeta( nTraits = 2, means = c(1e-5, 2e-5), ses = c(1e-6, 1e-6) @@ -865,7 +877,7 @@ test_that("a constant annotation column contributes no variance", { test_that("readSldscAnnot accepts annotCols by position", { dir <- withr::local_tempdir() for (chr in 1:2) { - .make_annot_gz(dir, chr) + .makeAnnotGz(dir, chr) } # A numeric annotCols indexes into the DETECTED columns, so 1 is the # first annotation rather than the first column of the file. @@ -882,3 +894,36 @@ test_that("sldscSubsetMeta requires a per_trait element", { "has no `per_trait` element" ) }) + +test_that("metaSldscRandom forwards metaArgs to metafor::rma", { + seen <- NULL + real <- metafor::rma + mkEst <- function(m, s) { + list( + summary = data.frame( + target = "annot_A_0", + enrichment = m, + enrichmentSe = s + ) + ) + } + perTrait <- list( + traitX = mkEst(1.5, 0.3), + traitY = mkEst(1.8, 0.4), + traitZ = mkEst(1.2, 0.25) + ) + suppressWarnings(with_mocked_bindings( + metaSldscRandom( + perTrait, + category = "annot_A_0", + quantity = "enrichment", + metaArgs = RmaOptions(test = "knha") + ), + rma = function(...) { + seen <<- list(...) + real(...) + }, + .package = "metafor" + )) + expect_equal(seen$test, "knha") +}) diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 7ef51e75b..fb797093b 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -20,6 +20,26 @@ context("sumstats_qc") # ldMismatchQc # =========================================================================== +# Captures the options slalom was called with, so a test can assert that a +# constructor's settings actually reached the engine. +.ssq_captureSlalom <- function(capture) { + function( + zScore, + R = NULL, + X = NULL, + standardError = rep(1, length(zScore)), + abfPriorVariance = 0.04, + nlog10pDentistSThreshold = 4.0, + r2Threshold = 0.6, + leadVariantChoice = "pvalue", + ldMethod = "sample" + ) { + capture$r2Threshold <- r2Threshold + capture$abfPriorVariance <- abfPriorVariance + list(data = data.frame(outlier = rep(FALSE, length(zScore)))) + } +} + test_that("ldMismatchQc dentist returns a data frame with an outlier column", { set.seed(42) p <- 20 @@ -47,119 +67,19 @@ test_that("ldMismatchQc method argument is validated", { }) # =========================================================================== -# zMismatchQc resolver +# ldMismatchQcMethod resolver # =========================================================================== # =========================================================================== # krigingOutlierQc # =========================================================================== -# An allele switch (what the flip rule targets) is an LD-CONSISTENT z with one -# entry's sign reversed -- not a magnitude outlier. Build z = R %*% b (a single -# causal SNP) then negate a strongly-tagged neighbour, so susieR's logLR fires. -.kr_switchScenario <- function() { - m <- 10 - rho <- 0.9 - R <- outer(seq_len(m), seq_len(m), function(i, j) rho^abs(i - j)) - ids <- paste0("1:", seq_len(m) * 100, ":A:G") - rownames(R) <- colnames(R) <- ids - b <- numeric(m) - b[5] <- 6 - z <- as.numeric(R %*% b) - z[6] <- -z[6] # flip a strongly-tagged neighbour of the causal - list(z = z, R = R, ids = ids, flipped = 6L) -} - -test_that("krigingOutlierQc flags an allele switch and spares the rest", { - skip_if_not( - "kriging_rss" %in% getNamespaceExports("susieR"), - "installed susieR has no kriging_rss" - ) - s <- .kr_switchScenario() - kr <- krigingOutlierQc(s$z, s$R, n = 1000, variantIds = s$ids) - expect_true(kr$flip[s$flipped]) - expect_equal(sum(kr$flip), 1L) - expect_equal(nrow(kr$diagnostics), length(s$z)) - expect_true(all( - c("z", "condmean", "z_std_diff", "logLR", "flipped") %in% - colnames(kr$diagnostics) - )) - expect_identical(kr$diagnostics$flipped, kr$flip) -}) - -test_that("krigingOutlierQc flip == susieR's logLR>2 & |z|>2 selection", { - skip_if_not( - "kriging_rss" %in% getNamespaceExports("susieR"), - "installed susieR has no kriging_rss" - ) - set.seed(7) - m <- 10 - R <- cov2cor(crossprod(matrix(rnorm(m * m), m))) - ids <- paste0("1:", seq_len(m) * 100, ":A:G") - rownames(R) <- colnames(R) <- ids - z <- as.numeric(R %*% rnorm(m)) - z[4] <- 9 - kr <- krigingOutlierQc(z, R, n = 5000, variantIds = ids) - ref <- susieR::kriging_rss(z = z, R = R, n = 5000)$conditional_dist - # susieR's own allele-switch rule (susie_rss_utils.R): logLR > 2 & |z| > 2. - expected <- as.numeric(ref$logLR) > 2 & abs(z) > 2 - expect_identical(kr$flip, expected) - expect_equal(kr$diagnostics$logLR, as.numeric(ref$logLR), tolerance = 1e-8) - expect_equal( - kr$diagnostics$z_std_diff, - as.numeric(ref$z_std_diff), - tolerance = 1e-8 - ) - expect_equal( - kr$diagnostics$condmean, - as.numeric(ref$condmean), - tolerance = 1e-8 - ) -}) - -test_that("krigingOutlierQc thresholds are configurable", { - skip_if_not( - "kriging_rss" %in% getNamespaceExports("susieR"), - "installed susieR has no kriging_rss" - ) - s <- .kr_switchScenario() - # The switch fires at the default logLRThreshold = 2 ... - expect_true(krigingOutlierQc(s$z, s$R, n = 1000, variantIds = s$ids)$flip[ - s$flipped - ]) - # ... and an impossibly high logLR threshold suppresses every flip. - expect_false(any( - krigingOutlierQc( - s$z, - s$R, - n = 1000, - variantIds = s$ids, - logLRThreshold = 1e6 - )$flip - )) - # A |z| threshold above the switched z also suppresses it. - expect_false(any( - krigingOutlierQc( - s$z, - s$R, - n = 1000, - variantIds = s$ids, - zThreshold = 1e6 - )$flip - )) -}) - -test_that("krigingOutlierQc requires a positive sample size n", { - expect_error(krigingOutlierQc(c(1, 2, 3), diag(3)), "positive sample size") -}) - - context("raiss") library(tidyverse) library(MASS) # Helper: build LdData S4 from a ref_panel data.frame, correlation matrix, and blockMetadata -make_ld_data_from_ref_panel <- function(R_mat, ref_panel, blockMetadata) { +makeLdDataFromRefPanel <- function(R_mat, ref_panel, blockMetadata) { ref_panel$chrom <- as.character(ref_panel$chrom) ref_panel$variant_id <- as.character(ref_panel$variant_id) variants_gr <- pecotmr:::.refPanelToGranges(ref_panel) @@ -170,7 +90,7 @@ make_ld_data_from_ref_panel <- function(R_mat, ref_panel, blockMetadata) { ) } -generate_dummy_data <- function( +generateDummyData <- function( seed = 1, ref_panel_ordered = TRUE, known_zscores_ordered = TRUE @@ -225,11 +145,11 @@ generate_dummy_data <- function( } test_that("Input validation for raiss works correctly", { - input_data <- generate_dummy_data() - input_data_ref_panel_unordered <- generate_dummy_data( + input_data <- generateDummyData() + input_data_ref_panel_unordered <- generateDummyData( ref_panel_ordered = FALSE ) - input_data_zscores_unordered <- generate_dummy_data( + input_data_zscores_unordered <- generateDummyData( known_zscores_ordered = FALSE ) expect_error(raiss( @@ -245,7 +165,7 @@ test_that("Input validation for raiss works correctly", { }) test_that("Default parameters for raiss work correctly", { - input_data <- generate_dummy_data() + input_data <- generateDummyData() result <- raiss( input_data$ref_panel, input_data$known_zscores, @@ -410,7 +330,7 @@ test_that("formatRaissDf returns correctly formatted data frame", { A2 = sample(c("A", "T", "G", "C"), 10, replace = TRUE) ) - unknowns <- sample(1:nrow(ref_panel), 5) + unknowns <- sample(seq_len(nrow(ref_panel)), 5) result <- formatRaissDf(imp, ref_panel, unknowns) @@ -486,7 +406,7 @@ test_that("Merge operation is correct for mergeRaissDf", { expect_true(all(c("chr21", "chr22") %in% merged_df$chrom)) }) -generate_fro_test_data <- function(seed = 1) { +generateFroTestData <- function(seed = 1) { set.seed(seed) return(data.frame( chrom = paste0("chr", rep(22, 10)), @@ -501,7 +421,7 @@ generate_fro_test_data <- function(seed = 1) { } test_that("Correct columns are selected in filterRaissOutput", { - test_data <- generate_fro_test_data() + test_data <- generateFroTestData() output <- filterRaissOutput(test_data)$zscores expect_true(all( c('variant_id', 'A1', 'A2', 'z', 'Var', 'raissLdScore') %in% @@ -510,14 +430,14 @@ test_that("Correct columns are selected in filterRaissOutput", { }) test_that("raissR2 is calculated correctly in filterRaissOutput", { - test_data <- generate_fro_test_data() + test_data <- generateFroTestData() output <- filterRaissOutput(test_data)$zscores expected_R2 <- 1 - test_data[which(test_data$raissLdScore >= 5), ]$Var expect_equal(output$raissR2, expected_R2[which(expected_R2 > 0.6)]) }) test_that("Filtering is applied correctly in filterRaissOutput", { - test_data <- generate_fro_test_data() + test_data <- generateFroTestData() R2_threshold <- 0.6 minimum_ld <- 5 output <- filterRaissOutput(test_data, R2_threshold, minimum_ld)$zscores @@ -527,7 +447,7 @@ test_that("Filtering is applied correctly in filterRaissOutput", { }) test_that("Function returns the correct subset in filterRaissOutput", { - test_data <- generate_fro_test_data() + test_data <- generateFroTestData() test_data$raissR2 <- 1 - test_data$Var output <- filterRaissOutput(test_data)$zscores @@ -549,7 +469,7 @@ test_that("computeMu basic functionality", { expect_equal(result, expected_result) }) -generate_mock_data_for_computeVar <- function(seed = 1) { +generateMockDataForComputeVar <- function(seed = 1) { return( list( sig_i_t_1 = matrix(c(1, 2, 3, 4), nrow = 2), @@ -560,7 +480,7 @@ generate_mock_data_for_computeVar <- function(seed = 1) { } test_that("computeVar returns correct output for batch = TRUE", { - input_data <- generate_mock_data_for_computeVar() + input_data <- generateMockDataForComputeVar() result <- computeVar( input_data$sig_i_t_1, input_data$sig_t_inv_1, @@ -575,7 +495,7 @@ test_that("computeVar returns correct output for batch = TRUE", { }) test_that("computeVar returns correct output for batch = FALSE", { - input_data <- generate_mock_data_for_computeVar() + input_data <- generateMockDataForComputeVar() result <- computeVar( input_data$sig_i_t_1, input_data$sig_t_inv_1, @@ -683,6 +603,20 @@ test_that("invertMatEigen handles matrices with negative eigenvalues", { expect_silent(invertMatEigen(mat)) }) +test_that("invertMatEigen inverts a matrix that keeps a single eigenvector", { + # A near-rank-1 matrix puts >99.9% of the variance in one eigenvalue, so + # L == 1. That used to drop the eigenvector subscript to a vector and + # hand diag() a length-one value, which returns an identity matrix of + # THAT ORDER (diag(0.1) is 0x0) rather than a 1x1 matrix holding it. + v <- c(1, 1, 1) / sqrt(3) + mat <- 3 * outer(v, v) + diag(1e-9, 3) + actual <- invertMatEigen(mat) + expect_equal(dim(actual), c(3L, 3L)) + expect_equal(actual, t(actual)) + # The rank-1 pseudo-inverse reproduces the matrix it came from. + expect_equal(mat %*% actual %*% mat, mat, tolerance = 1e-6) +}) + # =========================================================================== # raissSingleMatrix edge cases # =========================================================================== @@ -761,7 +695,7 @@ test_that("raissSingleMatrixFromX returns NULL with no known overlap", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -794,7 +728,7 @@ test_that("raissSingleMatrixFromX returns known z when nothing to impute", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -802,7 +736,7 @@ test_that("raissSingleMatrixFromX returns known z when nothing to impute", { known_zscores <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), z = rnorm(p), @@ -832,7 +766,7 @@ test_that("raiss with single-matrix LD list dispatches to single matrix path", { ref_panel <- data.frame( chrom = rep(1, n_variants), pos = seq(10, n_variants * 10, 10), - variant_id = paste0("rs", 1:n_variants), + variant_id = paste0("rs", seq_len(n_variants)), A1 = rep("A", n_variants), A2 = rep("G", n_variants), stringsAsFactors = FALSE @@ -875,7 +809,7 @@ test_that("raiss with genotype_matrix list processes multiple blocks", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -919,7 +853,7 @@ test_that("raiss with genotype_matrix list returns NULL when all blocks fail", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -950,7 +884,7 @@ test_that("raiss with genotype_matrix list returns NULL when all blocks fail", { # Block-Diagonal LD data generator for RAISS testing # Corrected function to generate proper block-diagonal test data -generate_block_diagonal_test_data <- function( +generateBlockDiagonalTestData <- function( seed = 123, block_structure = "overlapping", n_variants = 30 @@ -1002,7 +936,7 @@ generate_block_diagonal_test_data <- function( block_size <- 5 n_blocks <- ceiling(n_variants / block_size) block_boundaries <- list() - for (i in 1:n_blocks) { + for (i in seq_len(n_blocks)) { startIdx <- (i - 1) * block_size + 1 endIdx <- min(i * block_size, n_variants) block_boundaries[[i]] <- c(startIdx, endIdx) @@ -1021,8 +955,8 @@ generate_block_diagonal_test_data <- function( # Create the block matrix with correlations ONLY within the block block_matrix <- matrix(0, nrow = n_block, ncol = n_block) - for (a in 1:n_block) { - for (b in 1:n_block) { + for (a in seq_len(n_block)) { + for (b in seq_len(n_block)) { if (a == b) { block_matrix[a, b] <- 1 } else { @@ -1058,18 +992,18 @@ generate_block_diagonal_test_data <- function( } # Create block metadata - block_sizes <- sapply(block_boundaries, function(b) b[2] - b[1] + 1) + block_sizes <- map_dbl(block_boundaries, function(b) b[2] - b[1] + 1) blockMetadata <- data.frame( blockId = seq_along(block_boundaries), chrom = rep(1, length(block_boundaries)), size = block_sizes, - startIdx = sapply(seq_along(block_boundaries), function(i) { + startIdx = map_dbl(seq_along(block_boundaries), function(i) { # Adjust for 1-based indexing in R if (i == 1) { return(1) } # Count unique variants before this block - sum(sapply(1:(i - 1), function(j) { + sum(map_dbl(seq_len(i - 1), function(j) { # If there's an overlap with the next block, count one less if ( j < length(block_boundaries) && @@ -1084,9 +1018,9 @@ generate_block_diagonal_test_data <- function( })) + 1 }), - endIdx = sapply(seq_along(block_boundaries), function(i) { + endIdx = map_dbl(seq_along(block_boundaries), function(i) { # Count all unique variants up to and including this block - sum(sapply(1:i, function(j) { + sum(map_dbl(seq_len(i), function(j) { # If there's an overlap with the next block, count one less if ( j < i && @@ -1150,13 +1084,13 @@ test_that("full matrix and block processing produce identical results", { block_structures <- c("non_overlapping", "single_block") for (structure in block_structures) { - test_data <- generate_block_diagonal_test_data( + test_data <- generateBlockDiagonalTestData( seed = 123, block_structure = structure ) # Prepare ld_data as LdData S4 for partitionLdMatrix - ld_data <- make_ld_data_from_ref_panel( + ld_data <- makeLdDataFromRefPanel( test_data$LD_matrix_full, test_data$ref_panel, test_data$blockMetadata @@ -1242,7 +1176,7 @@ test_that("full matrix and block processing produce identical results", { test_that("overlapping blocks keep variant IDs but may differ in z", { # Test only overlapping structure - test_data <- generate_block_diagonal_test_data( + test_data <- generateBlockDiagonalTestData( seed = 123, block_structure = "overlapping" ) @@ -1281,7 +1215,7 @@ test_that("overlapping blocks keep variant IDs but may differ in z", { # Test 2: For overlapping blocks, verify boundary variants exist and have valid values # Identify boundary variants boundary_variants <- character(0) - for (i in 1:(length(test_data$block_boundaries) - 1)) { + for (i in seq_len(length(test_data$block_boundaries) - 1)) { overlap_pos <- test_data$block_boundaries[[i]][2] boundary_variants <- c(boundary_variants, paste0("var", overlap_pos)) } @@ -1321,7 +1255,7 @@ test_that("overlapping blocks keep variant IDs but may differ in z", { test_that("raiss handles block boundaries correctly", { # Generate test data with overlapping blocks - test_data <- generate_block_diagonal_test_data( + test_data <- generateBlockDiagonalTestData( seed = 456, block_structure = "overlapping" ) @@ -1367,7 +1301,7 @@ test_that("raiss handles block boundaries correctly", { # Check that boundary variants have reasonable values boundary_variants <- character(0) - for (i in 1:(length(test_data$block_boundaries) - 1)) { + for (i in seq_len(length(test_data$block_boundaries) - 1)) { overlap_pos <- test_data$block_boundaries[[i]][2] boundary_variants <- c(boundary_variants, paste0("var", overlap_pos)) } @@ -1461,12 +1395,12 @@ test_that("raiss handles block boundaries correctly", { }) test_that("partitionLdMatrix integrates correctly with RAISS", { - test_data <- generate_block_diagonal_test_data( + test_data <- generateBlockDiagonalTestData( seed = 456, block_structure = "non_overlapping" ) - ld_data <- make_ld_data_from_ref_panel( + ld_data <- makeLdDataFromRefPanel( test_data$LD_matrix_full, test_data$ref_panel, test_data$blockMetadata @@ -1519,7 +1453,7 @@ test_that("partitionLdMatrix integrates correctly with RAISS", { # Test 3: Boundary overlap handling test_that("boundary overlaps are handled correctly", { - test_data <- generate_block_diagonal_test_data( + test_data <- generateBlockDiagonalTestData( seed = 789, block_structure = "overlapping" ) @@ -1555,7 +1489,7 @@ test_that("boundary overlaps are handled correctly", { # Test 4: Single-block case test_that("RAISS handles single-block list correctly", { - test_data <- generate_block_diagonal_test_data( + test_data <- generateBlockDiagonalTestData( seed = 202, block_structure = "single_block" ) @@ -1600,7 +1534,7 @@ test_that("RAISS handles single-block list correctly", { #' Helper: generate a genotype matrix X with corresponding ref_panel, #' known_zscores, and LD matrix R for equivalence testing. -generate_X_test_data <- function(n = 200, p = 100, n_known = 50, seed = 42) { +generateXTestData <- function(n = 200, p = 100, n_known = 50, seed = 42) { set.seed(seed) # Generate genotype-like matrix (dosages 0/1/2) X_raw <- matrix( @@ -1687,7 +1621,7 @@ test_that("safeSvd rejects all-zero matrix", { }) test_that("X path matches R path: basic equivalence (n > p)", { - data <- generate_X_test_data(n = 200, p = 100, n_known = 50, seed = 42) + data <- generateXTestData(n = 200, p = 100, n_known = 50, seed = 42) result_R <- raiss( data$ref_panel, @@ -1735,7 +1669,7 @@ test_that("X path matches R path: basic equivalence (n > p)", { }) test_that("X path matches R path: n < p regime", { - data <- generate_X_test_data(n = 50, p = 200, n_known = 100, seed = 123) + data <- generateXTestData(n = 50, p = 200, n_known = 100, seed = 123) result_R <- raiss( data$ref_panel, @@ -1776,7 +1710,7 @@ test_that("X path matches R path: n < p regime", { }) test_that("X path matches R path: n >> p regime", { - data <- generate_X_test_data(n = 500, p = 50, n_known = 25, seed = 99) + data <- generateXTestData(n = 500, p = 50, n_known = 25, seed = 99) result_R <- raiss( data$ref_panel, @@ -1807,7 +1741,7 @@ test_that("X path matches R path: n >> p regime", { }) test_that("X path matches R path: varying lambda", { - data <- generate_X_test_data(n = 150, p = 80, n_known = 40, seed = 7) + data <- generateXTestData(n = 150, p = 80, n_known = 40, seed = 7) for (lamb in c(0.001, 0.01, 0.1)) { result_R <- raiss( @@ -1850,7 +1784,7 @@ test_that("X path matches R path: varying lambda", { }) test_that("X path handles all-known edge case", { - data <- generate_X_test_data(n = 100, p = 50, n_known = 50, seed = 10) + data <- generateXTestData(n = 100, p = 50, n_known = 50, seed = 10) # Make all variants known all_known <- data.frame( chrom = data$ref_panel$chrom, @@ -1871,7 +1805,7 @@ test_that("X path handles all-known edge case", { }) test_that("X path handles single unknown variant", { - data <- generate_X_test_data(n = 100, p = 50, n_known = 49, seed = 15) + data <- generateXTestData(n = 100, p = 50, n_known = 49, seed = 15) result_R <- raiss( data$ref_panel, @@ -1901,7 +1835,7 @@ test_that("X path handles single unknown variant", { }) test_that("X path handles single known variant", { - data <- generate_X_test_data(n = 100, p = 50, n_known = 1, seed = 20) + data <- generateXTestData(n = 100, p = 50, n_known = 1, seed = 20) result_X <- raiss( data$ref_panel, @@ -1918,7 +1852,7 @@ test_that("X path handles single known variant", { }) test_that("X path R2 filtering matches R path", { - data <- generate_X_test_data(n = 200, p = 100, n_known = 50, seed = 42) + data <- generateXTestData(n = 200, p = 100, n_known = 50, seed = 42) result_R <- raiss( data$ref_panel, @@ -2034,7 +1968,7 @@ test_that("raw genotype_matrix path differs from the legacy LD path", { }) test_that("raiss rejects both ldMatrix and genotype_matrix", { - data <- generate_X_test_data(n = 50, p = 20, n_known = 10, seed = 1) + data <- generateXTestData(n = 50, p = 20, n_known = 10, seed = 1) expect_error( raiss( data$ref_panel, @@ -2047,7 +1981,7 @@ test_that("raiss rejects both ldMatrix and genotype_matrix", { }) test_that("raiss rejects neither ldMatrix nor genotype_matrix", { - data <- generate_X_test_data(n = 50, p = 20, n_known = 10, seed = 1) + data <- generateXTestData(n = 50, p = 20, n_known = 10, seed = 1) expect_error( raiss(data$ref_panel, data$known_zscores), "Provide either" @@ -2147,7 +2081,7 @@ context("slalom") # ============================================================================ # Helper: build a valid positive-definite LD matrix from a genotype matrix # ============================================================================ -make_synthetic_ld <- function(n_samples, n_snps, seed = 1) { +makeSyntheticLd <- function(n_samples, n_snps, seed = 1) { set.seed(seed) # Simulate genotypes with some LD structure by using a factor model # X = Z %*% L + noise, where Z is latent and L is a loading matrix @@ -2181,7 +2115,7 @@ test_that("slalom basic output structure", { z <- rnorm(n) R <- diag(n) # Add some off-diagonal correlations - for (i in 1:(n - 1)) { + for (i in seq_len(n - 1)) { R[i, i + 1] <- 0.3 R[i + 1, i] <- 0.3 } @@ -2202,7 +2136,40 @@ test_that("slalom basic output structure", { test_that("slalom errors on non-square R", { z <- rnorm(10) R <- matrix(rnorm(50), nrow = 5, ncol = 10) - expect_error(slalom(zScore = z, R = R), "R must be a square matrix") + expect_error(slalom(zScore = z, R = R), "R.*Must have exactly 10 rows") +}) + +test_that("slalom honours ldMethod when given genotypes", { + # `ldMethod` is documented as "Passed to computeLd", but slalom used to + # correlate the lead column of X with cor() directly, so "population" + # and "gcta" were accepted and silently given sample LD. It now resolves + # LD the same way dentist does. + set.seed(11) + X <- matrix(sample(0:2, 100 * 6, replace = TRUE), nrow = 100, ncol = 6) + colnames(X) <- paste0("snp", seq_len(6)) + z <- rnorm(6) + seen <- NULL + local_mocked_bindings( + computeLd = function(X, method = "sample", ...) { + seen <<- method + stats::cor(X) + }, + .package = "pecotmr" + ) + invisible(slalom(zScore = z, X = X, ldMethod = "gcta")) + expect_equal(seen, "gcta") + invisible(slalom(zScore = z, X = X)) + expect_equal(seen, "sample") +}) + +test_that("slalom still refuses both or neither of R and X", { + # resolveLdInput now carries the exactly-one-of rule that .slalomValidate + # used to duplicate; the errors must not have gone with it. + z <- rnorm(4) + R <- diag(4) + X <- matrix(rnorm(40), nrow = 10, ncol = 4) + expect_error(slalom(zScore = z), "Either R .* or X .* must be provided") + expect_error(slalom(zScore = z, R = R, X = X), "not both") }) test_that("slalom accepts X matrix instead of R", { @@ -2214,7 +2181,7 @@ test_that("slalom accepts X matrix instead of R", { nrow = n_samples, ncol = n_snps ) - colnames(X) <- paste0("snp", 1:n_snps) + colnames(X) <- paste0("snp", seq_len(n_snps)) z <- rnorm(n_snps) result <- slalom(zScore = z, X = X) @@ -2486,7 +2453,7 @@ test_that("DENTIST-S: perfectly consistent variant in LD is not flagged", { test_that("DENTIST-S: n_dentist_s_outlier and fraction are consistent", { set.seed(401) n <- 20 - syn <- make_synthetic_ld(200, n, seed = 401) + syn <- makeSyntheticLd(200, n, seed = 401) z <- rnorm(n, sd = 1) z[1] <- -5 @@ -2505,7 +2472,7 @@ test_that("DENTIST-S: n_dentist_s_outlier and fraction are consistent", { test_that("DENTIST-S: lowering threshold flags more outliers", { set.seed(402) n <- 15 - syn <- make_synthetic_ld(300, n, seed = 402) + syn <- makeSyntheticLd(300, n, seed = 402) z <- rnorm(n, sd = 2) z[5] <- -6 @@ -2597,7 +2564,7 @@ test_that("edge case: mismatched dimensions error", { R <- diag(5) expect_error( slalom(zScore = z, R = R), - "R must be a square matrix matching the length of zScore" + "R.*Must have exactly 10 rows" ) }) @@ -2697,7 +2664,7 @@ test_that("different standard_error values affect PIPs", { test_that("r2_threshold variation affects n_r2 count", { set.seed(701) n <- 10 - syn <- make_synthetic_ld(200, n, seed = 701) + syn <- makeSyntheticLd(200, n, seed = 701) z <- rnorm(n, sd = 2) z[1] <- -5 @@ -2710,7 +2677,7 @@ test_that("r2_threshold variation affects n_r2 count", { test_that("nlog10p_dentist_s_threshold variation affects outlier count", { set.seed(702) n <- 10 - syn <- make_synthetic_ld(200, n, seed = 702) + syn <- makeSyntheticLd(200, n, seed = 702) z <- rnorm(n, sd = 2) z[1] <- -6 @@ -2812,7 +2779,7 @@ test_that("fraction is between 0 and 1", { for (s in 1:5) { set.seed(900 + s) n <- sample(10:30, 1) - syn <- make_synthetic_ld(200, n, seed = 900 + s) + syn <- makeSyntheticLd(200, n, seed = 900 + s) z <- rnorm(n, sd = 2) z[1] <- -6 @@ -2842,7 +2809,7 @@ test_that("maxPip equals the maximum of prob vector", { test_that("realistic LD: correlated variants share PIP mass", { set.seed(1000) - syn <- make_synthetic_ld(500, 20, seed = 1000) + syn <- makeSyntheticLd(500, 20, seed = 1000) z <- rep(0, 20) z[3] <- 5 @@ -2854,7 +2821,7 @@ test_that("realistic LD: correlated variants share PIP mass", { test_that("realistic LD: DENTIST-S detects outlier in correlated block", { set.seed(1001) - syn <- make_synthetic_ld(500, 15, seed = 1001) + syn <- makeSyntheticLd(500, 15, seed = 1001) R <- syn$R lead_idx <- 1 @@ -2880,7 +2847,7 @@ test_that("realistic LD: DENTIST-S detects outlier in correlated block", { test_that("realistic LD: no outliers when z perfectly matches LD structure", { set.seed(1002) - syn <- make_synthetic_ld(500, 10, seed = 1002) + syn <- makeSyntheticLd(500, 10, seed = 1002) R <- syn$R lead_idx <- 1 @@ -3124,7 +3091,7 @@ context("summaryStatsQc") test_that("summaryStatsQc: rejects non-SumStats input", { expect_error( summaryStatsQc("not_a_sumstats"), - "requires a QtlSumStats or GwasSumStats input" + "Must inherit from class 'QtlSumStats'/'GwasSumStats'" ) }) @@ -3140,7 +3107,10 @@ test_that("mafCutoff > 0 with no frequency skips the filter, not the run", { .package = "pecotmr" ) expect_warning( - res <- summaryStatsQc(ss, mafCutoff = 0.05), + res <- summaryStatsQc( + ss, + panelFilterArgs = PanelFilterParam(mafCutoff = 0.05) + ), "skipping the MAF filter" ) expect_s4_class(res, "GwasSumStats") @@ -3149,7 +3119,10 @@ test_that("mafCutoff > 0 with no frequency skips the filter, not the run", { test_that("summaryStatsQc: infoCutoff > 0 with no INFO column errors", { ss <- .ssQ_makeGwasSumStats() expect_error( - summaryStatsQc(ss, infoCutoff = 0.5), + summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(infoCutoff = 0.5) + ), "infoCutoff > 0 requires every entry to carry an INFO column" ) }) @@ -3174,7 +3147,11 @@ test_that("summaryStatsQc: PIP screen runs AFTER allele harmonization", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - out <- summaryStatsQc(ss, pipCutoffToSkip = 0.5, nCutoff = 0) + out <- summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(pip = 0.5), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) snps <- as.character(S4Vectors::mcols(out[[1L]])$SNP) expect_false("rsX" %in% snps) # dropped by harmonization # screen (post-harmonization) skips the region @@ -3182,7 +3159,7 @@ test_that("summaryStatsQc: PIP screen runs AFTER allele harmonization", { }) test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { - # Same harmonized variants, screen disabled (pipCutoffToSkip = 0): the three + # Same harmonized variants, screen disabled (no metric set): the three # panel-matched variants survive (behavior-invariance for the screen-off path). gr <- .ssQ_makeEntryGr( c("rs1", "rs2", "rs3", "rsX"), @@ -3197,7 +3174,11 @@ test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - out <- summaryStatsQc(ss, pipCutoffToSkip = 0, nCutoff = 0) + out <- summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) snps <- as.character(S4Vectors::mcols(out[[1L]])$SNP) # SNP is re-keyed to the panel-harmonized id (chr:pos:A2:A1) after # harmonization; the panel is A1=A / A2=G, so the surviving three become @@ -3240,7 +3221,11 @@ test_that("summaryStatsQc: harmonization re-keys SNP and sign-flips Z", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - out <- summaryStatsQc(ss, pipCutoffToSkip = 0, nCutoff = 0) + out <- summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) e <- out[[1L]] o <- order(GenomicRanges::start(e)) snp <- as.character(S4Vectors::mcols(e)$SNP)[o] @@ -3315,7 +3300,11 @@ test_that("a tag-named panel entry survives the end-to-end sketch subset", { genome = "hg19", ldSketch = h ) - out <- summaryStatsQc(ss, pipCutoffToSkip = 0, nCutoff = 0) + out <- summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) snp <- as.character(S4Vectors::mcols(out[[1L]])$SNP) expect_true("chr1:200:G:A" %in% snp) # the retained sketch keeps the panel row the QC'd entry still refers to @@ -3343,7 +3332,11 @@ test_that("the sketch survives a chr:pos:A1:A2 panel (PLINK .bim order)", { genome = "hg19", ldSketch = h ) - out <- summaryStatsQc(ss, pipCutoffToSkip = 0, nCutoff = 0) + out <- summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) kept <- pecotmr:::.ldSketchMatchIds(getLdSketch(out)) expect_length(kept, 4L) expect_setequal( @@ -3385,9 +3378,9 @@ test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants", { expect_no_error( out <- summaryStatsQc( ss, - zMismatchQc = "slalom", - pipCutoffToSkip = 0, - nCutoff = 0 + ldMismatchQcMethod = "slalom", + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) ) snp <- as.character(S4Vectors::mcols(out[[1L]])$SNP) @@ -3395,7 +3388,7 @@ test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants", { expect_equal(length(out[[1L]]), 3L) }) -test_that("summaryStatsQc: zMismatchQc reconciles a chr-prefix difference", { +test_that("summaryStatsQc: ldMismatchQc reconciles a chr-prefix difference", { # Panel SNP ids are non-chr-prefixed positional; QC re-keys the entry to the # canonical chr-prefixed form, so the opt-in z-mismatch panel match must # reconcile the prefix (previously errored "absent from the ldSketch panel"). @@ -3429,9 +3422,9 @@ test_that("summaryStatsQc: zMismatchQc reconciles a chr-prefix difference", { expect_no_error( out <- summaryStatsQc( ss, - zMismatchQc = "slalom", - pipCutoffToSkip = 0, - nCutoff = 0 + ldMismatchQcMethod = "slalom", + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) ) expect_gte(length(out[[1L]]), 1L) @@ -3526,7 +3519,7 @@ test_that("summaryStatsQc: PIP screen triggers when no variant has signal", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - res <- summaryStatsQc(ss, pipCutoffToSkip = 0.99) + res <- summaryStatsQc(ss, signalScreenArgs = SignalScreenParam(pip = 0.99)) ea <- getQcInfo(res)$entryAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) expect_match(ea$pipScreenReason, "no signals above PIP threshold") @@ -3544,9 +3537,11 @@ test_that("summaryStatsQc: options block records the curated knobs", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc( ss, - removeIndels = TRUE, - removeStrandAmbiguous = FALSE, - nCutoff = 10 + sumstatsFilterArgs = SumstatsFilterParam( + removeIndels = TRUE, + removeStrandAmbiguous = FALSE, + nCutoff = 10 + ) ) opts <- getQcInfo(res)$options expect_true(opts$removeIndels) @@ -3822,7 +3817,7 @@ test_that("summaryStatsQc: quantitative QtlSumStats: no effective N", { # summaryStatsQc with LD-mismatch QC enabled (mocked extractor) # =========================================================================== -test_that("summaryStatsQc: zMismatchQc 'dentist' walks the LD branch", { +test_that("summaryStatsQc: ldMismatchQcMethod 'dentist' walks the LD branch", { # Panel ids follow the chr:pos:A2:A1 convention (as real LD sketches do) so the # post-harmonization re-keyed SNP resolves against the panel for z-mismatch QC. ss <- GwasSumStats( @@ -3838,7 +3833,7 @@ test_that("summaryStatsQc: zMismatchQc 'dentist' walks the LD branch", { extractBlockGenotypes = .ssQ_mockExtractor(), .package = "pecotmr" ) - res <- suppressWarnings(summaryStatsQc(ss, zMismatchQc = "dentist")) + res <- suppressWarnings(summaryStatsQc(ss, ldMismatchQcMethod = "dentist")) ea <- getQcInfo(res)$entryAudit[[1L]] expect_equal(ea$ldMismatchMethod, "dentist") expect_true("ldMismatchOutliersDropped" %in% names(ea)) @@ -3881,7 +3876,11 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { ) # rs5/rs6 (pos 500/600) sit beyond the observed range (100-400); impute now # scopes to the region window, so widen it with a flank to reach them. - res <- summaryStatsQc(ss, impute = TRUE, imputeOpts = list(flank = 500)) + res <- summaryStatsQc( + ss, + impute = TRUE, + imputeArgs = RaissParam(flank = 500) + ) ea <- getQcInfo(res)$entryAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) expect_equal(ea$raissImputedVariants, 2L) @@ -3918,7 +3917,11 @@ test_that("summaryStatsQc: impute scopes panel/dosage to the region", { raiss = function(...) NULL, .package = "pecotmr" ) - suppressWarnings(summaryStatsQc(ss, impute = TRUE, nCutoff = 0)) + suppressWarnings(summaryStatsQc( + ss, + impute = TRUE, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + )) expect_gt(length(cap$idx), 0L) # No read reaches past the region window's 4 panel variants. expect_true(all(map_lgl(cap$idx, function(i) all(i %in% 1:4)))) @@ -4017,7 +4020,7 @@ test_that("summaryStatsQc: skipped steps are omitted from the rollup", { summaryStatsQc( ss, alleleFlipKriging = FALSE, - zMismatchQc = "none", + ldMismatchQcMethod = "none", impute = FALSE ) ) @@ -4386,7 +4389,10 @@ test_that("summaryStatsQc: surfaces the sanity audit, honours the knobs", { ea <- getQcInfo(res)$entryAudit[[1L]] expect_equal(ea$sanityChecks$zeroEffectDropped, 2L) # Disable the knob: zero-effect rows should remain. - res2 <- summaryStatsQc(ss, dropZeroEffect = FALSE) + res2 <- summaryStatsQc( + ss, + sumstatsCleaningArgs = SumstatsCleaningParam(dropZeroEffect = FALSE) + ) ea2 <- getQcInfo(res2)$entryAudit[[1L]] expect_null(ea2$sanityChecks$zeroEffectDropped) }) @@ -4643,11 +4649,13 @@ test_that("fine-mapping keeps onMissing='error' for an absent variant", { .ssTwin_opts <- function() { list( matchMinProp = 0, - removeIndels = FALSE, - removeStrandAmbiguous = TRUE, + sumstatsFilterArgs = SumstatsFilterParam( + removeIndels = FALSE, + removeStrandAmbiguous = TRUE + ), alleleFlipKriging = TRUE, nForPip = 1000, - zMismatchQc = "slalom" + ldMismatchQcMethod = "slalom" ) } @@ -4756,41 +4764,6 @@ test_that(".applyLdMismatchQcToEntry: NA slalom outlier flags are kept", { # Signal screen: metric resolver + absZ / bf / logBf metrics # =========================================================================== -test_that(".resolveScreenMetric enforces one metric and sane cutoffs", { - expect_null(pecotmr:::.resolveScreenMetric()) # all 0 -> off - expect_equal( - pecotmr:::.resolveScreenMetric(pipCutoffToSkip = 0.5), - list(metric = "pip", cutoff = 0.5) - ) - expect_equal( - pecotmr:::.resolveScreenMetric(absZCutoffToSkip = 5), - list(metric = "absZ", cutoff = 5) - ) - expect_equal( - pecotmr:::.resolveScreenMetric(bfCutoffToSkip = 100), - list(metric = "bf", cutoff = 100) - ) - expect_equal( - pecotmr:::.resolveScreenMetric(logBfCutoffToSkip = 3), - list(metric = "logBf", cutoff = 3) - ) - expect_error( - pecotmr:::.resolveScreenMetric( - pipCutoffToSkip = 0.5, - absZCutoffToSkip = 5 - ), - "one signal screen" - ) - expect_error( - pecotmr:::.resolveScreenMetric(absZCutoffToSkip = -1), - "must be > 0" - ) - expect_error( - pecotmr:::.resolveScreenMetric(bfCutoffToSkip = -1), - "must be > 0" - ) -}) - test_that(".asScreen canonicalizes screen specs", { expect_null(pecotmr:::.asScreen(NULL)) expect_null(pecotmr:::.asScreen(0)) @@ -4870,11 +4843,16 @@ test_that("summaryStatsQc: absZ / bf / logBf screens skip a no-signal entry", { ) } for (arg in list( - list(absZCutoffToSkip = 5), - list(bfCutoffToSkip = 100), - list(logBfCutoffToSkip = 5) + list(signalScreenArgs = SignalScreenParam(absZ = 5)), + list(signalScreenArgs = SignalScreenParam(bf = 100)), + list(signalScreenArgs = SignalScreenParam(logBf = 5)) )) { - res <- do.call(summaryStatsQc, c(list(mk()), arg, list(nCutoff = 0))) + res <- exec( + summaryStatsQc, + mk(), + !!!arg, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) ea <- getQcInfo(res)$entryAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) expect_equal(length(res[[1L]]), 0L) @@ -4892,7 +4870,11 @@ test_that("summaryStatsQc: absZ screen keeps a strong marginal Z", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - res <- summaryStatsQc(ss, absZCutoffToSkip = 5, nCutoff = 0) + res <- summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(absZ = 5), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) ea <- getQcInfo(res)$entryAudit[[1L]] expect_false(isTRUE(ea$pipScreenSkipped)) expect_gt(length(res[[1L]]), 0L) @@ -4901,8 +4883,11 @@ test_that("summaryStatsQc: absZ screen keeps a strong marginal Z", { test_that("summaryStatsQc: enabling two screens at once errors", { ss <- .ssQ_makeGwasSumStats() expect_error( - summaryStatsQc(ss, pipCutoffToSkip = 0.5, absZCutoffToSkip = 5), - "one signal screen" + summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(pip = 0.5, absZ = 5) + ), + "only one screening metric" ) }) @@ -4911,7 +4896,7 @@ context("dentist_qc") library(MASS) library(corpcor) -generate_dentist_data <- function( +generateDentistData <- function( seed = 42, nSnps = 100, sample_size = 100, @@ -4921,7 +4906,7 @@ generate_dentist_data <- function( ) { set.seed(seed) cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -4930,19 +4915,16 @@ generate_dentist_data <- function( diag(cor_matrix) <- 1 ld_matrix <- cov2cor(make.positive.definite(cor_matrix)) z_scores <- mvrnorm(n = 1, mu = rep(0, nSnps), Sigma = ld_matrix) - outlier_indices <- sample(1:nSnps, n_outliers) + outlier_indices <- sample(seq_len(nSnps), n_outliers) z_scores[outlier_indices] <- rnorm(n_outliers, mean = 0, sd = 5) sumstat <- data.frame( - position = unlist(lapply( - seq(start_pos, end_pos, length.out = nSnps), - round - )), + position = map_dbl(seq(start_pos, end_pos, length.out = nSnps), round), z = z_scores ) return(list(sumstat = sumstat, ldMat = ld_matrix, nSample = sample_size)) } -generate_dentist_single_window_data <- function( +generateDentistSingleWindowData <- function( seed = 42, nSnps = 100, sample_size = 100, @@ -4950,7 +4932,7 @@ generate_dentist_single_window_data <- function( ) { set.seed(seed) cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -4959,7 +4941,7 @@ generate_dentist_single_window_data <- function( diag(cor_matrix) <- 1 ld_matrix <- cov2cor(make.positive.definite(cor_matrix)) z_scores <- mvrnorm(n = 1, mu = rep(0, nSnps), Sigma = ld_matrix) - outlier_indices <- sample(1:nSnps, n_outliers) + outlier_indices <- sample(seq_len(nSnps), n_outliers) z_scores[outlier_indices] <- rnorm(n_outliers, mean = 0, sd = 5) return(list(z_scores = z_scores, ldMat = ld_matrix, nSample = sample_size)) } @@ -4969,7 +4951,7 @@ generate_dentist_single_window_data <- function( # =========================================================================== test_that("dentist output has exactly N rows for N input variants", { - data <- generate_dentist_data(nSnps = 100) + data <- generateDentistData(nSnps = 100) expect_warning( res <- dentist(data$sumstat, R = data$ldMat, nSample = data$nSample) ) @@ -4977,41 +4959,41 @@ test_that("dentist output has exactly N rows for N input variants", { }) test_that("dentist output has exactly N rows with correctChenEtAlBug = FALSE", { - data <- generate_dentist_data(nSnps = 100) + data <- generateDentistData(nSnps = 100) expect_warning( res <- dentist( data$sumstat, R = data$ldMat, nSample = data$nSample, - correctChenEtAlBug = FALSE + methodArgs = DentistParam(correctChenEtAlBug = FALSE) ) ) expect_equal(nrow(res), 100) }) test_that("dentist stops when missing position", { - data <- generate_dentist_data() + data <- generateDentistData() colnames(data$sumstat) <- c("something", "z") expect_error( dentist( data$sumstat, R = data$ldMat, nSample = data$nSample, - correctChenEtAlBug = FALSE + methodArgs = DentistParam(correctChenEtAlBug = FALSE) ), regexp = "missing either.*pos.*or.*z" ) }) test_that("dentist stops when missing zscore", { - data <- generate_dentist_data() + data <- generateDentistData() colnames(data$sumstat) <- c("position", "something") expect_error( dentist( data$sumstat, R = data$ldMat, nSample = data$nSample, - correctChenEtAlBug = FALSE + methodArgs = DentistParam(correctChenEtAlBug = FALSE) ), regexp = "missing either.*pos.*or.*z" ) @@ -5022,7 +5004,7 @@ test_that("dentist accepts 'position' and 'zscore' column names", { nSnps <- 80 n_samples <- 100 cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -5062,7 +5044,7 @@ test_that("dentist with X matrix input returns exactly N rows", { # =========================================================================== test_that("dentistSingleWindow returns exactly N rows for N input z-scores", { - data <- generate_dentist_single_window_data() + data <- generateDentistSingleWindowData() expect_warning( res <- dentistSingleWindow( data$z_scores, @@ -5074,7 +5056,7 @@ test_that("dentistSingleWindow returns exactly N rows for N input z-scores", { }) test_that("dentistSingleWindow warns when < 2000 variants", { - data <- generate_dentist_single_window_data() + data <- generateDentistSingleWindowData() expect_warning(dentistSingleWindow( data$z_scores, R = data$ldMat, @@ -5083,11 +5065,11 @@ test_that("dentistSingleWindow warns when < 2000 variants", { }) test_that("dentistSingleWindow stops on a zscore/LD dimension mismatch", { - data <- generate_dentist_single_window_data() + data <- generateDentistSingleWindowData() expect_warning(expect_error( dentistSingleWindow( - generate_dentist_single_window_data()$z_scores, - R = generate_dentist_single_window_data(nSnps = 80)$ldMat, + generateDentistSingleWindowData()$z_scores, + R = generateDentistSingleWindowData(nSnps = 80)$ldMat, nSample = data$nSample ), regexp = "ldMat must be a square matrix" @@ -5095,7 +5077,7 @@ test_that("dentistSingleWindow stops on a zscore/LD dimension mismatch", { }) test_that("dentistSingleWindow output columns are correct", { - data <- generate_dentist_single_window_data() + data <- generateDentistSingleWindowData() expect_warning( res <- dentistSingleWindow( data$z_scores, @@ -5116,7 +5098,7 @@ test_that("dentistSingleWindow output columns are correct", { }) test_that("dentistSingleWindow original_z matches input z-scores", { - data <- generate_dentist_single_window_data() + data <- generateDentistSingleWindowData() expect_warning( res <- dentistSingleWindow( data$z_scores, @@ -5142,7 +5124,7 @@ test_that("dentistSingleWindow with X matrix input returns exactly N rows", { }) test_that("dentistSingleWindow correctChenEtAlBug = FALSE returns N rows", { - data <- generate_dentist_single_window_data() + data <- generateDentistSingleWindowData() expect_warning( res <- dentistSingleWindow( data$z_scores, @@ -5156,7 +5138,7 @@ test_that("dentistSingleWindow correctChenEtAlBug = FALSE returns N rows", { }) test_that("dentistSingleWindow with gcControl = TRUE returns N rows", { - data <- generate_dentist_single_window_data() + data <- generateDentistSingleWindowData() expect_warning( res <- dentistSingleWindow( data$z_scores, @@ -5170,13 +5152,13 @@ test_that("dentistSingleWindow with gcControl = TRUE returns N rows", { }) test_that("dentist with gcControl = TRUE returns N rows", { - data <- generate_dentist_data(nSnps = 100) + data <- generateDentistData(nSnps = 100) expect_warning( res <- dentist( data$sumstat, R = data$ldMat, nSample = data$nSample, - gcControl = TRUE + methodArgs = DentistParam(gcControl = TRUE) ) ) expect_equal(nrow(res), 100) @@ -5187,7 +5169,7 @@ test_that("dentistSingleWindow dedup path with message for duplicates", { nSnps <- 80 n_samples <- 100 cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in 1:(nSnps - 1)) { + for (i in seq_len(nSnps - 1)) { for (j in (i + 1):nSnps) { cor_matrix[i, j] <- runif(1, 0.2, 0.8) cor_matrix[j, i] <- cor_matrix[i, j] @@ -5282,11 +5264,11 @@ test_that("segment_by_dist fill regions cover all input positions", { res <- pecotmr:::segmentByDist(pos, maxDist = 2000000, minDim = 10) # Collect all fill region indices covered <- integer(0) - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { covered <- c(covered, res$fillStartIdx[k]:(res$fillEndIdx[k] - 1L)) } # Every position from 1 to length(pos) should be covered - expect_equal(sort(unique(covered)), 1:length(pos)) + expect_equal(sort(unique(covered)), seq_along(pos)) }) test_that("segment_by_dist errors on empty positions", { @@ -5355,7 +5337,7 @@ test_that("segment_by_count produces valid windows", { # All window ends should be <= length(pos) + 1 expect_true(all(res$windowEndIdx <= length(pos) + 1)) # Fill regions should be within windows - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { expect_true(res$fillStartIdx[k] >= res$windowStartIdx[k]) expect_true(res$fillEndIdx[k] <= res$windowEndIdx[k]) } @@ -5365,10 +5347,10 @@ test_that("segment_by_count fill regions cover all positions", { pos <- seq(1000000, by = 1000, length.out = 500) res <- pecotmr:::segmentByCount(pos, maxCount = 100) covered <- integer(0) - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { covered <- c(covered, res$fillStartIdx[k]:(res$fillEndIdx[k] - 1L)) } - expect_equal(sort(unique(covered)), 1:length(pos)) + expect_equal(sort(unique(covered)), seq_along(pos)) }) test_that("segment_by_count handles centromeric gap", { @@ -5382,10 +5364,10 @@ test_that("segment_by_count handles centromeric gap", { expect_true(nrow(res) >= 2) # Fill regions should still cover all positions covered <- integer(0) - for (k in 1:nrow(res)) { + for (k in seq_len(nrow(res))) { covered <- c(covered, res$fillStartIdx[k]:(res$fillEndIdx[k] - 1L)) } - expect_equal(sort(unique(covered)), 1:length(pos)) + expect_equal(sort(unique(covered)), seq_along(pos)) }) test_that("segment_by_count skips blocks smaller than half max_count", { @@ -5434,7 +5416,7 @@ test_that("segment_by_count verbose mode prints intervals", { # =========================================================================== test_that("merge_windows returns exactly N rows", { - data <- generate_dentist_data( + data <- generateDentistData( nSnps = 1000, sample_size = 1000, start_pos = 0, @@ -5447,7 +5429,7 @@ test_that("merge_windows returns exactly N rows", { ) dentist_result_by_window <- list() suppressWarnings({ - for (k in 1:nrow(window_divided_res)) { + for (k in seq_len(nrow(window_divided_res))) { idx_range <- window_divided_res$windowStartIdx[ k ]:(window_divided_res$windowEndIdx[k] - 1L) @@ -5463,7 +5445,7 @@ test_that("merge_windows returns exactly N rows", { nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - ncpus = 1, + numThreads = 1, correctChenEtAlBug = TRUE ) } @@ -5518,7 +5500,7 @@ test_that("merge_windows correctly indexes and merges windows", { test_that("dentist windowed output has exactly N rows for large input", { # Generate data large enough to trigger windowed mode (> min_dim) - data <- generate_dentist_data( + data <- generateDentistData( seed = 123, nSnps = 1000, sample_size = 1000, @@ -5539,7 +5521,7 @@ test_that("dentist windowed output has exactly N rows for large input", { }) test_that("dentist outlier_stat formula is correct: (z-imputed)^2/(1-rsq)", { - data <- generate_dentist_single_window_data(seed = 55, nSnps = 100) + data <- generateDentistSingleWindowData(seed = 55, nSnps = 100) expect_warning( res <- dentistSingleWindow( data$z_scores, @@ -5557,7 +5539,7 @@ test_that("dentist outlier_stat formula is correct: (z-imputed)^2/(1-rsq)", { # =========================================================================== test_that("dentist with window_mode='count' returns exactly N rows", { - data <- generate_dentist_data( + data <- generateDentistData( seed = 789, nSnps = 500, sample_size = 500, @@ -5597,25 +5579,25 @@ test_that("segment_by_dist and segment_by_count agree on even spacing", { # Both should cover all positions covered_dist <- integer(0) - for (k in 1:nrow(res_dist)) { + for (k in seq_len(nrow(res_dist))) { covered_dist <- c( covered_dist, res_dist$fillStartIdx[k]:(res_dist$fillEndIdx[k] - 1L) ) } covered_count <- integer(0) - for (k in 1:nrow(res_count)) { + for (k in seq_len(nrow(res_count))) { covered_count <- c( covered_count, res_count$fillStartIdx[k]:(res_count$fillEndIdx[k] - 1L) ) } - expect_equal(sort(unique(covered_dist)), 1:n) - expect_equal(sort(unique(covered_count)), 1:n) + expect_equal(sort(unique(covered_dist)), seq_len(n)) + expect_equal(sort(unique(covered_count)), seq_len(n)) }) test_that("both windowing modes produce same dentist results on uniform data", { - data <- generate_dentist_data( + data <- generateDentistData( seed = 555, nSnps = 500, sample_size = 500, @@ -5839,7 +5821,11 @@ test_that("summaryStatsQc: preserves nCase/nControl columns through QC", { nControl = 1500 ) expect_true(all(c("nCase", "nControl") %in% colnames(S4Vectors::mcols(ss)))) - out <- summaryStatsQc(ss, pipCutoffToSkip = 0, nCutoff = 0) + out <- summaryStatsQc( + ss, + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) expect_true(all( c("nCase", "nControl") %in% colnames(S4Vectors::mcols(out)) )) @@ -6239,7 +6225,7 @@ test_that("raissSingleMatrix coerces a data.frame LD matrix and is verbose", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -6364,7 +6350,7 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { ref_panel <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), stringsAsFactors = FALSE @@ -6395,7 +6381,7 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { all_known <- data.frame( chrom = rep(1, p), pos = seq(10, p * 10, 10), - variant_id = paste0("rs", 1:p), + variant_id = paste0("rs", seq_len(p)), A1 = rep("A", p), A2 = rep("G", p), z = rnorm(p), @@ -6418,7 +6404,7 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { # =========================================================================== test_that("raiss genotypeMatrix: single, list, all-fail and bad-type", { - data <- generate_X_test_data(n = 60, p = 20, n_known = 10, seed = 3) + data <- generateXTestData(n = 60, p = 20, n_known = 10, seed = 3) # Single matrix, verbose -> "Processing genotype matrix via SVD..." expect_message( @@ -6568,8 +6554,8 @@ ssqcOverlapImputedBlocks <- function(seed = 5) { mkBlock <- function(ids) { nb <- length(ids) m <- matrix(0, nb, nb) - for (a in 1:nb) { - for (b in 1:nb) { + for (a in seq_len(nb)) { + for (b in seq_len(nb)) { m[a, b] <- if (a == b) 1 else 0.9^abs(a - b) } } @@ -6632,7 +6618,7 @@ test_that("raiss multi-LD-block: messages and an imputed boundary merge", { }) test_that("raiss multi-LD-block: stops on a block dimension mismatch", { - td <- generate_block_diagonal_test_data( + td <- generateBlockDiagonalTestData( seed = 2, block_structure = "non_overlapping", n_variants = 30 @@ -6652,7 +6638,7 @@ test_that("raiss multi-LD-block: stops on a block dimension mismatch", { }) test_that("raiss multi-LD-block: NULL when no block has known variants", { - td <- generate_block_diagonal_test_data( + td <- generateBlockDiagonalTestData( seed = 3, block_structure = "non_overlapping", n_variants = 30 @@ -6706,28 +6692,6 @@ test_that("raissModel batch = FALSE reports the condition number", { # krigingOutlierQc: non-square LD stop + variantIds defaulting to rownames # =========================================================================== -test_that("krigingOutlierQc requires a square LD matrix aligned to zScore", { - expect_error( - krigingOutlierQc(c(1, 2, 3), diag(2), n = 100), - "square LD matrix" - ) -}) - -test_that("krigingOutlierQc defaults variantIds to rownames(R)", { - skip_if_not( - "kriging_rss" %in% getNamespaceExports("susieR"), - "installed susieR has no kriging_rss" - ) - m <- 6 - R <- matrix(0.6, m, m) - diag(R) <- 1 - ids <- paste0("1:", seq_len(m) * 100, ":A:G") - rownames(R) <- colnames(R) <- ids - z <- rep(2, m) - kr <- krigingOutlierQc(z, R, n = 1000) # no variantIds passed - expect_equal(kr$diagnostics$variant_id, ids) -}) - # =========================================================================== # .safeSvd: all singular values below tolerance # =========================================================================== @@ -6832,7 +6796,10 @@ test_that("summaryStatsQc: emit() drops the label for an empty study id", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - msgs <- capture_messages(summaryStatsQc(ss, nCutoff = 0)) + msgs <- capture_messages(summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + )) joined <- paste(msgs, collapse = "") expect_match(joined, "QC summary:") # No bracketed label prefix appears on the rollup line. @@ -6848,7 +6815,12 @@ test_that("summaryStatsQc: the N filter emits its message and rollup", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - msgs <- capture_messages(res <- summaryStatsQc(ss, nCutoff = 3)) + msgs <- capture_messages( + res <- summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 3) + ) + ) joined <- paste(msgs, collapse = "") expect_match(joined, "MAF/INFO/N filters kept") expect_match(joined, "nCutoff 1") @@ -6875,7 +6847,10 @@ test_that("summaryStatsQc: derives BETA/SE from Z+MAF+N, records it", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - res <- summaryStatsQc(ss, nCutoff = 0) + res <- summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) ea <- getQcInfo(res)$entryAudit[[1L]] expect_equal(ea$betaSeFromZ$nDerived, 4L) }) @@ -6889,7 +6864,10 @@ test_that("summaryStatsQc: clamps tiny Z-derived P and audits it", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - res <- summaryStatsQc(ss, nCutoff = 0) + res <- summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) ea <- getQcInfo(res)$entryAudit[[1L]] expect_true(!is.null(ea$sanityChecks$smallPClamped)) expect_gte(ea$sanityChecks$smallPClamped, 1L) @@ -6903,7 +6881,10 @@ test_that("summaryStatsQc: early-exits below two pre-harmonization variants", { genome = "hg19", ldSketch = .ssQ_makeHandle() ) - res <- summaryStatsQc(ss, nCutoff = 0) + res <- summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + ) ea <- getQcInfo(res)$entryAudit[[1L]] expect_match(ea$earlyExit, "fewer than two variants") expect_equal(length(res[[1L]]), 1L) @@ -6931,8 +6912,8 @@ test_that("summaryStatsQc: kriging QC records its audit and rollup", { res <- summaryStatsQc( ss, alleleFlipKriging = TRUE, - pipCutoffToSkip = 0, - nCutoff = 0 + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) ) joined <- paste(msgs, collapse = "") @@ -6987,7 +6968,11 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { .package = "pecotmr" ) # rs5/rs6 (pos 500/600) are beyond the observed range; widen the impute window. - res <- summaryStatsQc(ss, impute = TRUE, imputeOpts = list(flank = 500)) + res <- summaryStatsQc( + ss, + impute = TRUE, + imputeArgs = RaissParam(flank = 500) + ) ea <- getQcInfo(res)$entryAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) expect_equal(ea$raissImputedVariants, 2L) @@ -7124,9 +7109,11 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { msgs <- capture_messages( res <- summaryStatsQc( ss, - mafCutoff = 0.01, - infoCutoff = 0.5, - nCutoff = 3 + sumstatsFilterArgs = SumstatsFilterParam( + infoCutoff = 0.5, + nCutoff = 3 + ), + panelFilterArgs = PanelFilterParam(mafCutoff = 0.01) ) ) joined <- paste(msgs, collapse = "") @@ -7285,7 +7272,7 @@ test_that("segmentByDist keeps a last window that clears the cutoff", { }) test_that("raiss multi-LD-block skips a NULL middle block, keeps the rest", { - td <- generate_block_diagonal_test_data( + td <- generateBlockDiagonalTestData( seed = 11, block_structure = "non_overlapping", n_variants = 30 @@ -7328,9 +7315,12 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { n <- length(getSampleIds(handle)) k <- length(snpIdx) f <- rnorm(n) # shared latent factor - M <- sapply(seq_len(k), function(j) { - sqrt(0.7) * f + sqrt(0.3) * rnorm(n) - }) + M <- exec( + cbind, + !!!map(seq_len(k), function(j) { + sqrt(0.7) * f + sqrt(0.3) * rnorm(n) + }) + ) rr <- GenomicRanges::GRanges( seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( @@ -7379,8 +7369,8 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { summaryStatsQc( ss, alleleFlipKriging = TRUE, - pipCutoffToSkip = 0, - nCutoff = 0 + signalScreenArgs = SignalScreenParam(pip = 0), + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) ) ea <- getQcInfo(res)$entryAudit[[1L]] @@ -7556,7 +7546,11 @@ test_that("summaryStatsQc: mafCutoff drops panel-rare observed variants", { maf <- .ssqcPanelMaf(h) cutoff <- stats::median(maf, na.rm = TRUE) ss <- .ssqcPanelSumStats(h) - out <- suppressMessages(summaryStatsQc(ss, mafCutoff = cutoff, nCutoff = 0)) + out <- suppressMessages(summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0), + panelFilterArgs = PanelFilterParam(mafCutoff = cutoff) + )) entry <- pecotmr:::.collectionEntry(out, 1) expect_equal(length(entry), sum(!is.na(maf) & maf >= cutoff)) # ... and the panel carried on the result -- the seed handle every LD @@ -7577,7 +7571,11 @@ test_that("summaryStatsQc: macCutoff is the stricter of MAF / MAC", { # MAC expressed per panel sample: 2 * nSamples * mafEquivalent. cutoff <- stats::median(maf, na.rm = TRUE) mac <- ceiling(cutoff * 2 * getNSamples(h)) - out <- suppressMessages(summaryStatsQc(ss, macCutoff = mac, nCutoff = 0)) + out <- suppressMessages(summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0), + panelFilterArgs = PanelFilterParam(macCutoff = mac) + )) entry <- pecotmr:::.collectionEntry(out, 1) expected <- sum(!is.na(maf) & maf >= mac / (2 * getNSamples(h))) expect_equal(length(entry), expected) @@ -7587,7 +7585,10 @@ test_that("summaryStatsQc: the panel filter is off by default", { skip_if_not_installed("pgenlibr") h <- .ssqcPanelHandle() ss <- .ssqcPanelSumStats(h) - out <- suppressMessages(summaryStatsQc(ss, nCutoff = 0)) + out <- suppressMessages(summaryStatsQc( + ss, + sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) + )) expect_equal( length(pecotmr:::.collectionEntry(out, 1)), nrow(getSnpInfo(h)) @@ -7596,10 +7597,34 @@ test_that("summaryStatsQc: the panel filter is off by default", { test_that("summaryStatsQc validates the panel cutoffs before any panel read", { ss <- .ssQ_makeGwasSumStats() - expect_error(summaryStatsQc(ss, mafCutoff = -1), "mafCutoff") - expect_error(summaryStatsQc(ss, macCutoff = c(1, 2)), "macCutoff") - expect_error(summaryStatsQc(ss, imissCutoff = NA_real_), "imissCutoff") - expect_error(summaryStatsQc(ss, macCutoff = Inf), "macCutoff") + expect_error( + summaryStatsQc( + ss, + panelFilterArgs = PanelFilterParam(mafCutoff = -1) + ), + "mafCutoff" + ) + expect_error( + summaryStatsQc( + ss, + panelFilterArgs = PanelFilterParam(macCutoff = c(1, 2)) + ), + "macCutoff" + ) + expect_error( + summaryStatsQc( + ss, + panelFilterArgs = PanelFilterParam(imissCutoff = NA_real_) + ), + "imissCutoff" + ) + expect_error( + summaryStatsQc( + ss, + panelFilterArgs = PanelFilterParam(macCutoff = Inf) + ), + "macCutoff" + ) }) @@ -7621,7 +7646,7 @@ test_that("summaryStatsQc validates the panel cutoffs before any panel read", { set.seed(1) nS <- 100L af <- c(runif(20L, 0.2, 0.4), runif(20L, 0.002, 0.01)) - dosage <- vapply(af, function(f) rbinom(nS, 2L, f), numeric(nS)) + dosage <- exec(cbind, !!!map(af, function(f) rbinom(nS, 2L, f))) ids <- sprintf("chr1:%d:A:G", 1000L * seq_along(af)) colnames(dosage) <- ids dosage[1:60, 3] <- NA @@ -7653,7 +7678,7 @@ test_that("summaryStatsQc validates the panel cutoffs before any panel read", { f$refPanel, f$knownZ, f$dosage, - list(imputeOpts = list(...)) + list(imputeArgs = as.list(RaissParam(...))) ) } @@ -7735,7 +7760,7 @@ test_that(".qcRaissTargetMask drops a target whose MAF is undefined", { expect_false(keep[[12]]) }) -test_that("summaryStatsQc imputeOpts cutoffs bound what RAISS imputes", { +test_that("summaryStatsQc imputeArgs cutoffs bound what RAISS imputes", { data(gwasSumStatsS4Example) gss <- gwasSumStatsS4Example variants <- unlist(gss) @@ -7753,7 +7778,10 @@ test_that("summaryStatsQc imputeOpts cutoffs bound what RAISS imputes", { out <- suppressWarnings(suppressMessages(summaryStatsQc( thin, impute = TRUE, - imputeOpts = utils::modifyList(base, list(...)) + imputeArgs = do.call( + RaissParam, + utils::modifyList(base, list(...)) + ) ))) sum(lengths(out)) } @@ -8214,3 +8242,203 @@ test_that("an allele swap complements af but leaves the directionless maf", { expect_equal(h$Z, -2.0) expect_equal(h$MAF, 0.2) }) + +test_that("sumstatsQc: argument guards fire", { + expect_error( + mergeVariantInfo(data.frame(), data.frame(), all = NA), + "all.*May not be NA" + ) + expect_error( + autoDecision(data.frame(), highCorrCols = 1L), + "highCorrCols.*Must be of type 'character'" + ) +}) + +test_that(".entrySnpIds answers character(0) for a NULL entry", { + expect_identical(pecotmr:::.entrySnpIds(NULL), character(0)) +}) + +test_that("SlalomParam / DentistParam carry defaults and reject a typo", { + sa <- SlalomParam(r2Threshold = 0.8) + expect_s4_class(sa, "SlalomParam") + expect_equal(sa$r2Threshold, 0.8) + expect_equal(sa$abfPriorVariance, 0.04) + da <- DentistParam(propSVD = 0.5) + expect_equal(da$propSVD, 0.5) + expect_equal(da$nIter, 10) + # Our own engines, so no `...`: R itself rejects an unknown name. + expect_error(SlalomParam(zzz = 1), "unused argument") + expect_error(DentistParam(zzz = 1), "unused argument") +}) + +test_that("SlalomParam leaves the data-dependent standardError to slalom", { + # slalom defaults it to rep(1, length(zScore)), which no static default + # can express, so a NULL default is dropped rather than forwarded. + expect_false(is_in("standardError", names(SlalomParam()))) + expect_true(is_in("standardError", names(SlalomParam(standardError = 1)))) +}) + +test_that("ldMismatchQc takes a name or a constructor for method", { + set.seed(1) + n <- 60L + p <- 8L + X <- matrix(rnorm(n * p), n, p) + z <- rnorm(p) + R <- cor(X) + byName <- ldMismatchQc(z, R = R, nSample = n, method = "slalom") + byCtor <- ldMismatchQc(z, R = R, nSample = n, method = SlalomParam()) + # A bare name means the engine with no options set, which is exactly what + # an unconfigured constructor produces. + expect_identical(byName, byCtor) +}) + +test_that("ldMismatchQc forwards the constructor's options to the engine", { + set.seed(1) + n <- 60L + p <- 8L + z <- rnorm(p) + R <- cor(matrix(rnorm(n * p), n, p)) + cap <- new.env(parent = emptyenv()) + local_mocked_bindings( + slalom = .ssq_captureSlalom(cap), + .package = "pecotmr" + ) + ldMismatchQc( + z, + R = R, + nSample = n, + method = SlalomParam(r2Threshold = 0.9) + ) + expect_equal(cap$r2Threshold, 0.9) +}) + +test_that("ldMismatchQc rejects a constructor for another engine", { + set.seed(1) + z <- rnorm(4L) + R <- diag(4L) + expect_error( + ldMismatchQc(z, R = R, nSample = 50L, method = PlinkQcOptions()), + "unknown engine" + ) +}) + +test_that("summaryStatsQc takes a constructor for ldMismatchQcMethod", { + expect_error( + pecotmr:::.resolveLdMismatchChoice("nope"), + "unknown engine 'nope'" + ) + expect_equal(pecotmr:::.resolveLdMismatchChoice("none"), "none") + expect_s4_class( + pecotmr:::.resolveLdMismatchChoice(DentistParam()), + "DentistParam" + ) +}) + +# ============================================================================= +# RaissParam() +# ============================================================================= + +test_that("RaissParam carries every field the QC imputation path reads", { + a <- RaissParam() + expect_s4_class(a, "RaissParam") + expect_setequal( + names(a), + c( + "lamb", + "svdTol", + "r2Threshold", + "minimumLd", + "mafCutoff", + "macCutoff", + "imissCutoff", + "flank" + ) + ) +}) + +test_that("RaissParam refuses rcond, which the QC path cannot use", { + # summaryStatsQc always hands RAISS a genotype matrix, which solves via + # .raissSvdImpute (svdTol). rcond belongs to the LD-matrix path, so it was + # advertised in the old imputeOpts default and read by nobody. + expect_error(RaissParam(rcond = 0.01), "unused argument") + expect_true("rcond" %in% names(formals(raiss))) + expect_false("rcond" %in% names(RaissParam())) +}) + +test_that("RaissParam fields split into raiss formals and pecotmr's own", { + forwarded <- c("lamb", "svdTol", "r2Threshold", "minimumLd") + expect_true(all(forwarded %in% names(formals(raiss)))) + # The rest scope what RAISS is asked to impute; they are not raiss formals + # and are consumed before the call. + ours <- c("mafCutoff", "macCutoff", "imissCutoff", "flank") + expect_false(any(ours %in% names(formals(raiss)))) +}) + +test_that("summaryStatsQc refuses a bare list for imputeArgs", { + data(gwasSumStatsS4Example) + expect_error( + summaryStatsQc(gwasSumStatsS4Example, imputeArgs = list(flank = 500)), + "must be built with RaissParam" + ) +}) + +test_that("an empty imputeArgs resolves to the full default bundle", { + resolved <- pecotmr:::.ssqcResolveImputeArgs(list()) + expect_equal(resolved, as.list(RaissParam())) + # Every read site indexes this without a fallback, so a missing field + # would surface as NULL rather than a default. + expect_false(any(map_lgl(resolved, is.null))) +}) + +test_that("the forwarded half of RaissParam is exactly raiss's own formals", { + fwd <- pecotmr:::.raissForwardedNames() + expect_true(all(fwd %in% names(formals(raiss)))) + # The other half never reaches raiss; splicing it in would be an error. + rest <- setdiff(names(RaissParam()), fwd) + expect_false(any(rest %in% names(formals(raiss)))) + expect_setequal( + names(pecotmr:::.raissForwardedArgs(RaissParam())), + fwd + ) +}) + +test_that("SumstatsCleaningParam is separate from SumstatsFilterParam", { + # Cleaning decides whether a row is a well-formed record; filtering + # applies quality thresholds to rows that already are. No field overlaps. + expect_length( + intersect( + names(formals(SumstatsCleaningParam)), + names(formals(SumstatsFilterParam)) + ), + 0L + ) +}) + +test_that("every SumstatsCleaningParam field is one the resolver hands on", { + expect_setequal( + names(formals(SumstatsCleaningParam)), + names(pecotmr:::.sumstatsCleaningResolve(SumstatsCleaningParam())) + ) + # And every one of them is an .applySanityChecks argument, since the + # resolved record is spliced straight into it. + expect_true(all( + names(pecotmr:::.sumstatsCleaningResolve(SumstatsCleaningParam())) %in% + names(formals(pecotmr:::.applySanityChecks)) + )) +}) + +test_that(".sumstatsCleaningResolve fills defaults an empty bundle omits", { + # .applySanityChecks tests these with `if (!flag)`, so a missing field + # must not arrive as NULL. + res <- pecotmr:::.sumstatsCleaningResolve(list()) + expect_equal( + res, + pecotmr:::.sumstatsCleaningResolve(SumstatsCleaningParam()) + ) + expect_true(res$coerceNumeric) + expect_equal(res$smallPFloor, 5e-324) + expect_error( + pecotmr:::.sumstatsCleaningResolve(list(coerceNumeric = FALSE)), + "must be built with SumstatsCleaningParam" + ) +}) diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 16ff494a9..28a5e931b 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -14,9 +14,9 @@ setClass("TsTestCollection", contains = "RangedTupleList") rep(list(GenomicRanges::GRanges()), n) ) if (length(cols) > 0L) { - S4Vectors::mcols(grl) <- do.call( + S4Vectors::mcols(grl) <- exec( S4Vectors::DataFrame, - c(cols, list(check.names = FALSE)) + !!!c(cols, list(check.names = FALSE)) ) } methods::new("TsTestCollection", grl) @@ -114,7 +114,7 @@ test_that(".tupleSelectRow: non-scalar selectors error", { trait = "t1", method = "susie" ), - "must each be length 1" + "Must have length 1" ) }) @@ -212,7 +212,7 @@ test_that(".tupleSelectRowGwasFmr: non-scalar region errors", { method = "susie", region = c("r1", "r2") ), - "`region` must be length 1" + "region.*Must have length 1" ) }) @@ -472,7 +472,10 @@ test_that(".appendTraitPosCol: traitPos must be a GRanges of matching length", { test_that(".validateTraitPosColumn: reports non-GRanges and wrong-length traitPos", { expect_equal( pecotmr:::.validateTraitPosColumn(.ts_coll(traitPos = c("x", "y"))), - "'traitPos' column must be a GRanges" + str_c( + "'traitPos' column Must inherit from class 'GRanges', ", + "but has class 'character'" + ) ) # A one-range traitPos beside two rows: assigned through the mcols # listData because the parallel-length check would reject it otherwise, @@ -628,3 +631,7 @@ test_that(".twrRowResolveWeights drops rows whose weights are all NA", { expect_equal(kept$variantIds, "chr1:2:C:T") expect_equal(kept$weights, 0.5) }) + +test_that(".ssConcatChr answers character(0) for no pieces", { + expect_identical(pecotmr:::.ssConcatChr(list()), character(0)) +}) diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index ca88040b5..7225b2e09 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -3,10 +3,10 @@ context("twasWeights") # --------------------------------------------------------------------------- # Shared synthetic data generator # --------------------------------------------------------------------------- -make_data <- function(n = 50, p = 10, seed = 42, add_zero_var_col = FALSE) { +makeData <- function(n = 50, p = 10, seed = 42, add_zero_var_col = FALSE) { set.seed(seed) X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("sample_", seq_len(n)) beta <- rep(0, p) @@ -26,7 +26,7 @@ make_data <- function(n = 50, p = 10, seed = 42, add_zero_var_col = FALSE) { list(X = X, Y = Y, beta = beta) } -make_fake_susie_fit <- function(p = 10, L = 3, inf = FALSE) { +makeFakeSusieFit <- function(p = 10, L = 3, inf = FALSE) { fit <- list( alpha = matrix(1 / p, nrow = L, ncol = p), mu = matrix(0, nrow = L, ncol = p), @@ -42,10 +42,10 @@ make_fake_susie_fit <- function(p = 10, L = 3, inf = FALSE) { fit } -mock_susie <- function(...) { +mockSusie <- function(...) { args <- list(...) L <- if (is.null(args$L)) 3 else args$L - make_fake_susie_fit( + makeFakeSusieFit( ncol(args$X), L = L, inf = identical(args$unmappable_effects, "inf") @@ -91,6 +91,42 @@ mock_susie <- function(...) { # # =========================================================================== +# Simulate a small (X, Y) pair. Local to this file: it was a helper-*.R +# shared with the causal-inference tests, which never adopted it. +generateXY <- function( + seed = 1, + numSamples = 10, + numFeatures = 10, + xRownames = TRUE, + yRownames = TRUE +) { + set.seed(seed) + X <- scale( + matrix(rnorm(numSamples * numFeatures), nrow = numSamples), + center = TRUE, + scale = TRUE + ) + + if (xRownames) { + rownames(X) <- paste0("sample", seq_len(numSamples)) + } else { + rownames(X) <- NULL + } + + beta <- rep(0, numFeatures) + beta[1:4] <- 1 + y <- X %*% beta + rnorm(numSamples) + y <- matrix(y, nrow = numSamples, ncol = 1) + if (yRownames) { + rownames(y) <- paste0("sample", seq_len(numSamples)) + } else { + rownames(y) <- NULL + } + colnames(y) <- c("Outcome") + + return(list(X = X, Y = y)) +} + test_that(".twas_method_lookup: 'default' preset returns 10 methods", { result <- pecotmr:::.twasMethodLookup("default") expected_names <- c( @@ -138,13 +174,11 @@ test_that(".twas_method_lookup: unknown method produces error", { ) }) -test_that(".twas_method_lookup: default args are set for susie and mrash", { +test_that(".twas_method_lookup: default args are set for mrash, not susie", { result <- pecotmr:::.twasMethodLookup("fastDefault") - expect_equal(result$susie_weights$refine, FALSE) - # Matches susieR::susie's own defaults (L = min(10, p), greedy loop off), - # as fineMappingPipeline does. - expect_equal(result$susie_weights$L, 10) - expect_null(result$susie_weights$L_greedy) + # susie carries NO fitting defaults: susieWeights extracts from a supplied + # fit and never runs susie, so `refine` / `L` would have nothing to configure. + expect_length(result$susie_weights, 0L) expect_equal(result$mrash_weights$initPriorSd, TRUE) expect_equal(result$mrash_weights$max.iter, 100) }) @@ -178,7 +212,7 @@ test_that(".twas_method_lookup: all DPR variants can coexist", { # =========================================================================== test_that("twasPredict: basic matrix multiplication is correct", { - d <- make_data(n = 20, p = 5) + d <- makeData(n = 20, p = 5) set.seed(99) w <- matrix(runif(5), ncol = 1) rownames(w) <- colnames(d$X) @@ -190,7 +224,7 @@ test_that("twasPredict: basic matrix multiplication is correct", { }) test_that("twasPredict: multiple weight methods in list", { - d <- make_data(n = 20, p = 5) + d <- makeData(n = 20, p = 5) w1 <- matrix(c(1, 0, 0, 0, 0), ncol = 1) w2 <- matrix(c(0, 0, 0, 0, 1), ncol = 1) wl <- list(method_a_weights = w1, method_b_weights = w2) @@ -228,7 +262,7 @@ test_that("twasPredict: names without _weights suffix are kept unchanged", { }) test_that("twasPredict: single column Y dimension preserved", { - d <- make_data(n = 10, p = 4) + d <- makeData(n = 10, p = 4) w <- matrix(rep(0.25, 4), ncol = 1) wl <- list(avg_weights = w) res <- twasPredict(d$X, wl) @@ -265,26 +299,26 @@ test_that("twasPredict: zero weights give zero predictions", { # =========================================================================== test_that("twasWeights: X must be a matrix", { - d <- make_data() + d <- makeData() expect_error( learnTwasWeights(as.data.frame(d$X), d$Y, weightMethods = list()), - "X must be a matrix" + "X.*Must be of type 'matrix'" ) }) test_that("twasWeights: Y must be a matrix or vector", { - d <- make_data() + d <- makeData() # In R, is.vector(list(...)) returns TRUE, so a list passes the initial # type check and gets converted via matrix(). The resulting matrix has # 1 row which mismatches X's 50 rows, triggering the row count error. expect_error( learnTwasWeights(d$X, list(d$Y), weightMethods = list()), - "The number of rows in X and Y must be the same" + "One of the following must apply" ) }) test_that("twasWeights: Y as vector gets converted to matrix internally", { - d <- make_data() + d <- makeData() y_vec <- as.numeric(d$Y) # Mock lassoWeights (an existing package function) to return trivial weights @@ -294,7 +328,7 @@ test_that("twasWeights: Y as vector gets converted to matrix internally", { result <- learnTwasWeights( d$X, y_vec, - weightMethods = list(lassoWeights = list()) + weightMethods = list(lasso_weights = list()) ) expect_true(is(result, "TwasWeights")) expect_equal(length(getMethodNames(result)), 1) @@ -307,16 +341,16 @@ test_that("twasWeights: Y as vector gets converted to matrix internally", { }) test_that("twasWeights: mismatched row counts error", { - d <- make_data(n = 50, p = 10) + d <- makeData(n = 50, p = 10) Y_short <- d$Y[1:30, , drop = FALSE] expect_error( learnTwasWeights(d$X, Y_short, weightMethods = list()), - "The number of rows in X and Y must be the same" + "Y.*Must have exactly 50 rows" ) }) test_that("twasWeights: character weight_methods input is accepted", { - d <- make_data() + d <- makeData() local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0, ncol(X)) ) @@ -327,7 +361,7 @@ test_that("twasWeights: character weight_methods input is accepted", { }) test_that("twasWeights: zero variance columns are filtered and padded back with zeros", { - d <- make_data(n = 50, p = 10, add_zero_var_col = TRUE) + d <- makeData(n = 50, p = 10, add_zero_var_col = TRUE) p_with_extra <- ncol(d$X) # 11 columns, last is zero-var local_mocked_bindings( @@ -340,7 +374,7 @@ test_that("twasWeights: zero variance columns are filtered and padded back with result <- learnTwasWeights( d$X, d$Y, - weightMethods = list(lassoWeights = list()) + weightMethods = list(lasso_weights = list()) ) # The returned weight matrix should have rows equal to total columns (including zero-var) @@ -353,7 +387,7 @@ test_that("twasWeights: zero variance columns are filtered and padded back with }) test_that("twasWeights: rownames of result match colnames of X", { - d <- make_data() + d <- makeData() local_mocked_bindings( enetWeights = function(X, y, ...) rep(0.1, ncol(X)) ) @@ -369,7 +403,7 @@ test_that("twasWeights: rownames of result match colnames of X", { }) test_that("twasWeights: result dimensions match ncol(X) x ncol(Y)", { - d <- make_data() + d <- makeData() local_mocked_bindings( enetWeights = function(X, y, ...) rep(0, ncol(X)) ) @@ -385,7 +419,7 @@ test_that("twasWeights: result dimensions match ncol(X) x ncol(Y)", { }) test_that("twasWeights: multiple methods return named list with one entry per method", { - d <- make_data() + d <- makeData() local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0.1, ncol(X)), enetWeights = function(X, y, ...) rep(0.2, ncol(X)) @@ -393,7 +427,7 @@ test_that("twasWeights: multiple methods return named list with one entry per me result <- learnTwasWeights( d$X, d$Y, - weightMethods = list(lassoWeights = list(), enetWeights = list()) + weightMethods = list(lasso_weights = list(), enetWeights = list()) ) expect_equal(length(getMethodNames(result)), 2) expect_true("lasso" %in% getMethodNames(result)) @@ -408,11 +442,11 @@ test_that("twasWeights: multiple methods return named list with one entry per me test_that("twasWeights: lassoWeights produces correct structure with real glmnet", { skip_if_not_installed("glmnet") - d <- make_data(n = 50, p = 10) + d <- makeData(n = 50, p = 10) result <- learnTwasWeights( d$X, d$Y, - weightMethods = list(lassoWeights = list()) + weightMethods = list(lasso_weights = list()) ) expect_true(is(result, "TwasWeights")) @@ -425,7 +459,7 @@ test_that("twasWeights: lassoWeights produces correct structure with real glmnet test_that("twasWeights: enetWeights produces correct structure with real glmnet", { skip_if_not_installed("glmnet") - d <- make_data(n = 50, p = 10) + d <- makeData(n = 50, p = 10) result <- learnTwasWeights( d$X, d$Y, @@ -444,14 +478,14 @@ test_that("twasWeights: enetWeights produces correct structure with real glmnet" # =========================================================================== test_that("twasWeightsCv: NULL weight_methods returns only samplePartition", { - d <- make_data() + d <- makeData() result <- twasWeightsCv(d$X, d$Y, fold = 3, weightMethods = NULL) expect_equal(names(result), "samplePartition") expect_true(is.data.frame(result$samplePartition)) }) test_that("twasWeightsCv: samplePartition structure is correct", { - d <- make_data() + d <- makeData() result <- twasWeightsCv(d$X, d$Y, fold = 5, weightMethods = NULL) sp <- result$samplePartition @@ -464,7 +498,7 @@ test_that("twasWeightsCv: samplePartition structure is correct", { }) test_that("twasWeightsCv: character weight_methods are accepted", { - d <- make_data() + d <- makeData() local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0, ncol(X)) ) @@ -485,14 +519,14 @@ test_that("twasWeightsCv: character weight_methods are accepted", { test_that("twasWeightsCv: basic CV with lassoWeights produces correct metrics structure", { skip_if_not_installed("glmnet") - d <- make_data(n = 50, p = 10) + d <- makeData(n = 50, p = 10) set.seed(123) result <- twasWeightsCv( d$X, d$Y, fold = 3, - weightMethods = list(lassoWeights = list()) + weightMethods = list(lasso_weights = list()) ) # Structure checks @@ -524,7 +558,7 @@ test_that("twasWeightsCv: basic CV with lassoWeights produces correct metrics st test_that("twasWeightsCv: multiple real methods produce per-method metrics", { skip_if_not_installed("glmnet") - d <- make_data(n = 50, p = 10) + d <- makeData(n = 50, p = 10) set.seed(99) result <- twasWeightsCv( @@ -552,7 +586,7 @@ test_that("twasWeightsCv: multiple real methods produce per-method metrics", { # =========================================================================== test_that("twasWeightsCv: multivariate Y with multiple columns", { - d <- make_data(n = 50, p = 10) + d <- makeData(n = 50, p = 10) # Create multi-column Y set.seed(42) Y_multi <- cbind( @@ -570,7 +604,7 @@ test_that("twasWeightsCv: multivariate Y with multiple columns", { d$X, Y_multi, fold = 2, - weightMethods = list(lassoWeights = list()) + weightMethods = list(lasso_weights = list()) ) pred <- result$prediction[["lasso_predicted"]] @@ -588,65 +622,74 @@ test_that("twasWeightsCv: multivariate Y with multiple columns", { # # =========================================================================== -test_that("twasWeights: SuSiE-inf is fitted before and initializes ordinary SuSiE", { - d <- make_data(n = 50, p = 10) - y_vec <- as.numeric(d$Y) - susie_calls <- list() +test_that("learnTwasWeights refuses the susie + susieInf pair without fits", { + # The chained susieInf -> susie fit lives in fineMappingPipeline() now; + # learnTwasWeights never fine-maps, so the pair is an error here. + # fitSusieInfThenSusie() itself is covered in test_fineMappingWrappers.R. + d <- makeData(n = 50, p = 10) + expect_error( + learnTwasWeights( + d$X, + as.numeric(d$Y), + weightMethods = list( + susie_weights = list(), + susie_inf_weights = list() + ) + ), + "susie, susieInf" + ) +}) + +test_that("learnTwasWeights resolves fits under camelCase method names", { + # `susieWeights` and `susie_weights` name the same method; a fit supplied + # for one spelling must land on the other's arguments too. + d <- makeData(n = 50, p = 10) + seen <- NULL local_mocked_bindings( - susieInfWeights = function(X, y, ...) rep(0, ncol(X)), - susieWeights = function(X, y, ...) { + susieWeights = function(X, y, susieFit = NULL, ...) { + seen <<- susieFit rep(0, ncol(X)) } ) - # The two chained SuSiE fits now run through .fmFitSusieIndiv, which calls - # susieR::susie, so capture at the susieR namespace. - local_mocked_bindings( - susie = function(...) { - args <- list(...) - susie_calls[[length(susie_calls) + 1]] <<- args - make_fake_susie_fit( - p = ncol(args$X), - L = if (identical(args$unmappable_effects, "inf")) { - 7 - } else { - args$L - }, - inf = identical(args$unmappable_effects, "inf") - ) - }, - .package = "susieR" + learnTwasWeights( + d$X, + as.numeric(d$Y), + weightMethods = list(susie_weights = list()), + fittedModels = list(susie = makeFakeSusieFit(p = 10, L = 5)) ) + expect_true("susie" %in% class(seen)) +}) + +test_that("learnTwasWeights runs susie + susieInf from supplied fits", { + d <- makeData(n = 50, p = 10) + local_mocked_bindings( + susieInfWeights = function(X, y, ...) rep(0, ncol(X)), + susieWeights = function(X, y, ...) rep(0, ncol(X)) + ) result <- learnTwasWeights( d$X, - y_vec, + as.numeric(d$Y), weightMethods = list( - susie_weights = list(L = 5, L_greedy = 3), + susie_weights = list(), susie_inf_weights = list() + ), + fittedModels = list( + susie = makeFakeSusieFit(p = 10, L = 5), + susieInf = makeFakeSusieFit(p = 10, L = 7, inf = TRUE) ) ) - expect_equal(getMethodNames(result), c("susie", "susie_inf")) - expect_length(susie_calls, 2) - expect_equal(susie_calls[[1]]$unmappable_effects, "inf") - expect_equal(susie_calls[[1]]$convergence_method, "pip") - expect_equal(susie_calls[[2]]$unmappable_effects, "none") - expect_true("susieInf" %in% class(susie_calls[[2]]$model_init)) - expect_equal(susie_calls[[2]]$L_greedy, 5) }) -# =========================================================================== -# twasWeightsCv: extra split_data / sample-name / variant-selection branches -# =========================================================================== - test_that("twasWeightsCv: NA values in Y trigger NA-removal branch in metrics", { set.seed(42) n <- 30 p <- 5 X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n), ncol = 1) rownames(Y) <- rownames(X) @@ -666,19 +709,19 @@ test_that("twasWeightsCv: NA values in Y trigger NA-removal branch in metrics", X, Y, fold = 2, - weightMethods = list(lassoWeights = list()) + weightMethods = list(lasso_weights = list()) ) perf <- result$performance[["lasso_performance"]] # NA-removal branch ran; metrics should be finite (not all-NA) expect_true(is.finite(perf[1, "rsq"])) }) -test_that("twasWeightsCv: multivariate cv_args data_driven_priorMatricesCv is plumbed through", { +test_that("twasWeightsCv: dataDrivenPriorMatricesCv is plumbed through", { set.seed(42) n <- 20 p <- 4 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") @@ -703,18 +746,17 @@ test_that("twasWeightsCv: multivariate cv_args data_driven_priorMatricesCv is pl Y, fold = 2, weightMethods = list(mrmashWeights = list()), - data_driven_priorMatricesCv = prior_cv + dataDrivenPriorMatricesCv = prior_cv ) # mrmashWeights mock should have been called and received the per-fold prior # matrix under the camelCase name that actually binds mrmashWrapper's # `dataDrivenPriorMatrices` argument (the snake_case form was a latent no-op). expect_true(length(captured_args) >= 1) - expect_true(any(vapply( + expect_true(any(map_lgl( captured_args, function(a) { "dataDrivenPriorMatrices" %in% names(a) - }, - logical(1) + } ))) }) @@ -732,7 +774,7 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns p <- 5 X <- matrix(rnorm(n * p), nrow = n, ncol = p) # all columns valid (no zero variance) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) Y <- matrix(rnorm(n * 2), nrow = n, ncol = 2) colnames(Y) <- c("y1", "y2") @@ -747,7 +789,7 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns ncol = ncol(Y) ) rownames(m) <- c( - sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + sprintf("chr1:%d:A:G", 100L * seq_len(p)), "extra1", "extra2" ) @@ -765,7 +807,7 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns expect_equal(ncol(.weightsByMethod(result, "mrmashWeights")), 2) expect_equal( rownames(.weightsByMethod(result, "mrmashWeights")), - sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + sprintf("chr1:%d:A:G", 100L * seq_len(p)) ) }) @@ -774,14 +816,16 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns # =========================================================================== test_that("twasWeightsCv is reproducible with seed", { - sim <- generate_X_Y(seed = 1) + sim <- generateXY(seed = 1) X <- sim$X - y = sim$Y + y <- sim$Y local_mocked_bindings( - susieWeights = function(X, y, ...) rnorm(ncol(X)), + enetWeights = function(X, y, ...) rnorm(ncol(X)), glmnetWeights = function(X, y, ...) runif(ncol(X)) ) - weight_methods_test <- list(susieWeights = list(), glmnetWeights = list()) + # Non-SuSiE methods: this test is about the seeded fold partition, and a + # SuSiE-family token now requires per-fold fits it has no reason to carry. + weight_methods_test <- list(enetWeights = list(), glmnetWeights = list()) set.seed(1) result_seed1 <- twasWeightsCv( X, @@ -801,19 +845,22 @@ test_that("twasWeightsCv is reproducible with seed", { test_that("twasWeightsCv handles errors appropriately", { - sim <- generate_X_Y(seed = 1) + sim <- generateXY(seed = 1) X <- sim$X - y = sim$Y + y <- sim$Y local_mocked_bindings( susieWeights = function(X, y, ...) rnorm(ncol(X)), glmnetWeights = function(X, y, ...) runif(ncol(X)) ) - weight_methods_test <- list(susieWeights = list(), glmnetWeights = list()) + weight_methods_test <- list(susie = list(), glmnetWeights = list()) expect_error(twasWeightsCv(X, y, fold = NULL), "fold.*samplePartitions") - expect_error(twasWeightsCv(X, y, fold = "invalid"), "positive integer") - expect_error(twasWeightsCv(X, y, fold = -1), "positive integer") - expect_error(twasWeightsCv(2, y, fold = 2), "must be a matrix") - expect_error(twasWeightsCv(X, 2, fold = 2), "number of rows") + expect_error( + twasWeightsCv(X, y, fold = "invalid"), + "Must be of type 'count'" + ) + expect_error(twasWeightsCv(X, y, fold = -1), "Must be >= 1") + expect_error(twasWeightsCv(2, y, fold = 2), "Must be of type 'matrix'") + expect_error(twasWeightsCv(X, 2, fold = 2), "Y.*Must have exactly 10 rows") expect_error( twasWeightsCv( matrix(rnorm(4, nrow = 2)), @@ -827,20 +874,20 @@ test_that("twasWeightsCv handles errors appropriately", { test_that("learnTwasWeights handles errors appropriately", { - sim <- generate_X_Y(seed = 1) + sim <- generateXY(seed = 1) X <- sim$X - y = sim$Y + y <- sim$Y local_mocked_bindings( susieWeights = function(X, y, ...) rnorm(ncol(X)), glmnetWeights = function(X, y, ...) runif(ncol(X)) ) - weight_methods_test <- list(susieWeights = list(), glmnetWeights = list()) + weight_methods_test <- list(susie = list(), glmnetWeights = list()) expect_error( learnTwasWeights( matrix(rnorm(4, nrow = 2)), matrix(rnorm(2, nrow = 1)) ), - "unused argument" + "weightMethods.*is missing" ) expect_error(learnTwasWeights(X, y), "weightMethods") }) @@ -1343,26 +1390,24 @@ test_that(".resolveMethodFunction: unresolvable key falls back to the key itself # # =========================================================================== -test_that(".prepareSusieWeightMethods: seeds susie_weights from a supplied susieInf fit (vector Y)", { - d <- make_data(n = 40, p = 8) - y_vec <- as.numeric(d$Y) # vector -> exercises the Y matrix coercion - infFit <- make_fake_susie_fit(p = 8, L = 3, inf = TRUE) +test_that(".prepareSusieWeightMethods writes supplied fits onto the method args", { + infFit <- makeFakeSusieFit(p = 8, L = 3, inf = TRUE) + susieFit <- makeFakeSusieFit(p = 8, L = 5) wm <- pecotmr:::.prepareSusieWeightMethods( - d$X, - y_vec, weightMethods = list( - susie_weights = list(L = 5), + susie_weights = list(), susie_inf_weights = list() ), - fittedModels = list(susieInf = infFit) + fittedModels = list(susie = susieFit, susieInf = infFit) ) - # The supplied susieInf fit is class-tagged and propagated onto susie_inf_weights, - # and susie_weights is rebuilt from it (model_init carries the inf fit). + # Each supplied fit is class-tagged and lands on its own method's args. + # susie's fitting arguments are NOT derived from the inf fit: that + # prepares a susie fit, which belongs to fineMappingPipeline(). expect_true("susieInf" %in% class(wm$susie_inf_weights$susieInfFit)) - expect_true("susieInf" %in% class(wm$susie_weights$model_init)) - expect_equal(wm$susie_weights$unmappable_effects, "none") + expect_true("susie" %in% class(wm$susie_weights$susieFit)) + expect_null(wm$susie_weights$model_init) }) # =========================================================================== @@ -1372,8 +1417,8 @@ test_that(".prepareSusieWeightMethods: seeds susie_weights from a supplied susie # =========================================================================== test_that("twasWeightsCv: warns when no random seed has been set", { - d <- make_data(n = 20, p = 5) - # make_data() set a seed; drop it just before the call so the unset-seed + d <- makeData(n = 20, p = 5) + # makeData() set a seed; drop it just before the call so the unset-seed # branch (verbose>=1) is exercised. The fold-sampling at line ~713 restores # .Random.seed afterwards, so later tests are unaffected. if (exists(".Random.seed", envir = .GlobalEnv)) { @@ -1390,7 +1435,7 @@ test_that("twasWeightsCv: mvsusie per-fold reweighted prior is plumbed (verbose= n <- 24 p <- 4 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") @@ -1410,31 +1455,36 @@ test_that("twasWeightsCv: mvsusie per-fold reweighted prior is plumbed (verbose= ) prior_cv <- list(matrix(1, 2, 2), matrix(2, 2, 2)) set.seed(1) + # A SuSiE-family token needs that fold's own fit; the fitter is mocked + # here, so a stub per fold is enough to reach the per-fold prior path. + sp <- suppressMessages(twasWeightsCv(X, Y, fold = 2))$samplePartition + foldFits <- list(fold_1 = "FIT1", fold_2 = "FIT2") + attr(foldFits, "partitionKey") <- pecotmr:::.cvPartitionKey(sp) result <- suppressMessages(twasWeightsCv( X, Y, - fold = 2, + samplePartitions = sp, weightMethods = list(mvsusieWeights = list()), reweightedMixturePriorCv = prior_cv, + fittedModelsCv = list(mvsusie = foldFits), verbose = 2 )) expect_true("prediction" %in% names(result)) # the per-fold prior_variance was forwarded to the multivariate fitter - expect_true(any(vapply( + expect_true(any(map_lgl( captured, function(a) { "prior_variance" %in% names(a) - }, - logical(1) + } ))) }) -test_that("twasWeightsCv: retainFits forwards retainFit to a multivariate fitter that supports it", { +test_that("twasWeightsCv forwards fitRetention to a fitter that takes it", { set.seed(42) n <- 24 p <- 4 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") @@ -1442,8 +1492,9 @@ test_that("twasWeightsCv: retainFits forwards retainFit to a multivariate fitter captured <- list() local_mocked_bindings( - mrmashWeights = function(X, Y, retainFit = FALSE, ...) { - captured[[length(captured) + 1]] <<- list(retainFit = retainFit) + mrmashWeights = function(X, Y, fitRetention = "none", ...) { + captured[[length(captured) + 1]] <<- + list(fitRetention = fitRetention) matrix( 0, nrow = ncol(X), @@ -1458,18 +1509,17 @@ test_that("twasWeightsCv: retainFits forwards retainFit to a multivariate fitter Y, fold = 2, weightMethods = list(mrmashWeights = list()), - retainFits = TRUE + fitRetention = "slim" )) expect_true("foldFits" %in% names(result)) - expect_true(all(vapply( + expect_true(all(map_lgl( captured, - function(a) isTRUE(a$retainFit), - logical(1) + function(a) identical(a$fitRetention, "slim") ))) }) test_that("twasWeightsCv: univariate fitter runs under verbose=2 (no quiet wrapper)", { - d <- make_data(n = 30, p = 6) + d <- makeData(n = 30, p = 6) local_mocked_bindings( lassoWeights = function(X, y, ...) { w <- rep(0, ncol(X)) @@ -1482,7 +1532,7 @@ test_that("twasWeightsCv: univariate fitter runs under verbose=2 (no quiet wrapp d$X, d$Y, fold = 2, - weightMethods = list(lassoWeights = list()), + weightMethods = list(lasso_weights = list()), verbose = 2 )) expect_true("prediction" %in% names(result)) @@ -1491,31 +1541,25 @@ test_that("twasWeightsCv: univariate fitter runs under verbose=2 (no quiet wrapp # =========================================================================== # -# learnTwasWeights: retainFits plumbing + verbose=2 + parallel +# learnTwasWeights: fitRetention plumbing + verbose=2 + parallel # # =========================================================================== -test_that("learnTwasWeights: multivariate fitter with retainFits + verbose=2 (fitDetail forwarded)", { +test_that("learnTwasWeights: multivariate fitter, fitRetention + verbose=2", { set.seed(42) n <- 24 p <- 5 X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) Y <- matrix(rnorm(n * 2), nrow = n) colnames(Y) <- c("y1", "y2") captured <- list() local_mocked_bindings( - mrmashWeights = function( - X, - Y, - retainFit = FALSE, - fitDetail = c("slim", "full"), - ... - ) { + mrmashWeights = function(X, Y, fitRetention = "none", ...) { captured[[length(captured) + 1]] <<- - list(retainFit = retainFit, fitDetail = fitDetail) + list(fitRetention = fitRetention) matrix( 0, nrow = ncol(X), @@ -1528,20 +1572,21 @@ test_that("learnTwasWeights: multivariate fitter with retainFits + verbose=2 (fi X, Y, weightMethods = list(mrmashWeights = list()), - retainFits = TRUE, + fitRetention = "slim", verbose = 2 )) expect_true(is(result, "TwasWeights")) - expect_true(isTRUE(captured[[1]]$retainFit)) - expect_equal(captured[[1]]$fitDetail, "slim") + expect_equal(captured[[1]]$fitRetention, "slim") }) -test_that("learnTwasWeights: legacy retain_fit alias is forwarded to methods exposing it", { - d <- make_data(n = 30, p = 6) - captured <- list() +test_that("a method that takes no fitRetention is left alone", { + # Retention is passed only to a weight function that declares it; one + # that does not keeps nothing, and must not be handed the argument. + d <- makeData(n = 30, p = 6) + seen <- NULL local_mocked_bindings( - bayesRWeights = function(X, y, retain_fit = FALSE, ...) { - captured[[length(captured) + 1]] <<- list(retain_fit = retain_fit) + bayesRWeights = function(X, y, ...) { + seen <<- names(list(...)) rep(0, ncol(X)) } ) @@ -1549,21 +1594,21 @@ test_that("learnTwasWeights: legacy retain_fit alias is forwarded to methods exp d$X, d$Y, weightMethods = list(bayesRWeights = list()), - retainFits = TRUE + fitRetention = "slim" )) expect_true(is(result, "TwasWeights")) - expect_true(isTRUE(captured[[1]]$retain_fit)) + expect_false("fitRetention" %in% seen) }) test_that("learnTwasWeights: univariate fitter runs under verbose=2", { - d <- make_data(n = 30, p = 6) + d <- makeData(n = 30, p = 6) local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0.2, ncol(X)) ) result <- suppressMessages(learnTwasWeights( d$X, d$Y, - weightMethods = list(lassoWeights = list()), + weightMethods = list(lasso_weights = list()), verbose = 2 )) expect_true(is(result, "TwasWeights")) @@ -1571,7 +1616,7 @@ test_that("learnTwasWeights: univariate fitter runs under verbose=2", { }) test_that("learnTwasWeights: parallel weights path (numThreads = 2)", { - d <- make_data(n = 30, p = 6) + d <- makeData(n = 30, p = 6) local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0.1, ncol(X)), enetWeights = function(X, y, ...) rep(0.2, ncol(X)) @@ -1579,7 +1624,7 @@ test_that("learnTwasWeights: parallel weights path (numThreads = 2)", { result <- suppressMessages(learnTwasWeights( d$X, d$Y, - weightMethods = list(lassoWeights = list(), enetWeights = list()), + weightMethods = list(lasso_weights = list(), enetWeights = list()), numThreads = 2 )) expect_true(is(result, "TwasWeights")) @@ -1598,11 +1643,11 @@ test_that("twasPredict: accepts a TwasWeights S4 collection", { w1 <- rnorm(p) w2 <- rnorm(p) e1 <- twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = w1 ) e2 <- twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(p))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = w2 ) tw <- TwasWeights( @@ -1629,14 +1674,11 @@ test_that("validity names the missing key and payload columns", { data(twasWeightsExample) bad <- twasWeightsExample S4Vectors::mcols(bad)$method <- NULL - expect_equal( - pecotmr:::.twasValidateRequiredCols(bad), - "missing columns: method" - ) - expect_equal( - pecotmr:::.twasValidateRequiredCols(twasWeightsExample), - character() + expect_error( + methods::validObject(bad), + "missing elements \\{'method'\\}" ) + expect_true(methods::validObject(twasWeightsExample)) bad2 <- twasWeightsExample S4Vectors::mcols(bad2)$cvResult <- NULL expect_equal( @@ -1673,15 +1715,17 @@ test_that(".twasApplyRownames leaves weights alone when X has no colnames", { test_that(".twasBadColMsg names the offending column and its class", { expect_equal( - as.character(pecotmr:::.twasBadColMsg("study", data.frame(study = 1:2))), + as.character(pecotmr:::.twasBadColMsg( + "study", + data.frame(study = 1:2) + )), "'study' column must be character (got integer)" ) }) test_that(".twasMethodRows keeps a per-outcome context vector", { vids <- c("chr1:100:A:G", "chr1:200:C:T") - Y <- matrix(0, nrow = 4L, ncol = 2L, - dimnames = list(NULL, c("y1", "y2"))) + Y <- matrix(0, nrow = 4L, ncol = 2L, dimnames = list(NULL, c("y1", "y2"))) wMat <- matrix( c(0.1, 0.2, 0.3, 0.4), nrow = 2L, @@ -1689,25 +1733,595 @@ test_that(".twasMethodRows keeps a per-outcome context vector", { ) mkCtx <- function(contexts) { list( - Y = Y, trait = c("t1", "t2"), context = contexts, study = "s1", - retainFits = FALSE, standardized = TRUE, dataType = "rnaseq" + Y = Y, + trait = c("t1", "t2"), + context = contexts, + study = "s1", + fitRetention = "none", + standardized = TRUE, + dataType = "rnaseq" ) } # One context per outcome column: used as-is, not recycled. perOutcome <- pecotmr:::.twasMethodRows( - "lasso_weights", wMat, vids, mkCtx(c("cA", "cB")) + "lasso_weights", + wMat, + vids, + mkCtx(c("cA", "cB")) ) expect_length(perOutcome, 2L) expect_equal( - vapply(perOutcome, function(z) z$context, character(1)), + map_chr(perOutcome, function(z) z$context), c("cA", "cB") ) # A single context is recycled across the outcomes instead. recycled <- pecotmr:::.twasMethodRows( - "lasso_weights", wMat, vids, mkCtx("cOnly") + "lasso_weights", + wMat, + vids, + mkCtx("cOnly") ) expect_equal( - vapply(recycled, function(z) z$context, character(1)), + map_chr(recycled, function(z) z$context), c("cOnly", "cOnly") ) }) + +test_that("twasWeightsCv: argument guards fire", { + d <- generateXY(seed = 1) + base <- list(X = d$X, Y = d$Y, fold = 2, weightMethods = list()) + expect_error( + exec( + twasWeightsCv, + !!!list_modify(base, !!!list(samplePartitions = 1L)) + ), + "samplePartitions.*Must be of type 'data.frame'" + ) + expect_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(maxNumVariants = 0))), + "maxNumVariants.*is not >= 1" + ) + expect_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(numThreads = 1.5))), + "numThreads.*Must be of type 'single integerish value'" + ) + expect_error( + exec( + twasWeightsCv, + !!!list_modify(base, !!!list(fitRetention = "sometimes")) + ), + "must be one of" + ) + expect_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(seed = "x"))), + "seed.*Must be of type 'single integerish value'" + ) + # Inf is the documented "no cap" sentinel and must still be accepted. + expect_no_error( + exec(twasWeightsCv, !!!list_modify(base, !!!list(maxNumVariants = Inf))) + ) +}) + +test_that("learnTwasWeights: argument guards fire", { + d <- generateXY(seed = 1) + base <- list(X = d$X, Y = d$Y, weightMethods = list()) + expect_error( + exec(learnTwasWeights, !!!list_modify(base, !!!list(study = 1L))), + "study.*Must be of type 'string'" + ) + # Called directly, not via modifyList(): modifyList() DROPS an element + # whose value is NULL, so the argument would fall back to its default. + expect_error( + learnTwasWeights( + d$X, + d$Y, + weightMethods = list(), + standardized = NULL + ), + "standardized.*Must be of type 'logical flag'" + ) + expect_error( + exec(learnTwasWeights, !!!list_modify(base, !!!list(dataType = 1L))), + "dataType.*Must be of type 'string'" + ) + expect_error( + exec( + learnTwasWeights, + !!!list_modify(base, !!!list(weightMethods = 1L)) + ), + "weightMethods.*One of the following must apply" + ) +}) + +test_that("twasPredict: weightsList must be a list or TwasWeights", { + expect_error( + twasPredict(matrix(0, 2, 2), "nope"), + "weightsList.*One of the following must apply" + ) +}) + +# --------------------------------------------------------------------------- +# Cross-validating a SuSiE-family method. Those wrappers extract from a +# supplied fit and never fine-map, so CV is only possible when +# fineMappingPipeline's own CV retained each fold's fit. +# --------------------------------------------------------------------------- + +.twcv_foldFits <- function(seed = 11, fold = 3) { + set.seed(seed) + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:40] + y <- eqtlRegionExample$yRes + Y <- matrix(y, ncol = 1, dimnames = list(rownames(X), "t1")) + cv <- pecotmr:::.fmWeightsCv( + X, + Y, + tokens = "susie", + methodArgs = list(), + fold = fold, + verbose = 0, + seed = 1 + ) + list(X = X, Y = Y, cv = cv, slice = pecotmr:::.fmSliceCv(cv, "susie")) +} + +test_that("fineMappingPipeline CV retains a lean per-fold fit", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + expect_false(is.null(f$cv$foldFits)) + expect_equal(names(f$cv$foldFits), c("fold_1", "fold_2", "fold_3")) + # lean: only the fields the weight extractors read + fit1 <- f$cv$foldFits[["fold_1"]][["susie"]] + expect_true(all(c("pip", "alpha", "mu") %in% names(fit1))) + expect_false("lbf_variable" %in% names(fit1)) + # and it slices per method onto the row payload + expect_equal(names(f$slice$foldFits), c("fold_1", "fold_2", "fold_3")) +}) + +test_that("twasWeightsCv cannot cross-validate susie without the fold fits", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + samplePartitions = f$slice$samplePartition, + weightMethods = list(susie_weights = list()), + verbose = 0 + )), + "never run fine-mapping themselves" + ) +}) + +test_that("twasWeightsCv cross-validates susie from the retained fold fits", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + out <- suppressMessages(twasWeightsCv( + f$X, + f$Y, + samplePartitions = f$slice$samplePartition, + weightMethods = list(susie_weights = list()), + fittedModelsCv = list(susie = f$slice$foldFits), + verbose = 0 + )) + expect_true(all(c("prediction", "performance") %in% names(out))) + expect_false(is.null(out$prediction)) +}) + +test_that(".twasFoldFit injects the fold's fit under the adapter's fit arg", { + ff <- list(susie = list(fold_1 = "FIT1", fold_2 = "FIT2")) + a <- pecotmr:::.twasFoldFit(list(), "susie_weights", 2L, ff) + expect_identical(a$susieFit, "FIT2") + # a method with no fine-mapping adapter is untouched + b <- pecotmr:::.twasFoldFit(list(), "lasso_weights", 1L, ff) + expect_length(b, 0L) + # and so is the NULL case + expect_length(pecotmr:::.twasFoldFit(list(), "susie_weights", 1L, NULL), 0L) +}) + +test_that("twasWeightsCv refuses fold fits from a different partition", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + wm <- list(susie = list()) + + # (a) no partition at all: a freshly drawn one would score each fold with + # a fit that saw its held-out samples. + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + weightMethods = wm, + verbose = 0, + fittedModelsCv = list(susie = f$slice$foldFits) + )), + "needs the fold partition" + ) + + # (b) fits with no fingerprint cannot be shown to match. + unstamped <- f$slice$foldFits + attr(unstamped, "partitionKey") <- NULL + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + weightMethods = wm, + verbose = 0, + samplePartitions = f$slice$samplePartition, + fittedModelsCv = list(susie = unstamped) + )), + "no partition fingerprint" + ) + + # (c) a genuinely different split is caught by the fingerprint. + other <- suppressMessages(pecotmr:::.fmWeightsCv( + f$X, + f$Y, + tokens = "susie", + methodArgs = list(), + fold = 3, + verbose = 0, + seed = 77 + )) + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + weightMethods = wm, + verbose = 0, + samplePartitions = other$samplePartition, + fittedModelsCv = list(susie = f$slice$foldFits) + )), + "trained on a different fold partition" + ) +}) + +test_that(".cvPartitionKey ignores row order but not fold assignment", { + sp <- data.frame(Sample = c("s1", "s2", "s3"), Fold = c(1L, 2L, 1L)) + shuffled <- sp[c(3, 1, 2), ] + expect_identical( + pecotmr:::.cvPartitionKey(sp), + pecotmr:::.cvPartitionKey(shuffled) + ) + moved <- sp + moved$Fold <- c(1L, 1L, 2L) + expect_false(identical( + pecotmr:::.cvPartitionKey(sp), + pecotmr:::.cvPartitionKey(moved) + )) +}) + +# --------------------------------------------------------------------------- +# Up-front gate: a SuSiE-family method without its fit is refused before any +# fitting work, rather than surfacing from inside the per-fold map. +# --------------------------------------------------------------------------- + +test_that("learnTwasWeights refuses a susie token with no fit", { + skip_if_not_installed("susieR") + set.seed(11) + data(eqtlRegionExample) + X <- eqtlRegionExample$X[, 1:40] + Y <- matrix( + eqtlRegionExample$yRes, + ncol = 1, + dimnames = list(rownames(X), "t1") + ) + expect_error( + suppressMessages(learnTwasWeights( + X, + Y, + weightMethods = list(susie_weights = list()), + verbose = 0 + )), + "never run fine-mapping themselves" + ) + # supplying it through fittedModels satisfies the gate + fit <- suppressMessages(susieR::susie(X, Y[, 1], L = 5)) + expect_no_error(suppressMessages(learnTwasWeights( + X, + Y, + weightMethods = list(susie_weights = list()), + fittedModels = list(susie = fit), + verbose = 0 + ))) + # a method with no fine-mapping adapter is unaffected + expect_no_error(suppressMessages(learnTwasWeights( + X, + Y, + weightMethods = list(lasso_weights = list()), + verbose = 0 + ))) +}) + +test_that("twasWeightsCv refuses a susie token with no per-fold fits", { + skip_if_not_installed("susieR") + f <- suppressMessages(.twcv_foldFits()) + expect_error( + suppressMessages(twasWeightsCv( + f$X, + f$Y, + samplePartitions = f$slice$samplePartition, + weightMethods = list(susie_weights = list()), + verbose = 0 + )), + "needs that fold's own fit" + ) +}) + +test_that(".twasSusieTokensRequested matches both method spellings", { + expect_equal( + pecotmr:::.twasSusieTokensRequested(list(susie = list())), + "susie" + ) + expect_equal( + pecotmr:::.twasSusieTokensRequested(c("mvsusieWeights")), + "mvsusie" + ) + expect_length( + pecotmr:::.twasSusieTokensRequested(list(lasso_weights = list())), + 0L + ) +}) + +test_that("the twas lookup helpers answer NULL when the token is absent", { + expect_null(pecotmr:::.twasMethodArgsFor(list(), "susie")) + expect_null(pecotmr:::.twasFoldFitsFor(NULL, "susie")) +}) + +# --- per-token argument chains ---------------------------------------------- +# +# The recorded chains in .twasMethodChains() are the basis for checking a +# method's arguments, so they must not drift silently. These tests re-derive +# them by EXECUTION -- tracing which functions a real fit enters -- which is +# how they were established in the first place; reading the sources hides the +# forwarding behind list_modify()/exec() and imported-without-:: calls. + +# Traces the pecotmr functions entered while `expr` runs, restricted to the +# ones a chain could name. Returns their names. +.tw_traceChain <- function(expr) { + ns <- asNamespace("pecotmr") + watched <- c( + "glmnetWeights", + "ncvregWeights", + "bglrWeights", + "bayesAlphabetWeights", + "dprWeights", + "mrmashWrapper", + ".penalizedRssWeights", + ".rssShrinkGridWeights", + "buildMrmashPriorMatrices", + "penalizedRss", + "lassosumRss", + "sdpr", + "prsCs" + ) + hit <- new.env(parent = emptyenv()) + for (f in watched) { + ob <- tryCatch(get(f, envir = ns), error = function(e) NULL) + if (!is.function(ob)) { + next + } + suppressMessages(trace( + f, + where = ns, + print = FALSE, + tracer = substitute( + assign(NM, TRUE, envir = HIT), + list(NM = f, HIT = hit) + ) + )) + } + on.exit( + for (f in watched) { + try(suppressMessages(untrace(f, where = ns)), silent = TRUE) + }, + add = TRUE + ) + invisible(tryCatch( + suppressWarnings(suppressMessages(force(expr))), + error = function(e) NULL + )) + # all.names: the internal hops are dot-prefixed and ls() hides those. + sort(ls(hit, all.names = TRUE)) +} + +.tw_rssFixture <- function(p = 6L) { + set.seed(1) + LD <- diag(p) + LD[abs(row(LD) - col(LD)) == 1] <- 0.3 + list( + LD = LD, + stat = list(bhat = rnorm(p) * 0.1, shat = rep(0.05, p), n = 500L) + ) +} + +test_that("the recorded individual-path chains match what a fit enters", { + skip_if_not_installed("glmnet") + skip_if_not_installed("ncvreg") + set.seed(1) + n <- 60L + p <- 5L + X <- matrix(rnorm(n * p), n, p) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) + y <- as.numeric(X %*% rnorm(p) + rnorm(n)) + recorded <- function(tk) { + setdiff( + pecotmr:::.twasMethodChainFor(tk, "QtlDataset"), + c(paste0(tk, "Weights"), "lassoWeights", "enetWeights") + ) + } + expect_true(is_in( + "glmnetWeights", + .tw_traceChain(lassoWeights(X, y)) + )) + expect_true(is_in("glmnetWeights", recorded("lasso"))) + expect_true(is_in( + "ncvregWeights", + .tw_traceChain(scadWeights(X, y)) + )) + expect_true(is_in("ncvregWeights", recorded("scad"))) +}) + +test_that("the recorded RSS chains match what a fit enters", { + fx <- .tw_rssFixture() + seen <- .tw_traceChain(scadRssWeights(fx$stat, fx$LD)) + recorded <- pecotmr:::.twasMethodChainFor("scad", "QtlSumStats") + # Every pecotmr hop the run entered must be in the recorded chain. + expect_true(all(is_in(seen, recorded))) + expect_true(is_in("penalizedRss", seen)) + expect_true(is_in(".rssShrinkGridWeights", seen)) +}) + +test_that("every RSS chain yields a checkable argument set", { + # The point of the chains: each summary-statistics path ends in one of + # pecotmr's own solvers, which enumerate their formals, so the RSS side + # is checkable even where the individual side is not. + for (tk in c("scad", "mcp", "l0learn", "lasso", "prsCs", "dprGibbs")) { + expect_false( + is.null(pecotmr:::.twasChainAccepted(tk, "QtlSumStats")), + label = paste("accepted set for", tk) + ) + } +}) + +test_that("a middle-hop argument is accepted and a typo is not", { + skip_if_not_installed("mr.mashr") + # canonicalPriorMatrices belongs to buildMrmashPriorMatrices, in the + # middle of the mrmash chain -- neither the entry wrapper nor the engine. + acc <- pecotmr:::.twasChainAccepted("mrmash", "QtlDataset") + expect_true(is_in("canonicalPriorMatrices", acc)) + expect_true(is_in("max_iter", acc)) + expect_false(is_in("zzz", acc)) +}) + +test_that("per-class checking rejects a name only the other path accepts", { + skip_if_not_installed("ncvreg") + # `s` is a formal of the RSS shrinkage grid, not of the individual path. + sumAcc <- pecotmr:::.twasChainAccepted("scad", "QtlSumStats") + expect_true(is_in("s", sumAcc)) + expect_error( + pecotmr:::.twasCheckMethodArgsForInput( + list(scad = list(zzz = 1)), + "QtlSumStats" + ), + "method 'scad': unknown argument\\(s\\) zzz" + ) + # The individual path reaches ncvreg, which takes `...`, so nothing can + # be rejected there. + expect_silent( + pecotmr:::.twasCheckMethodArgsForInput( + list(scad = list(zzz = 1)), + "QtlDataset" + ) + ) +}) + +test_that("the TWAS Options registry is derived from each implementation", { + # It used to be 18 hand-written token -> constructor pairs, which had to + # restate a pairing the implementation already declares through its own + # `methodArgs` default. The two paths of one method often reach different + # packages, so a second table is a second thing to keep in step. + reg <- pecotmr:::.twasMethodCtors() + expect_setequal(names(reg), names(pecotmr:::.twasMethodCapabilities)) + expect_setequal(names(reg), pecotmr:::.twasConfigurableMethods()) + expect_true(all(map_lgl(reg, is.function))) + + nameOf <- function(f) { + if (is.null(f)) { + return(NA_character_) + } + hit <- keep( + grep("Options$", getNamespaceExports("pecotmr"), value = TRUE), + function(n) identical(get(n, envir = asNamespace("pecotmr")), f) + ) + if (length(hit) > 0L) hit[[1L]] else "?" + } + # Spot-check the pairs the derivation must reproduce. + expect_equal(nameOf(reg$lasso), "GlmnetOptions") + expect_equal(nameOf(reg$mcp), "NcvregOptions") + expect_equal(nameOf(reg$bayesB), "BglrOptions") + # prsCs has no individual implementation, so the path-blind view falls + # back to its summary-statistics constructor rather than dropping it. + expect_equal(nameOf(reg$prsCs), "PrsCsOptions") +}) + +test_that("each method's Options constructor is resolved per input path", { + nameOf <- function(f) { + if (is.null(f)) { + return(NA_character_) + } + hit <- keep( + grep("Options$", getNamespaceExports("pecotmr"), value = TRUE), + function(n) identical(get(n, envir = asNamespace("pecotmr")), f) + ) + if (length(hit) > 0L) hit[[1L]] else "?" + } + # The two paths of one method can reach different PACKAGES, which is why + # one constructor per method was never enough. + expect_equal( + nameOf(pecotmr:::.twasMethodCtorFor("lasso", "QtlDataset")), + "GlmnetOptions" + ) + expect_equal( + nameOf(pecotmr:::.twasMethodCtorFor("lasso", "QtlSumStats")), + "LassosumOptions" + ) + expect_equal( + nameOf(pecotmr:::.twasMethodCtorFor("dprGibbs", "QtlSumStats")), + "SdprOptions" + ) + expect_equal( + nameOf(pecotmr:::.twasMethodCtorFor("mrmash", "QtlSumStats")), + "MrmashRssOptions" + ) + # A method that does not run on a path has no constructor there. + expect_null(pecotmr:::.twasMethodCtorFor("enet", "QtlSumStats")) + expect_null(pecotmr:::.twasMethodCtorFor("prsCs", "QtlDataset")) + expect_null(pecotmr:::.twasMethodCtorFor("nosuch", "QtlDataset")) +}) + +# =========================================================================== +# Lookup and per-fold helpers: the absent-input branches +# =========================================================================== + +test_that(".twasMethodListArgs answers an empty list for nothing usable", { + f <- pecotmr:::.twasMethodListArgs + expect_equal(f(list()), list()) + # Unnamed entries carry no method to key on. + expect_equal(f(list(1, 2)), list()) + # Named entries are re-keyed with the _weights suffix dropped. + expect_named(f(list(lasso_weights = list(a = 1))), "lasso") +}) + +test_that("name lookups answer NA / NULL when the name resolves to nothing", { + expect_equal( + pecotmr:::.twasChainHopFormals("noSuchFunctionAnywhere"), + NA_character_ + ) + expect_null(pecotmr:::.twasImplCtorName("noSuchImplAnywhere")) + expect_null(pecotmr:::.twasImplCtorName(NULL)) +}) + +test_that(".twasCanonicalShortName maps a function name back, else passes on", { + f <- pecotmr:::.twasCanonicalShortName + map <- c(lassoWeights = "lasso") + expect_equal(f("lassoWeights", map), "lasso") + expect_equal(f("lasso", map), "lasso") + expect_equal(f("unknownThing", map), "unknownThing") +}) + +test_that(".twasFoldFitsFor answers NULL when no spelling is present", { + f <- pecotmr:::.twasFoldFitsFor + expect_null(f(NULL, "susie")) + # A CV payload keyed by something else is not this token's fits. + expect_null(f(list(somethingElse = list()), "susie")) +}) + +test_that(".twasFoldFit leaves args alone when there is no fold fit", { + f <- pecotmr:::.twasFoldFit + args <- list(X = 1) + # No CV payload at all. + expect_identical(f(args, "susie", 1L, NULL), args) + # A method with no fine-mapping token to look up. + expect_identical(f(args, "lasso", 1L, list(susie = list())), args) + # The token is present but carries no folds, so there is nothing to add. + expect_identical(f(args, "susie", 1L, list(susie = list())), args) +}) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 7f7d0604b..e638f6bbe 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -25,7 +25,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") path = "/tmp/tp.gds", format = "gds", snpInfo = data.frame( - SNP = sprintf("chr1:%d:A:G", 100L * (seq_len(snp_n))), + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), CHR = rep("1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), @@ -78,7 +78,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") ) { gh <- .tp_makeHandle(snp_n = 20L, n_samples = n_samples) phen <- setNames( - lapply(contexts, function(.) { + map(contexts, function(.) { .tp_makeSe(traits = traits, n_samples = n_samples) }), contexts @@ -146,7 +146,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") method = method, stringsAsFactors = FALSE ) - entries <- lapply(seq_len(nrow(rows)), function(i) { + entries <- map(seq_len(nrow(rows)), function(i) { if (is.null(fitPayload)) { fitPayload <- list( method = rows$method[[i]], @@ -155,7 +155,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") ) } tl <- data.frame( - variant_id = sprintf("chr1:%d:A:G", 100L * (seq_len(3L))), + variant_id = sprintf("chr1:%d:A:G", 100L * seq_len(3L)), pip = c(0.9, 0.5, 0.1), stringsAsFactors = FALSE ) @@ -191,7 +191,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") X = NULL, y = NULL, susieFit = NULL, - retainFit = FALSE, + fitRetention = "none", ... ) { rep(0, ncol(X)) @@ -214,16 +214,19 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, - methods = list(lasso_weights = list(), enet_weights = list()), + methods = list( + lasso = list(), + enet = list() + ), cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) ) expect_s4_class(res, "TwasWeights") @@ -256,9 +259,9 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tighten the variant set", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -267,14 +270,14 @@ test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tight call <- function(...) { suppressMessages(twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), traitId = "ENSG_A", cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, verbose = 0, - ... + ..., + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() )) } vcount <- function(res) { @@ -291,11 +294,17 @@ test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tight # Mock MAF spans 0.225..0.388; a 0.25 cutoff drops the 3 lowest-MAF variants # while leaving the rest, so the variant set strictly shrinks. The filter is # the same one fine-mapping uses (unified QtlDataset QC), not TWAS-specific. - tight <- vcount(call(mafCutoff = 0.25)) + tight <- vcount(call( + genotypeFilterArgs = GenotypeFilterParam(mafCutoff = 0.25) + )) expect_lt(tight, 20L) expect_gt(tight, 0L) - # xvarCutoff overrides the per-variant variance slot; a no-op value is accepted. - expect_s4_class(call(xvarCutoff = 0), "TwasWeights") + # xvarCutoff overrides the per-variant variance slot; a no-op value is + # accepted. + expect_s4_class( + call(genotypeFilterArgs = GenotypeFilterParam(xvarCutoff = 0)), + "TwasWeights" + ) }) test_that("twasWeightsPipeline(QtlDataset): contexts filter restricts the per-context loop", { @@ -304,17 +313,17 @@ test_that("twasWeightsPipeline(QtlDataset): contexts filter restricts the per-co list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), contexts = "brain", cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) ) expect_setequal(getContexts(res), "brain") @@ -327,7 +336,7 @@ test_that("twasWeightsPipeline(QtlDataset): unknown context errors", { twasWeightsPipeline( qd, contexts = "ghost", - methods = list(lasso_weights = list()) + methods = list(lasso = list()) ), "unknown context" ) @@ -339,7 +348,7 @@ test_that("twasWeightsPipeline(QtlDataset): no traits selected errors", { twasWeightsPipeline( qd, traitId = "ENSG_Z", - methods = list(lasso_weights = list()) + methods = list(lasso = list()) ), "no traits selected" ) @@ -348,8 +357,11 @@ test_that("twasWeightsPipeline(QtlDataset): no traits selected errors", { test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( - twasWeightsPipeline(qd, methods = list(prsCs_weights = list())), - "not available for input class 'QtlDataset'" + twasWeightsPipeline( + qd, + methods = list(prsCs = list()) + ), + "prsCs is not a method this pipeline runs on QtlDataset" ) }) @@ -379,7 +391,7 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { studies <- rep("s1", n_entries) contexts <- if (n_entries == 1L) "c1" else paste0("c", seq_len(n_entries)) traits <- rep("t1", n_entries) - entries <- lapply(seq_len(n_entries), function(.) .tp_makeSumstatsEntry()) + entries <- map(seq_len(n_entries), function(.) .tp_makeSumstatsEntry()) QtlSumStats( study = studies, context = contexts, @@ -408,7 +420,7 @@ test_that("twasWeightsPipeline(QtlSumStats): runs end-to-end with mocked solvers list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) # Method tokens are the bare short names; the QtlSumStats dispatch # resolves them to the *Rss impl via the .twasMethodCapabilities table. # Fine-mapping methods (susie / susieInf / etc.) require a @@ -455,7 +467,7 @@ test_that("twasWeightsPipeline(QtlSumStats): per-method failure surfaces as warn mocks$lassosumRssWeights <- function(stat, LD, ...) { stop("synthetic test failure") } - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) # All entries fail -> the per-method-warning fires *and* the pipeline # then errors out (no rows produced). Capture both. expect_error( @@ -466,7 +478,10 @@ test_that("twasWeightsPipeline(QtlSumStats): per-method failure surfaces as warn ) }) -test_that("twasWeightsPipeline(QtlSumStats): multivariate requires >=2 contexts per (study, trait)", { +test_that("twasWeightsPipeline( + QtlSumStats): multivariate requires >=2 contexts per (study, + trait +)", { ss <- .tp_makeQtlSumStats(n_entries = 1L) # 1 context per (study, trait) # Provide a stub FineMappingResult so the gate passes; the multivariate # guard is what we want to exercise here. @@ -571,7 +586,7 @@ test_that("gate: non-FineMappingResult object passed in errors", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( twasWeightsPipeline(qd, methods = "susie", fineMappingResult = list()), - "must be a FineMappingResult" + "Must inherit from class 'FineMappingResultBase'" ) }) @@ -606,17 +621,17 @@ test_that("gate: QtlDataset + susie + fineMappingResult threads the susieFit", { rep(0, ncol(X)) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, methods = "susie", fineMappingResult = fmr, cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -643,7 +658,7 @@ test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit rep(0, nrow(LD)) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -674,7 +689,7 @@ test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAsh rep(0, nrow(LD)) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -704,7 +719,7 @@ test_that("gate: missing matching tuple in fineMappingResult warns and skips", { list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights() ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) expect_error( suppressWarnings(suppressMessages( twasWeightsPipeline( @@ -726,7 +741,10 @@ test_that("gate: missing matching tuple in fineMappingResult warns and skips", { # matrix; we mock that solver to return a zero matrix of the expected shape. # =========================================================================== -test_that("twasWeightsPipeline(QtlDataset): mvsusie multivariate path returns one row per (context, trait)", { +test_that("twasWeightsPipeline( + QtlDataset): mvsusie multivariate path returns one row per (context, + trait +)", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") fmr <- .tp_makeStubFineMappingResult( study = "study1", @@ -749,17 +767,17 @@ test_that("twasWeightsPipeline(QtlDataset): mvsusie multivariate path returns on ) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, methods = "mvsusie", fineMappingResult = fmr, cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -787,16 +805,16 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 tra ) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, methods = "mrmash", cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -808,24 +826,39 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 tra }) test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the fits slot", { - # The multivariate dispatch runs with retainFits=TRUE so the mr.mash fit + # The multivariate dispatch retains fits so the mr.mash fit # parts (the shared fit fineMappingPipeline consumes to build the mvSuSiE # prior) land on the entry's `fits` slot. qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") ddpm <- list(U = list(comp = diag(2))) mocks <- list( extractBlockGenotypes = .tp_mockExtractor(), - mrmashWeights = function(X, Y, retainFit = FALSE, ...) { + # The mock must carry the formals the production code reads off the + # implementation: `methodArgs` (whose default names the per-path + # Options constructor) and `dataDrivenPriorMatrices` (a wrapper-level + # argument). .splitMethodArgs routes any name that is NOT a wrapper + # formal to the engine, so a double that drops one sends a + # wrapper argument to mr.mash and it is rejected there. + mrmashWeights = function( + X, + Y, + fitRetention = "none", + dataDrivenPriorMatrices = NULL, + methodArgs = MrmashOptions(), + ... + ) { w <- matrix( 0, nrow = ncol(X), ncol = ncol(Y), dimnames = list(colnames(X), colnames(Y)) ) - if (isTRUE(retainFit)) { - dots <- list(...) + if (!identical(fitRetention, "none")) { + # Read the formal, not `...`: now that the mock declares + # `dataDrivenPriorMatrices` (as the real one does) the value + # arrives there rather than in the dots. attr(w, "fit") <- list( - dataDrivenPriorMatrices = dots$dataDrivenPriorMatrices, + dataDrivenPriorMatrices = dataDrivenPriorMatrices, w0 = c(null = 0.5, comp = 0.5), V = diag(ncol(Y)) ) @@ -833,18 +866,18 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the w } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, methods = list( - mrmash_weights = list(dataDrivenPriorMatrices = ddpm) + mrmash = list(dataDrivenPriorMatrices = ddpm) ), cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) )) fit <- getFits( @@ -871,7 +904,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the positions = seq(100L, by = 100L, length.out = 8L) ) { n <- length(contexts) - entries <- lapply(seq_len(n), function(i) { + entries <- map(seq_len(n), function(i) { # Same SNP order across contexts -- required by the multivariate path # (it errors on any divergence after summaryStatsQc). .tp_makeSumstatsEntry(snp_ids = snp_ids, positions = positions) @@ -913,7 +946,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns o ) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -944,7 +977,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash multivariate solver failure stop("synthetic multivariate failure") } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) # All multivariate fits fail -> no rows -> the pipeline errors out at the # end, surfacing the per-group warning along the way. expect_error( @@ -987,17 +1020,17 @@ test_that("twasWeightsPipeline(QtlDataset): full cache hit avoids all weight fit rep(0, ncol(X)) }) ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, twasWeights = cached, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) ) expect_s4_class(res, "TwasWeights") @@ -1030,17 +1063,20 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing } ) ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages( twasWeightsPipeline( qd, - methods = list(lasso_weights = list(), enet_weights = list()), + methods = list( + lasso = list(), + enet = list() + ), cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, twasWeights = cached, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) ) expect_setequal(getMethodNames(res), c("lasso", "enet")) @@ -1067,7 +1103,7 @@ test_that("twasWeightsPipeline(QtlSumStats): cache hit on a per-tuple basis", { rssCalls <<- rssCalls + 1L rep(0, nrow(LD)) } - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -1164,17 +1200,17 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { mkW(X, Y) } ) - do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, methods = c("mrmash", "mvsusie"), fineMappingResult = fmr, cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ) )) expect_s4_class(res, "TwasWeights") @@ -1203,7 +1239,7 @@ context("ensembleWeights") # prediction is a convex combination of the truth + noise, letting us control # per-method accuracy. Returns a list shaped exactly like twasWeightsCv()'s # output (with $prediction, $performance, $samplePartition). -make_cv_result <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { +makeCvResult <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { set.seed(seed) y <- rnorm(n) sampleNames <- paste0("sample_", seq_len(n)) @@ -1218,7 +1254,7 @@ make_cv_result <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { pred_names <- paste0(method_names, "_predicted") prediction <- setNames( - lapply(seq_len(K), function(k) { + map(seq_len(K), function(k) { noise_sd <- method_quality[k] pred <- y + rnorm(n, sd = noise_sd) mat <- matrix(pred, ncol = 1) @@ -1231,7 +1267,7 @@ make_cv_result <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { # Dummy performance (not used by ensembleWeights) performance <- setNames( - lapply(seq_len(K), function(k) { + map(seq_len(K), function(k) { m <- matrix(NA, nrow = 1, ncol = 6) colnames(m) <- c("corr", "rsq", "adj_rsq", "pval", "RMSE", "MAE") m @@ -1254,12 +1290,12 @@ make_cv_result <- function(n = 100, K = 4, seed = 1, method_quality = NULL) { } # Build synthetic learnTwasWeights() output -make_weight_list <- function(p = 20, method_names, seed = 2) { +makeWeightList <- function(p = 20, method_names, seed = 2) { set.seed(seed) setNames( - lapply(method_names, function(m) { + map(method_names, function(m) { w <- matrix(rnorm(p), ncol = 1) - rownames(w) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + rownames(w) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) colnames(w) <- "outcome_1" w }), @@ -1276,17 +1312,17 @@ test_that("ensembleWeights: NULL cv_results errors", { }) test_that("ensembleWeights: NULL Y errors", { - cv <- make_cv_result(n = 20, K = 3) + cv <- makeCvResult(n = 20, K = 3) expect_error(ensembleWeights(cv, Y = NULL), "'Y' is required") }) test_that("ensembleWeights: single method errors (need >= 2 for ensemble)", { - cv <- make_cv_result(n = 20, K = 1) + cv <- makeCvResult(n = 20, K = 1) expect_error(ensembleWeights(cv, Y = cv$.y), "at least 2 methods") }) test_that("ensembleWeights: invalid context_index errors", { - cv <- make_cv_result(n = 20, K = 3) + cv <- makeCvResult(n = 20, K = 3) expect_error( ensembleWeights(cv, Y = cv$.y, contextIndex = 0), "contextIndex" @@ -1298,7 +1334,7 @@ test_that("ensembleWeights: invalid context_index errors", { }) test_that("ensembleWeights: context_index beyond Y columns errors", { - cv <- make_cv_result(n = 20, K = 3) + cv <- makeCvResult(n = 20, K = 3) Y_mat <- matrix(cv$.y, ncol = 1) expect_error( ensembleWeights(cv, Y = Y_mat, contextIndex = 5), @@ -1307,8 +1343,8 @@ test_that("ensembleWeights: context_index beyond Y columns errors", { }) test_that("ensembleWeights: multi-dataset with mismatched lengths errors", { - cv1 <- make_cv_result(n = 20, K = 3, seed = 1) - cv2 <- make_cv_result(n = 20, K = 3, seed = 2) + cv1 <- makeCvResult(n = 20, K = 3, seed = 1) + cv2 <- makeCvResult(n = 20, K = 3, seed = 2) expect_error( ensembleWeights(list(cv1, cv2), Y = list(cv1$.y)), "same length" @@ -1316,8 +1352,8 @@ test_that("ensembleWeights: multi-dataset with mismatched lengths errors", { }) test_that("ensembleWeights: multi-dataset with different methods errors", { - cv1 <- make_cv_result(n = 20, K = 3, seed = 1) - cv2 <- make_cv_result(n = 20, K = 4, seed = 2) + cv1 <- makeCvResult(n = 20, K = 3, seed = 1) + cv2 <- makeCvResult(n = 20, K = 4, seed = 2) expect_error( ensembleWeights(list(cv1, cv2), Y = list(cv1$.y, cv2$.y)), "same method names" @@ -1329,7 +1365,7 @@ test_that("ensembleWeights: multi-dataset with different methods errors", { # =========================================================================== test_that("ensembleWeights: coefficients are non-negative and sum to 1", { - cv <- make_cv_result(n = 100, K = 4, seed = 42) + cv <- makeCvResult(n = 100, K = 4, seed = 42) res <- ensembleWeights(cv, Y = cv$.y) expect_true(all(res$methodCoef >= 0)) @@ -1338,7 +1374,7 @@ test_that("ensembleWeights: coefficients are non-negative and sum to 1", { test_that("ensembleWeights: best method receives the largest coefficient", { # Method 1 is best (lowest noise), method K is worst - cv <- make_cv_result( + cv <- makeCvResult( n = 200, K = 4, seed = 7, @@ -1350,7 +1386,7 @@ test_that("ensembleWeights: best method receives the largest coefficient", { }) test_that("ensembleWeights: does not return ensemble_performance (in-sample R^2 omitted)", { - cv <- make_cv_result(n = 300, K = 5, seed = 13) + cv <- makeCvResult(n = 300, K = 5, seed = 13) res <- ensembleWeights(cv, Y = cv$.y) expect_null(res$ensemble_performance) @@ -1358,7 +1394,7 @@ test_that("ensembleWeights: does not return ensemble_performance (in-sample R^2 }) test_that("ensembleWeights: per-method R^2 values are sensible (between 0 and 1)", { - cv <- make_cv_result(n = 200, K = 4, seed = 21) + cv <- makeCvResult(n = 200, K = 4, seed = 21) res <- ensembleWeights(cv, Y = cv$.y) expect_true(all(res$methodPerformance >= 0, na.rm = TRUE)) @@ -1367,7 +1403,7 @@ test_that("ensembleWeights: per-method R^2 values are sensible (between 0 and 1) }) test_that("ensembleWeights: method names are stripped of _predicted suffix", { - cv <- make_cv_result(n = 50, K = 3, seed = 1) + cv <- makeCvResult(n = 50, K = 3, seed = 1) res <- ensembleWeights(cv, Y = cv$.y) expect_equal(names(res$methodCoef), c("method1", "method2", "method3")) @@ -1382,7 +1418,7 @@ test_that("ensembleWeights: method names are stripped of _predicted suffix", { # =========================================================================== test_that("ensembleWeights: aligns Y and predictions by sample name", { - cv <- make_cv_result(n = 50, K = 3, seed = 10) + cv <- makeCvResult(n = 50, K = 3, seed = 10) # Shuffle Y order relative to predictions shuffled_order <- sample(50) @@ -1401,7 +1437,7 @@ test_that("ensembleWeights: aligns Y and predictions by sample name", { }) test_that("ensembleWeights: aligns Y matrix and predictions by sample name", { - cv <- make_cv_result(n = 50, K = 3, seed = 10) + cv <- makeCvResult(n = 50, K = 3, seed = 10) # Create Y as a matrix with shuffled row order shuffled_order <- sample(50) @@ -1419,7 +1455,7 @@ test_that("ensembleWeights: aligns Y matrix and predictions by sample name", { }) test_that("ensembleWeights: errors when no common sample names", { - cv <- make_cv_result(n = 20, K = 3, seed = 1) + cv <- makeCvResult(n = 20, K = 3, seed = 1) y_bad <- setNames(rnorm(20), paste0("other_", seq_len(20))) expect_error(ensembleWeights(cv, Y = y_bad), "No common sample names") @@ -1430,7 +1466,7 @@ test_that("ensembleWeights: errors when no common sample names", { # =========================================================================== test_that("ensembleWeights: zero-variance method gets coefficient 0", { - cv <- make_cv_result(n = 100, K = 3, seed = 5) + cv <- makeCvResult(n = 100, K = 3, seed = 5) # Force method 2 to have constant predictions cv$prediction$method2_predicted[, 1] <- 0.5 res <- ensembleWeights(cv, Y = cv$.y) @@ -1440,7 +1476,7 @@ test_that("ensembleWeights: zero-variance method gets coefficient 0", { }) test_that("ensembleWeights: NA predictions in some samples are dropped", { - cv <- make_cv_result(n = 100, K = 3, seed = 5) + cv <- makeCvResult(n = 100, K = 3, seed = 5) cv$prediction$method1_predicted[1:5, 1] <- NA expect_message( res <- ensembleWeights(cv, Y = cv$.y), @@ -1450,7 +1486,7 @@ test_that("ensembleWeights: NA predictions in some samples are dropped", { }) test_that("ensembleWeights: all zero-variance methods errors", { - cv <- make_cv_result(n = 50, K = 2, seed = 5) + cv <- makeCvResult(n = 50, K = 2, seed = 5) cv$prediction$method1_predicted[, 1] <- 0 cv$prediction$method2_predicted[, 1] <- 0 expect_error(ensembleWeights(cv, Y = cv$.y), "zero-variance predictions") @@ -1461,8 +1497,8 @@ test_that("ensembleWeights: all zero-variance methods errors", { # =========================================================================== test_that("ensembleWeights: ensembleTwasWeights is sum of zeta_k * w_k", { - cv <- make_cv_result(n = 100, K = 3, seed = 42) - wt <- make_weight_list(p = 10, method_names = cv$.method_names) + cv <- makeCvResult(n = 100, K = 3, seed = 42) + wt <- makeWeightList(p = 10, method_names = cv$.method_names) res <- ensembleWeights(cv, Y = cv$.y, twasWeightList = wt) @@ -1482,13 +1518,13 @@ test_that("ensembleWeights: ensembleTwasWeights is sum of zeta_k * w_k", { }) test_that("ensembleWeights: NULL twas_weight_list returns NULL ensembleTwasWeights", { - cv <- make_cv_result(n = 50, K = 3, seed = 1) + cv <- makeCvResult(n = 50, K = 3, seed = 1) res <- ensembleWeights(cv, Y = cv$.y, twasWeightList = NULL) expect_null(res$ensembleTwasWeights) }) test_that("ensembleWeights: weights with no matching keys warns and skips", { - cv <- make_cv_result(n = 50, K = 2, seed = 1) + cv <- makeCvResult(n = 50, K = 2, seed = 1) wt <- list(unknown_weights = matrix(1, nrow = 10, ncol = 1)) expect_warning( @@ -1503,8 +1539,8 @@ test_that("ensembleWeights: weights with no matching keys warns and skips", { # =========================================================================== test_that("ensembleWeights: multi-dataset combines predictions correctly", { - cv1 <- make_cv_result(n = 80, K = 3, seed = 1) - cv2 <- make_cv_result(n = 80, K = 3, seed = 2) + cv1 <- makeCvResult(n = 80, K = 3, seed = 1) + cv2 <- makeCvResult(n = 80, K = 3, seed = 2) res <- ensembleWeights( cvResults = list(cv1, cv2), @@ -1517,7 +1553,7 @@ test_that("ensembleWeights: multi-dataset combines predictions correctly", { }) test_that("ensembleWeights: Y as matrix with context_index works", { - cv <- make_cv_result(n = 50, K = 3, seed = 1) + cv <- makeCvResult(n = 50, K = 3, seed = 1) Y_mat <- matrix(cv$.y, ncol = 1) colnames(Y_mat) <- "ctx1" @@ -1536,7 +1572,7 @@ test_that("ensembleWeights: end-to-end with twasWeightsCv output", { n <- 100 p <- 20 X <- matrix(rnorm(n * p), nrow = n, ncol = p) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (seq_len(p))) + colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("sample_", seq_len(n)) beta <- c(1.5, -1.0, 0.8, rep(0, p - 3)) @@ -1586,7 +1622,7 @@ for (slv in c("quadprog", "nnls", "lbfgsb", "glmnet")) { skip_if_not_installed("glmnet") } - cv <- make_cv_result(n = 100, K = 4, seed = 42) + cv <- makeCvResult(n = 100, K = 4, seed = 42) res <- ensembleWeights(cv, Y = cv$.y, solver = slv) expect_true(all(res$methodCoef >= 0)) @@ -1612,7 +1648,7 @@ for (slv in c("quadprog", "nnls", "lbfgsb", "glmnet")) { skip_if_not_installed("glmnet") } - cv <- make_cv_result( + cv <- makeCvResult( n = 200, K = 4, seed = 7, @@ -1641,8 +1677,8 @@ for (slv in c("quadprog", "nnls", "lbfgsb", "glmnet")) { skip_if_not_installed("glmnet") } - cv <- make_cv_result(n = 100, K = 3, seed = 42) - wt <- make_weight_list(p = 10, method_names = cv$.method_names) + cv <- makeCvResult(n = 100, K = 3, seed = 42) + wt <- makeWeightList(p = 10, method_names = cv$.method_names) res <- ensembleWeights( cv, Y = cv$.y, @@ -1668,7 +1704,7 @@ for (slv in c("quadprog", "nnls", "lbfgsb", "glmnet")) { } test_that("ensembleWeights: invalid solver errors", { - cv <- make_cv_result(n = 50, K = 3, seed = 1) + cv <- makeCvResult(n = 50, K = 3, seed = 1) expect_error( ensembleWeights(cv, Y = cv$.y, solver = "bogus"), "must be one of" @@ -1679,7 +1715,7 @@ test_that("ensembleWeights: invalid solver errors", { test_that("ensembleWeights: solver='glmnet' respects alpha parameter", { skip_if_not_installed("glmnet") - cv <- make_cv_result(n = 200, K = 4, seed = 42) + cv <- makeCvResult(n = 200, K = 4, seed = 42) res_lasso <- ensembleWeights(cv, Y = cv$.y, solver = "glmnet", alpha = 1) res_ridge <- ensembleWeights(cv, Y = cv$.y, solver = "glmnet", alpha = 0) @@ -1732,29 +1768,40 @@ test_that(".twasNormalizeMethods: character vector of short names forwards to .t ) }) -test_that(".twasNormalizeMethods: named list passes through unchanged", { - ml <- list(lassoWeights = list(), enetWeights = list(alpha = 0.5)) - res <- pecotmr:::.twasNormalizeMethods(ml) - expect_identical(res$methodList, ml) +test_that(".twasNormalizeMethods: a methods record passes its kwargs through", { + res <- pecotmr:::.twasNormalizeMethods( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(lasso = list(), enet = list()) + ), + inputKind = "QtlDataset" + ) + expect_setequal(res$tokens, c("lasso", "enet")) }) -test_that(".twasNormalizeMethods: tokens strip both _weights and Weights suffixes", { - res_snake <- pecotmr:::.twasNormalizeMethods(list( - lasso_weights = list(), - enet_weights = list() - )) - res_camel <- pecotmr:::.twasNormalizeMethods(list( - lassoWeights = list(), - enetWeights = list() - )) - expect_equal(res_snake$tokens, c("lasso", "enet")) - expect_equal(res_camel$tokens, c("lasso", "enet")) +test_that(".twasNormalizeMethods: a bare named list is routed by path", { + # It used to be refused so that options reached the engine checked. + # They still do -- this call knows its input class, so the overrides go + # into that path's slot and are checked there. + ind <- pecotmr:::.twasNormalizeMethods( + list(lasso = list(alpha = 0.5)), + inputKind = "QtlDataset" + ) + expect_equal(ind$tokens, "lasso") + # The two paths of lasso reach different packages, so an argument for + # one is refused on the other: `alpha` is glmnet's, not lassosum's. + expect_error( + pecotmr:::.twasNormalizeMethods( + list(lasso = list(alpha = 0.5)), + inputKind = "QtlSumStats" + ), + "unknown argument" + ) }) test_that(".twasNormalizeMethods: unrecognised input type errors", { expect_error( pecotmr:::.twasNormalizeMethods(42L), - "must be a character vector, preset string, or named list" + "must be a character vector, a preset string, a named list" ) }) @@ -2023,7 +2070,7 @@ test_that("getSumStatsDf: require=c('Z','N') errors when columns missing", { # =========================================================================== test_that("estimateSparsity: legacy list input reads attr(.,'fit')$pi", { - # Build a weight result that mimics learnTwasWeights(retainFits = TRUE): + # Build a weight result that mimics learnTwasWeights keeping its fits: # element name carries the `_weights` suffix; attr 'fit' carries an mr.ash # object whose pi[1] is the spike weight. fake_w <- structure(c(0.1, 0, 0.3), fit = list(pi = c(0.6, 0.2, 0.2))) @@ -2084,7 +2131,7 @@ test_that("estimateSparsity: TwasWeights with mrash entry but no fit$pi errors", test_that("estimateSparsity: legacy list input without mrash_weights errors", { expect_error( - estimateSparsity(list(lasso_weights = c(0.1, 0.2))), + estimateSparsity(list(lasso = c(0.1, 0.2))), "'mrash_weights'.*not found" ) }) @@ -2105,10 +2152,10 @@ context("twasWeights internal helpers (extra)") .tw_makeFmEntry <- function(method_tag = "susie", n = 3) { fineMappingRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(n)), susieFit = list(payload = method_tag), topLoci = data.frame( - variant_id = sprintf("chr1:%d:A:G", 100L * (seq_len(n))), + variant_id = sprintf("chr1:%d:A:G", 100L * seq_len(n)), pip = seq(0.9, by = -0.1, length.out = n), stringsAsFactors = FALSE ) @@ -2133,7 +2180,7 @@ test_that(".twasFineMappingFits: non-FineMappingResult input errors", { context = "c1", trait = "t1" ), - "must be a FineMappingResult or NULL" + "Must inherit from class 'FineMappingResultBase'" ) }) @@ -2292,10 +2339,15 @@ test_that(".twasMergeRegionEntries rbinds matrix weights across regions", { expect_true(is.matrix(w)) expect_equal(dim(w), c(4L, 2L)) expect_equal(colnames(w), c("cA", "cB")) - expect_equal(rownames(w), c( - "chr1:100:A:G", "chr1:200:A:G", - "chr1:300:A:G", "chr1:400:A:G" - )) + expect_equal( + rownames(w), + c( + "chr1:100:A:G", + "chr1:200:A:G", + "chr1:300:A:G", + "chr1:400:A:G" + ) + ) expect_equal(unname(w[, "cA"]), c(0.1, 0.2, 0.5, 0.6)) expect_equal(unname(w[, "cB"]), c(0.3, 0.4, 0.7, 0.8)) expect_equal(names(getFits(m)), c("r1", "r2")) @@ -2338,12 +2390,18 @@ test_that(".twasMergedEntryForRow gathers one key across regions", { test_that(".twasMergedEntryForRow returns NULL when no region matches", { data(twasWeightsExample) bad <- data.frame( - study = "nope", context = "x", trait = "y", method = "z", + study = "nope", + context = "x", + trait = "y", + method = "z", stringsAsFactors = FALSE ) expect_null( pecotmr:::.twasMergedEntryForRow( - 1L, bad, list(twasWeightsExample), "rA" + 1L, + bad, + list(twasWeightsExample), + "rA" ) ) }) @@ -2353,7 +2411,7 @@ test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { expect_error( twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), region = GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 2000)), cisWindow = 1000L ), @@ -2363,9 +2421,9 @@ test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per-region weights", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -2377,14 +2435,14 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per- ) res <- suppressMessages(twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), traitId = "ENSG_A", region = regions, jointRegions = FALSE, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() )) expect_s4_class(res, "TwasWeights") # 1 ctx x 1 trait x 1 method -> a single merged row. @@ -2402,9 +2460,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per- test_that("twasWeightsPipeline(QtlDataset): jointRegions=TRUE fits one concatenated block", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -2416,14 +2474,14 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=TRUE fits one concatena ) res <- suppressMessages(twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), traitId = "ENSG_A", region = regions, jointRegions = TRUE, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() )) expect_equal(nrow(res), 1L) w <- getWeights( @@ -2441,9 +2499,9 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatena contexts = c("brain", "liver"), traits = c("ENSG_A", "ENSG_B") ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), mrmashWeights = function(X, Y, ...) { @@ -2468,10 +2526,10 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatena traitId = c("ENSG_A", "ENSG_B"), region = regions, jointRegions = FALSE, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") # 2 contexts x 2 traits = 4 rows, each with weights concatenated over regions. @@ -2639,7 +2697,7 @@ test_that(".rbindTwasWeights: concatenates two collections and rejects non-TwasW expect_setequal(as.character(out$method), c("lasso", "enet")) expect_error( pecotmr:::.rbindTwasWeights(list(), .tp_tw()), - "expects two TwasWeights" + "Must inherit from class 'TwasWeights'" ) }) @@ -2811,7 +2869,7 @@ test_that(".solveEnsembleLbfgsb: solver failure and all-zero solution fall back .tp_predBlock <- function(n = 30L, methods = c("a", "b")) { samp <- paste0("s", seq_len(n)) setNames( - lapply(methods, function(.) { + map(methods, function(.) { matrix(rnorm(n), n, 1, dimnames = list(samp, NULL)) }), paste0(methods, "_predicted") @@ -2949,9 +3007,9 @@ test_that("twasWeightsPipeline(QtlDataset): fitFullData=FALSE without CV errors" expect_error( twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), fitFullData = FALSE, - cvFolds = 0 + crossValidationArgs = CrossValidationParam(folds = 0) ), "fitFullData = FALSE requires cross-validation" ) @@ -2959,9 +3017,9 @@ test_that("twasWeightsPipeline(QtlDataset): fitFullData=FALSE without CV errors" test_that("twasWeightsPipeline(QtlDataset): mashPrior with no mrmash warns and is ignored", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -2970,13 +3028,13 @@ test_that("twasWeightsPipeline(QtlDataset): mashPrior with no mrmash warns and i expect_warning( suppressMessages(twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), mashPrior = MashPrior(fullFit = list(U = list(comp = diag(2)))), cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() )), "not among `methods`" ) @@ -3002,13 +3060,13 @@ test_that("twasWeightsPipeline(QtlDataset): mashPrior full prior is threaded int ) suppressMessages(suppressWarnings(twasWeightsPipeline( qd, - methods = list(mrmash_weights = list()), + methods = list(mrmash = list()), mashPrior = MashPrior(fullFit = ddpm), cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ))) expect_identical(captured, ddpm) }) @@ -3021,9 +3079,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso trait = "ENSG_A", method = "mrmash" ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), .twasDispatchJointSpecsQtlDataset = function(...) jointRes @@ -3037,10 +3095,10 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso methods = c("mrmash", "lasso"), jointSpecification = "context", cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") expect_true("mrmash" %in% as.character(res$method)) # from jointResult @@ -3049,9 +3107,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = c("ENSG_A", "ENSG_B")) # @1000, @2000 - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), list(.package = "pecotmr") @@ -3060,12 +3118,12 @@ test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(900, 1600)) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( qd, - methods = list(lasso_weights = list()), + methods = list(lasso = list()), region = region, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ))) expect_setequal(getTraits(res), "ENSG_A") # only the overlapping gene }) @@ -3076,14 +3134,17 @@ test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS preset", { ss <- .tp_makeQtlSumStats() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), - prsCsWeights = function(stat, LD, ...) rep(0, nrow(LD)), - sdprWeights = function(stat, LD, ...) rep(0, nrow(LD)) + prsCsWeights = function(stat, LD, ...) rep(0, nrow(LD)) ), + # .tp_mockSumstatWeights() already mocks sdprWeights. Passing a + # binding to local_mocked_bindings() twice makes it record the + # first mock as the "original", so unwinding restores the mock + # instead of the real function and it leaks for the session. .tp_mockSumstatWeights(), list(.package = "pecotmr") ) @@ -3097,29 +3158,33 @@ test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS p test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type", { ss <- .tp_makeQtlSumStats() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights(), list(.package = "pecotmr") ) ) res <- suppressMessages(suppressWarnings( - twasWeightsPipeline(ss, methods = list(lasso = list()), verbose = 0) + twasWeightsPipeline( + ss, + methods = list(lasso = list()), + verbose = 0 + ) )) expect_setequal(getMethodNames(res), "lasso") expect_error( twasWeightsPipeline(ss, methods = 42), - "must be NULL, a character vector, or a named list" + "must be NULL, a character vector, a named list" ) }) test_that("twasWeightsPipeline(QtlSumStats): traitId filter selects matching rows", { ss <- .tp_makeQtlSumStats() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockSumstatWeights(), list(.package = "pecotmr") @@ -3137,9 +3202,9 @@ test_that("twasWeightsPipeline(QtlSumStats): traitId filter selects matching row test_that("twasWeightsPipeline(QtlSumStats): multivariate mr.mash returns a column per context", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # 2 contexts of (s1, t1) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), mrmashRssWeights = function(stat, LD, ...) { @@ -3190,11 +3255,61 @@ test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fin MultiStudyQtlDataset(qtlDatasets = list(study1 = qd), sumStats = ss) } +test_that("twasWeightsPipeline(MultiStudyQtlDataset): per-study options are not dropped", { + # residualization and fit retention were declared on the multi-study + # method and never reached .twasMsDriver's config, and the + # QtlDataset-only options rode `...` into the embedded QtlSumStats call. + cap <- new.env(parent = emptyenv()) + local_mocked_bindings( + .twasPerStudy = function(qd, cfg) { + cap$cfg <- cfg + NULL + }, + .twasSumStats = function(ss, cfg) NULL, + .package = "pecotmr" + ) + # Both workers are stubbed out, so the driver finds nothing to rbind -- + # the config it handed them is what this test is about. + expect_error( + suppressMessages(suppressWarnings(twasWeightsPipeline( + .tp_makeMultiStudy(), + methods = "lasso", + cisWindow = 1000L, + verbose = 0, + estimatePi = FALSE, + fitFullData = FALSE, + fitRetention = "none", + residualizationArgs = ResidualizationParam( + residualizeGenotype = FALSE + ), + crossValidationArgs = CrossValidationParam(folds = 0) + ))), + "no entries produced weights" + ) + expect_false(cap$cfg$estimatePi) + expect_false(cap$cfg$fitFullData) + # "none" is provably not the default, and lasso can honour it. + expect_equal(cap$cfg$fitRetention, "none") + expect_false(cap$cfg$residualizationArgs$residualizeGenotype) +}) + +test_that("twasWeightsPipeline(MultiStudyQtlDataset): a misspelled option errors", { + # The method no longer takes `...`, so a typo cannot be swallowed. + expect_error( + twasWeightsPipeline( + .tp_makeMultiStudy(), + methods = "lasso", + fitRetentoin = "full" + ), + "unused argument" + ) +}) + test_that("twasWeightsPipeline(MultiStudyQtlDataset): recurses into components and rbinds", { mt <- .tp_makeMultiStudy() - do.call( + exec( local_mocked_bindings, - c( + !!!c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights(), .tp_mockSumstatWeights(), @@ -3205,10 +3320,10 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): recurses into components a mt, methods = "lasso", cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") expect_setequal(as.character(res$study), c("study1", "s1")) # both phases @@ -3258,9 +3373,9 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univar trait = "t1", method = "mrmash" ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), .twasDispatchJointSpecsMultiStudy = function(...) jointRes @@ -3275,10 +3390,10 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univar methods = c("mrmash", "lasso"), jointSpecification = "context", cisWindow = 1000L, - cvFolds = 0, - ensemble = FALSE, estimatePi = FALSE, - verbose = 0 + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") expect_true("mrmash" %in% as.character(res$method)) @@ -3344,9 +3459,9 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lass trait = "t1", method = "mrmash" ) - do.call( + exec( local_mocked_bindings, - c( + !!!c( list( extractBlockGenotypes = .tp_mockExtractor(), .twasDispatchJointSpecsQtlSumStats = function(...) jointRes @@ -3365,9 +3480,12 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lass expect_true("lasso" %in% as.character(res$method)) # 1300-1301 rbind }) -test_that("twasWeightsPipeline(QtlSumStats): a single-context (study, trait) group is skipped for mr.mash", { +test_that("twasWeightsPipeline( + QtlSumStats): a single-context (study, + trait +) group is skipped for mr.mash", { # t1 has 2 contexts (processed); t2 has 1 context (skipped at the < 2 guard). - entries <- lapply(1:3, function(.) .tp_makeSumstatsEntry()) + entries <- map(1:3, function(.) .tp_makeSumstatsEntry()) ss <- QtlSumStats( study = rep("s1", 3), context = c("c1", "c2", "c1"), @@ -3435,7 +3553,7 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): list-form methods, joint m ) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( mt, - methods = list(mrmash_weights = list()), + methods = list(mrmash = list()), jointSpecification = "context", cisWindow = 1000L, verbose = 0 @@ -3644,8 +3762,13 @@ test_that(".ensembleAccumulateWeights skips a dim-mismatched member", { # @noRd .twrssf_n <- function(ss, ...) { + # `...` is the panel filter: every caller passes only its fields. sum(lengths(suppressWarnings(suppressMessages( - twasWeightsPipeline(ss, methods = "lasso", ...) + twasWeightsPipeline( + ss, + methods = "lasso", + panelFilterArgs = PanelFilterParam(...) + ) )))) } @@ -3681,7 +3804,7 @@ test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { length(.panelVariantFilter( getLdSketch(ss), ids, - mafCutoff = cut + PanelFilterParam(mafCutoff = cut) )), label = str_c("mafCutoff ", cut) ) @@ -3774,7 +3897,7 @@ test_that("method tokens are read from a character vector or a named list", { f <- pecotmr:::.twasMethodTokensFromArg expect_equal(f(c("lasso", "enet")), c("lasso", "enet")) expect_equal( - f(list(lasso_weights = list(), enetWeights = list())), + f(list(lasso = list(), enet = list())), c("lasso", "enet") ) # Anything else contributes no tokens rather than erroring. @@ -3864,7 +3987,7 @@ test_that(".twasMvThreadFit warns and returns NULL when the fit is absent", { "S1", "T1", c("cA", "cB"), - list(fineMappingResult = NULL) + fineMappingResult = NULL ), "no 'mvsusie' fit found" ) @@ -3872,16 +3995,20 @@ test_that(".twasMvThreadFit warns and returns NULL when the fit is absent", { }) test_that(".twasQssMultivariateFitOne returns no rows when the fit is absent", { - p <- list( - fineMappingResult = NULL, - methodArgs = list(), - retainFitDetail = FALSE - ) # mvsusie carries an adapter, so the missing pre-fit short-circuits # before any weight function is called. expect_warning( rows <- pecotmr:::.twasQssMultivariateFitOne( - "mvsusie", "S1", "T1", c("cA", "cB"), NULL, NULL, p + "mvsusie", + "S1", + "T1", + c("cA", "cB"), + NULL, + NULL, + methodArgs = list(), + fitRetention = "none", + fineMappingResult = NULL, + dataType = NULL ), "no 'mvsusie' fit found" ) @@ -3893,14 +4020,22 @@ test_that(".twasQssMultivariateFitOne promotes vector weights to a matrix", { stat = NULL, variantIds = c("chr1:1:A:G", "chr1:2:A:G") ) - p <- list(methodArgs = list(), retainFitDetail = FALSE, dataType = "rnaseq") local_mocked_bindings( .twasTryWeights = function(...) c(0.5, 0.25), .package = "pecotmr" ) # mrmash has no adapter, so the thread-fit branch is skipped entirely. rows <- pecotmr:::.twasQssMultivariateFitOne( - "mrmash", "S1", "T1", "cA", mvStat, NULL, p + "mrmash", + "S1", + "T1", + "cA", + mvStat, + NULL, + methodArgs = list(), + fitRetention = "none", + fineMappingResult = NULL, + dataType = "rnaseq" ) expect_length(rows, 1L) expect_equal(rows[[1L]]$context, "cA") @@ -3910,7 +4045,7 @@ test_that(".twasQssMultivariateFitOne promotes vector weights to a matrix", { test_that(".twasQssAssemble passes the joint result through alone", { jr <- "SENTINEL_JOINT" expect_identical( - pecotmr:::.twasQssAssemble(list(), jr, list(ldSketch = NULL)), + pecotmr:::.twasQssAssemble(list(), jr, ldSketch = NULL), jr ) }) @@ -3920,15 +4055,23 @@ test_that(".twasMsJointPhase aborts when only mrmash asked and it fails", { .twasDispatchJointSpecsMultiStudy = function(...) NULL, .package = "pecotmr" ) - p <- list( - methods = "mrmash", data = NULL, contexts = NULL, traitId = NULL, - cisWindow = NULL, verbose = FALSE, retainFit = FALSE, - retainFitDetail = FALSE, seed = 1L - ) # Stripping mrmash leaves nothing, so a NULL joint result is fatal # rather than a fall-through to the per-tuple phase. expect_error( - pecotmr:::.twasMsJointPhase(p, list(spec1 = "x"), NULL), + pecotmr:::.twasMsJointPhase( + list(spec1 = "x"), + "mrmash", + pecotmr:::.twasMsJointCfg( + data = NULL, + contexts = NULL, + traitId = NULL, + cisWindow = NULL, + verbose = FALSE, + xRegions = NULL, + fitRetention = "none", + seed = 1L + ) + ), "no joint fits produced" ) }) @@ -3947,3 +4090,416 @@ test_that(".twasRunMultivariateGrid returns NULL when every region is empty", { ) ) }) + +test_that(".fmrAnyCvResult reports whether any row carries cross-validation", { + # Not a fine-mapping result at all, and a result whose rows carry no + # cvResult, both answer FALSE; one row with a cvResult answers TRUE. + expect_false(pecotmr:::.fmrAnyCvResult(NULL)) + expect_false(pecotmr:::.fmrAnyCvResult("not a result")) + tl <- data.frame( + variant_id = "chr1:100:A:G", + pip = 0.5, + stringsAsFactors = FALSE + ) + bare <- fineMappingRow("chr1:100:A:G", list(), tl) + noCv <- QtlFineMappingResult( + study = "S", + context = "C", + trait = "T", + method = "susie", + entry = list(bare) + ) + expect_false(pecotmr:::.fmrAnyCvResult(noCv)) + withCv <- QtlFineMappingResult( + study = "S", + context = "C", + trait = "T", + method = "susie", + entry = list(fineMappingRow( + "chr1:100:A:G", + list(), + tl, + cvResult = list( + samplePartition = data.frame( + Sample = c("s1", "s2"), + Fold = c(1L, 2L) + ) + ) + )) + ) + expect_true(pecotmr:::.fmrAnyCvResult(withCv)) +}) + +test_that("a per-method bundle may name wrapper and engine arguments", { + skip_if_not_installed("mr.mashr") + # A token's arguments are one flat bag that .splitMethodArgs routes in + # two directions, so both destinations' names are legal and the bundle + # is NOT coerced into the engine's Options record -- that would reject + # the wrapper half. + wrapper <- TwasWeightsMethodsParam( + qtlDatasetMethods = list( + mrmash = list(dataDrivenPriorMatrices = list()) + ) + ) + expect_true(is_in( + "dataDrivenPriorMatrices", + names(wrapper$qtlDatasetMethods$mrmash) + )) + engine <- TwasWeightsMethodsParam( + qtlDatasetMethods = list(mrmash = list(max_iter = 5)) + ) + expect_true(is_in("max_iter", names(engine$qtlDatasetMethods$mrmash))) + # A name belonging to neither reaches nothing, so it is a mistake. + expect_error( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(mrmash = list(zzz = 1)) + ), + "unknown argument" + ) +}) + +test_that("a fit-derived method takes no options but can be selected", { + # Naming one with list() selects it, which the aggregator could not + # express -- it conflated selecting a method with configuring one. + expect_s4_class( + TwasWeightsMethodsParam(qtlDatasetMethods = list(mvsusie = list())), + "TwasWeightsMethodsParam" + ) + expect_error( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(susie = list(L = 1)) + ), + "extracts weights from a fit supplied via" + ) +}) + +test_that("an entry must come from that method's constructor for that path", { + skip_if_not_installed("glmnet") + # lasso and enet share the glmnet constructor, so the check is on the + # engine the method uses -- and now on the engine for THIS path, which + # the path-blind aggregator could not narrow to. + expect_s4_class( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(enet = GlmnetOptions()) + ), + "TwasWeightsMethodsParam" + ) + expect_error( + TwasWeightsMethodsParam(qtlDatasetMethods = list(lasso = QggOptions())), + "uses the 'glmnet' constructor" + ) + expect_error( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(bayesA = GlmnetOptions()) + ), + "uses the 'qgg' constructor" + ) +}) + +test_that("only an engine that takes `...` goes unchecked", { + # An engine is unchecked for exactly one reason: its own signature ends + # in `...`, so every name is legal and there is nothing to reject. + # cv.glmnet, cv.ncvreg and RcppDPR::fit_model do; the rest enumerate. + skip_if_not_installed("glmnet") + skip_if_not_installed("ncvreg") + expect_output(show(GlmnetOptions()), "NOT checked") + expect_output(show(NcvregOptions()), "NOT checked") + # L0Learn enumerates, and so do all four pecotmr RSS solvers -- each has + # its own constructor rather than riding on the individual-level one. + skip_if_not_installed("L0Learn") + expect_output(show(L0learnOptions()), "checked") + expect_failure(expect_output(show(L0learnOptions()), "NOT checked")) + for (ctor in list( + PenalizedRssOptions, + LassosumOptions, + SdprOptions, + PrsCsOptions + )) { + expect_failure(expect_output(show(ctor()), "NOT checked")) + } +}) + +test_that("each path takes that path's own constructor", { + # lasso fits with glmnet on individual data and with pecotmr's lassosum + # solver on summary statistics. The aggregator accepted either for + # either; the slots now say which belongs where. + skip_if_not_installed("glmnet") + expect_s4_class( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(lasso = GlmnetOptions()), + qtlSumStatsMethods = list(lasso = LassosumOptions()) + ), + "TwasWeightsMethodsParam" + ) + expect_s4_class( + TwasWeightsMethodsParam( + qtlSumStatsMethods = list( + mcp = PenalizedRssOptions(), + dprGibbs = SdprOptions() + ) + ), + "TwasWeightsMethodsParam" + ) + # Crossed over, each is wrong for the slot it is in. + expect_error( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(lasso = LassosumOptions()) + ), + "options are for QtlSumStats" + ) + # enet has no summary-statistics path at all. + expect_error( + TwasWeightsMethodsParam(qtlSumStatsMethods = list(enet = list())), + "enet is not a method this pipeline runs on QtlSumStats" + ) +}) + +test_that("twasWeightsPipeline: fitRetention='full' says so when unhonourable", { + # Only the mr.mash engines distinguish the levels; for every other + # method "full" was silently indistinguishable from "slim". + expect_error( + twasWeightsPipeline( + .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A"), + methods = "lasso", + fitRetention = "full" + ), + "only honoured by the mr.mash methods" + ) + # A mixed run warns and proceeds -- mr.mash honours "full", lasso does + # not. Asserted on the rule itself: driving it through the pipeline would + # also need mr.mash mocked, which tests the mock rather than the rule. + expect_warning( + pecotmr:::.twasWarnUnretainableDetail("full", c("lasso", "mrmash")), + "lasso retain their usual fit" + ) + expect_silent(pecotmr:::.twasWarnUnretainableDetail("full", "mrmash")) + expect_silent(pecotmr:::.twasWarnUnretainableDetail("slim", "lasso")) + expect_silent(pecotmr:::.twasWarnUnretainableDetail("none", "lasso")) + # Tokens unknown yet (methods = NULL) defers rather than guessing. + expect_silent(pecotmr:::.twasWarnUnretainableDetail("full", NULL)) +}) + +test_that("twasWeightsPipeline: fitRetention rejects an unknown level", { + expect_error( + twasWeightsPipeline( + .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A"), + methods = "lasso", + fitRetention = "trimmed" + ), + "must be one of" + ) +}) + +test_that("twasWeightsPipeline(QtlDataset): residualization reaches the fit", { + # It was a declared formal that .twasPipelineQtlDataset did not even + # take, so every QtlDataset run used the default regardless of the ask. + cap <- new.env(parent = emptyenv()) + local_mocked_bindings( + .fmResidGeno = function(x, residualizationArgs, ...) { + cap$geno <- residualizationArgs + matrix( + 0, + nrow = 2, + ncol = 2, + dimnames = list(c("s1", "s2"), c("v1", "v2")) + ) + }, + .package = "pecotmr" + ) + suppressWarnings(try( + suppressMessages(twasWeightsPipeline( + .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A"), + methods = "lasso", + cisWindow = 1000L, + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + residualizationArgs = ResidualizationParam( + residualizeGenotype = FALSE + ) + )), + silent = TRUE + )) + expect_false(cap$geno$residualizeGenotype) +}) + +test_that("twasWeightsPipeline(QtlDataset): usePCA adds top-PC rows", { + # The TWAS peer of fineMappingPipeline's usePCA: a second dispatch cell + # whose enumerator builds the same IndividualJointGroup with PC scores as + # Y, so CV / ensemble / retention apply unchanged. + qd <- .tp_makeQtlDataset( + contexts = "brain", + traits = c("ENSG_A", "ENSG_B") + ) + exec( + local_mocked_bindings, + !!!c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") + ) + ) + run <- function(usePCA) { + suppressMessages(suppressWarnings(twasWeightsPipeline( + qd, + methods = "lasso", + cisWindow = 1000L, + verbose = 0, + usePCA = usePCA, + nPCs = 2L, + crossValidationArgs = CrossValidationParam(folds = 0), + ensembleArgs = EnsembleParam() + ))) + } + plain <- run(FALSE) + withPc <- run(TRUE) + expect_false(any(str_detect(as.character(getTraits(plain)), "^topPC"))) + pcs <- unique(as.character(getTraits(withPc))) + expect_true(any(str_detect(pcs, "^topPC"))) + # the per-trait rows are still there -- PC rows are additional + expect_true(all(is_in(c("ENSG_A", "ENSG_B"), pcs))) +}) + +test_that("a multivariate method needs every MultiStudy component multivariate", { + # mvsusie / mr.mash / fsusie fit one model across a tuple's traits and + # contexts, so each component they run on must supply a multivariate Y. + uni <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + multi <- .tp_makeQtlDataset( + contexts = c("brain", "liver"), + traits = "ENSG_A" + ) + multi2 <- .tp_makeQtlDataset( + contexts = c("brain", "liver"), + traits = "ENSG_B" + ) + # A MultiStudyQtlDataset needs at least two studies, so both arms carry + # two; only the mix includes a univariate one. + mixed <- MultiStudyQtlDataset(qtlDatasets = list(s1 = multi, s2 = uni)) + allMv <- MultiStudyQtlDataset(qtlDatasets = list(s1 = multi, s2 = multi2)) + + expect_error( + pecotmr:::.twasCheckMultivariateComponents("mrmash", mixed), + "every study in a MultiStudyQtlDataset must be multivariate" + ) + expect_match( + tryCatch( + pecotmr:::.twasCheckMultivariateComponents("mrmash", mixed), + error = function(e) conditionMessage(e) + ), + "s2" + ) + expect_silent( + pecotmr:::.twasCheckMultivariateComponents("mrmash", allMv) + ) + # A univariate method is unaffected by any of this. + expect_silent(pecotmr:::.twasCheckMultivariateComponents("lasso", mixed)) + expect_silent(pecotmr:::.twasCheckMultivariateComponents( + character(0), + mixed + )) +}) + +test_that("a multivariate group resumes from the cache only in full", { + # The resume cache used to be consulted by the univariate builder only: + # .twasCacheLookup keys on one (study, context, trait, method), and a + # multivariate fit spans every context in its (study, trait) group, so + # there was no per-group question being asked. There is -- it is just + # all-or-nothing, because reusing some contexts' weights while refitting + # the others would mix two fits inside a group that was fitted together. + w <- .tp_tw(study = "s1", context = "c1", trait = "t1", method = "mrmash") + + # One context cached out of two -> no reuse. + expect_null(pecotmr:::.twasMvCacheHits( + w, + "s1", + "t1", + c("c1", "c2"), + "mrmash" + )) + # The one context it does have -> reuse. + hit <- pecotmr:::.twasMvCacheHits(w, "s1", "t1", "c1", "mrmash") + expect_length(hit, 1L) + expect_named(hit, "c1") + # A different method or trait is not this group. + expect_null(pecotmr:::.twasMvCacheHits(w, "s1", "t1", "c1", "mvsusie")) + expect_null(pecotmr:::.twasMvCacheHits(w, "s1", "t2", "c1", "mrmash")) + # No cache at all is the ordinary case and must not error. + expect_null(pecotmr:::.twasMvCacheHits(NULL, "s1", "t1", "c1", "mrmash")) +}) + +test_that("twasWeightsPipeline: multivariate resume is all-or-nothing", { + # The unit test above asks .twasMvCacheHits directly, which cannot tell a + # cache hit from a mocked fit -- both hand back weights. Here the fitter + # is a counting spy, so "reused" means it was never reached. + ss <- .tp_makeQtlSumStats(n_entries = 2L) # 2 contexts of (s1, t1) + calls <- new.env(parent = emptyenv()) + calls$n <- 0L + exec( + local_mocked_bindings, + !!!c( + list( + extractBlockGenotypes = .tp_mockExtractor(), + mrmashRssWeights = function(stat, LD, ...) { + calls$n <- calls$n + 1L + k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L + matrix(0, nrow(LD), k, dimnames = list(rownames(LD), NULL)) + } + ), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") + ) + ) + + # Cold run: one joint fit spans both contexts of the group. + cold <- suppressMessages(suppressWarnings( + twasWeightsPipeline(ss, methods = "mrmash", verbose = 0) + )) + expect_equal(nrow(cold), 2L) + expect_equal(calls$n, 1L) + + # Every context of the group is cached, so nothing is refitted. + calls$n <- 0L + warm <- suppressMessages(suppressWarnings(twasWeightsPipeline( + ss, + methods = "mrmash", + verbose = 0, + twasWeights = cold + ))) + expect_equal(nrow(warm), 2L) + expect_equal(calls$n, 0L) + + # One context short: the whole group refits rather than mixing two fits. + calls$n <- 0L + partial <- cold[1] + expect_equal(nrow(partial), 1L) + refit <- suppressMessages(suppressWarnings(twasWeightsPipeline( + ss, + methods = "mrmash", + verbose = 0, + twasWeights = partial + ))) + expect_equal(nrow(refit), 2L) + expect_equal(calls$n, 1L) +}) + +test_that(".ensembleAssertCv reports the fold count it actually saw", { + # The message interpolated `crossValidation$folds`, but the formal is + # `crossValidationArgs` -- so firing the assertion raised glue's own + # "failed to evaluate" instead of the actionable message. Error paths + # are where this hides: the condition was right, only the report was not. + expect_error( + pecotmr:::.ensembleAssertCv( + EnsembleParam(enabled = TRUE), + CrossValidationParam(folds = 0) + ), + "requires CrossValidationParam\\(folds >= 2\\); got folds = 0" + ) + # Enabled with folds, or disabled entirely, both pass silently. + expect_silent(pecotmr:::.ensembleAssertCv( + EnsembleParam(enabled = TRUE), + CrossValidationParam(folds = 5) + )) + expect_silent(pecotmr:::.ensembleAssertCv( + EnsembleParam(), + CrossValidationParam(folds = 0) + )) +}) diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index 0838e95fc..d0f1e5819 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -1199,12 +1199,61 @@ test_that(".harmonizeRestoreUnmatched is a no-op when nothing is unmatched", { withExtra <- rbind( targetData, data.frame( - chrom = "chr1", pos = 300L, A1 = "A", A2 = "G", + chrom = "chr1", + pos = 300L, + A1 = "A", + A2 = "G", stringsAsFactors = FALSE ) ) appended <- pecotmr:::.harmonizeRestoreUnmatched( - result, matchResult, withExtra + result, + matchResult, + withExtra ) expect_equal(nrow(appended$result), 3L) }) + +test_that("parseVariantId: rejects input that is neither character nor df", { + expect_error(parseVariantId(1:3), "One of the following must apply") +}) + +test_that("normalizeVariantId: argument guards fire", { + ids <- "chr1:100:A:G" + expect_error(normalizeVariantId(1:3), "Must be of type 'character'") + expect_error( + normalizeVariantId(ids, chrPrefix = NA), + "chrPrefix.*May not be NA" + ) + expect_error( + normalizeVariantId(ids, chrPrefix = c(TRUE, FALSE)), + "chrPrefix.*Must have length 1" + ) + expect_error( + normalizeVariantId(ids, convention = "nope"), + "convention.*Must be of type 'list'" + ) +}) + +test_that("regionToDf: argument guards fire", { + expect_error(regionToDf(1L), "Must be of type 'character'") + expect_error( + regionToDf("1_100_200", colnames = c("a", "b")), + "colnames.*Must have length 3" + ) +}) + +test_that("asGranges leaves an already chr-prefixed chromosome alone", { + # The prefix is added only when absent; a frame that already carries it + # must not become "chrchr1". + gr <- asGranges(data.frame( + chrom = c("chr1", "chr2"), + start = c(100L, 200L), + end = c(150L, 250L), + stringsAsFactors = FALSE + )) + expect_identical( + as.character(GenomicRanges::seqnames(gr)), + c("chr1", "chr2") + ) +}) diff --git a/tests/testthat/test_vcfWriter.R b/tests/testthat/test_vcfWriter.R index 403934dee..810e3aeaa 100644 --- a/tests/testthat/test_vcfWriter.R +++ b/tests/testthat/test_vcfWriter.R @@ -4,7 +4,7 @@ # Test data helpers # ============================================================================= -make_test_genotype_handle <- function() { +makeTestGenotypeHandle <- function() { new( "GenotypeHandle", path = "/tmp/test.gds", @@ -16,7 +16,7 @@ make_test_genotype_handle <- function() { ) } -make_test_gwasSumStats <- function(n = 5) { +makeTestGwasSumStats <- function(n = 5) { gr <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(start = seq(100, by = 100, length.out = n), width = 1) @@ -32,11 +32,11 @@ make_test_gwasSumStats <- function(n = 5) { study = "test_trait", entry = list(gr), genome = "hg38", - ldSketch = make_test_genotype_handle() + ldSketch = makeTestGenotypeHandle() ) } -make_test_finemapping_result <- function(n = 5) { +makeTestFineMappingResult <- function(n = 5) { beta <- seq(0.5, by = -0.1, length.out = n) se <- rep(0.1, n) zv <- seq(5.0, by = -1.0, length.out = n) @@ -83,7 +83,7 @@ test_that("writeSumStatsVcf writes GwasSumStats to uncompressed VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - ss <- make_test_gwasSumStats(5) + ss <- makeTestGwasSumStats(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) @@ -101,7 +101,7 @@ test_that("writeSumStatsVcf writes GwasSumStats to bgzipped VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - ss <- make_test_gwasSumStats(5) + ss <- makeTestGwasSumStats(5) out <- tempfile(fileext = ".vcf.bgz") on.exit(unlink(c(out, paste0(out, ".tbi")), force = TRUE), add = TRUE) @@ -119,7 +119,7 @@ test_that("writeSumStatsVcf writes FineMappingResult to uncompressed VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fm <- make_test_finemapping_result(5) + fm <- makeTestFineMappingResult(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) @@ -133,7 +133,7 @@ test_that("writeSumStatsVcf(FineMappingResult): emits PIP + CS posterior FORMAT skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fm <- make_test_finemapping_result(5) + fm <- makeTestFineMappingResult(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) writeSumStatsVcf(fm, out) @@ -200,7 +200,7 @@ test_that("writeSumStatsVcf writes FineMappingResult to BCF", { ) skip_if(!asbcf_works, "Rsamtools::asBcf is not functional in this build") - fm <- make_test_finemapping_result(5) + fm <- makeTestFineMappingResult(5) out <- tempfile(fileext = ".bcf") on.exit(unlink(out), add = TRUE) @@ -256,10 +256,10 @@ test_that("writeSumStatsVcf errors on empty FineMappingResult", { # splitByContext / splitByTrait — one file per tuple # ============================================================================= -.make_multi_tuple_qtl_fmr <- function() { +.makeMultiTupleQtlFmr <- function() { contexts <- c("brain", "blood") traits <- c("ENSG_A", "ENSG_B") - entries <- lapply(seq_along(contexts), function(i) { + entries <- map(seq_along(contexts), function(i) { ids <- paste0("chr1:", 100 * (1:3), ":T:A") tl <- data.frame( variant_id = ids, @@ -293,7 +293,7 @@ test_that("writeSumStatsVcf errors on empty FineMappingResult", { test_that("writeSumStatsVcf(FineMappingResult): splitByContext emits one VCF per context", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fmr <- .make_multi_tuple_qtl_fmr() + fmr <- .makeMultiTupleQtlFmr() baseOut <- tempfile(fileext = ".vcf") on.exit( unlink(list.files( @@ -316,7 +316,7 @@ test_that("writeSumStatsVcf(FineMappingResult): splitByContext emits one VCF per test_that("writeSumStatsVcf(FineMappingResult): splitByTrait emits one VCF per trait", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fmr <- .make_multi_tuple_qtl_fmr() + fmr <- .makeMultiTupleQtlFmr() baseOut <- tempfile(fileext = ".vcf") on.exit( unlink(list.files( @@ -335,7 +335,7 @@ test_that("writeSumStatsVcf(FineMappingResult): splitByTrait emits one VCF per t test_that("writeSumStatsVcf(FineMappingResult): splitByContext + splitByTrait combines tags", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fmr <- .make_multi_tuple_qtl_fmr() + fmr <- .makeMultiTupleQtlFmr() baseOut <- tempfile(fileext = ".vcf") on.exit( unlink(list.files( @@ -359,7 +359,7 @@ test_that("writeSumStatsVcf(FineMappingResult): splitByContext + splitByTrait co test_that("writeSumStatsVcf(FineMappingResult): multi-row without split flags requires selectors", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fmr <- .make_multi_tuple_qtl_fmr() + fmr <- .makeMultiTupleQtlFmr() out <- tempfile(fileext = ".vcf") expect_error(writeSumStatsVcf(fmr, out), "2 matching rows") }) @@ -368,7 +368,7 @@ test_that("writeSumStatsVcf(FineMappingResult): multi-row without split flags re # GwasSumStats: multi-study selection, MAF/AF field, .gz rename # ============================================================================= -.make_two_study_gwasSumStats <- function(n = 3, withMaf = FALSE) { +.makeTwoStudyGwasSumStats <- function(n = 3, withMaf = FALSE) { mkGr <- function() { gr <- GenomicRanges::GRanges( "chr1", @@ -394,13 +394,13 @@ test_that("writeSumStatsVcf(FineMappingResult): multi-row without split flags re study = c("studyA", "studyB"), entry = list(mkGr(), mkGr()), genome = "hg38", - ldSketch = make_test_genotype_handle() + ldSketch = makeTestGenotypeHandle() ) } test_that("writeSumStatsVcf(GwasSumStats): multi-study without `study` selector errors", { skip_if_not_installed("VariantAnnotation") - ss2 <- .make_two_study_gwasSumStats() + ss2 <- .makeTwoStudyGwasSumStats() out <- tempfile(fileext = ".vcf") expect_error(writeSumStatsVcf(ss2, out), "2 studies") }) @@ -408,7 +408,7 @@ test_that("writeSumStatsVcf(GwasSumStats): multi-study without `study` selector test_that("writeSumStatsVcf(GwasSumStats): `study` selector writes the chosen study", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - ss2 <- .make_two_study_gwasSumStats() + ss2 <- .makeTwoStudyGwasSumStats() out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) res <- writeSumStatsVcf(ss2, out, study = "studyB") @@ -437,7 +437,7 @@ test_that("writeSumStatsVcf(GwasSumStats): emits the AF genotype field when MAF gr })), genome = "hg38", - ldSketch = make_test_genotype_handle() + ldSketch = makeTestGenotypeHandle() ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) @@ -450,7 +450,7 @@ test_that("writeSumStatsVcf(GwasSumStats): emits the AF genotype field when MAF test_that("writeSumStatsVcf(GwasSumStats): .vcf.gz output is renamed from writeVcf's .bgz", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - ss <- make_test_gwasSumStats(5) + ss <- makeTestGwasSumStats(5) out <- tempfile(fileext = ".vcf.gz") on.exit(unlink(c(out, paste0(out, ".tbi")), force = TRUE), add = TRUE) res <- writeSumStatsVcf(ss, out) @@ -467,7 +467,7 @@ test_that("writeSumStatsVcf(GwasSumStats): .vcf.gz output is renamed from writeV test_that("writeSumStatsVcf(FineMappingResult): explicit selectors pick a single row", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fmr <- .make_multi_tuple_qtl_fmr() + fmr <- .makeMultiTupleQtlFmr() out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) res <- writeSumStatsVcf( @@ -485,7 +485,7 @@ test_that("writeSumStatsVcf(FineMappingResult): explicit selectors pick a single test_that("writeSumStatsVcf(FineMappingResult): no matching rows errors", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fmr <- .make_multi_tuple_qtl_fmr() + fmr <- .makeMultiTupleQtlFmr() out <- tempfile(fileext = ".vcf") expect_error( writeSumStatsVcf(fmr, out, study = "does_not_exist"), @@ -496,7 +496,7 @@ test_that("writeSumStatsVcf(FineMappingResult): no matching rows errors", { test_that("writeSumStatsVcf(FineMappingResult): splitByContext decorates composite .vcf.bgz paths", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") - fmr <- .make_multi_tuple_qtl_fmr() + fmr <- .makeMultiTupleQtlFmr() baseOut <- tempfile(fileext = ".vcf.bgz") stem <- tools::file_path_sans_ext(tools::file_path_sans_ext(baseOut)) on.exit( @@ -523,7 +523,7 @@ test_that("writeSumStatsVcf(FineMappingResult): splitByContext on a context-less skip_if_not_installed("Biostrings") # GwasFineMappingResult has no context/trait axes, so the split tag set is # empty and the original output path is used unchanged. - fm <- make_test_finemapping_result(5) + fm <- makeTestFineMappingResult(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) paths <- writeSumStatsVcf(fm, out, splitByContext = TRUE) @@ -632,7 +632,7 @@ test_that("writeSumStatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit 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) + fm <- makeTestFineMappingResult(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( diff --git a/vignettes/coloc-pipeline.Rmd b/vignettes/coloc-pipeline.Rmd index 8ad07bc1a..e23153bc0 100644 --- a/vignettes/coloc-pipeline.Rmd +++ b/vignettes/coloc-pipeline.Rmd @@ -62,14 +62,15 @@ qtlFmr <- fineMappingPipeline( The recommend approach is to provide `colocPipeline()` a `QtlFineMappingResult` and a `GwasSumStats`. The pipeline runs `fineMappingPipeline()` internally on -the GWAS sumstats (with `finemappingMethods`) over the exact window used in the +the GWAS sumstats (configured by `GwasFineMappingParam()`) over the exact +window used in the `QtlFineMappingResult`, then runs `coloc.bf_bf` per (QTL, GWAS) pair. ```{r coloc-quickstart} res <- colocPipeline( qtlFineMappingResult = qtlFmr, gwasInput = gwasSumStatsS4Example, - finemappingMethods = "susie" + gwasFineMappingArgs = GwasFineMappingParam(methods = "susie") ) res ``` @@ -112,45 +113,65 @@ included. Two opt-in filters can adjust this: | Filter | Description | Default | |---|---|---| -| `filterLbfCs` | TRUE keeps only effects that produced a credible set (`trimmedFit$sets$cs_index`). | FALSE | -| `filterLbfCsSecondary` | Numeric coverage in (0,1). Runs a CS-concentration filter at that coverage. | NULL | -| `filterLbfCsConcentration` | Numeric in (0,1). Concentration factor: a CS at coverage X is kept only if it spans fewer than `nVariants * X * concentration` variants. | 0.5 | -| `priorTol` | Drop effects whose estimated prior variance is at or below this threshold. | 1e-9 | +| `ColocLbfFilterParam(filterLbfCs=)` | TRUE keeps only effects that produced a credible set (`trimmedFit$sets$cs_index`). | FALSE | +| `ColocLbfFilterParam(secondary=)` | Numeric coverage in (0,1). Runs a CS-concentration filter at that coverage. | NULL | +| `ColocLbfFilterParam(concentration=)` | Numeric in (0,1). Concentration factor: a CS at coverage X is kept only if it spans fewer than `nVariants * X * concentration` variants. | 0.5 | +| `ColocLbfFilterParam(priorTol=)` | Drop effects whose estimated prior variance is at or below this threshold. | 1e-9 | ```{r coloc-filter-example, eval=FALSE} colocPipeline( qtlFineMappingResult = qtlFmr, gwasInput = gwasSumStatsS4Example, - filterLbfCsSecondary = 0.5, # 50% CS concentration filter - filterLbfCsConcentration = 0.5 + lbfFilterArgs = ColocLbfFilterParam( + secondary = 0.5, # 50% CS concentration filter + concentration = 0.5 + ) ) # span < 25% of locus variants ``` -## Enrichment-aware coloc (enloc mode) +## Enrichment-aware colocalisation (enloc mode) -Pass a per-`(gwasStudy, qtlContext)` enrichment table (the output of -`qtlEnrichmentPipeline()`) to scale the shared-signal prior: +Passing a per-`(gwasStudy, qtlContext)` enrichment table --- the output of +`qtlEnrichmentPipeline()` --- switches the pair from coloc to enloc. This is +a port of `fastenloc`, not a reweighting of coloc: the priors are *derived* +from the enrichment estimate rather than the baseline `p12` being scaled by +it. -\[ p_{12}^{\text{used}} = \min\bigl(p_{12}\,(1 + \text{enrichment}),\, -p_{12,\max}\bigr) \] +The estimator returns the enrichment parameters $(a_0, a_1)$ on the log-odds +scale, and the priors follow as `fastenloc`'s `set_enrich_params` writes them, +with $P_{\text{eQTL}}$ the per-variant QTL prior: -Pairs without a matching enrichment row fall back to the baseline -`p12` with a warning. Two extra columns are added to the output: -`enrichment` (the lookup) and `p12Used` (what was actually passed to -`coloc.bf_bf`). +\[ p_1 = (1 - P_{\text{eQTL}})\,\sigma(a_0), \quad +p_2 = P_{\text{eQTL}}\,\bigl(1 - \sigma(a_0 + a_1)\bigr), \quad +p_{12} = P_{\text{eQTL}}\,\sigma(a_0 + a_1) \] + +`qtlEnrichmentPipeline()` carries all three out as the `colocP1`, `colocP2` +and `colocP12` columns, so the table you pass already holds them. Because the +enrichment determines the priors, supplying `priors` as well is an error +rather than a silent precedence rule. + +What makes the scoring enloc rather than coloc is that the prior depends on +whether the GWAS hit *is* the causal QTL --- $\sigma(a_0 + a_1)$ when it is, +$\sigma(a_0)$ when it is not. coloc applies one $p_{12}$ to every shared +configuration and cannot express that. + +Pairs without a matching enrichment row fall back to the baseline priors with +a warning. Four columns are added: `enrichment` and `p12Used` (the per-pair +factor and the derived shared-signal prior), plus `RCP` and `LCP`, enloc's +regional and locus colocalisation probabilities. Those last two are the same +quantities as `PP.H4.abf` and `PP.H3.abf + PP.H4.abf`, reported under enloc's +names as well. ```{r coloc-enloc, eval=FALSE} -enrichmentTable <- data.frame( - gwasStudy = "trait1", - qtlContext = "brain", - enrichment = 2.5, - stringsAsFactors = FALSE +enrichmentTable <- qtlEnrichmentPipeline( + gwasFineMappingResult = gwasFineMappingExample, + qtlFineMappingResult = qtlFineMappingExample, + verbose = FALSE ) colocPipeline( qtlFineMappingResult = qtlFmr, gwasInput = gwasSumStatsS4Example, - enrichment = enrichmentTable, - p12Max = 1e-3 + enrichment = enrichmentTable ) ``` @@ -177,17 +198,19 @@ colocPipeline( colocPipeline( qtlFineMappingResult = qtlFmr, gwasInput = gwasSumStatsS4Example, - filterLbfCs = FALSE, - filterLbfCsSecondary = NULL, # e.g. 0.5 - filterLbfCsConcentration = 0.5, - priorTol = 1e-9, - p1 = 1e-4, - p2 = 1e-4, - p12 = 5e-6, - finemappingMethods = "susie", # inline GWAS FM when needed + lbfFilterArgs = ColocLbfFilterParam( + filterLbfCs = FALSE, + secondary = NULL, # e.g. 0.5 + concentration = 0.5, + priorTol = 1e-9 + ), + priors = ColocPriorParam(p1 = 1e-4, p2 = 1e-4, p12 = 5e-6), + gwasFineMappingArgs = GwasFineMappingParam( # inline GWAS FM when needed + methods = "susie", + credibleSetArgs = CredibleSetParam(coverage = 0.95) + ), returnGwasFineMapping = FALSE, enrichment = NULL, # data.frame for enloc mode - p12Max = 1e-3, adjustPips = TRUE ) ``` diff --git a/vignettes/constructing-qtl-datasets.Rmd b/vignettes/constructing-qtl-datasets.Rmd index 2b2a59912..8cff984c0 100644 --- a/vignettes/constructing-qtl-datasets.Rmd +++ b/vignettes/constructing-qtl-datasets.Rmd @@ -181,9 +181,11 @@ applied at load), for example: ```{r qtl-manifest-qc} qdFiltered <- loadQtlDatasetFromManifest( manifest, - mafCutoff = 0.01, - imissCutoff = 0.05, - keepIndel = FALSE + genotypeFilterArgs = GenotypeFilterParam( + mafCutoff = 0.01, + imissCutoff = 0.05, + keepIndel = FALSE + ) ) ``` @@ -305,6 +307,20 @@ large an unrelated set as possible. `relatednessThreshold` defaults to 0.0625, which is third-degree relatives; raise it to 0.125 to keep everyone but second-degree and closer. +The column names above are the defaults. A table that spells them differently +is described with `RelatednessColumnsParam()`: + +```r +filterRelatedness( + relatedness, + columns = RelatednessColumnsParam(iid1 = "ID1", iid2 = "ID2", value = "KINSHIP") +) +``` + +Building the description rather than passing a bare list means a misspelled +field is an error at the call site instead of a default silently left in +place. + The exclusion list is not applied for you — feed it to `keepSamples`, the constructor argument this vignette introduced above, or subset an existing dataset with `qd[, unrelated, ]`. Both narrow `colData` and `sampleMap` diff --git a/vignettes/constructing-sumstats.Rmd b/vignettes/constructing-sumstats.Rmd index 5e25a3138..d4e704f5c 100644 --- a/vignettes/constructing-sumstats.Rmd +++ b/vignettes/constructing-sumstats.Rmd @@ -393,7 +393,7 @@ The collections carry no QC yet. Run `summaryStatsQc()` before any downstream analysis (it populates `qcInfo`; downstream pipelines require it): ```{r qc, eval=FALSE} -gws_qcd <- summaryStatsQc(gws, zMismatchQc = "slalom") +gws_qcd <- summaryStatsQc(gws, ldMismatchQcMethod = "slalom") ``` See the *Quality Control for GWAS and QTL Summary Statistics* vignette for the diff --git a/vignettes/ctwas-pipeline.Rmd b/vignettes/ctwas-pipeline.Rmd index 6e0310a8b..9ffaf1035 100644 --- a/vignettes/ctwas-pipeline.Rmd +++ b/vignettes/ctwas-pipeline.Rmd @@ -99,7 +99,10 @@ gwasSumStats <- loadGwasSumStatsFromManifest( region = "chr22:10000000-19000000", ldBlocks = blocks ) -gwasByRegion <- summaryStatsQc(gwasSumStats, mafCutoff = 0.0025) +gwasByRegion <- summaryStatsQc( + gwasSumStats, + panelFilterArgs = PanelFilterParam(mafCutoff = 0.0025) +) data(ctwasWeightsExample) ``` @@ -110,13 +113,17 @@ data(ctwasWeightsExample) res <- ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), - thin = 1, - niterPrefit = 3, - niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - min_nonSNP_PIP = 0, - fallbackToPrefit = TRUE + ctwasPriorArgs = CtwasPriorParam( + thin = 1, + niterPrefit = 3, + niter = 10, + fallbackToPrefit = TRUE + ), + methodArgs = CtwasOptions( + min_group_size = 1, + min_p_single_effect = 0, + min_nonSNP_PIP = 0 + ) ) res ``` @@ -156,13 +163,13 @@ scales with them. Four arguments trim each gene before cTWAS sees it: | Argument | Effect | |---|---| -| `twasWeightCutoff` | drop variants with `abs(weight)` below the cutoff | -| `maxNumVariants` | cap variants per gene | +| `weightCutoff` | drop variants with `abs(weight)` below the cutoff | +| `maxVariants` | cap variants per gene | | `csMinCor` | keep variants in a credible set with purity at least this | -| `minPipCutoff` | keep variants with PIP above this | +| `pipRescue` | keep variants with PIP above this | -`csMinCor` and `minPipCutoff` mark variants as must-keep, so they survive -the `maxNumVariants` cap. Both need a `fineMappingResult`; without one they +`csMinCor` and `pipRescue` mark variants as must-keep, so they survive +the `maxVariants` cap. Both need a `fineMappingResult`; without one they are no-ops and the cap falls back to ordering by `abs(weight)`. ```{r ctwas-filters, eval=FALSE} @@ -170,10 +177,12 @@ ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), fineMappingResult = fmr, - twasWeightCutoff = 1e-4, - maxNumVariants = 1000, - csMinCor = 0.8, - minPipCutoff = 0.1 + variantPruningArgs = VariantPruningParam( + weightCutoff = 1e-4, + maxVariants = 1000, + csMinCor = 0.8, + pipRescue = 0.1 + ) ) ``` @@ -211,7 +220,7 @@ set. PIPs, and the EM group priors sit on each row's entry: ```{r ctwas-param} -param <- getCtwasParam(res$entry[[1]]) +param <- getCtwasGroupPriors(res$entry[[1]]) param$group_prior param$group_prior_var param$converged @@ -234,16 +243,17 @@ inputs <- assembleCtwasInputs( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample) ) -est <- estCtwasParam( +est <- estCtwasGroupPriors( inputs, - thin = 1, - niterPrefit = 3, - niter = 10, - min_group_size = 1, - min_p_single_effect = 0, - fallbackToPrefit = TRUE + ctwasPriorArgs = CtwasPriorParam( + thin = 1, + niterPrefit = 3, + niter = 10, + fallbackToPrefit = TRUE + ), + methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0) ) -screened <- screenCtwasRegions(est, min_nonSNP_PIP = 0) +screened <- screenCtwasRegions(est, methodArgs = CtwasOptions(min_nonSNP_PIP = 0)) finemapped <- finemapCtwasRegions(screened) nrow(finemapped$finemap_res) ``` @@ -261,12 +271,12 @@ Each step's payload is also bundled, so you can enter anywhere: ```{r ctwas-bundled-payloads, eval=FALSE} data(ctwasInputsExample) # after assembleCtwasInputs -data(ctwasEstExample) # after estCtwasParam +data(ctwasEstExample) # after estCtwasGroupPriors data(ctwasFinemapExample) # after finemapCtwasRegions ``` The most common reason to use the granular path is to override the priors. -`estCtwasParam()`'s accurate-EM step can diverge on underpowered data; +`estCtwasGroupPriors()`'s accurate-EM step can diverge on underpowered data; `fallbackToPrefit = TRUE` handles that automatically, but taking the steps apart lets you substitute priors of your own into `screenCtwasRegions()`. @@ -285,7 +295,8 @@ merged <- mergeCtwasBoundaryRegions( ) ``` -`ctwasPipeline(mergeBoundary = TRUE)` does the same thing inline, with +`ctwasPipeline(boundaryMergeArgs = BoundaryMergeParam(enabled = TRUE))` does +the same thing inline, with `mergePipThresh` / `mergeFilterCs` / `mergeMaxSNP` forwarding to those arguments. It is off by default because it only matters when a high-PIP gene actually straddles a boundary. @@ -297,15 +308,18 @@ ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), method = NULL, # NULL: "ensemble" if present, else every method - thin = 0.1, - niterPrefit = 3, - niter = 30, L = 5, - groupPriorVarStructure = "shared_type", ncore = 1, keepSnps = FALSE, - mergeBoundary = FALSE, - fallbackToPrefit = FALSE + ctwasPriorArgs = CtwasPriorParam( + thin = 0.1, + niterPrefit = 3, + niter = 30, + varStructure = "shared_type", + fallbackToPrefit = FALSE + ), + variantPruningArgs = VariantPruningParam(), + boundaryMergeArgs = BoundaryMergeParam(enabled = FALSE) ) ``` diff --git a/vignettes/fine-mapping.Rmd b/vignettes/fine-mapping.Rmd index 9189abbb7..1fafd9346 100644 --- a/vignettes/fine-mapping.Rmd +++ b/vignettes/fine-mapping.Rmd @@ -160,12 +160,14 @@ fineMappingPipeline( methods = c("susie", "susieInf"), contexts = "brain", traitId = "ENSG_example", - region = "chr22:25000000-26000000", cisWindow = 5e5, - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5), - signalCutoff = 0.025, - minAbsCorr = 0.8, + credibleSetArgs = CredibleSetParam( + coverage = 0.95, + secondaryCoverage = c(0.7, 0.5), + signalCutoff = 0.025, + minAbsCorr = 0.8, + L = 10L + ), addSusieInf = TRUE, naAction = "drop", # "drop" (default) or "impute" verbose = 1 @@ -175,12 +177,16 @@ fineMappingPipeline( - `naAction` controls how phenotype NAs are handled by `getResidualizedPhenotypes()`: `"drop"` removes samples with any NA across the requested traits, `"impute"` mean-imputes each trait independently. -- `addSusieInf = TRUE` runs SuSiE-inf first and uses its result to initialise - the susie fit, which improves credible-set purity in regions with - background polygenic signal. -- `secondaryCoverage` adds secondary CS columns at the requested coverages - (alongside the primary `coverage`); useful when you want both narrow and - broad CS reports. +- `addSusieInf = TRUE` runs SuSiE-inf first and uses its result to + initialise the susie fit, which improves credible-set purity in regions + with background polygenic signal. +- `CredibleSetParam(L = ...)` bounds how many single effects the fit may + carry, and so how many credible sets can exist. +- `CredibleSetParam(secondaryCoverage = ...)` adds secondary CS columns at the + requested coverages (alongside the primary `coverage`); useful when you + want both narrow and broad CS reports. +- Each of these settings is a constructor rather than a loose argument, so a + misspelled option is an error instead of being silently ignored. ## Joint multi-context / multi-trait fits diff --git a/vignettes/mash-pipeline.Rmd b/vignettes/mash-pipeline.Rmd index 4a6b57e8b..b894f71aa 100644 --- a/vignettes/mash-pipeline.Rmd +++ b/vignettes/mash-pipeline.Rmd @@ -69,7 +69,11 @@ ss ```{r mash-pipeline, results="hide"} sumStatsList <- list(strong = ss, random = ss, null = ss) -fit <- mashPipeline(sumStatsList, alpha = 0, nPcs = 2L) +fit <- mashPipeline( + sumStatsList, + alpha = 0, + prior = MashPriorParam(nPcs = 2L) +) ``` ```{r mash-pipeline-show} @@ -110,8 +114,8 @@ a null set: fitSimple <- mashPipeline( sumStatsList, alpha = 0, - nPcs = 2L, - residualCorrelationMethod = "simple" + residualCorrelationMethod = "simple", + prior = MashPriorParam(priorCovariances = fit$U) ) ``` @@ -119,6 +123,11 @@ fitSimple <- mashPipeline( round(head(sort(fitSimple$w, decreasing = TRUE), 5), 4) ``` +Passing `fit$U` back in holds the prior fixed, so `Vhat` is the only thing +that differs from the fit above and the shift in the weights is attributable +to it alone. Re-estimating the prior here would confound the comparison -- +and cost a second data-driven estimate for a prior you already have. + Supplying a `null` partition while leaving the default in place reports that the partition is going unused, since that combination is more often an oversight than an intent. @@ -204,16 +213,25 @@ mashPriorCovariances( alpha = 0, vhat = vhat, components = c("canonical", "pca", "flash", "flashNonneg"), - engine = "cov_ed", # or "ud" / "ud_ted" (udr) + engine = "covEd", # or "covUdr", or "none" nPcs = 2L ) ``` -`"cov_ed"` is the default and is mashr's own extreme deconvolution. The -`udr` engines are opt-in and have known numerical issues; `"ud_ted"` -additionally assumes i.i.d. (Z-scale) data. Their dominant cost is -`udControl$n_unconstrained` (default 50), which is worth cutting sharply -when you have few conditions. +`"covEd"` is the default and is mashr's own extreme deconvolution. `"covUdr"` +is opt-in and has known numerical issues; its TED update additionally assumes +i.i.d. (Z-scale) data, so it is requested as +`CovUdrOptions(fit = UdFitOptions(unconstrained.update = "ted"))` rather than +as a separate engine name. udr is two functions -- `ud_init()` then +`ud_fit()` -- so each one's arguments travel in their own bundle and are +checked against their own source. Its dominant cost is +`CovUdrOptions(init = UdInitOptions(n_unconstrained = ))` (default 50), +which is worth cutting sharply when you have few conditions. + +The engine refines only the *data-driven* components. Canonical components +are fixed structural hypotheses -- identity, singletons, equal effects -- and +reach the prior unmodified, matching mashr's own workflow. `engine = "none"` +uses the data-driven components as generated, without refinement. To bypass the covariance chain entirely and fit weights against a prior you already have: diff --git a/vignettes/rss-qc.Rmd b/vignettes/rss-qc.Rmd index 51e5651ca..3ceb6dff0 100644 --- a/vignettes/rss-qc.Rmd +++ b/vignettes/rss-qc.Rmd @@ -57,14 +57,17 @@ make these objects. In this example the object is `GwasSumStats` object called ```{r run-qc, eval=FALSE} gws_qcd <- summaryStatsQc( gws, - useDbsnpRefCheck = FALSE, # opt-in to MungeSumstats dbSNP checks - removeIndels = FALSE, - removeStrandAmbiguous = TRUE, - mafCutoff = 0, # 0 = off; > 0 requires MAF column - infoCutoff = 0, # 0 = off; > 0 requires INFO column - nCutoff = 5, + sumstatsFilterArgs = SumstatsFilterParam( + removeIndels = FALSE, + removeStrandAmbiguous = TRUE, + infoCutoff = 0, # 0 = off; > 0 requires INFO column + nCutoff = 5 + ), + panelFilterArgs = PanelFilterParam( + mafCutoff = 0 # 0 = off; > 0 requires MAF column + ), skipRegion = NULL, # e.g. MHC "chr6:25000000-35000000" - zMismatchQc = "slalom", # "none", "slalom", "dentist" + ldMismatchQcMethod = "slalom", # "none", "slalom", "dentist" alleleFlipKriging = FALSE, # opt-in pre-SLALOM LD-consistency check impute = FALSE, # RAISS imputation against ldSketch matchMinProp = 0 @@ -209,17 +212,17 @@ head(kr$diagnostics) # variant_id, z, predicted, residual, statistic, ``` Kriging and SLALOM/DENTIST are complementary and can be combined: the kriging -prefilter removes allele-flip outliers up front, then `zMismatchQc` handles the -remaining LD-mismatch variants. +prefilter removes allele-flip outliers up front, then `ldMismatchQcMethod` +handles the remaining LD-mismatch variants. ## LD mismatch correction with SLALOM and DENTIST -`summaryStatsQc(zMismatchQc = ...)` dispatches to one of two +`summaryStatsQc(ldMismatchQcMethod = ...)` dispatches to one of two LD-mismatch detectors. They differ in how they decide whether a variant's z-score is inconsistent with the LD pattern around it. **SLALOM** (Kanai et al. 2022, the recommended default once you turn -zMismatchQc on): +ldMismatchQcMethod on): - For each variant, compares its z-score against the *lead* variant's z-score scaled by their LD: a large `(z_i − r_{i,lead} · z_lead)` flags the variant @@ -252,7 +255,7 @@ DENTIST's outlier rate is sensitive to its window size. On a typical | 20,000 | ∼0.6 % | For this reason SLALOM is the recommended default when you turn -zMismatchQc on. Use DENTIST when you specifically want its iterative +ldMismatchQcMethod on. Use DENTIST when you specifically want its iterative imputation output, or when you are reproducing a DENTIST-based pipeline. @@ -260,25 +263,32 @@ pipeline. SLALOM only *flags* outliers; it does not impute them. To re-impute the flagged variants from the surviving ones, pair SLALOM with **RAISS** (a -LD-regression imputer). `summaryStatsQc(zMismatchQc = "slalom", impute = TRUE)` +LD-regression imputer). +`summaryStatsQc(ldMismatchQcMethod = "slalom", impute = TRUE)` does this for you. The standalone version is exposed as `raiss()`; the -full set of RAISS knobs lives under the `imputeOpts` argument to -`summaryStatsQc()`: +full set of RAISS knobs lives under the `imputeArgs` argument to +`summaryStatsQc()`, built with `RaissParam()`: ```{r raiss-args, eval=FALSE} gws_qcd <- summaryStatsQc( gws, - zMismatchQc = "slalom", + ldMismatchQcMethod = "slalom", impute = TRUE, - imputeOpts = list( - rcond = 0.01, + imputeArgs = RaissParam( r2Threshold = 0.6, minimumLd = 5, - lamb = 0.01 + lamb = 0.01, + # Bound what RAISS is asked to impute, and widen the window it reads. + mafCutoff = 0.01, + flank = 5e5 ) ) ``` +QC always hands RAISS a genotype matrix, so it solves through the SVD path +and takes `svdTol`; `raiss()`'s `rcond` belongs to its LD-matrix path and is +deliberately not offered here. + ## Next steps diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index 8415431ff..c0fa77860 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -50,7 +50,8 @@ data(qtlDatasetExample, qtlSumStatsExample, multiStudyQtlDatasetExample) ## Individual-level weights The simplest individual-level call learns a single regression-based weight set -from a `QtlDataset`. Cross-validation is enabled by default (`cvFolds = 5`). +from a `QtlDataset`. Cross-validation is off by default +(`CrossValidationParam(folds = 0)`). Like `fineMappingPipeline()`, you need to tell it which genotype window to extract — `cisWindow` (per trait) is the most common choice. @@ -98,11 +99,23 @@ set of per-variant weight estimates. When you pass an existing matching `(study, context, trait)` tuple is added to the ensemble as an additional weights row instead of being re-fit. +The same holds under cross-validation: each fold needs a fit trained on that +fold's rows, and the weights pipeline will not produce one. Run the +fine-mapping with `crossValidation` so those per-fold fits travel with the +result — +requesting a fine-mapping method under cross-validation without them is an +error. That fold partition then governs the whole run: every other weight +method is cross-validated on the same folds, which is what makes their +scores comparable. The fold samples must be the samples of the dataset being +scored, or the run stops rather than scoring a fit against rows it was never +separated from. + ```{r individual-with-fmr} fmr <- fineMappingPipeline( qtlDatasetExample, methods = "susie", - cisWindow = 1e6 + cisWindow = 1e6, + crossValidationArgs = CrossValidationParam(folds = 3) ) tw2 <- twasWeightsPipeline( qtlDatasetExample, @@ -240,8 +253,10 @@ pipeline consumes, so reach for the raw function when you want the diagnostics rather than just the weights. The mr.mash methods need prior covariance matrices, built by -`buildMrmashPriorMatrices()` from components like `computeCovDiag()` and -`computeCovFlash()`. +`buildMrmashPriorMatrices()`. Pass `dataDrivenPriorMatrices` to add +data-driven components alongside the canonical mixture --- `computeCovDiag()` +gives the per-condition diagonal, and `mashr::cov_flash()` returns a list of +FLASH-derived components in the shape that argument expects. ## Cross-validation, ensembling and prediction @@ -250,7 +265,7 @@ combination of the others, with the weights chosen by cross-validation. Those steps are exported too: - `twasWeightsCv()` runs the cross-validation that scores each method. -- `learnTwasWeights()` fits one method across CV folds. +- `learnTwasWeights()` runs the requested weight methods on the full data. - `combineTwasWeights()` forms the ensemble from per-method weights. - `estimateSparsity()` reports how sparse a fitted weight vector is. @@ -278,24 +293,33 @@ twasWeightsPipeline( traitId = "ENSG_example", region = "chr22:25000000-26000000", cisWindow = 5e5, - cvFolds = 5, - samplePartition = NULL, - maxCvVariants = -1, - cvThreads = 1, - ensemble = TRUE, - ensembleR2Threshold = 0.01, - ensembleSolver = "quadprog", + crossValidationArgs = CrossValidationParam( + folds = 5, + numThreads = 1, + samplePartition = NULL, + maxVariants = -1 + ), + # required for a fine-mapping method, and under folds > 1 it must carry + # the per-fold fits (fineMappingPipeline(..., crossValidationArgs = ...)) + fineMappingResult = fmr, + ensembleArgs = EnsembleParam( + enabled = TRUE, + r2Threshold = 0.01, + solver = "quadprog" + ), estimatePi = TRUE, - phenotypeCovariatesToResidualize = NULL, - genotypeCovariatesToResidualize = NULL, + residualizationArgs = ResidualizationParam( + phenotypeCovariates = NULL, + genotypeCovariates = NULL + ), dataType = NULL, naAction = "drop" ) ``` -- `ensemble = TRUE` adds an additional `ensembleWeights` row to the collection - — a weighted combination of the individual methods' CV predictions filterd - by `ensembleR2Threshold`. +- `EnsembleParam(enabled = TRUE)` adds an additional `ensembleWeights` row to + the collection — a weighted combination of the individual methods' CV + predictions, filtered by that bundle's `r2Threshold`. - `naAction` is forwarded to `getResidualizedPhenotypes()` (see the [fine-mapping vignette](fine-mapping.html#common-parameters) for semantics). @@ -339,7 +363,7 @@ do.call(getDataType, c(list(tw), key)) # tag carried through for reporting matrix for multivariate ones. The remaining payloads are keyed the same way: `getVariantIds()` for the aligned variant set, `getCvResult()` for the cross-validation record (`rsq`, `r`, predicted values), and `getFits()` for -the full fit object when the pipeline was run with `retainFit = TRUE`. +the full fit object when the pipeline kept fits (`fitRetention != "none"`). `resolveWeights()` returns the weights and their variant IDs together, which is the form the downstream TWAS and MR steps consume. diff --git a/vignettes/twas-zscore.Rmd b/vignettes/twas-zscore.Rmd index 091bbec79..d64aaa2bb 100644 --- a/vignettes/twas-zscore.Rmd +++ b/vignettes/twas-zscore.Rmd @@ -47,10 +47,13 @@ library(pecotmr) data(qtlDatasetExample, gwasSumStatsS4Example) # Pre-compute the QTL-side products from the bundled QtlDataset. +# crossValidation carries the per-fold susie fits to the weights pipeline, +# which never fine-maps for itself. fmr <- fineMappingPipeline( qtlDatasetExample, methods = "susie", - cisWindow = 1e6 + cisWindow = 1e6, + crossValidationArgs = CrossValidationParam(folds = 3) ) tw <- twasWeightsPipeline( qtlDatasetExample, @@ -86,8 +89,7 @@ res2 <- causalInferencePipeline( gwasSumStats = gwasSumStatsS4Example, twasWeights = tw, fineMappingResult = fmr, - mrMethod = "ivwPerVariant", - mrPipCutoff = 0.5 + mrArgs = MrParam(method = "ivwPerVariant", pipCutoff = 0.5) ) S4Vectors::mcols(res2)[, c( "twasZ", @@ -101,18 +103,17 @@ S4Vectors::mcols(res2)[, c( ## MR variants: per-variant vs CS-aware IVW -| `mrMethod` | What it does | Extra filters | +| `MrParam(method=)` | What it does | Extra filters | |---|---|---| -| `"ivwPerVariant"` (default) | Treats every `topLoci` variant with `pip > mrPipCutoff` as an IV; pools their Wald ratios via inverse-variance weighting. | `mrPipCutoff` | -| `"csAware"` | Groups variants by credible set (column `cs` in `topLoci`), forms a PIP-weighted composite Wald ratio per CS (subject to per-CS cumulative-PIP cutoff `mrCpipCutoff`), then IVW-pools across CSs. Reports Cochran's Q and I-squared. | `mrCpipCutoff` | +| `"ivwPerVariant"` (default) | Treats every `topLoci` variant with `pip > pipCutoff` as an IV; pools their Wald ratios via inverse-variance weighting. | `pipCutoff` | +| `"csAware"` | Groups variants by credible set (column `cs` in `topLoci`), forms a PIP-weighted composite Wald ratio per CS (subject to per-CS cumulative-PIP cutoff `cpipCutoff`), then IVW-pools across CSs. Reports Cochran's Q and I-squared. | `cpipCutoff` | ```{r ci-csaware, eval=FALSE} causalInferencePipeline( gwasSumStats = gwasSumStatsS4Example, twasWeights = tw, fineMappingResult = fmr, - mrMethod = "csAware", - mrCpipCutoff = 0.5 + mrArgs = MrParam(method = "csAware", cpipCutoff = 0.5) ) ``` @@ -167,9 +168,10 @@ causalInferencePipeline( gwasSumStats = gwasSumStatsS4Example, twasWeights = tw, fineMappingResult = fmr, - mrPipCutoff = 0.5, # ivwPerVariant - mrMethod = "ivwPerVariant", - mrCpipCutoff = 0.5, # csAware + mrArgs = MrParam( + method = "ivwPerVariant", + pipCutoff = 0.5 # cpipCutoff instead, for method = "csAware" + ), combineMethods = NULL ) # e.g. c("acat", "hmp") ```