diff --git a/NAMESPACE b/NAMESPACE index 31edc915..378c0196 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method(as.data.frame,GwasSumStats) S3method(dplyr::arrange,RangedTupleList) S3method(dplyr::filter,RangedTupleList) S3method(dplyr::group_by,RangedTupleList) @@ -13,6 +12,22 @@ S3method(postprocessFinemappingFit,susiF) S3method(postprocessFinemappingFit,susie) S3method(postprocessFinemappingFit,susieInf) S3method(postprocessFinemappingFit,susieRss) +export("af<-") +export("credibleSetParam<-") +export("csCoverage<-") +export("fineMappingMethods<-") +export("fitRetention<-") +export("includeAllCs<-") +export("initializeWithSusieInf<-") +export("maf<-") +export("medianAbsCorr<-") +export("minAbsCorr<-") +export("nSamples<-") +export("panelFilterParam<-") +export("perCsColumns<-") +export("secondaryCoverage<-") +export("signalCutoff<-") +export("susieRssParam<-") export(AnnotationMatrix) export(AspuOptions) export(BglrOptions) @@ -32,10 +47,18 @@ export(CovPcaOptions) export(CovUdrOptions) export(CredibleSetParam) export(CrossValidationParam) +export(CtwasBoundaryGenesOptions) +export(CtwasEstParamOptions) +export(CtwasExpandOptions) +export(CtwasFinemapOptions) +export(CtwasGeneZOptions) +export(CtwasMergeOptions) export(CtwasOptions) export(CtwasPriorParam) +export(CtwasRegionDataOptions) export(CtwasResult) export(CtwasResultEntry) +export(CtwasScreenOptions) export(DentistParam) export(DprOptions) export(EnsembleParam) @@ -113,11 +136,16 @@ export(UdFitOptions) export(UdInitOptions) export(VariantPruningParam) export(WeightSelectionParam) +export(af) +export(annotCols) +export(annotData) +export(annotationJackknifeCoefs) export(asCtwasResult) export(asGranges) export(assembleCtwasInputs) export(autoDecision) export(bLassoWeights) +export(baselineAnnotations) export(bayesAWeights) export(bayesAlphabetWeights) export(bayesBWeights) @@ -125,6 +153,7 @@ export(bayesCWeights) export(bayesLWeights) export(bayesNWeights) export(bayesRWeights) +export(blockMetadata) export(buildLdEigen) export(buildLdScore) export(buildMrmashPriorMatrices) @@ -133,7 +162,12 @@ export(calculateFeatureScores) export(causalInferencePipeline) export(checkLd) export(classifyVariantType) +export(colocBoostOutcomes) +export(colocCredibleSets) +export(colocGenes) +export(colocPairs) export(colocPipeline) +export(colocVariants) export(colocboostPipeline) export(combineFineMappingResults) export(combineGwasSumStats) @@ -148,7 +182,17 @@ export(computeLd) export(computeLdScores) export(computeSldscAnnotSd) export(computeSldscMRef) +export(computingTime) +export(contexts) +export(credibleSetParam) +export(credibleSetSummary) +export(credibleSets) +export(csCoverage) +export(ctwasGroupPriors) export(ctwasPipeline) +export(ctwasPosteriors) +export(cvFits) +export(cvResult) export(dentist) export(dentistSingleWindow) export(dprAdaptiveGibbsWeights) @@ -156,6 +200,7 @@ export(dprGibbsWeights) export(dprVbWeights) export(dprWeights) export(effectiveN) +export(eigenList) export(enetWeights) export(enforceDesignFullRank) export(enlocClusterProbabilities) @@ -169,147 +214,61 @@ export(filterInvalidSummaryStat) export(filterMixtureComponents) export(filterRelatedness) export(filterVariantsByLdReference) +export(fineMappingMethods) export(fineMappingPipeline) +export(fineMappingResult) export(fineMappingRow) export(finemapCtwasRegions) export(fitFsusie) export(fitMashContrast) export(fitMvsusie) export(fitMvsusieRss) +export(fitRetention) export(fitSusieInfThenSusieRss) export(flattenTupleRanges) export(formatFinemappingOutput) +export(frqData) export(fsusieAffectedRegions) export(fsusieCredibleBand) export(fsusieGetCs) export(fsusieWeights) export(fsusieWrapper) -export(getAddSusieInf) -export(getAf) -export(getAnnotCols) -export(getAnnotData) -export(getBaseline) -export(getBeta) -export(getBlockMetadata) -export(getCandidates) -export(getColocBoostOutcomes) -export(getColocCredibleSets) -export(getColocGenes) -export(getColocPairs) -export(getColocVariants) -export(getComputingTime) -export(getContexts) -export(getCorrelation) -export(getCoverage) -export(getCredibleSetArgs) -export(getCredibleSetSummary) -export(getCs) -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) -export(getGenome) -export(getGenotypeCovariates) -export(getGenotypes) -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) -export(getQcDiagnostics) -export(getQcInfo) -export(getQtlDatasets) -export(getRefPanel) -export(getRefVariantInfo) -export(getRegion) -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) -export(getStudy) -export(getSumStats) -export(getSumStatsDf) -export(getSusieAlpha) -export(getSusieFit) -export(getSusieResult) -export(getTauBlocks) -export(getTopLoci) -export(getTraitName) -export(getTraitPosition) -export(getTraitRun) -export(getTraitRuns) -export(getTraits) -export(getTwasWeights) -export(getVarY) -export(getVariantIds) -export(getVariantInfo) -export(getWeights) -export(getXvarCutoff) -export(getZ) +export(fullFit) +export(genomicRegion) +export(genotypeCovariates) +export(genotypes) export(glmnetWeights) export(h2EstimateToSldscTrait) export(hasGenotypes) +export(heritabilityEstimate) +export(heritabilityEstimateSe) +export(heritabilityIntercept) +export(heritabilityInterceptSe) +export(imissCutoff) +export(inSample) +export(includeAllCs) +export(initializeWithSusieInf) export(intersectVariants) export(invertMinmaxScaling) export(isBinarySldscAnnot) +export(keepIndel) +export(keepVariants) export(krigingOutlierQc) export(l0learnRssWeights) export(l0learnWeights) export(lassoWeights) export(lassosumRss) export(lassosumRssWeights) +export(lbf) export(lbfToAlpha) +export(ldBlocks) export(ldClumpByScore) +export(ldMatrix) +export(ldMatrixList) export(ldMismatchQc) +export(ldPanelNSamples) export(ldPruneByCorrelation) +export(ldSketch) export(learnTwasWeights) export(loadGenotypeRegion) export(loadGwasSumStatsFromManifest) @@ -317,7 +276,12 @@ export(loadLdMatrix) export(loadMultiStudyQtlDatasetFromManifest) export(loadQtlDatasetFromManifest) export(loadQtlSumStatsFromManifest) +export(localH2Blocks) +export(macCutoff) +export(maf) +export(mafCutoff) export(makePairwiseContrastCol) +export(marginalEffects) export(mashCovarianceComponents) export(mashInput) export(mashModelFit) @@ -327,14 +291,22 @@ export(mashPosteriorContrast) export(mashPriorCovariances) export(mashRandNullSample) export(mashResidualCorrelation) +export(maxNumSingleEffects) +export(maxNumSingleEffectsGreedy) export(mcpRssWeights) export(mcpWeights) +export(medianAbsCorr) export(mergeCtwasBoundaryRegions) export(mergeMashData) export(mergeSusieCs) export(mergeVariantInfo) export(metaAnalysisPerCondition) export(metaSldscRandom) +export(methodFits) +export(methodNames) +export(minAbsCorr) +export(mixtureWeights) +export(molecularTraits) export(mrashRssWeights) export(mrashWeights) export(mrmashRssWeights) @@ -342,18 +314,27 @@ export(mrmashWeights) export(mrmashWrapper) export(mvsusieRssWeights) export(mvsusieWeights) +export(nSamples) export(nSignificantScore) export(nSnps) export(nestTupleRanges) export(normalizeVariantId) export(overlapTopLoci) +export(panelFilterParam) export(parseRegion) export(parseVariantId) export(penalizedRss) +export(perCsColumns) +export(phenotypeCovariates) +export(pip) export(postprocessFinemappingFits) export(prsCs) export(prsCsWeights) +export(pval) +export(qcDiagnostics) +export(qcInfo) export(qtlAssociationPostprocess) +export(qtlDatasets) export(qtlEnrichment) export(qtlEnrichmentPipeline) export(qtlSumStatsFromBetaMatrix) @@ -365,51 +346,71 @@ export(readGenotypes) export(readSldscAnnot) export(readSldscFrq) export(readSldscTrait) +export(refPanel) +export(refVariantInfo) export(regionToDf) +export(regionVcp) +export(residualizedGenotypes) +export(residualizedPhenotypes) export(resolveWeights) +export(retainedMass) export(sanitizeMashData) export(scadRssWeights) export(scadWeights) +export(scaleResiduals) export(scoreFromCs) +export(scoreStats) export(screenCtwasRegions) export(sdpr) export(sdprWeights) +export(se) +export(secondaryCoverage) 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(signalCutoff) +export(significantQtls) export(slalom) export(sldscPostprocessingPipeline) +export(sldscResults) export(sldscSubsetMeta) export(sliceMashData) +export(snpIdx) export(standardizeSldscTrait) +export(stratifiedHeritabilityEnrichment) +export(studyName) export(subsetChr) export(subsetRegion) +export(sumStats) export(summaryStatsQc) +export(susieAlpha) export(susieAshRssWeights) export(susieAshWeights) +export(susieFit) export(susieInfRssWeights) export(susieInfWeights) +export(susieResult) +export(susieRssParam) export(susieRssWeights) export(susieWeights) +export(testedAnnotations) +export(topLoci) +export(traitNames) +export(traitPosition) export(twasPredict) +export(twasWeights) export(twasWeightsCv) export(twasWeightsPipeline) export(twasWeightsRow) export(twasZ) export(updateMashModelCov) +export(varY) +export(variantIds) +export(variantInfo) export(waldTestPval) +export(weightStandardized) +export(weightsDataType) export(writeSumStatsVcf) +export(xvarCutoff) +export(z) exportClasses(AnnotationMatrix) exportClasses(BoundaryMergeParam) exportClasses(ColocBoostResult) @@ -473,126 +474,124 @@ exportMethods("$<-") exportMethods("[") exportMethods("[[") exportMethods("[[<-") +exportMethods("af<-") +exportMethods("maf<-") +exportMethods("nSamples<-") +exportMethods(af) +exportMethods(annotCols) +exportMethods(annotData) +exportMethods(annotationJackknifeCoefs) exportMethods(as.data.frame) exportMethods(as.list) +exportMethods(baselineAnnotations) exportMethods(bindROWS) +exportMethods(blockMetadata) +exportMethods(coef) exportMethods(colnames) +exportMethods(colocBoostOutcomes) +exportMethods(colocCredibleSets) +exportMethods(colocGenes) +exportMethods(colocPairs) +exportMethods(colocVariants) exportMethods(colocboostPipeline) exportMethods(computeLdScores) +exportMethods(computingTime) +exportMethods(contexts) +exportMethods(credibleSetSummary) +exportMethods(credibleSets) +exportMethods(ctwasGroupPriors) +exportMethods(ctwasPosteriors) +exportMethods(cvFits) +exportMethods(cvResult) +exportMethods(eigenList) exportMethods(endoapply) exportMethods(estimateH2) exportMethods(fineMappingPipeline) +exportMethods(fineMappingResult) +exportMethods(frqData) exportMethods(fsusieAffectedRegions) exportMethods(fsusieCredibleBand) -exportMethods(getAf) -exportMethods(getAnnotCols) -exportMethods(getAnnotData) -exportMethods(getBeta) -exportMethods(getBlockMetadata) -exportMethods(getColocBoostOutcomes) -exportMethods(getColocCredibleSets) -exportMethods(getColocGenes) -exportMethods(getColocPairs) -exportMethods(getColocVariants) -exportMethods(getComputingTime) -exportMethods(getContexts) -exportMethods(getCorrelation) -exportMethods(getCredibleSetSummary) -exportMethods(getCs) -exportMethods(getCtwasGroupPriors) -exportMethods(getCvFits) -exportMethods(getCvResult) -exportMethods(getDataType) -exportMethods(getEigenList) -exportMethods(getEnrichment) -exportMethods(getFineMappingResult) -exportMethods(getFinemap) -exportMethods(getFits) -exportMethods(getFrqData) -exportMethods(getFullFit) -exportMethods(getGenome) -exportMethods(getGenotypeCovariates) -exportMethods(getGenotypes) -exportMethods(getH2) -exportMethods(getH2Se) -exportMethods(getImissCutoff) -exportMethods(getInSample) -exportMethods(getIntercept) -exportMethods(getInterceptSe) -exportMethods(getKeepIndel) -exportMethods(getKeepVariants) -exportMethods(getLbf) -exportMethods(getLdBlocks) -exportMethods(getLdMatrixList) -exportMethods(getLdScoreWeights) -exportMethods(getLdScores) -exportMethods(getLdSketch) -exportMethods(getLocal) -exportMethods(getMacCutoff) -exportMethods(getMaf) -exportMethods(getMafCutoff) -exportMethods(getMarginalEffects) -exportMethods(getMethodNames) -exportMethods(getMixtureWeights) -exportMethods(getN) -exportMethods(getNRef) -exportMethods(getNSnps) -exportMethods(getP) -exportMethods(getPhenotypeCovariates) -exportMethods(getPhenotypes) -exportMethods(getPip) -exportMethods(getQcDiagnostics) -exportMethods(getQcInfo) -exportMethods(getQtlDatasets) -exportMethods(getRefPanel) -exportMethods(getRegion) -exportMethods(getRegionVcp) -exportMethods(getResidualizedGenotypes) -exportMethods(getResidualizedPhenotypes) -exportMethods(getRetainedMass) -exportMethods(getScaleResiduals) -exportMethods(getScoreStats) -exportMethods(getSe) -exportMethods(getSignificantQtls) -exportMethods(getSnpIdx) -exportMethods(getStandardized) -exportMethods(getStudy) -exportMethods(getSumStats) -exportMethods(getSumStatsDf) -exportMethods(getSusieAlpha) -exportMethods(getSusieFit) -exportMethods(getTauBlocks) -exportMethods(getTopLoci) -exportMethods(getTraitName) -exportMethods(getTraitPosition) -exportMethods(getTraitRun) -exportMethods(getTraitRuns) -exportMethods(getTraits) -exportMethods(getTwasWeights) -exportMethods(getVarY) -exportMethods(getVariantIds) -exportMethods(getVariantInfo) -exportMethods(getWeights) -exportMethods(getXvarCutoff) -exportMethods(getZ) +exportMethods(fullFit) +exportMethods(genomicRegion) +exportMethods(genotypeCovariates) +exportMethods(genotypes) exportMethods(hasGenotypes) +exportMethods(heritabilityEstimate) +exportMethods(heritabilityEstimateSe) +exportMethods(heritabilityIntercept) +exportMethods(heritabilityInterceptSe) +exportMethods(imissCutoff) +exportMethods(inSample) exportMethods(intersectVariants) +exportMethods(keepIndel) +exportMethods(keepVariants) +exportMethods(lbf) +exportMethods(ldBlocks) +exportMethods(ldMatrix) +exportMethods(ldMatrixList) +exportMethods(ldPanelNSamples) +exportMethods(ldSketch) exportMethods(length) +exportMethods(localH2Blocks) exportMethods(longForm) +exportMethods(macCutoff) +exportMethods(maf) +exportMethods(mafCutoff) +exportMethods(marginalEffects) +exportMethods(methodFits) +exportMethods(methodNames) +exportMethods(mixtureWeights) +exportMethods(molecularTraits) +exportMethods(nSamples) exportMethods(nSnps) exportMethods(names) exportMethods(ncol) exportMethods(nrow) exportMethods(overlapTopLoci) +exportMethods(phenotypeCovariates) +exportMethods(pip) +exportMethods(pval) +exportMethods(qcDiagnostics) +exportMethods(qcInfo) exportMethods(qtlAssociationPostprocess) +exportMethods(qtlDatasets) exportMethods(readAnnotations) exportMethods(readGenotypes) +exportMethods(refPanel) +exportMethods(regionVcp) +exportMethods(residualizedGenotypes) +exportMethods(residualizedPhenotypes) exportMethods(resolveWeights) +exportMethods(retainedMass) +exportMethods(scaleResiduals) +exportMethods(scoreStats) +exportMethods(se) exportMethods(show) +exportMethods(significantQtls) +exportMethods(sldscResults) +exportMethods(snpIdx) +exportMethods(stratifiedHeritabilityEnrichment) +exportMethods(studyName) exportMethods(subsetChr) exportMethods(subsetRegion) +exportMethods(sumStats) +exportMethods(susieAlpha) +exportMethods(susieFit) +exportMethods(testedAnnotations) +exportMethods(topLoci) +exportMethods(traitNames) +exportMethods(traitPosition) +exportMethods(twasWeights) exportMethods(twasWeightsPipeline) +exportMethods(varY) +exportMethods(variantIds) +exportMethods(variantInfo) +exportMethods(weightStandardized) +exportMethods(weights) +exportMethods(weightsDataType) exportMethods(writeSumStatsVcf) +exportMethods(xvarCutoff) +exportMethods(z) importClassesFrom(GenomicRanges,GRanges) importClassesFrom(MultiAssayExperiment,MultiAssayExperiment) importClassesFrom(S4Vectors,DataFrame) @@ -602,7 +601,9 @@ importClassesFrom(SummarizedExperiment,RangedSummarizedExperiment) importFrom(BiocGenerics, colnames, ncol, - nrow + nrow, + path, + weights ) importFrom(BiocParallel, MulticoreParam, diff --git a/R/AllClasses.R b/R/AllClasses.R index 8b8a15b5..80898645 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -36,7 +36,7 @@ setClassUnion( # list one handle per panel for a mixture reference, averaged by # `mixtureWeights` # matrix dosages already extracted and filtered, kept so -# getGenotypes() answers without reopening the file (see +# genotypes() answers without reopening the file (see # .loadLdFromBlocks); `snpIdx` is NULL in this case because # the matrix is already the subset # NULL no genotypes -- the object carries a pre-computed R @@ -79,9 +79,9 @@ setClassUnion("LdMixtureWeights", c("numeric", "NULL")) # lives in seqinfo, not a slot). Each element # is one tuple's per-variant GRanges: x[[i]], formerly x$entry[[i]]. # -# getZ / getN / getMaf / nSnps are -# defined once on SumStatsBase (they only delegate to getSumStats); subsetChr / -# getVarY / getSumStats / getSumStatsDf stay on the concrete subclass because +# z / nSamples / maf / nSnps are +# defined once on SumStatsBase (they only delegate to sumStats); subsetChr / +# varY / sumStats / as.data.frame stay on the concrete subclass because # they rely on the tuple shape (3-tuple QtlSumStats, 1-tuple GwasSumStats). # ============================================================================= @@ -104,7 +104,7 @@ setClassUnion("LdMixtureWeights", c("numeric", "NULL")) #' on construction; populated by \code{summaryStatsQc()} with a per-step audit #' record (filter names, drop counts, liftover target, RAISS settings, etc.). #' Fine-mapping and TWAS-weights pipelines reject inputs where -#' \code{length(getQcInfo(x)) == 0L} -- the slot serves as both the gating +#' \code{length(qcInfo(x)) == 0L} -- the slot serves as both the gating #' flag and the audit trail. #' @export setClass( @@ -202,33 +202,19 @@ setClass( ) } -#' @rdname getGenome +#' @rdname qcInfo #' @examples #' data(qtlSumStatsExample) -#' getGenome(qtlSumStatsExample) +#' qcInfo(qtlSumStatsExample) #' @export -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 <- discard(unique(GenomeInfoDb::genome(x)), is.na) - if (length(build) == 0L) NA_character_ else build[[1L]] -}) - -#' @rdname getQcInfo -#' @examples -#' data(qtlSumStatsExample) -#' getQcInfo(qtlSumStatsExample) -#' @export -setMethod("getQcInfo", "SumStatsBase", function(x) x@qcInfo) +setMethod("qcInfo", "SumStatsBase", function(x) x@qcInfo) -#' @rdname getQcDiagnostics +#' @rdname qcDiagnostics #' @examples #' data(qtlSumStatsExample) -#' getQcDiagnostics(qtlSumStatsExample) +#' qcDiagnostics(qtlSumStatsExample) #' @export -setMethod("getQcDiagnostics", "SumStatsBase", function(x, entry = 1L) { +setMethod("qcDiagnostics", "SumStatsBase", function(x, entry = 1L) { qc <- x@qcInfo if (length(qc) == 0L) { return(NULL) @@ -260,190 +246,457 @@ setMethod("getQcDiagnostics", "SumStatsBase", function(x, entry = 1L) { } }) -#' @rdname getLdSketch +#' @rdname ldSketch #' @examples #' data(qtlSumStatsExample) -#' getLdSketch(qtlSumStatsExample) +#' ldSketch(qtlSumStatsExample) #' @export -setMethod("getLdSketch", "SumStatsBase", function(x) x@ldSketch) +setMethod("ldSketch", "SumStatsBase", function(x) x@ldSketch) -#' @rdname getStudy +#' @rdname studyName #' @examples #' data(qtlDatasetExample) -#' getStudy(qtlDatasetExample) +#' studyName(qtlDatasetExample) #' @export -setMethod("getStudy", "SumStatsBase", function(x) unique(as.character(x$study))) +setMethod("studyName", "SumStatsBase", function(x) { + unique(as.character(x$study)) +}) -# getZ / getN / getMaf / nSnps delegate purely to getSumStats (which the +# z / nSamples / maf / nSnps delegate purely to sumStats (which the # concrete subclass dispatches with its own tuple shape), so they live once on # the base and forward `...` through. -#' @rdname getZ +#' @rdname z #' @examples #' data(qtlSumStatsExample) -#' getZ(qtlSumStatsExample) +#' z(qtlSumStatsExample) #' @export setMethod( - "getZ", + "z", "SumStatsBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) { sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - mcols(exec(getSumStats, x, !!!sel))$Z + mcols(exec(sumStats, x, !!!sel))$Z } ) -#' @rdname getN +#' @rdname nSamples #' @examples #' data(qtlSumStatsExample) -#' getN(qtlSumStatsExample) +#' nSamples(qtlSumStatsExample) #' @export setMethod( - "getN", + "nSamples", "SumStatsBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) { sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - mcols(exec(getSumStats, x, !!!sel))$N + mcols(exec(sumStats, x, !!!sel))$N } ) -# getP / getBeta / getSe are first-class alongside getZ / getN: they read the +# pval / coef / se are first-class alongside z / nSamples: they read the # optional P / BETA / SE mcols and return NULL when the entry does not carry # them (DataFrame `$` semantics), so a p-value-primary sumstats (e.g. TensorQTL # cis output) is an equal citizen to a Z-primary GWAS sumstats. -#' @rdname getP +#' @rdname pval #' @examples #' data(qtlSumStatsExample) -#' getP(qtlSumStatsExample) +#' pval(qtlSumStatsExample) #' @export setMethod( - "getP", + "pval", "SumStatsBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) { sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - mcols(exec(getSumStats, x, !!!sel))$P + mcols(exec(sumStats, x, !!!sel))$P } ) -#' @rdname getBeta +#' @rdname coef-methods #' @examples #' data(qtlSumStatsExample) -#' getBeta(qtlSumStatsExample) +#' coef(qtlSumStatsExample) #' @export setMethod( - "getBeta", + "coef", "SumStatsBase", function( - x, - study = NULL, + object, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, - ranges = NULL + ranges = NULL, + ... ) { sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - mcols(exec(getSumStats, x, !!!sel))$BETA + mcols(exec(sumStats, object, !!!sel))$BETA } ) -#' @rdname getSe +#' @rdname se #' @examples #' data(qtlSumStatsExample) -#' getSe(qtlSumStatsExample) +#' se(qtlSumStatsExample) #' @export setMethod( - "getSe", + "se", "SumStatsBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) { sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - mcols(exec(getSumStats, x, !!!sel))$SE + mcols(exec(sumStats, x, !!!sel))$SE } ) -#' @rdname getMaf +#' @rdname maf #' @examples #' data(qtlDatasetExample) -#' getMaf(qtlDatasetExample) +#' maf(qtlDatasetExample) #' @export setMethod( - "getMaf", + "maf", "SumStatsBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) { sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - mc <- mcols(exec(getSumStats, x, !!!sel)) + mc <- mcols(exec(sumStats, x, !!!sel)) if (is_in("MAF", colnames(mc))) mc$MAF else NULL } ) +#' @rdname af +#' @examples +#' data(qtlSumStatsExample) +#' af(qtlSumStatsExample) +#' @export +setMethod( + "af", + "SumStatsBase", + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL + ) { + sel <- list( + study = studyName, + context = context, + trait = trait, + annotateSignificance = annotateSignificance, + ranges = ranges + ) + mc <- mcols(exec(sumStats, x, !!!sel)) + if (is_in("AF", colnames(mc))) mc$AF else NULL + } +) + +# ============================================================================= +# Variant-level replacement +# ============================================================================= + +# The element index the selectors pin. GwasSumStats is keyed by study alone +# and QtlSumStats by the (study, context, trait) tuple; branching here rather +# than adding an internal generic keeps one copy of each replacement body. +# @noRd +.ssRowIndexFor <- function(x, studyName, context, trait) { + if (methods::is(x, "QtlSumStats")) { + return(.qtlSumStatsSelectRow(x, studyName, context, trait)) + } + .gwasRefuseQtlSelectors(context, trait, NULL) + .gwasSelectStudy(x, studyName) +} + +# Write one per-variant column onto the pinned element and put it back. The +# `[[<-` route rebuilds the collection and re-runs validity, so a write that +# would break the identity invariants is refused rather than stored. +# @noRd +.ssWriteVariantColumn <- function(x, idx, column, values) { + el <- x[[idx]] + mcols(el)[[column]] <- values + x[[idx]] <- el + x +} + +# Positional replacement. The vector is taken to be in the element's own +# variant order, so length is the only thing checkable -- and it is checked +# hard: a recycled or truncated frequency vector is silently wrong, which is +# exactly the failure the GRanges form exists to avoid. +# @noRd +.ssVariantColumnPositional <- function(x, idx, column, value) { + n <- length(x[[idx]]) + if (length(value) != n) { + abort(glue( + "{column}: a positional replacement needs one value per variant ", + "({n}); got {length(value)}. Pass a GRanges carrying A1/A2 to ", + "match on (chrom, pos, A1, A2) instead." + )) + } + .ssWriteVariantColumn(x, idx, column, as.numeric(value)) +} + +# Variant ids for either side of a match, rebuilt from the coordinates and +# alleles rather than read off a stored id column, so the two sides agree on +# format. NOTE formatVariantId() takes A2 BEFORE A1. +# @noRd +.ssVariantKeys <- function(gr) { + mc <- mcols(gr) + formatVariantId( + chrom = as.character(seqnames(gr)), + pos = start(gr), + A2 = as.character(mc$A2), + A1 = as.character(mc$A1) + ) +} + +# The payload column of a replacement GRanges. A1/A2 are the match key, so +# exactly one other mcols column is the values; requiring that rather than a +# fixed name keeps the caller from having to know the stored column names. +# @noRd +.ssReplacementPayload <- function(value, column) { + mc <- mcols(value) + nms <- colnames(mc) + if (!all(is_in(c("A1", "A2"), nms))) { + abort(glue( + "{column}: a GRanges replacement must carry A1 and A2 in ", + "mcols() so an allele swap can be detected." + )) + } + payload <- setdiff(nms, c("A1", "A2")) + if (length(payload) != 1L) { + abort(glue( + "{column}: a GRanges replacement must carry exactly one value ", + "column besides A1/A2 (got {length(payload)}", + "{if (length(payload)) str_c(': ', str_flatten(payload, ', '))", + " else ''})." + )) + } + as.numeric(mc[[payload]]) +} + +# Matched replacement. Ids are rebuilt from both sides and paired with +# matchVariants, so a chr-prefix or separator difference does not read as +# no-overlap. A variant the replacement does not name becomes NA -- its value +# is unknown, not unchanged. `directional` says whether an allele swap +# inverts the quantity: AF goes to 1 - AF, while MAF (min(af, 1 - af)) and N +# are swap-invariant, and complementing those would corrupt them. +# @noRd +.ssVariantColumnMatched <- function(x, idx, column, value, directional) { + vals <- .ssReplacementPayload(value, column) + el <- x[[idx]] + m <- matchVariants(.ssVariantKeys(el), .ssVariantKeys(value)) + if (length(m$idxA) == 0L) { + abort(glue( + "{column}: no variant in the replacement matches this entry on ", + "(chrom, pos, A1, A2)." + )) + } + picked <- vals[m$idxB] + if (directional) { + picked <- ifelse(m$sign < 0, 1 - picked, picked) + } + out <- rep(NA_real_, length(el)) + out[m$idxA] <- picked + unused <- length(value) - length(m$idxB) + if (unused > 0L) { + warn(glue( + "{column}: {unused} of {length(value)} replacement variant(s) ", + "are not in this entry and were ignored." + )) + } + missed <- length(el) - length(m$idxA) + if (missed > 0L) { + warn(glue( + "{column}: {missed} of {length(el)} entry variant(s) are not in ", + "the replacement and were set NA." + )) + } + .ssWriteVariantColumn(x, idx, column, out) +} + +# @noRd +.ssReplacePositional <- function(x, column, value, studyName, context, trait) { + .ssVariantColumnPositional( + x, + .ssRowIndexFor(x, studyName, context, trait), + column, + value + ) +} + +# @noRd +.ssReplaceMatched <- function( + x, + column, + value, + directional, + studyName, + context, + trait +) { + .ssVariantColumnMatched( + x, + .ssRowIndexFor(x, studyName, context, trait), + column, + value, + directional + ) +} + +#' @rdname variantColumnReplace +#' @export +setReplaceMethod( + "af", + signature(x = "SumStatsBase", value = "numeric"), + function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { + .ssReplacePositional(x, "AF", value, studyName, context, trait) + } +) + +#' @rdname variantColumnReplace +#' @export +setReplaceMethod( + "af", + signature(x = "SumStatsBase", value = "GRanges"), + function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { + .ssReplaceMatched( + x, + "AF", + value, + directional = TRUE, + studyName, + context, + trait + ) + } +) + +#' @rdname variantColumnReplace +#' @export +setReplaceMethod( + "maf", + signature(x = "SumStatsBase", value = "numeric"), + function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { + .ssReplacePositional(x, "MAF", value, studyName, context, trait) + } +) + +#' @rdname variantColumnReplace +#' @export +setReplaceMethod( + "maf", + signature(x = "SumStatsBase", value = "GRanges"), + function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { + .ssReplaceMatched( + x, + "MAF", + value, + directional = FALSE, + studyName, + context, + trait + ) + } +) + +#' @rdname variantColumnReplace +#' @export +setReplaceMethod( + "nSamples", + signature(x = "SumStatsBase", value = "numeric"), + function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { + .ssReplacePositional(x, "N", value, studyName, context, trait) + } +) + +#' @rdname variantColumnReplace +#' @export +setReplaceMethod( + "nSamples", + signature(x = "SumStatsBase", value = "GRanges"), + function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { + .ssReplaceMatched( + x, + "N", + value, + directional = FALSE, + studyName, + context, + trait + ) + } +) + #' @rdname nSnps #' @examples #' data(qtlSumStatsExample) @@ -454,20 +707,20 @@ setMethod( "SumStatsBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) { sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - length(exec(getSumStats, x, !!!sel)) + length(exec(sumStats, x, !!!sel)) } ) @@ -500,22 +753,22 @@ setClass( representation(ldSketch = "LdSketch_OR_NULL") ) -#' @rdname getStudy +#' @rdname studyName #' @export -setMethod("getStudy", "FineMappingResultBase", function(x) { +setMethod("studyName", "FineMappingResultBase", function(x) { unique(as.character(x$study)) }) -#' @rdname getLdSketch +#' @rdname ldSketch #' @export -setMethod("getLdSketch", "FineMappingResultBase", function(x) x@ldSketch) +setMethod("ldSketch", "FineMappingResultBase", function(x) x@ldSketch) -#' @rdname getMethodNames +#' @rdname methodNames #' @examples #' data(qtlFineMappingExample) -#' getMethodNames(qtlFineMappingExample) +#' methodNames(qtlFineMappingExample) #' @export -setMethod("getMethodNames", "FineMappingResultBase", function(x) { +setMethod("methodNames", "FineMappingResultBase", function(x) { unique(as.character(x$method)) }) @@ -575,12 +828,12 @@ setMethod( withFit <- `[[<-`( md, "susieFit", - value = S4Vectors::SimpleList(map(entries, getSusieFit)) + value = S4Vectors::SimpleList(map(entries, susieFit)) ) `[[<-`( withFit, "cvResult", - value = S4Vectors::SimpleList(map(entries, getCvResult)) + value = S4Vectors::SimpleList(map(entries, cvResult)) ) } @@ -589,10 +842,10 @@ setMethod( # @noRd .fmrFromEntries <- function(x, entries) { grl <- `mcols<-`( - GenomicRanges::GRangesList(map(entries, rowVariants)), + GenomicRanges::GRangesList(map(entries, variants)), value = .withEntryPayload(mcols(x, use.names = FALSE), entries) ) - new(class(x), grl, ldSketch = .asLdSketch(getLdSketch(x))) + new(class(x), grl, ldSketch = .asLdSketch(ldSketch(x))) } # TRUE when an entry shares at least one variant with `keepVariants`, matched @@ -617,7 +870,7 @@ setMethod( # What reconciliation does NOT do is recover the information the dropped # variants carried. Coverage falls as overlap shrinks -- equally for a # renormalization and for a full refit -- so that loss is irreducible, not an -# approximation error. getRetainedMass() is what makes it visible instead of +# approximation error. retainedMass() is what makes it visible instead of # letting a heavily-trimmed fit look as confident as an untouched one. # ============================================================================= @@ -672,9 +925,9 @@ setMethod( # Retained-mass diagnostic # ============================================================================= -#' @rdname getRetainedMass +#' @rdname retainedMass #' @export -setMethod("getRetainedMass", "FineMappingResultBase", function(x) { +setMethod("retainedMass", "FineMappingResultBase", function(x) { if (nrow(x) == 0L) { return(.rcEmptyMass(x)) } @@ -769,14 +1022,14 @@ setGeneric(".fmrSelectEntry", function(x, ...) { standardGeneric(".fmrSelectEntry") }) -#' @rdname getCs +#' @rdname credibleSets #' @export setMethod( - "getCs", + "credibleSets", "FineMappingResultBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -792,7 +1045,7 @@ setMethod( # coverage. .fmrAggregateView( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -806,16 +1059,16 @@ setMethod( } ) -#' @rdname getLbf +#' @rdname lbf #' @export -setMethod("getLbf", "FineMappingResultBase", function(x) { +setMethod("lbf", "FineMappingResultBase", function(x) { .fmrAggregateView(x, perEntry = .fmrRowLbf) }) -#' @rdname getCredibleSetSummary +#' @rdname credibleSetSummary #' @export setMethod( - "getCredibleSetSummary", + "credibleSetSummary", "FineMappingResultBase", function(x, coverage = 0.95) { .fmrAggregateView( @@ -843,16 +1096,15 @@ setMethod("fsusieAffectedRegions", "FineMappingResultBase", function(x) { exec(c, !!!grs) }) -#' @rdname getTopLoci +#' @rdname topLoci #' @export setMethod( - "getTopLoci", + "topLoci", "FineMappingResultBase", function( x, - type = c("data.frame", "GRanges"), signalCutoff = 0.025, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -860,68 +1112,47 @@ setMethod( 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. + # The five selectors travel together to both branches, so they are + # named once and spliced rather than relisted twice. sel <- list( - study = study, + study = studyName, context = context, trait = trait, method = method, region = region ) + # raw = TRUE hands back the stored canonical table verbatim, which is + # a data.frame by definition -- there is no posterior projection to + # put on a range. if (isTRUE(raw)) { - return(.fmrbTopLociRaw(x, sel, type)) + return(exec(.fmrbTopLociTable, x, !!!sel, list(raw = TRUE))) } - # type = "GRanges" is honored only for a single pinned entry; the - # aggregate (identity-prefixed) form is data.frame-only. - if (type == "GRanges") { - return(exec( - .fmrbTopLociGranges, - x, - !!!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. - exec( + # The per-variant table first -- bare when the selectors pin one + # entry, else the matching rows' tables stacked with row-identity + # columns -- then one conversion to ranges. Converting last is what + # lets the aggregate form be a GRanges too: the identity columns just + # become mcols, where the old type = "GRanges" branch had to refuse + # anything but a single pinned entry. + tbl <- exec( .fmrbTopLociTable, x, !!!sel, - list( - type = "data.frame", - signalCutoff = signalCutoff, - minPurity = minPurity - ) + list(signalCutoff = signalCutoff, minPurity = minPurity) ) + .fmeTopLociGRanges(tbl) } ) -# 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`. +# The per-variant top-loci table: the stored table verbatim (raw) or the +# projected posterior view, selected by `viewArgs`. Both stack with +# row-identity columns when the selectors match more than one entry. The +# caller converts to ranges; this stays a table so the aggregate form can be +# stacked before conversion. # @noRd .fmrbTopLociTable <- function( x, - study, + studyName, context, trait, method, @@ -930,7 +1161,7 @@ setMethod( ) { .fmrAggregateView( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -939,56 +1170,18 @@ setMethod( 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, - context, - trait, - method, - region, - signalCutoff, - minPurity -) { - sel <- try_fetch( - .fmrSelectEntry( - x, - study = study, - context = context, - trait = trait, - method = method, - region = region - ), - error = function(cnd) cnd - ) - if (inherits(sel, "error")) { - msg <- glue( - "getTopLoci: aggregating across multiple entries requires ", - "type = 'data.frame'." - ) - abort(msg) - } - .fmrRowTopLoci( - sel, - type = "GRanges", - signalCutoff = signalCutoff, - minPurity = minPurity - ) -} - -#' @rdname getMarginalEffects +# raw = TRUE hands back the stored canonical table verbatim, so the +# posterior-view projection does not apply -- and marginal effects are +# not a posterior view, so they stay a table rather than ranges. +#' @rdname marginalEffects #' @export setMethod( - "getMarginalEffects", + "marginalEffects", "FineMappingResultBase", function( x, maxPval = NULL, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -999,7 +1192,7 @@ setMethod( # prefixed with the row identity (study/context/trait/blockId/method). .fmrAggregateView( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -1010,32 +1203,32 @@ setMethod( } ) -#' @rdname getRegion +#' @rdname genomicRegion #' @examples #' data(qtlFineMappingExample) -#' getRegion(qtlFineMappingExample) +#' genomicRegion(qtlFineMappingExample) #' @export -setMethod("getRegion", "FineMappingResultBase", function(x) { +setMethod("genomicRegion", "FineMappingResultBase", function(x) { .getRegionColumn(x) }) -#' @rdname getTraitPosition +#' @rdname traitPosition #' @examples #' data(qtlDatasetExample) -#' getTraitPosition(qtlDatasetExample) +#' traitPosition(qtlDatasetExample) #' @export -setMethod("getTraitPosition", "FineMappingResultBase", function(x) { +setMethod("traitPosition", "FineMappingResultBase", function(x) { .getTraitPosColumn(x) }) -#' @rdname getSusieFit +#' @rdname susieFit #' @export setMethod( - "getSusieFit", + "susieFit", "FineMappingResultBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -1043,7 +1236,7 @@ setMethod( ) { .fmrPartsSusieFit(.fmrSelectEntry( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -1059,14 +1252,14 @@ setMethod( "FineMappingResultBase", function( x, - study = NULL, + studyName = 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 + # collection because that is what fineMappingResult() now # returns; the body is the per-row primitive, so they cannot drift. # # The selectors are named, not absorbed by `...`: .fmrSelectEntry is the @@ -1074,7 +1267,7 @@ setMethod( # index by (a QtlFineMappingResult has no `region` axis). .fmrRowResolveWeights(.fmrSelectEntry( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -1083,14 +1276,14 @@ setMethod( } ) -#' @rdname getVariantIds +#' @rdname variantIds #' @export setMethod( - "getVariantIds", + "variantIds", "FineMappingResultBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -1098,7 +1291,7 @@ setMethod( ) { .fmrPartsVariantIds(.fmrSelectEntry( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -1107,14 +1300,14 @@ setMethod( } ) -#' @rdname getVariantIds +#' @rdname variantIds #' @export setMethod( - "getVariantIds", + "variantIds", "SumStatsBase", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, @@ -1127,13 +1320,13 @@ setMethod( # Rendered with the same .grVariantIds() the row classes use, so an id # means the same string whichever object produced it. sel <- list( - study = study, + study = studyName, context = context, trait = trait, annotateSignificance = annotateSignificance, ranges = ranges ) - .grVariantIds(exec(getSumStats, x, !!!sel)) + .grVariantIds(exec(sumStats, x, !!!sel)) } ) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 33c3de52..039b0f03 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -53,8 +53,8 @@ NULL #' @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. +#' @param studyName Character (length 1) or \code{NULL}. Restrict the selection +#' to this study; \code{NULL} matches all studies. #' @return An \code{H2Estimate} object. #' @examples #' data(ldScoreExample) @@ -71,8 +71,9 @@ NULL #' panel <- readGenotypes( #' system.file("extdata", "toy_ref.bed", package = "pecotmr") #' ) -#' ss <- GwasSumStats(study = "trait1", entry = list(gr), -#' genome = getGenome(ldScoreExample), ldSketch = panel) +#' ss <- GwasSumStats(studyName = "trait1", entry = list(gr), +#' genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), +#' ldSketch = panel) #' estimateH2(ss, ldScoreExample, method = "sldsc") #' @export setGeneric( @@ -217,9 +218,9 @@ setGeneric( #' @return A \code{data.frame} of local estimates, or NULL. #' @examples #' data(h2EstimateExample) -#' getLocal(h2EstimateExample) +#' localH2Blocks(h2EstimateExample) #' @export -setGeneric("getLocal", function(object) standardGeneric("getLocal")) +setGeneric("localH2Blocks", function(object) standardGeneric("localH2Blocks")) #' @title Get Enrichment Estimates #' @description Extract annotation enrichment estimates from a result object. @@ -227,9 +228,11 @@ setGeneric("getLocal", function(object) standardGeneric("getLocal")) #' @return A \code{data.frame} of enrichment estimates, or NULL. #' @examples #' data(h2EstimateExample) -#' getEnrichment(h2EstimateExample) +#' stratifiedHeritabilityEnrichment(h2EstimateExample) #' @export -setGeneric("getEnrichment", function(object) standardGeneric("getEnrichment")) +setGeneric("stratifiedHeritabilityEnrichment", function(object) { + standardGeneric("stratifiedHeritabilityEnrichment") +}) #' @title Get Score Statistics #' @description Extract score statistics for candidate annotations. @@ -237,9 +240,9 @@ setGeneric("getEnrichment", function(object) standardGeneric("getEnrichment")) #' @return A list with \code{z} and \code{R}, or NULL. #' @examples #' data(h2EstimateExample) -#' getScoreStats(h2EstimateExample) +#' scoreStats(h2EstimateExample) #' @export -setGeneric("getScoreStats", function(object) standardGeneric("getScoreStats")) +setGeneric("scoreStats", function(object) standardGeneric("scoreStats")) # ============================================================================= # GwasSumStats accessor generics @@ -252,79 +255,89 @@ 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 studyName 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. +#' \code{\link{sumStats}} (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")) +setGeneric("z", function(x, ...) standardGeneric("z")) #' @title Get Sample Sizes -#' @description Extract sample size vector from a \code{GwasSumStats} or -#' \code{QtlSumStats} entry, selected by its identity tuple. -#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @description Extract sample sizes: the per-variant sample-size vector of a +#' \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity +#' tuple, or the number of samples carried by a \code{GenotypeHandle}. +#' @param x A \code{GwasSumStats}, \code{QtlSumStats} or +#' \code{GenotypeHandle} 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 studyName 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. +#' \code{\link{sumStats}} (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. +#' @return Numeric vector of sample sizes for a summary-statistic entry; +#' integer of length 1 for a \code{GenotypeHandle}. +#' @details The genotype handle is the seed layer behind a panel and is not +#' part of the public interface; obtain a panel from +#' \code{readGenotypes()} and ask it directly. #' @export -setGeneric("getN", function(x, ...) standardGeneric("getN")) +setGeneric("nSamples", function(x, ...) standardGeneric("nSamples")) #' @title Get Association P-values #' @description Extract the association p-value vector from a #' \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity #' tuple. Part of the first-class summary-statistic column set alongside -#' \code{\link{getZ}} / \code{\link{getBeta}} / \code{\link{getSe}}. +#' \code{\link{z}} / \code{\link{coef}} / \code{\link{se}}. #' @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 studyName 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. +#' \code{\link{sumStats}} (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")) +setGeneric("pval", function(x, ...) standardGeneric("pval")) #' @title Get Marginal Effect Sizes #' @description Extract the marginal effect-size (beta) vector from a #' \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity -#' tuple. -#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' tuple. A GWAS / QTL effect size is a regression coefficient, so this +#' adopts \code{stats::coef} rather than defining a pecotmr generic. +#' Promoting the existing function keeps it as the default method, so +#' \code{coef()} on a model fit is unaffected. +#' @param object 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 studyName 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. +#' \code{\link{sumStats}} (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")) +#' @importFrom stats coef +#' @rdname coef-methods +setGeneric("coef") #' @title Get Effect-Size Standard Errors #' @description Extract the effect-size standard-error vector from a @@ -332,33 +345,33 @@ 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 studyName 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. +#' \code{\link{sumStats}} (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")) +setGeneric("se", function(x, ...) standardGeneric("se")) #' @title Get Minor Allele Frequencies #' @description Extract MAF vector from a GwasSumStats object. #' @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 studyName 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. +#' \code{\link{sumStats}} (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}. @@ -370,19 +383,82 @@ setGeneric("getSe", function(x, ...) standardGeneric("getSe")) #' \code{NULL} uses all samples. #' @return Numeric vector of MAFs, or NULL if not available. #' @export -setGeneric("getMaf", function(x, ...) standardGeneric("getMaf")) +setGeneric("maf", function(x, ...) standardGeneric("maf")) + +#' @title Replace a Per-Variant Column +#' @description Supply or overwrite one per-variant column of a +#' \code{GwasSumStats} / \code{QtlSumStats} entry after construction -- +#' the usual case being an effect-allele frequency the source file did not +#' carry. Dispatch is on \code{value}: +#' \describe{ +#' \item{\code{numeric}}{positional: the vector is in the entry's own +#' variant order and must have exactly one value per variant. Length is +#' checked hard, because a recycled or truncated vector is otherwise +#' silently wrong.} +#' \item{\code{GRanges}}{matched: paired to the entry on +#' \code{(chrom, pos, A1, A2)} via \code{matchVariants}, so ordering +#' does not matter. \code{A1}/\code{A2} are \strong{required} in +#' \code{mcols()} so an allele swap can be detected, and exactly one +#' other \code{mcols} column carries the values. Entry variants the +#' replacement does not name are set \code{NA}.} +#' } +#' An allele swap sends \code{af} to \code{1 - af}, so \code{af<-} +#' complements a flipped match. \code{maf} is \code{min(af, 1 - af)} and +#' \code{nSamples} is a count, both swap-invariant, so neither is +#' complemented. +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @param studyName,context,trait Selectors pinning one entry; \code{context} +#' and \code{trait} are \code{QtlSumStats}-only. +#' @param ... Unused. +#' @param value A \code{numeric} vector (positional) or a \code{GRanges} +#' carrying \code{A1}/\code{A2} plus one value column (matched). +#' @return The object, with that entry's column replaced. +#' @examples +#' data(qtlSumStatsExample) +#' x <- qtlSumStatsExample +#' af(x) <- runif(length(variantIds(x))) +#' head(af(x)) +#' @rdname variantColumnReplace +#' @aliases variantColumnReplace +#' @export +setGeneric("af<-", function(x, ..., value) standardGeneric("af<-")) + +#' @rdname variantColumnReplace +#' @export +setGeneric("maf<-", function(x, ..., value) standardGeneric("maf<-")) + +#' @rdname variantColumnReplace +#' @export +setGeneric("nSamples<-", function(x, ..., value) { + standardGeneric("nSamples<-") +}) #' @title Get Effect-Allele Frequencies -#' @description Extract the directional effect-allele (A1) frequency vector for -#' a \code{QtlDataset}. Unlike \code{\link{getMaf}}, the value is \emph{not} -#' folded to the minor allele: it is the frequency of the dosage-counted -#' allele (A1, the effect allele), matching the allele the marginal effect -#' sizes and the fine-mapping \code{af} column report. -#' @param x A \code{QtlDataset} object. +#' @description Extract the directional effect-allele (A1) frequency vector +#' for a \code{QtlDataset}, or for one entry of a \code{GwasSumStats} / +#' \code{QtlSumStats} collection. Unlike \code{\link{maf}}, the value is +#' \emph{not} folded to the minor allele: it is the frequency of the +#' dosage-counted allele (A1, the effect allele), matching the allele the +#' marginal effect sizes and the fine-mapping \code{af} column report. For +#' a summary-statistic collection this is \code{NULL} when the source +#' carried no frequency column -- see \code{\link{variantColumnReplace}} +#' for supplying one afterwards. +#' @param x A \code{QtlDataset}, \code{GwasSumStats} or \code{QtlSumStats} +#' object. #' @param ... Class-specific selection arguments (e.g., \code{traitId}, #' \code{region}, \code{cisWindow}, \code{samples} for \code{QtlDataset}). #' @param traitId Character or \code{NULL}. Molecular trait / feature identifier #' to select; \code{NULL} matches all traits in the dataset. +#' @param studyName 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{sumStats}} (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. @@ -394,23 +470,25 @@ setGeneric("getMaf", function(x, ...) standardGeneric("getMaf")) #' IDs), or an empty vector when no variants are selected. #' @examples #' data(qtlDatasetExample) -#' getAf(qtlDatasetExample) +#' af(qtlDatasetExample) #' @export -setGeneric("getAf", function(x, ...) standardGeneric("getAf")) +setGeneric("af", function(x, ...) standardGeneric("af")) #' @title Get Number of SNPs #' @description Number of SNPs in a \code{GwasSumStats} or \code{QtlSumStats} -#' entry, selected by its identity tuple. -#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' entry, selected by its identity tuple, or the number of variants an +#' \code{H2Estimate} was computed over. +#' @param x A \code{GwasSumStats}, \code{QtlSumStats} or \code{H2Estimate} +#' 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 studyName 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. +#' \code{\link{sumStats}} (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. @@ -440,7 +518,7 @@ setGeneric("nSnps", function(x, ...) standardGeneric("nSnps")) #' tes_distance = c(0L, 500L, 900000L, 2000000L)) #' gr #' }) -#' qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), +#' qss <- QtlSumStats(studyName = rep("s", G), context = rep("brain", G), #' trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", #' extraCols = list( #' n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), @@ -473,16 +551,16 @@ setGeneric("qtlAssociationPostprocess", function(x, ...) { #' tes_distance = c(0L, 500L, 900000L, 2000000L)) #' gr #' }) -#' qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), +#' qss <- QtlSumStats(studyName = rep("s", G), context = rep("brain", G), #' trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", #' 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) +#' significantQtls(pp) #' @export -setGeneric("getSignificantQtls", function(x, ...) { - standardGeneric("getSignificantQtls") +setGeneric("significantQtls", function(x, ...) { + standardGeneric("significantQtls") }) #' @title Subset by Chromosome @@ -516,7 +594,7 @@ setGeneric("subsetChr", function(x, chr) standardGeneric("subsetChr")) #' same variants. What it cannot recover is the information the dropped #' variants carried: coverage falls as overlap shrinks, equally for both, and #' that degradation is irreducible rather than an artifact of the method. -#' \code{getRetainedMass()} is what makes it visible. +#' \code{retainedMass()} is what makes it visible. #' @param x A fine-mapping collection to reconcile. #' @param y The collection to reconcile it against. #' @param oneSided Logical (length 1). \code{FALSE} (default) returns both @@ -557,12 +635,12 @@ setGeneric("intersectVariants", function(x, y, oneSided = FALSE, ...) { #' data(qtlFineMappingExample) #' data(gwasFineMappingExample) #' # Nothing has been reconciled yet, so there is no mass to report. -#' nrow(getRetainedMass(qtlFineMappingExample)) +#' nrow(retainedMass(qtlFineMappingExample)) #' both <- intersectVariants(qtlFineMappingExample, gwasFineMappingExample) -#' getRetainedMass(both$x) +#' retainedMass(both$x) #' @export -setGeneric("getRetainedMass", function(x, ...) { - standardGeneric("getRetainedMass") +setGeneric("retainedMass", function(x, ...) { + standardGeneric("retainedMass") }) #' @title Restrict a Collection to a Region @@ -608,8 +686,8 @@ setGeneric("subsetRegion", function(x, region, ...) { #' \code{NULL} when the entry has no \code{varY} recorded. #' @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 studyName 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 @@ -617,9 +695,9 @@ setGeneric("subsetRegion", function(x, region, ...) { #' @return Numeric phenotype variance, or NULL. #' @examples #' data(qtlSumStatsExample) -#' getVarY(qtlSumStatsExample) +#' varY(qtlSumStatsExample) #' @export -setGeneric("getVarY", function(x, ...) standardGeneric("getVarY")) +setGeneric("varY", function(x, ...) standardGeneric("varY")) #' @title Get a Single Summary-Statistic Entry or Embedded Collection #' @description Behavior depends on the class of \code{x}: @@ -636,8 +714,8 @@ setGeneric("getVarY", function(x, ...) standardGeneric("getVarY")) #' @param x A \code{GwasSumStats}, \code{QtlSumStats}, or #' \code{MultiStudyQtlDataset} object. #' @param ... Class-specific selection arguments (see above). -#' @param study Character (length 1) or \code{NULL}. Restrict the selection to -#' this study; \code{NULL} matches all studies. +#' @param studyName 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 @@ -650,40 +728,9 @@ setGeneric("getVarY", function(x, ...) standardGeneric("getVarY")) #' @return A \code{GRanges}, a \code{QtlSumStats}, or \code{NULL}. #' @examples #' data(qtlSumStatsExample) -#' getSumStats(qtlSumStatsExample) -#' @export -setGeneric("getSumStats", function(x, ...) standardGeneric("getSumStats")) - -#' @title Get Standardized Sumstat Data Frame for One Tuple -#' @description Return a per-tuple summary-statistics \code{data.frame} in the -#' standardized layout \code{variant_id, chrom, pos, A1, A2, z, beta, se, N, -#' maf} (optional columns omitted when absent on the entry). Combines -#' tuple-keyed row selection (\code{getSumStats}) with mcols unpacking; -#' replaces the pre-S4 idiom of pulling \code{S4Vectors::mcols(entry)$} -#' directly inside pipelines. -#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. -#' @param ... Class-specific selectors (\code{study} for \code{GwasSumStats}; -#' \code{study}, \code{context}, \code{trait} for \code{QtlSumStats}) plus -#' pass-throughs \code{require}, \code{derive}, \code{keepChrPrefix} forwarded -#' to the underlying unpacker. -#' @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 require Character vector. Columns that must be present (derived if -#' necessary) in the returned summary-statistics data frame. -#' @param derive Logical. Whether to derive missing standard columns (e.g. Z, -#' BETA, SE) from the available ones. -#' @param keepChrPrefix Logical. If \code{TRUE}, keep the \code{chr} prefix on -#' chromosome names; otherwise strip it. -#' @return A \code{data.frame}. -#' @examples -#' data(qtlSumStatsExample) -#' getSumStatsDf(qtlSumStatsExample) +#' sumStats(qtlSumStatsExample) #' @export -setGeneric("getSumStatsDf", function(x, ...) standardGeneric("getSumStatsDf")) +setGeneric("sumStats", function(x, ...) standardGeneric("sumStats")) #' @title Get the Embedded QtlDataset List #' @description Return the named list of \code{QtlDataset} objects carried by a @@ -692,20 +739,9 @@ setGeneric("getSumStatsDf", function(x, ...) standardGeneric("getSumStatsDf")) #' @return A named list of \code{QtlDataset} objects. #' @examples #' data(multiStudyQtlDatasetExample) -#' getQtlDatasets(multiStudyQtlDatasetExample) +#' qtlDatasets(multiStudyQtlDatasetExample) #' @export -setGeneric("getQtlDatasets", function(x) standardGeneric("getQtlDatasets")) - -#' @title Get the Genome Build -#' @description Return the genome build that the collection's LD sketch and -#' every entry are aligned to. Because all entries in a \code{GwasSumStats} or -#' \code{QtlSumStats} share the LD sketch, the genome build is a single value -#' at the collection level. -#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. -#' @param ... Unused (present for method-signature compatibility). -#' @return Character (length 1). -#' @export -setGeneric("getGenome", function(x, ...) standardGeneric("getGenome")) +setGeneric("qtlDatasets", function(x) standardGeneric("qtlDatasets")) #' @title Get QC Audit Record #' @description Return the audit record of QC steps applied to this collection. @@ -713,12 +749,12 @@ setGeneric("getGenome", function(x, ...) standardGeneric("getGenome")) #' \code{\link{summaryStatsQc}} has not yet been run. Pipelines that require #' harmonized sumstats (\code{fineMappingPipeline}, #' \code{twasWeightsPipeline}, and downstream consumers) reject inputs where -#' \code{length(getQcInfo(x)) == 0L}. +#' \code{length(qcInfo(x)) == 0L}. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Unused. #' @return A \code{list} (possibly empty). #' @export -setGeneric("getQcInfo", function(x, ...) standardGeneric("getQcInfo")) +setGeneric("qcInfo", function(x, ...) standardGeneric("qcInfo")) #' @title Get SLALOM / DENTIST Diagnostics #' @description Return the per-variant LD-mismatch diagnostics table (SLALOM or @@ -726,7 +762,7 @@ setGeneric("getQcInfo", function(x, ...) standardGeneric("getQcInfo")) #' \code{\link{summaryStatsQc}} when \code{ldMismatchQcMethod} was not #' \code{"none"}. #' Convenience accessor over -#' \code{getQcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. +#' \code{qcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param entry Integer index (default 1) of the entry whose diagnostics table #' to return. When \code{NULL}, returns a named list of every entry's @@ -737,8 +773,8 @@ setGeneric("getQcInfo", function(x, ...) standardGeneric("getQcInfo")) #' when no diagnostics were preserved for that entry, or a named list of such #' data.frames when \code{entry = NULL}. #' @export -setGeneric("getQcDiagnostics", function(x, entry = 1L, ...) { - standardGeneric("getQcDiagnostics") +setGeneric("qcDiagnostics", function(x, entry = 1L, ...) { + standardGeneric("qcDiagnostics") }) #' @title Get LD Sketch @@ -752,7 +788,7 @@ setGeneric("getQcDiagnostics", function(x, entry = 1L, ...) { #' @return A \code{RangedSummarizedExperiment} genotype panel, or #' \code{NULL}. #' @export -setGeneric("getLdSketch", function(x, ...) standardGeneric("getLdSketch")) +setGeneric("ldSketch", function(x, ...) standardGeneric("ldSketch")) # ============================================================================= # LdData accessor generics @@ -772,9 +808,9 @@ setGeneric("getLdSketch", function(x, ...) standardGeneric("getLdSketch")) #' ld <- LdData(correlation = cor(X), variants = gr, #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) -#' getCorrelation(ld) +#' ldMatrix(ld) #' @export -setGeneric("getCorrelation", function(x) standardGeneric("getCorrelation")) +setGeneric("ldMatrix", function(x) standardGeneric("ldMatrix")) #' @title Get Genotype Matrix #' @description Extract a genotype matrix from an object that carries genotype @@ -797,9 +833,9 @@ setGeneric("getCorrelation", function(x) standardGeneric("getCorrelation")) #' @return A numeric matrix, a list of matrices, or \code{NULL}. #' @examples #' data(qtlDatasetExample) -#' getGenotypes(qtlDatasetExample) +#' genotypes(qtlDatasetExample) #' @export -setGeneric("getGenotypes", function(x, ...) standardGeneric("getGenotypes")) +setGeneric("genotypes", function(x, ...) standardGeneric("genotypes")) #' @title Check Genotype Availability #' @description Check whether an \code{LdData} object has a genotype handle for @@ -824,8 +860,8 @@ setGeneric("hasGenotypes", function(x) standardGeneric("hasGenotypes")) #' one entry of a collection class selected by its identity tuple. #' @param x The 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 studyName 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 @@ -836,19 +872,19 @@ setGeneric("hasGenotypes", function(x) standardGeneric("hasGenotypes")) #' 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. +#' \code{\link{sumStats}} (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) -#' getVariantIds(qtlFineMappingExample) +#' variantIds(qtlFineMappingExample) #' @export -setGeneric("getVariantIds", function(x, ...) standardGeneric("getVariantIds")) +setGeneric("variantIds", function(x, ...) standardGeneric("variantIds")) -#' @title Get Phenotype List -#' @description Extract phenotype data from an object that carries it. For a -#' \code{QtlDataset}, the user can optionally select specific contexts, +#' @title Get Molecular Traits +#' @description Extract molecular-trait data from an object that carries it. +#' For a \code{QtlDataset}, the user can optionally select specific contexts, #' traits, or a region (see method documentation for the per-class selection #' arguments). #' @param x The object to extract from. @@ -870,13 +906,19 @@ setGeneric("getVariantIds", function(x, ...) standardGeneric("getVariantIds")) #' 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. +#' @return A \code{SummarizedExperiment} when one context is selected, or a +#' named list of them for several. A \code{QtlDataset} is a +#' \code{MultiAssayExperiment}, so these are its experiments; take the +#' measurement matrix itself with +#' \code{SummarizedExperiment::assay()} rather than asking this accessor +#' for one. #' @examples #' data(qtlDatasetExample) -#' getPhenotypes(qtlDatasetExample, contexts = "brain") +#' molecularTraits(qtlDatasetExample, contexts = "brain") #' @export -setGeneric("getPhenotypes", function(x, ...) standardGeneric("getPhenotypes")) +setGeneric("molecularTraits", function(x, ...) { + standardGeneric("molecularTraits") +}) # ============================================================================= # FineMappingResult accessor generics # ============================================================================= @@ -885,19 +927,19 @@ setGeneric("getPhenotypes", function(x, ...) standardGeneric("getPhenotypes")) #' @description Return the \code{FineMappingRow} for one \code{(study, #' context, trait, method)} row of a \code{FineMappingResult} collection. #' @param x A \code{FineMappingResult} object. -#' @param study,context,trait,method Single character identifiers. All required -#' when the collection has more than one row; optional when the collection has -#' a single row. +#' @param studyName,context,trait,method Single character identifiers. All +#' required when the collection has more than one row; optional when the +#' collection has a single row. #' @return A \code{FineMappingRow} object. #' @examples #' data(qtlFineMappingExample) -#' getFineMappingResult(qtlFineMappingExample, study = "study_1", +#' fineMappingResult(qtlFineMappingExample, studyName = "study_1", #' context = "context_1", trait = "gene_1", method = "susie") #' @export setGeneric( - "getFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { - standardGeneric("getFineMappingResult") + "fineMappingResult", + function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + standardGeneric("fineMappingResult") } ) @@ -935,8 +977,8 @@ setGeneric("adjustPips", function(x, keepVariants, ...) { #' (selected by its identity tuple). #' @param x A \code{FineMappingRow} or \code{FineMappingResult}. #' @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 studyName 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 @@ -951,9 +993,9 @@ setGeneric("adjustPips", function(x, keepVariants, ...) { #' @return A named numeric vector of PIPs. #' @examples #' data(qtlFineMappingExample) -#' getPip(qtlFineMappingExample) +#' pip(qtlFineMappingExample) #' @export -setGeneric("getPip", function(x, ...) standardGeneric("getPip")) +setGeneric("pip", function(x, ...) standardGeneric("pip")) #' @title Get SuSiE Fit #' @description Extract the SuSiE fit object from a fine-mapping entry or @@ -962,8 +1004,8 @@ setGeneric("getPip", function(x, ...) standardGeneric("getPip")) #' (when \code{trim = FALSE}). #' @param x A \code{FineMappingRow} or \code{FineMappingResult}. #' @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 studyName 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 @@ -976,9 +1018,9 @@ setGeneric("getPip", function(x, ...) standardGeneric("getPip")) #' @return A list (the SuSiE fit object). #' @examples #' data(qtlFineMappingExample) -#' getSusieFit(qtlFineMappingExample) +#' susieFit(qtlFineMappingExample) #' @export -setGeneric("getSusieFit", function(x, ...) standardGeneric("getSusieFit")) +setGeneric("susieFit", function(x, ...) standardGeneric("susieFit")) #' @title Compute Between-Credible-Set Correlation On Demand #' @description Compute the between-credible-set correlation matrix for a @@ -990,9 +1032,9 @@ setGeneric("getSusieFit", function(x, ...) standardGeneric("getSusieFit")) #' @param x A \code{\link{fineMappingRow}} carrying the fit (credible-set #' membership and PIP) and its variant ids. #' @param ldSource The object supplying the LD: a \code{QtlDataset} -#' (individual-level; genotypes via \code{\link{getGenotypes}}) or a +#' (individual-level; genotypes via \code{\link{genotypes}}) or a #' \code{QtlSumStats} / \code{GwasSumStats} (summary statistics; LD via -#' \code{\link{getLdSketch}}). Any other type is an error. +#' \code{\link{ldSketch}}). Any other type is an error. #' @param ... Passed to methods. #' @return A numeric \code{m x m} between-credible-set correlation matrix #' (\code{m} = number of credible sets), or \code{NULL} when the fit has @@ -1000,7 +1042,7 @@ setGeneric("getSusieFit", function(x, ...) standardGeneric("getSusieFit")) #' @examples #' data(qtlFineMappingPairedExample) #' data(qtlSumStatsExample) -#' fe <- getFineMappingResult(qtlFineMappingPairedExample) +#' fe <- fineMappingResult(qtlFineMappingPairedExample) #' computeCsCorrelation(fe, qtlSumStatsExample) #' @export setGeneric("computeCsCorrelation", function(x, ldSource, ...) { @@ -1036,8 +1078,8 @@ setGeneric("computeCsCorrelation", function(x, ldSource, ...) { #' cross-validation (\code{cvFolds <= 1}). #' @param x A \code{FineMappingRow} or \code{FineMappingResult}. #' @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 studyName 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 @@ -1047,9 +1089,9 @@ setGeneric("computeCsCorrelation", function(x, ldSource, ...) { #' @return A list (the CV payload) or \code{NULL}. #' @examples #' data(qtlFineMappingExample) -#' getCvResult(qtlFineMappingExample) +#' cvResult(qtlFineMappingExample) #' @export -setGeneric("getCvResult", function(x, ...) standardGeneric("getCvResult")) +setGeneric("cvResult", function(x, ...) standardGeneric("cvResult")) #' @title Get Marginal Effects #' @description Extract per-variant marginal univariate effects from a @@ -1061,8 +1103,8 @@ setGeneric("getCvResult", function(x, ...) standardGeneric("getCvResult")) #' @param maxPval Optional numeric (length 1). When non-\code{NULL}, filter rows #' where \code{p > maxPval}. Default \code{NULL} (no filter). #' @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 studyName 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 @@ -1075,10 +1117,10 @@ setGeneric("getCvResult", function(x, ...) standardGeneric("getCvResult")) #' @return A \code{data.frame}. #' @examples #' data(qtlFineMappingExample) -#' getMarginalEffects(qtlFineMappingExample) +#' marginalEffects(qtlFineMappingExample) #' @export -setGeneric("getMarginalEffects", function(x, maxPval = NULL, ...) { - standardGeneric("getMarginalEffects") +setGeneric("marginalEffects", function(x, maxPval = NULL, ...) { + standardGeneric("marginalEffects") }) #' @title Get Top Loci (posterior view) @@ -1090,13 +1132,12 @@ setGeneric("getMarginalEffects", function(x, maxPval = NULL, ...) { #' are filtered by PIP by default -- set \code{signalCutoff = 0} to return #' every variant. #' @param x A \code{FineMappingRow} or \code{FineMappingResult}. -#' @param type One of \code{"data.frame"} (default) or \code{"GRanges"}. #' @param signalCutoff Numeric (length 1). Drop rows where \code{pip <= #' signalCutoff}. Default \code{0.025}. Use \code{signalCutoff = 0} to keep #' every variant. #' @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 studyName 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 @@ -1110,26 +1151,30 @@ setGeneric("getMarginalEffects", function(x, maxPval = NULL, ...) { #' 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}. +#' verbatim -- a \code{data.frame}, not a \code{GRanges} -- so neither the +#' projection nor \code{signalCutoff} applies. +#' @return A \code{GRanges}, one range per retained variant, carrying the +#' per-variant columns in \code{mcols()}; when the selectors match more than +#' one entry the row-identity columns are carried there too. Take a table +#' with \code{as.data.frame()} (which adds the standard +#' \code{seqnames}/\code{start}/... columns) or +#' \code{as.data.frame(S4Vectors::mcols(.))} for the per-variant columns +#' alone. \code{raw = TRUE} returns the stored \code{data.frame} instead. #' @examples #' data(qtlFineMappingExample) -#' getTopLoci(qtlFineMappingExample) +#' topLoci(qtlFineMappingExample) #' @export setGeneric( - "getTopLoci", - function(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) { - standardGeneric("getTopLoci") - } + "topLoci", + function(x, signalCutoff = 0.025, ...) standardGeneric("topLoci") ) #' @title Get Credible Sets #' @description Extract credible set assignments at the requested coverage. #' @param x A \code{FineMappingRow} or \code{FineMappingResult}. #' @param ... Class-specific selection arguments plus \code{coverage}. -#' @param study Character (length 1) or \code{NULL}. Restrict the selection to -#' this study; \code{NULL} matches all studies. +#' @param studyName 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 @@ -1146,35 +1191,14 @@ setGeneric( #' @return A data.frame of credible set information. #' @examples #' data(qtlFineMappingExample) -#' getCs(qtlFineMappingExample) +#' credibleSets(qtlFineMappingExample) #' @export -setGeneric("getCs", function(x, ...) standardGeneric("getCs")) +setGeneric("credibleSets", function(x, ...) standardGeneric("credibleSets")) # ============================================================================= # TwasWeights accessor generics # ============================================================================= -#' @title Get TWAS Weights -#' @description Extract weights from a \code{TwasWeightsRow} or from one entry -#' of a \code{TwasWeights} collection. -#' @param x A \code{TwasWeightsRow} or \code{TwasWeights}. -#' @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 method Character (length 1) or \code{NULL}. Restrict the selection to -#' this fine-mapping / weight method; \code{NULL} matches all methods. -#' @return A numeric vector or matrix of weights. -#' @examples -#' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), -#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -#' getWeights(twe) -#' @export -setGeneric("getWeights", function(x, ...) standardGeneric("getWeights")) - #' @title Resolve Per-Variant Weights From a Weight Source #' @description Return an aligned \code{(variantIds, weights)} pair from a #' single weight-source entry, so cTWAS and @@ -1183,7 +1207,7 @@ setGeneric("getWeights", function(x, ...) standardGeneric("getWeights")) #' or a \code{FineMappingResult} one (its topLoci posterior effect). The #' selectors pin the single row the weights come from. #' @param x A \code{TwasWeights} or a \code{FineMappingResult}. -#' @param study,context,trait,method Optional length-1 selectors pinning one +#' @param studyName,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}. @@ -1194,7 +1218,7 @@ setGeneric("getWeights", function(x, ...) standardGeneric("getWeights")) #' (numeric) of equal length; both empty when no usable weights are present. #' @examples #' data(twasWeightsExample) -#' w <- resolveWeights(twasWeightsExample, study = "protocol_example", +#' w <- resolveWeights(twasWeightsExample, studyName = "protocol_example", #' context = "bulk_rnaseq", trait = "ENSG00000130538", method = "susie") #' length(w$variantIds) #' @export @@ -1209,11 +1233,13 @@ setGeneric("resolveWeights", function(x, ...) standardGeneric("resolveWeights")) #' @return A \code{data.frame} of posteriors (or \code{NULL} when absent). #' @examples #' cre <- CtwasResultEntry( -#' finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), +#' posteriors = 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))) -#' getFinemap(cre) +#' ctwasPosteriors(cre) #' @export -setGeneric("getFinemap", function(x, ...) standardGeneric("getFinemap")) +setGeneric("ctwasPosteriors", function(x, ...) { + standardGeneric("ctwasPosteriors") +}) #' @title Get cTWAS Per-effect Susie Alpha Table #' @description Return the full per-effect susie alpha table @@ -1227,11 +1253,11 @@ setGeneric("getFinemap", function(x, ...) standardGeneric("getFinemap")) #' absent). #' @examples #' cre <- CtwasResultEntry( -#' finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), +#' posteriors = 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))) -#' getSusieAlpha(cre) +#' susieAlpha(cre) #' @export -setGeneric("getSusieAlpha", function(x, ...) standardGeneric("getSusieAlpha")) +setGeneric("susieAlpha", function(x, ...) standardGeneric("susieAlpha")) #' @title Get cTWAS Group Prior Parameters #' @description Return the estimated \code{group_prior} / \code{group_prior_var} @@ -1241,20 +1267,20 @@ setGeneric("getSusieAlpha", function(x, ...) standardGeneric("getSusieAlpha")) #' @return The stored parameter object (typically a list), or \code{NULL}. #' @examples #' cre <- CtwasResultEntry( -#' finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), +#' posteriors = 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))) -#' getCtwasGroupPriors(cre) +#' ctwasGroupPriors(cre) #' @export -setGeneric("getCtwasGroupPriors", function(x, ...) { - standardGeneric("getCtwasGroupPriors") +setGeneric("ctwasGroupPriors", function(x, ...) { + standardGeneric("ctwasGroupPriors") }) #' @title Get Standardized Flag #' @description Check whether weights are on the standardized scale. #' @param x A \code{TwasWeightsRow} or \code{TwasWeights}. #' @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 studyName 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 @@ -1264,18 +1290,18 @@ setGeneric("getCtwasGroupPriors", function(x, ...) { #' @return Logical. #' @examples #' data(ctwasWeightsExample) -#' getStandardized(ctwasWeightsExample) +#' weightStandardized(ctwasWeightsExample) #' @export -setGeneric("getStandardized", function(x, ...) { - standardGeneric("getStandardized") +setGeneric("weightStandardized", function(x, ...) { + standardGeneric("weightStandardized") }) #' @title Get Model Fits #' @description Extract fitted model objects. #' @param x A \code{TwasWeightsRow} or \code{TwasWeights}. #' @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 studyName 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 @@ -1286,9 +1312,9 @@ setGeneric("getStandardized", function(x, ...) { #' @examples #' data(ctwasWeightsExample) #' # NULL unless the pipeline kept fits (fitRetention != "none") -#' getFits(ctwasWeightsExample) +#' methodFits(ctwasWeightsExample) #' @export -setGeneric("getFits", function(x, ...) standardGeneric("getFits")) +setGeneric("methodFits", function(x, ...) standardGeneric("methodFits")) #' @title Get the Full-Data Prior from a MashPrior #' @description Accessor for the \code{fullFit} slot (the full-data data-driven @@ -1299,9 +1325,9 @@ setGeneric("getFits", function(x, ...) standardGeneric("getFits")) #' @examples #' 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))) -#' getFullFit(mp) +#' fullFit(mp) #' @export -setGeneric("getFullFit", function(x, ...) standardGeneric("getFullFit")) +setGeneric("fullFit", function(x, ...) standardGeneric("fullFit")) #' @title Get the Per-Fold Priors from a MashPrior #' @description Accessor for the \code{cvFits} slot (per-fold priors + @@ -1312,9 +1338,9 @@ setGeneric("getFullFit", function(x, ...) standardGeneric("getFullFit")) #' @examples #' 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))) -#' getCvFits(mp) +#' cvFits(mp) #' @export -setGeneric("getCvFits", function(x, ...) standardGeneric("getCvFits")) +setGeneric("cvFits", function(x, ...) standardGeneric("cvFits")) #' @title Get Method Names #' @description Extract the method name(s) an object was produced with: one @@ -1324,16 +1350,16 @@ setGeneric("getCvFits", function(x, ...) standardGeneric("getCvFits")) #' @return Character vector. #' @examples #' data(h2EstimateExample) -#' getMethodNames(h2EstimateExample) +#' methodNames(h2EstimateExample) #' @export -setGeneric("getMethodNames", function(x) standardGeneric("getMethodNames")) +setGeneric("methodNames", function(x) standardGeneric("methodNames")) #' @title Get Data Type #' @description Extract the data-type tag. #' @param x A \code{TwasWeightsRow} or \code{TwasWeights}. #' @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 studyName 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 @@ -1343,10 +1369,13 @@ setGeneric("getMethodNames", function(x) standardGeneric("getMethodNames")) #' @return A character vector or NULL. #' @examples #' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), -#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -#' getDataType(twe) +#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), +#' weightStandardized = FALSE) +#' weightsDataType(twe) #' @export -setGeneric("getDataType", function(x, ...) standardGeneric("getDataType")) +setGeneric("weightsDataType", function(x, ...) { + standardGeneric("weightsDataType") +}) # ============================================================================= # AlleleQcResult accessor generics @@ -1371,8 +1400,8 @@ setGeneric("getDataType", function(x, ...) standardGeneric("getDataType")) #' \code{.vcf} for uncompressed VCF. #' @param sampleName Name for the VCF sample column (default: trait name or #' method name from the S4 object). -#' @param study Character or \code{NULL}. Restrict the written records to this -#' study; \code{NULL} includes all studies. +#' @param studyName Character or \code{NULL}. Restrict the written records to +#' this study; \code{NULL} includes all studies. #' @param context Character or \code{NULL}. Restrict the written records to this #' context; \code{NULL} includes all contexts. #' @param trait Character or \code{NULL}. Restrict the written records to this @@ -1403,7 +1432,7 @@ setGeneric("writeSumStatsVcf", function(x, outputPath, sampleName = NULL, ...) { #' @param x A \code{QtlDataset} object. #' @return Character (length 1). #' @export -setGeneric("getStudy", function(x) standardGeneric("getStudy")) +setGeneric("studyName", function(x) standardGeneric("studyName")) #' @title Get Context Names #' @description Return the names of all contexts carried by an object (e.g., the @@ -1413,21 +1442,23 @@ setGeneric("getStudy", function(x) standardGeneric("getStudy")) #' @return Character vector of context names. #' @examples #' data(qtlDatasetExample) -#' getContexts(qtlDatasetExample) +#' contexts(qtlDatasetExample) #' @export -setGeneric("getContexts", function(x) standardGeneric("getContexts")) +setGeneric("contexts", function(x) standardGeneric("contexts")) #' @title Get Unique Trait Names #' @description Return the unique trait identifiers carried by a collection -#' class (e.g., \code{QtlSumStats}), or the trait names of an -#' \code{\link{SldscData}}. +#' class (e.g., \code{QtlSumStats}), the trait names of an +#' \code{\link{SldscData}}, or the single trait label an +#' \code{H2Estimate} was computed for. #' @param x The object. -#' @return Character vector of unique trait names. +#' @return Character vector of unique trait names; length 1 for an +#' \code{H2Estimate}. #' @examples #' data(qtlSumStatsExample) -#' getTraits(qtlSumStatsExample) +#' traitNames(qtlSumStatsExample) #' @export -setGeneric("getTraits", function(x) standardGeneric("getTraits")) +setGeneric("traitNames", function(x) standardGeneric("traitNames")) #' @title Get Per-Row Genomic Regions #' @description Return the genomic anchor of each row of a per-tuple collection @@ -1440,13 +1471,13 @@ setGeneric("getTraits", function(x) standardGeneric("getTraits")) #' @return A \code{GRanges} with one range per row of \code{x}, or an empty #' \code{GRanges} when the collection carries no region provenance. #' @export -setGeneric("getRegion", function(x, ...) standardGeneric("getRegion")) +setGeneric("genomicRegion", function(x, ...) standardGeneric("genomicRegion")) #' @title Get Per-Row Trait Positions #' @description Return the molecular feature's OWN genomic coordinates (the gene #' / peak range; TSS = \code{start()}) for each row of a per-tuple collection, #' as a \code{GRanges} with one range per row. Distinct from -#' \code{\link{getRegion}} (the fine-mapping window for a +#' \code{\link{genomicRegion}} (the fine-mapping window for a #' \code{FineMappingResult}): the true trait position cannot be inferred from #' summary statistics, so it is threaded from the QtlDataset \code{rowRanges} #' or an explicit QtlSumStats trait-position and carried as provenance onto @@ -1458,8 +1489,8 @@ setGeneric("getRegion", function(x, ...) standardGeneric("getRegion")) #' @return A \code{GRanges} with one range per row of \code{x}, or an empty #' \code{GRanges} when the collection carries no trait-position provenance. #' @export -setGeneric("getTraitPosition", function(x, ...) { - standardGeneric("getTraitPosition") +setGeneric("traitPosition", function(x, ...) { + standardGeneric("traitPosition") }) #' @title Get Residualized Genotypes @@ -1493,10 +1524,10 @@ setGeneric("getTraitPosition", function(x, ...) { #' @return A numeric matrix (samples x variants). #' @examples #' data(qtlDatasetExample) -#' getResidualizedGenotypes(qtlDatasetExample, contexts = "brain") +#' residualizedGenotypes(qtlDatasetExample, contexts = "brain") #' @export -setGeneric("getResidualizedGenotypes", function(x, ...) { - standardGeneric("getResidualizedGenotypes") +setGeneric("residualizedGenotypes", function(x, ...) { + standardGeneric("residualizedGenotypes") }) #' @title Get Residualized Phenotypes @@ -1535,10 +1566,10 @@ setGeneric("getResidualizedGenotypes", function(x, ...) { #' @return A named list of numeric matrices keyed by context. #' @examples #' data(qtlDatasetExample) -#' getResidualizedPhenotypes(qtlDatasetExample, contexts = "brain") +#' residualizedPhenotypes(qtlDatasetExample, contexts = "brain") #' @export -setGeneric("getResidualizedPhenotypes", function(x, ...) { - standardGeneric("getResidualizedPhenotypes") +setGeneric("residualizedPhenotypes", function(x, ...) { + standardGeneric("residualizedPhenotypes") }) #' @title Get Per-Context Phenotype Covariates @@ -1546,14 +1577,14 @@ setGeneric("getResidualizedPhenotypes", function(x, ...) { #' \code{colData} of each context's \code{SummarizedExperiment}. #' @param x A \code{QtlDataset} object. #' @param contexts Character vector of context names (subset of -#' \code{names(getPhenotypes(x))}). +#' \code{names(molecularTraits(x))}). #' @return A named list of matrices keyed by context. #' @examples #' data(qtlDatasetExample) -#' getPhenotypeCovariates(qtlDatasetExample, contexts = "brain") +#' phenotypeCovariates(qtlDatasetExample, contexts = "brain") #' @export -setGeneric("getPhenotypeCovariates", function(x, contexts) { - standardGeneric("getPhenotypeCovariates") +setGeneric("phenotypeCovariates", function(x, contexts) { + standardGeneric("phenotypeCovariates") }) #' @title Get Genotype Covariates @@ -1563,10 +1594,10 @@ setGeneric("getPhenotypeCovariates", function(x, contexts) { #' @return Numeric matrix (samples x covariates). #' @examples #' data(qtlDatasetExample) -#' getGenotypeCovariates(qtlDatasetExample) +#' genotypeCovariates(qtlDatasetExample) #' @export -setGeneric("getGenotypeCovariates", function(x) { - standardGeneric("getGenotypeCovariates") +setGeneric("genotypeCovariates", function(x) { + standardGeneric("genotypeCovariates") }) #' @title Get scaleResiduals Flag @@ -1576,10 +1607,10 @@ setGeneric("getGenotypeCovariates", function(x) { #' @return Logical (length 1). #' @examples #' data(qtlDatasetExample) -#' getScaleResiduals(qtlDatasetExample) +#' scaleResiduals(qtlDatasetExample) #' @export -setGeneric("getScaleResiduals", function(x) { - standardGeneric("getScaleResiduals") +setGeneric("scaleResiduals", function(x) { + standardGeneric("scaleResiduals") }) # ============================================================================= @@ -1599,7 +1630,7 @@ setGeneric("getScaleResiduals", function(x) { #' been row-subset. Callers that only need chrom/pos/alleles should use #' \code{rowRanges()} on the panel instead. #' @keywords internal -setGeneric("getSnpInfo", function(x) standardGeneric("getSnpInfo")) +setGeneric("snpInfo", function(x) standardGeneric("snpInfo")) #' @title Get Genotype Storage Format #' @description Return the detected genotype storage format. @@ -1609,17 +1640,7 @@ setGeneric("getSnpInfo", function(x) standardGeneric("getSnpInfo")) #' is not part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. #' @keywords internal -setGeneric("getFormat", function(x) standardGeneric("getFormat")) - -#' @title Get File Path -#' @description Return the underlying genotype file path or stem. -#' @param x A \code{GenotypeHandle}. -#' @return Character (length 1). -#' @details The genotype handle is the seed layer behind a panel and -#' is not part of the public interface; obtain a panel from -#' \code{readGenotypes()} and ask it directly. -#' @keywords internal -setGeneric("getPath", function(x) standardGeneric("getPath")) +setGeneric("genotypeFormat", function(x) standardGeneric("genotypeFormat")) #' @title Get Sample Identifiers #' @description Return the sample-id vector. @@ -1629,7 +1650,7 @@ setGeneric("getPath", function(x) standardGeneric("getPath")) #' is not part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. #' @keywords internal -setGeneric("getSampleIds", function(x) standardGeneric("getSampleIds")) +setGeneric("sampleIds", function(x) standardGeneric("sampleIds")) #' @title Get plink2 pgen Pointer #' @description Return the cached external pointer to the plink2 pgen handle @@ -1640,17 +1661,7 @@ setGeneric("getSampleIds", function(x) standardGeneric("getSampleIds")) #' is not part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. #' @keywords internal -setGeneric("getPgenPtr", function(x) standardGeneric("getPgenPtr")) - -#' @title Get Sample Count -#' @description Return the number of samples carried by a \code{GenotypeHandle}. -#' @param x A \code{GenotypeHandle}. -#' @return Integer (length 1). -#' @details The genotype handle is the seed layer behind a panel and -#' is not part of the public interface; obtain a panel from -#' \code{readGenotypes()} and ask it directly. -#' @keywords internal -setGeneric("getNSamples", function(x) standardGeneric("getNSamples")) +setGeneric("pgenPtr", function(x) standardGeneric("pgenPtr")) #' @title Get Per-Block Eigendecompositions #' @description Return the per-block eigendecomposition list carried by an @@ -1659,9 +1670,9 @@ setGeneric("getNSamples", function(x) standardGeneric("getNSamples")) #' @return List of per-block eigen decompositions. #' @examples #' data(ldEigenExample) -#' getEigenList(ldEigenExample) +#' eigenList(ldEigenExample) #' @export -setGeneric("getEigenList", function(x) standardGeneric("getEigenList")) +setGeneric("eigenList", function(x) standardGeneric("eigenList")) #' @title Get LD Reference Panel Size #' @description Return the reference-panel sample size used to compute an @@ -1676,9 +1687,9 @@ setGeneric("getEigenList", function(x) standardGeneric("getEigenList")) #' ld <- LdData(correlation = cor(X), variants = gr, #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) -#' getNRef(ld) +#' ldPanelNSamples(ld) #' @export -setGeneric("getNRef", function(x) standardGeneric("getNRef")) +setGeneric("ldPanelNSamples", function(x) standardGeneric("ldPanelNSamples")) #' @title Get In-Sample Flag #' @description Whether the LD reference panel is from the same cohort as the @@ -1687,33 +1698,9 @@ setGeneric("getNRef", function(x) standardGeneric("getNRef")) #' @return Logical (length 1). #' @examples #' data(ldEigenExample) -#' getInSample(ldEigenExample) -#' @export -setGeneric("getInSample", function(x) standardGeneric("getInSample")) - -#' @title Get LD Scores -#' @description Return the per-SNP LD score matrix carried by an \code{LdScore} -#' object. -#' @param x An \code{LdScore}. -#' @return Numeric matrix (SNPs x annotations+1). -#' @examples -#' data(ldScoreExample) -#' getLdScores(ldScoreExample) -#' @export -setGeneric("getLdScores", function(x) standardGeneric("getLdScores")) - -#' @title Get LD-Score Regression Weights -#' @description Return the per-SNP regression weights vector carried by an -#' \code{LdScore} object. -#' @param x An \code{LdScore}. -#' @return Numeric vector. -#' @examples -#' data(ldScoreExample) -#' getLdScoreWeights(ldScoreExample) +#' inSample(ldEigenExample) #' @export -setGeneric("getLdScoreWeights", function(x) { - standardGeneric("getLdScoreWeights") -}) +setGeneric("inSample", function(x) standardGeneric("inSample")) #' @title Get Per-Block LD Matrix List #' @description Return the list of per-block LD (R^2) matrices used for the FGLS @@ -1722,9 +1709,9 @@ setGeneric("getLdScoreWeights", function(x) { #' @return List of matrices (empty list for S-LDSC). #' @examples #' data(ldScoreExample) -#' getLdMatrixList(ldScoreExample) +#' ldMatrixList(ldScoreExample) #' @export -setGeneric("getLdMatrixList", function(x) standardGeneric("getLdMatrixList")) +setGeneric("ldMatrixList", function(x) standardGeneric("ldMatrixList")) #' @title Get LD Block Container #' @description Return the \code{GRanges} of LD blocks carried by an @@ -1733,9 +1720,9 @@ setGeneric("getLdMatrixList", function(x) standardGeneric("getLdMatrixList")) #' @return A \code{GRanges} of LD block intervals. #' @examples #' data(ldEigenExample) -#' getLdBlocks(ldEigenExample) +#' ldBlocks(ldEigenExample) #' @export -setGeneric("getLdBlocks", function(x) standardGeneric("getLdBlocks")) +setGeneric("ldBlocks", function(x) standardGeneric("ldBlocks")) #' @title Get GenotypeHandle from LdData @@ -1743,14 +1730,14 @@ setGeneric("getLdBlocks", function(x) standardGeneric("getLdBlocks")) #' panels) carried by an \code{LdData}. #' @param x An \code{LdData}. #' @return A \code{GenotypeHandle}, a list of them, or NULL. For a -#' \code{QtlDataset} this is the handle itself; \code{getGenotypes()} +#' \code{QtlDataset} this is the handle itself; \code{genotypes()} #' extracts a dosage block from it instead. #' @details The genotype handle is the seed layer behind a panel and #' is not part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. #' @keywords internal -setGeneric("getGenotypeHandle", function(x) { - standardGeneric("getGenotypeHandle") +setGeneric("genotypeHandle", function(x) { + standardGeneric("genotypeHandle") }) #' @title Get Mixture Weights @@ -1767,10 +1754,10 @@ setGeneric("getGenotypeHandle", function(x) { #' ld <- LdData(correlation = cor(X), variants = gr, #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) -#' getMixtureWeights(ld) +#' mixtureWeights(ld) #' @export -setGeneric("getMixtureWeights", function(x) { - standardGeneric("getMixtureWeights") +setGeneric("mixtureWeights", function(x) { + standardGeneric("mixtureWeights") }) #' @title Get SNP Indices @@ -1786,9 +1773,9 @@ setGeneric("getMixtureWeights", function(x) { #' ld <- LdData(correlation = cor(X), variants = gr, #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) -#' getSnpIdx(ld) +#' snpIdx(ld) #' @export -setGeneric("getSnpIdx", function(x) standardGeneric("getSnpIdx")) +setGeneric("snpIdx", function(x) standardGeneric("snpIdx")) #' @title Get Variant GRanges #' @description Return the variant metadata \code{GRanges} of an \code{LdData}. @@ -1802,9 +1789,9 @@ setGeneric("getSnpIdx", function(x) standardGeneric("getSnpIdx")) #' ld <- LdData(correlation = cor(X), variants = gr, #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) -#' getVariantInfo(ld) +#' variantInfo(ld) #' @export -setGeneric("getVariantInfo", function(x) standardGeneric("getVariantInfo")) +setGeneric("variantInfo", function(x) standardGeneric("variantInfo")) #' @title Get Block Metadata #' @description Return the block metadata (\code{GRanges} or \code{data.frame}) @@ -1819,9 +1806,9 @@ setGeneric("getVariantInfo", function(x) standardGeneric("getVariantInfo")) #' ld <- LdData(correlation = cor(X), variants = gr, #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) -#' getBlockMetadata(ld) +#' blockMetadata(ld) #' @export -setGeneric("getBlockMetadata", function(x) standardGeneric("getBlockMetadata")) +setGeneric("blockMetadata", function(x) standardGeneric("blockMetadata")) #' @title Get Reference Panel (data.frame) #' @description Flatten the variant \code{GRanges} of an \code{LdData} into a @@ -1836,9 +1823,9 @@ setGeneric("getBlockMetadata", function(x) standardGeneric("getBlockMetadata")) #' ld <- LdData(correlation = cor(X), variants = gr, #' blockMetadata = S4Vectors::DataFrame( #' chrom = "22", start = 1L, end = 1000L)) -#' getRefPanel(ld) +#' refPanel(ld) #' @export -setGeneric("getRefPanel", function(x) standardGeneric("getRefPanel")) +setGeneric("refPanel", function(x) standardGeneric("refPanel")) #' @title Get Per-Block tau Matrix #' @description Return the per-block jackknife tau matrix carried by an @@ -1847,9 +1834,11 @@ setGeneric("getRefPanel", function(x) standardGeneric("getRefPanel")) #' @return A numeric matrix or NULL. #' @examples #' data(h2EstimateExample) -#' getTauBlocks(h2EstimateExample) +#' annotationJackknifeCoefs(h2EstimateExample) #' @export -setGeneric("getTauBlocks", function(x) standardGeneric("getTauBlocks")) +setGeneric("annotationJackknifeCoefs", function(x) { + standardGeneric("annotationJackknifeCoefs") +}) #' @title Get Global SNP Heritability #' @description Return the global SNP heritability estimate carried by an @@ -1858,9 +1847,11 @@ setGeneric("getTauBlocks", function(x) standardGeneric("getTauBlocks")) #' @return Numeric (length 1). #' @examples #' data(h2EstimateExample) -#' getH2(h2EstimateExample) +#' heritabilityEstimate(h2EstimateExample) #' @export -setGeneric("getH2", function(x) standardGeneric("getH2")) +setGeneric("heritabilityEstimate", function(x) { + standardGeneric("heritabilityEstimate") +}) #' @title Get Heritability Standard Error #' @description Return the standard error of the global SNP heritability @@ -1869,9 +1860,11 @@ setGeneric("getH2", function(x) standardGeneric("getH2")) #' @return Numeric (length 1). #' @examples #' data(h2EstimateExample) -#' getH2Se(h2EstimateExample) +#' heritabilityEstimateSe(h2EstimateExample) #' @export -setGeneric("getH2Se", function(x) standardGeneric("getH2Se")) +setGeneric("heritabilityEstimateSe", function(x) { + standardGeneric("heritabilityEstimateSe") +}) #' @title Get LD-Score Regression Intercept #' @description Return the regression intercept carried by an @@ -1881,9 +1874,11 @@ setGeneric("getH2Se", function(x) standardGeneric("getH2Se")) #' @return Numeric (length 1). #' @examples #' data(h2EstimateExample) -#' getIntercept(h2EstimateExample) +#' heritabilityIntercept(h2EstimateExample) #' @export -setGeneric("getIntercept", function(x) standardGeneric("getIntercept")) +setGeneric("heritabilityIntercept", function(x) { + standardGeneric("heritabilityIntercept") +}) #' @title Get Intercept Standard Error #' @description Return the standard error of the regression intercept carried @@ -1892,30 +1887,11 @@ setGeneric("getIntercept", function(x) standardGeneric("getIntercept")) #' @return Numeric (length 1). #' @examples #' data(h2EstimateExample) -#' getInterceptSe(h2EstimateExample) -#' @export -setGeneric("getInterceptSe", function(x) standardGeneric("getInterceptSe")) - -#' @title Get Variant Count -#' @description Return the number of variants the heritability estimate was -#' computed over. -#' @param x An \code{H2Estimate}. -#' @return Integer (length 1). -#' @examples -#' data(h2EstimateExample) -#' getNSnps(h2EstimateExample) -#' @export -setGeneric("getNSnps", function(x) standardGeneric("getNSnps")) - -#' @title Get Trait Name -#' @description Return the trait label carried by an \code{H2Estimate}. -#' @param x An \code{H2Estimate}. -#' @return Character (length 1). -#' @examples -#' data(h2EstimateExample) -#' getTraitName(h2EstimateExample) +#' heritabilityInterceptSe(h2EstimateExample) #' @export -setGeneric("getTraitName", function(x) standardGeneric("getTraitName")) +setGeneric("heritabilityInterceptSe", function(x) { + standardGeneric("heritabilityInterceptSe") +}) # Internal generics for the unified joint-analysis engine (see R/JointGroup.R # and dev/jointSpecification-s4-refactor.md). Not exported: the engine and its @@ -1942,7 +1918,7 @@ setGeneric("construct", function(pipeline, records, ...) { #' @title Get the annotation table from an SldscData #' @param x An \code{\link{SldscData}} object. #' @return A \code{data.frame} of annotations (CHR, SNP, annotation columns). -#' @rdname getAnnotData +#' @rdname annotData #' @examples #' mkRun <- function(cats) { #' n <- length(cats) @@ -1953,8 +1929,8 @@ setGeneric("construct", function(pipeline, records, ...) { #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -1966,47 +1942,15 @@ setGeneric("construct", function(pipeline, records, ...) { #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) -#' getAnnotData(sd) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +#' annotData(sd) #' @export -setGeneric("getAnnotData", function(x) standardGeneric("getAnnotData")) +setGeneric("annotData", function(x) standardGeneric("annotData")) #' @title Get the allele-frequency table from an SldscData #' @param x An \code{\link{SldscData}} object. #' @return A \code{data.frame} of reference-panel frequencies (SNP, MAF). -#' @rdname getFrqData -#' @examples -#' mkRun <- function(cats) { -#' n <- length(cats) -#' list(categories = cats, tau = setNames(rep(1e-7, n), cats), -#' tauSe = setNames(rep(3e-8, n), cats), -#' enrichment = setNames(rep(2, n), cats), -#' enrichmentSe = setNames(rep(0.4, n), cats), -#' enrichmentP = setNames(rep(0.01, n), cats), -#' propH2 = setNames(rep(0.2, n), cats), -#' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) -#' } -#' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), -#' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) -#' frq <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), -#' MAF = rep(0.2, 6)) -#' mkTrait <- function() { -#' list(single = list(mkRun(c("annot_A_0", "baselineLD_0")), -#' mkRun(c("annot_B_0", "baselineLD_0"))), -#' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) -#' } -#' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) -#' getFrqData(sd) -#' @export -setGeneric("getFrqData", function(x) standardGeneric("getFrqData")) - -#' @title Get the per-trait runs list from an SldscData -#' @param x An \code{\link{SldscData}} object. -#' @return The named list of per-trait \code{single}/\code{joint} runs. -#' @rdname getTraitRuns +#' @rdname frqData #' @examples #' mkRun <- function(cats) { #' n <- length(cats) @@ -2017,8 +1961,8 @@ setGeneric("getFrqData", function(x) standardGeneric("getFrqData")) #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -2030,15 +1974,15 @@ setGeneric("getFrqData", function(x) standardGeneric("getFrqData")) #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) -#' getTraitRuns(sd) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +#' frqData(sd) #' @export -setGeneric("getTraitRuns", function(x) standardGeneric("getTraitRuns")) +setGeneric("frqData", function(x) standardGeneric("frqData")) #' @title Get the annotation column names from an SldscData #' @param x An \code{\link{SldscData}} object. #' @return A character vector of annotation column names. -#' @rdname getAnnotCols +#' @rdname annotCols #' @examples #' mkRun <- function(cats) { #' n <- length(cats) @@ -2049,8 +1993,8 @@ setGeneric("getTraitRuns", function(x) standardGeneric("getTraitRuns")) #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -2062,20 +2006,46 @@ setGeneric("getTraitRuns", function(x) standardGeneric("getTraitRuns")) #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) -#' getAnnotCols(sd) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +#' annotCols(sd) +#' @export +setGeneric("annotCols", function(x) standardGeneric("annotCols")) + +#' @title Get Baseline Annotations +#' @description Extract only baseline-tier annotations from an +#' \code{AnnotationMatrix}. +#' @param x An \code{AnnotationMatrix} object. +#' @return An \code{AnnotationMatrix} with only baseline annotations. #' @export -setGeneric("getAnnotCols", function(x) standardGeneric("getAnnotCols")) +setGeneric("baselineAnnotations", function(x) { + standardGeneric("baselineAnnotations") +}) + +#' @title Get Tested Annotations +#' @description Extract only candidate-tier annotations from an +#' \code{AnnotationMatrix} -- the annotations whose enrichment is being +#' tested, as opposed to the baseline set they are tested against. +#' @param x An \code{AnnotationMatrix} object. +#' @return An \code{AnnotationMatrix} with only candidate annotations. +#' @export +setGeneric("testedAnnotations", function(x) { + standardGeneric("testedAnnotations") +}) -#' @title Get one trait's run from an SldscData +#' @title Get sLDSC Results from an SldscData +#' @description Return the stratified LD-score regression runs held by an +#' \code{\link{SldscData}}: every trait's runs when \code{trait} is +#' \code{NULL}, otherwise the selected run(s) for that one trait. #' @param x An \code{\link{SldscData}} object. -#' @param trait Character. Trait name. +#' @param trait Character trait name, or \code{NULL} (default) to return the +#' named list of per-trait \code{single}/\code{joint} runs for all traits. #' @param ... Further arguments: \code{mode} (\code{"single"}/\code{"joint"}) #' and \code{idx} (which single run). #' @param mode Character. Trait-run selection mode. #' @param idx Integer. Index of the trait run to select. -#' @return A single run list, the list of single runs, or \code{NULL}. -#' @rdname getTraitRun +#' @return The named list of per-trait runs when \code{trait} is \code{NULL}; +#' otherwise a single run list, the list of single runs, or \code{NULL}. +#' @rdname sldscResults #' @examples #' mkRun <- function(cats) { #' n <- length(cats) @@ -2086,8 +2056,8 @@ setGeneric("getAnnotCols", function(x) standardGeneric("getAnnotCols")) #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -2099,11 +2069,11 @@ setGeneric("getAnnotCols", function(x) standardGeneric("getAnnotCols")) #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) -#' getTraitRun(sd, "traitX") +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +#' sldscResults(sd, "traitX") #' @export -setGeneric("getTraitRun", function(x, trait, ...) { - standardGeneric("getTraitRun") +setGeneric("sldscResults", function(x, trait = NULL, ...) { + standardGeneric("sldscResults") }) #' @title Colocalization Views @@ -2113,20 +2083,20 @@ setGeneric("getTraitRun", function(x, trait, ...) { #' analysis needs, rather than any one of them being the stored shape. #' #' \describe{ -#' \item{\code{getColocPairs()}}{One row per tested pair -- coloc's native +#' \item{\code{colocPairs()}}{One row per tested pair -- coloc's native #' \code{$summary} granularity. Every testable pair is reported verbatim, #' including both halves of a credible set that straddles a block #' boundary; interpreting them is the caller's decision.} -#' \item{\code{getColocVariants()}}{One row per (pair, variant), carrying +#' \item{\code{colocVariants()}}{One row per (pair, variant), carrying #' \code{colocPp = PP.H4.abf * SNP.PP.H4} -- the posterior that this #' variant is the shared causal one. With \code{pooled = TRUE}, one row #' per (gene, variant) pooled by the rule below.} -#' \item{\code{getColocCredibleSets()}}{One row per coloc credible set: the +#' \item{\code{colocCredibleSets()}}{One row per coloc credible set: the #' smallest set of variants whose cumulative \code{SNP.PP.H4} reaches #' \code{coverage}. This is a THIRD variant set, not guaranteed to be a #' subset of either input credible set, so its purity is recomputed from #' LD rather than inherited.} -#' \item{\code{getColocGenes()}}{One row per gene, pooled across pairs.} +#' \item{\code{colocGenes()}}{One row per gene, pooled across pairs.} #' } #' #' @section Pooling: For a fixed QTL credible set \emph{i}, the per-(block, @@ -2138,7 +2108,7 @@ setGeneric("getTraitRun", function(x, trait, ...) { #' combine as \code{1 - prod_i (1 - p_i)}. #' #' @param x A \code{ColocResult}. -#' @param pooled Logical. \code{getColocVariants()} only: pool to one row per +#' @param pooled Logical. \code{colocVariants()} only: pool to one row per #' (gene, variant) instead of per (pair, variant). #' @param coverage Cumulative \code{SNP.PP.H4} the credible set must reach. #' @param minPp4 Optional lower bound on the pair's \code{PP.H4.abf}. Applied @@ -2161,37 +2131,37 @@ setGeneric("getTraitRun", function(x, trait, ...) { #' qtlFineMappingResult = qtlFineMappingLbfExample, #' gwasInput = gwasFineMappingLbfExample #' ) -#' head(getColocPairs(res)) -#' head(getColocVariants(res)) -#' getColocGenes(res) -#' head(getColocCredibleSets(res, minPp4 = 0.001)) +#' head(colocPairs(res)) +#' head(colocVariants(res)) +#' colocGenes(res) +#' head(colocCredibleSets(res, minPp4 = 0.001)) NULL #' @rdname colocViews #' @export -setGeneric("getColocPairs", function(x, ...) { - standardGeneric("getColocPairs") +setGeneric("colocPairs", function(x, ...) { + standardGeneric("colocPairs") }) #' @rdname colocViews #' @export -setGeneric("getColocVariants", function(x, pooled = FALSE, ...) { - standardGeneric("getColocVariants") +setGeneric("colocVariants", function(x, pooled = FALSE, ...) { + standardGeneric("colocVariants") }) #' @rdname colocViews #' @export setGeneric( - "getColocCredibleSets", + "colocCredibleSets", function(x, coverage = 0.95, minPp4 = NULL, minAbsCorr = 0.8, ...) { - standardGeneric("getColocCredibleSets") + standardGeneric("colocCredibleSets") } ) #' @rdname colocViews #' @export -setGeneric("getColocGenes", function(x, ...) { - standardGeneric("getColocGenes") +setGeneric("colocGenes", function(x, ...) { + standardGeneric("colocGenes") }) #' @title QtlDataset Filter Settings @@ -2201,51 +2171,51 @@ setGeneric("getColocGenes", function(x, ...) { #' out what a dataset already excludes. #' @param x A \code{QtlDataset}. #' @param ... Additional arguments passed on to methods. -#' @return \code{getMafCutoff()}, \code{getMacCutoff()}, -#' \code{getXvarCutoff()} and \code{getImissCutoff()} single numerics; -#' \code{getKeepVariants()} a character vector (empty when no restriction -#' was requested); \code{getKeepIndel()} a single logical. The sample set +#' @return \code{mafCutoff()}, \code{macCutoff()}, +#' \code{xvarCutoff()} and \code{imissCutoff()} single numerics; +#' \code{keepVariants()} a character vector (empty when no restriction +#' was requested); \code{keepIndel()} a single logical. The sample set #' is not among them: it lives in \code{colData(x)} and \code{sampleMap(x)}. #' @name qtlDatasetFilters #' @rdname qtlDatasetFilters #' @examples #' data(qtlDatasetExample) -#' getMafCutoff(qtlDatasetExample) -#' getKeepIndel(qtlDatasetExample) +#' mafCutoff(qtlDatasetExample) +#' keepIndel(qtlDatasetExample) NULL #' @rdname qtlDatasetFilters #' @export -setGeneric("getMafCutoff", function(x, ...) standardGeneric("getMafCutoff")) +setGeneric("mafCutoff", function(x, ...) standardGeneric("mafCutoff")) #' @rdname qtlDatasetFilters #' @export -setGeneric("getMacCutoff", function(x, ...) standardGeneric("getMacCutoff")) +setGeneric("macCutoff", function(x, ...) standardGeneric("macCutoff")) #' @rdname qtlDatasetFilters #' @export -setGeneric("getXvarCutoff", function(x, ...) standardGeneric("getXvarCutoff")) +setGeneric("xvarCutoff", function(x, ...) standardGeneric("xvarCutoff")) #' @rdname qtlDatasetFilters #' @export -setGeneric("getImissCutoff", function(x, ...) { - standardGeneric("getImissCutoff") +setGeneric("imissCutoff", function(x, ...) { + standardGeneric("imissCutoff") }) #' @rdname qtlDatasetFilters #' @export -setGeneric("getKeepVariants", function(x, ...) { - standardGeneric("getKeepVariants") +setGeneric("keepVariants", function(x, ...) { + standardGeneric("keepVariants") }) #' @rdname qtlDatasetFilters #' @export -setGeneric("getKeepIndel", function(x, ...) standardGeneric("getKeepIndel")) +setGeneric("keepIndel", function(x, ...) standardGeneric("keepIndel")) #' @title Get Per-Chromosome Payload Paths #' @description The chromosome-to-path map of a sharded #' \code{\link{GenotypeHandle}}. Empty (\code{character(0)}) for a -#' single-file handle, whose one path is \code{\link{getPath}} instead; a +#' single-file handle, whose one path is \code{\link{path}} instead; a #' non-empty map marks a one-file-per-chromosome handle whose extraction is #' routed by chromosome. #' @param x A \code{GenotypeHandle}. @@ -2256,7 +2226,7 @@ setGeneric("getKeepIndel", function(x, ...) standardGeneric("getKeepIndel")) #' is not part of the public interface; obtain a panel from #' \code{readGenotypes()} and ask it directly. #' @keywords internal -setGeneric("getChromPaths", function(x, ...) standardGeneric("getChromPaths")) +setGeneric("chromPaths", function(x, ...) standardGeneric("chromPaths")) #' Per-variant per-effect log Bayes factors (wide) #' @@ -2264,7 +2234,7 @@ setGeneric("getChromPaths", function(x, ...) standardGeneric("getChromPaths")) #' (\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one row #' per variant, one \code{lbf_L} column per effect. The per-variant scalar #' summary (max across effects) is the \code{logBF} column of -#' \code{\link{getTopLoci}}; this accessor keeps the full per-effect breakdown. +#' \code{\link{topLoci}}; this accessor keeps the full per-effect breakdown. #' Across entries with different effect counts the collection method NA-fills #' the ragged columns. #' @@ -2272,18 +2242,19 @@ setGeneric("getChromPaths", function(x, ...) standardGeneric("getChromPaths")) #' @param ... Ignored. #' @return A \code{tibble}: \code{variant_id} + \code{lbf_L1..lbf_LL} (the #' collection method also carries the entry identity columns). -#' @seealso \code{\link{getTopLoci}} (the scalar \code{logBF} column) +#' @seealso \code{\link{topLoci}} (the scalar \code{logBF} column) #' @examples #' data(qtlFineMappingExample) -#' getLbf(qtlFineMappingExample) +#' lbf(qtlFineMappingExample) #' @export -setGeneric("getLbf", function(x, ...) standardGeneric("getLbf")) +setGeneric("lbf", function(x, ...) standardGeneric("lbf")) #' Per-credible-set summary of a fine-mapping result #' #' One row per credible set (at a given coverage) with its size, purity, prior #' variance, log Bayes factor, and lead variant -- the per-CS complement to the -#' per-variant \code{\link{getCs}}. Replaces the legacy per-effect `effect.tsv`. +#' per-variant \code{\link{credibleSets}}. Replaces the legacy +#' per-effect `effect.tsv`. #' #' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. #' @param coverage Credible-set coverage to summarise. Default 0.95. @@ -2295,13 +2266,13 @@ setGeneric("getLbf", function(x, ...) standardGeneric("getLbf")) #' \code{cs_mean_effect} (mean posterior conditional effect), #' \code{lead_variant, lead_pip} (the collection method also carries the entry #' identity columns). -#' @seealso \code{\link{getCs}}, \code{\link{getTopLoci}} +#' @seealso \code{\link{credibleSets}}, \code{\link{topLoci}} #' @examples #' data(qtlFineMappingExample) -#' getCredibleSetSummary(qtlFineMappingExample) +#' credibleSetSummary(qtlFineMappingExample) #' @export -setGeneric("getCredibleSetSummary", function(x, ...) { - standardGeneric("getCredibleSetSummary") +setGeneric("credibleSetSummary", function(x, ...) { + standardGeneric("credibleSetSummary") }) #' fSuSiE credible band (fitted effect + uncertainty band) @@ -2380,172 +2351,172 @@ setGeneric("fsusieAffectedRegions", function(x, ...) { #' @param x A \code{CredibleSetParam}. #' @param ... Unused, present for generic consistency. #' @export -setGeneric("getCoverage", function(x, ...) { - standardGeneric("getCoverage") +setGeneric("csCoverage", function(x, ...) { + standardGeneric("csCoverage") }) #' @rdname CredibleSetParam #' @param value The replacement value for that setting. #' @export -setGeneric("setCoverage", function(x, value, ...) { - standardGeneric("setCoverage") +setGeneric("csCoverage<-", function(x, ..., value) { + standardGeneric("csCoverage<-") }) #' @rdname CredibleSetParam #' @export -setGeneric("getSecondaryCoverage", function(x, ...) { - standardGeneric("getSecondaryCoverage") +setGeneric("secondaryCoverage", function(x, ...) { + standardGeneric("secondaryCoverage") }) #' @rdname CredibleSetParam #' @export -setGeneric("setSecondaryCoverage", function(x, value, ...) { - standardGeneric("setSecondaryCoverage") +setGeneric("secondaryCoverage<-", function(x, ..., value) { + standardGeneric("secondaryCoverage<-") }) #' @rdname CredibleSetParam #' @export -setGeneric("getSignalCutoff", function(x, ...) { - standardGeneric("getSignalCutoff") +setGeneric("signalCutoff", function(x, ...) { + standardGeneric("signalCutoff") }) #' @rdname CredibleSetParam #' @export -setGeneric("setSignalCutoff", function(x, value, ...) { - standardGeneric("setSignalCutoff") +setGeneric("signalCutoff<-", function(x, ..., value) { + standardGeneric("signalCutoff<-") }) #' @rdname CredibleSetParam #' @export -setGeneric("getMinAbsCorr", function(x, ...) { - standardGeneric("getMinAbsCorr") +setGeneric("minAbsCorr", function(x, ...) { + standardGeneric("minAbsCorr") }) #' @rdname CredibleSetParam #' @export -setGeneric("setMinAbsCorr", function(x, value, ...) { - standardGeneric("setMinAbsCorr") +setGeneric("minAbsCorr<-", function(x, ..., value) { + standardGeneric("minAbsCorr<-") }) #' @rdname CredibleSetParam #' @export -setGeneric("getMedianAbsCorr", function(x, ...) { - standardGeneric("getMedianAbsCorr") +setGeneric("medianAbsCorr", function(x, ...) { + standardGeneric("medianAbsCorr") }) #' @rdname CredibleSetParam #' @export -setGeneric("setMedianAbsCorr", function(x, value, ...) { - standardGeneric("setMedianAbsCorr") +setGeneric("medianAbsCorr<-", function(x, ..., value) { + standardGeneric("medianAbsCorr<-") }) #' @rdname CredibleSetParam #' @export -setGeneric("getIncludeAllCs", function(x, ...) { - standardGeneric("getIncludeAllCs") +setGeneric("includeAllCs", function(x, ...) { + standardGeneric("includeAllCs") }) #' @rdname CredibleSetParam #' @export -setGeneric("setIncludeAllCs", function(x, value, ...) { - standardGeneric("setIncludeAllCs") +setGeneric("includeAllCs<-", function(x, ..., value) { + standardGeneric("includeAllCs<-") }) #' @rdname CredibleSetParam #' @export -setGeneric("getPerCsColumns", function(x, ...) { - standardGeneric("getPerCsColumns") +setGeneric("perCsColumns", function(x, ...) { + standardGeneric("perCsColumns") }) #' @rdname CredibleSetParam #' @export -setGeneric("setPerCsColumns", function(x, value, ...) { - standardGeneric("setPerCsColumns") +setGeneric("perCsColumns<-", function(x, ..., value) { + standardGeneric("perCsColumns<-") }) #' @rdname CredibleSetParam #' @export -setGeneric("getL", function(x, ...) { - standardGeneric("getL") +setGeneric("maxNumSingleEffects", function(x, ...) { + standardGeneric("maxNumSingleEffects") }) #' @rdname CredibleSetParam #' @export -setGeneric("getLgreedy", function(x, ...) { - standardGeneric("getLgreedy") +setGeneric("maxNumSingleEffectsGreedy", function(x, ...) { + standardGeneric("maxNumSingleEffectsGreedy") }) #' @rdname GwasFineMappingParam #' @param x A \code{GwasFineMappingParam}. #' @param ... Unused, present for generic consistency. #' @export -setGeneric("getFineMappingMethods", function(x, ...) { - standardGeneric("getFineMappingMethods") +setGeneric("fineMappingMethods", function(x, ...) { + standardGeneric("fineMappingMethods") }) #' @rdname GwasFineMappingParam #' @param value The replacement value for that setting. #' @export -setGeneric("setFineMappingMethods", function(x, value, ...) { - standardGeneric("setFineMappingMethods") +setGeneric("fineMappingMethods<-", function(x, ..., value) { + standardGeneric("fineMappingMethods<-") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("getCredibleSetArgs", function(x, ...) { - standardGeneric("getCredibleSetArgs") +setGeneric("credibleSetParam", function(x, ...) { + standardGeneric("credibleSetParam") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("setCredibleSetArgs", function(x, value, ...) { - standardGeneric("setCredibleSetArgs") +setGeneric("credibleSetParam<-", function(x, ..., value) { + standardGeneric("credibleSetParam<-") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("getRssArgs", function(x, ...) { - standardGeneric("getRssArgs") +setGeneric("susieRssParam", function(x, ...) { + standardGeneric("susieRssParam") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("setRssArgs", function(x, value, ...) { - standardGeneric("setRssArgs") +setGeneric("susieRssParam<-", function(x, ..., value) { + standardGeneric("susieRssParam<-") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("getPanelFilterArgs", function(x, ...) { - standardGeneric("getPanelFilterArgs") +setGeneric("panelFilterParam", function(x, ...) { + standardGeneric("panelFilterParam") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("setPanelFilterArgs", function(x, value, ...) { - standardGeneric("setPanelFilterArgs") +setGeneric("panelFilterParam<-", function(x, ..., value) { + standardGeneric("panelFilterParam<-") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("getAddSusieInf", function(x, ...) { - standardGeneric("getAddSusieInf") +setGeneric("initializeWithSusieInf", function(x, ...) { + standardGeneric("initializeWithSusieInf") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("setAddSusieInf", function(x, value, ...) { - standardGeneric("setAddSusieInf") +setGeneric("initializeWithSusieInf<-", function(x, ..., value) { + standardGeneric("initializeWithSusieInf<-") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("getFitRetention", function(x, ...) { - standardGeneric("getFitRetention") +setGeneric("fitRetention", function(x, ...) { + standardGeneric("fitRetention") }) #' @rdname GwasFineMappingParam #' @export -setGeneric("setFitRetention", function(x, value, ...) { - standardGeneric("setFitRetention") +setGeneric("fitRetention<-", function(x, ..., value) { + standardGeneric("fitRetention<-") }) diff --git a/R/AnnotationMatrix.R b/R/AnnotationMatrix.R index b27d1870..af272e84 100644 --- a/R/AnnotationMatrix.R +++ b/R/AnnotationMatrix.R @@ -25,7 +25,8 @@ NULL #' \code{rowRanges}, the annotation matrix in the \code{annotations} #' assay, and the per-annotation table in \code{colData}. Subsetting works #' in both directions -- \code{x[i, j]} narrows SNPs and annotations -#' together -- and \code{\link{getBaseline}} / \code{\link{getCandidates}} +#' together -- and \code{\link{baselineAnnotations}} / +#' \code{\link{testedAnnotations}} #' are column subsets rather than reconstructions. #' @importClassesFrom SummarizedExperiment RangedSummarizedExperiment #' @export @@ -89,17 +90,10 @@ setMethod("show", "AnnotationMatrix", function(object) { "Continuous: {sum(meta$type == 'continuous')}\n", .trim = FALSE )) - cat(glue(" Genome build: {getGenome(object)}\n", .trim = FALSE)) -}) - -#' @rdname getGenome -#' @export -setMethod("getGenome", "AnnotationMatrix", function(x) { - build <- discard( - unique(GenomeInfoDb::genome(SummarizedExperiment::rowRanges(x))), - is.na - ) - if (length(build) == 0L) NA_character_ else build[[1L]] + cat(glue( + " Genome build: {GenomeInfoDb::genome(object)}\n", + .trim = FALSE + )) }) # ============================================================================= @@ -202,17 +196,13 @@ 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] +# Callers are methods dispatching on AnnotationMatrix, so the class is +# already guaranteed here -- no assertClass. +.annotTier <- function(x, tier) { + x[, SummarizedExperiment::colData(x)$tier == tier] } -#' @title Get Baseline Annotations -#' @description Extract only baseline-tier annotations from an -#' \code{AnnotationMatrix}. -#' @param annot An \code{AnnotationMatrix} object. -#' @return An \code{AnnotationMatrix} with only baseline annotations. +#' @rdname baselineAnnotations #' @examples #' snpRanges <- GenomicRanges::GRanges( #' "22", IRanges::IRanges((1:10) * 100, width = 1)) @@ -221,17 +211,13 @@ AnnotationMatrix <- function( #' meta <- data.frame(name = paste0("annot", 1:5), tier = "baseline", #' type = "binary") #' am <- AnnotationMatrix(annotations, snpRanges, annotationMeta = meta) -#' getBaseline(am) +#' baselineAnnotations(am) #' @export -getBaseline <- function(annot) { - .annotTier(annot, "baseline") -} +setMethod("baselineAnnotations", "AnnotationMatrix", function(x) { + .annotTier(x, "baseline") +}) -#' @title Get Candidate Annotations -#' @description Extract only candidate-tier annotations from an -#' \code{AnnotationMatrix}. -#' @param annot An \code{AnnotationMatrix} object. -#' @return An \code{AnnotationMatrix} with only candidate annotations. +#' @rdname testedAnnotations #' @examples #' snpRanges <- GenomicRanges::GRanges( #' "22", IRanges::IRanges((1:10) * 100, width = 1)) @@ -240,8 +226,8 @@ getBaseline <- function(annot) { #' meta <- data.frame(name = paste0("annot", 1:5), #' tier = c(rep("baseline", 3), rep("candidate", 2)), type = "binary") #' am <- AnnotationMatrix(annotations, snpRanges, annotationMeta = meta) -#' getCandidates(am) +#' testedAnnotations(am) #' @export -getCandidates <- function(annot) { - .annotTier(annot, "candidate") -} +setMethod("testedAnnotations", "AnnotationMatrix", function(x) { + .annotTier(x, "candidate") +}) diff --git a/R/ColocBoostResult.R b/R/ColocBoostResult.R index 9d7d531a..181c947c 100644 --- a/R/ColocBoostResult.R +++ b/R/ColocBoostResult.R @@ -23,8 +23,8 @@ # # What the two DO share is the LD panel they were computed against and the # projection surface, so both extend ColocResultBase -- which carries the -# ldSketch slot and its accessor -- and both answer getColocPairs() and -# getColocVariants(). +# ldSketch slot and its accessor -- and both answer colocPairs() and +# colocVariants(). # # element the member variants of one CoS # inner mcols per-variant: vcp @@ -44,8 +44,8 @@ NULL #' @title ColocBoost Result #' @description A collection of ColocBoost results, one element per confidence -#' set (CoS). Project it with \code{\link{getColocPairs}}, -#' \code{\link{getColocVariants}} or \code{\link{getColocBoostOutcomes}}. +#' set (CoS). Project it with \code{\link{colocPairs}}, +#' \code{\link{colocVariants}} or \code{\link{colocBoostOutcomes}}. #' @slot outcomeInfo A data frame mapping each outcome \code{name} to its #' \code{study}, \code{context}, \code{trait} and \code{dataForm}. ColocBoost #' is given outcome names as bare labels, and those labels are lossy -- a @@ -220,7 +220,7 @@ setMethod("show", "ColocBoostResult", function(object) { #' # Its unit is a SET of colocalized outcomes rather than a pair, so one row #' # can carry any number of them. #' colocboostResultExample$outcomes -#' getColocPairs(colocboostResultExample)$nOutcomes +#' colocPairs(colocboostResultExample)$nOutcomes #' # A run that failed or was not requested arrives as NULL and is skipped, #' # giving an empty result rather than an error. #' nrow(ColocBoostResult(list(NULL), "xqtl_coloc")) @@ -405,7 +405,7 @@ ColocBoostResult <- function( # -- silently yields NA. # # min_abs_cor is used because that is what `minAbsCorr` means everywhere else -# in the package (fineMappingPipeline, getColocCredibleSets). +# in the package (fineMappingPipeline, colocCredibleSets). # @noRd .cbrPurity <- function(purity, id) { m <- purity$min_abs_cor @@ -553,7 +553,7 @@ ColocBoostResult <- function( #' @rdname colocViews #' @export -setMethod("getColocPairs", "ColocBoostResult", function(x) { +setMethod("colocPairs", "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) @@ -575,7 +575,7 @@ setMethod("getColocPairs", "ColocBoostResult", function(x) { #' @rdname colocViews #' @export setMethod( - "getColocVariants", + "colocVariants", "ColocBoostResult", function(x, pooled = FALSE) { long <- .cbrLongVariants(x) @@ -626,15 +626,15 @@ setMethod( #' \code{trait} and \code{dataForm}. #' @examples #' # See colocboostPipeline(); a ColocBoostResult carries the mapping it needs. -#' methods::existsMethod("getColocBoostOutcomes", "ColocBoostResult") +#' methods::existsMethod("colocBoostOutcomes", "ColocBoostResult") #' @export -setGeneric("getColocBoostOutcomes", function(x, ...) { - standardGeneric("getColocBoostOutcomes") +setGeneric("colocBoostOutcomes", function(x, ...) { + standardGeneric("colocBoostOutcomes") }) -#' @rdname getColocBoostOutcomes +#' @rdname colocBoostOutcomes #' @export -setMethod("getColocBoostOutcomes", "ColocBoostResult", function(x) { +setMethod("colocBoostOutcomes", "ColocBoostResult", function(x) { if (length(x) == 0L) { return(tibble()) } @@ -665,7 +665,7 @@ setMethod("getColocBoostOutcomes", "ColocBoostResult", function(x) { #' @title Coerce a ColocBoostResult to a data frame #' @description Returns the set-level view. New code should call the view it #' wants (\code{\link{colocViews}}, -#' \code{\link{getColocBoostOutcomes}}). +#' \code{\link{colocBoostOutcomes}}). #' @param x A \code{ColocBoostResult}. #' @param row.names,optional Ignored; present for generic compatibility. #' @param ... Ignored. @@ -677,7 +677,7 @@ setMethod( "as.data.frame", "ColocBoostResult", function(x, row.names = NULL, optional = FALSE, ...) { - as.data.frame(getColocPairs(x)) + as.data.frame(colocPairs(x)) } ) @@ -688,31 +688,31 @@ setMethod( #' @param ... Ignored. #' @return A list of timings, empty when none were recorded. #' @examples -#' methods::existsMethod("getComputingTime", "ColocBoostResult") +#' methods::existsMethod("computingTime", "ColocBoostResult") #' @export -setGeneric("getComputingTime", function(x, ...) { - standardGeneric("getComputingTime") +setGeneric("computingTime", function(x, ...) { + standardGeneric("computingTime") }) -#' @rdname getComputingTime +#' @rdname computingTime #' @export -setMethod("getComputingTime", "ColocBoostResult", function(x) { +setMethod("computingTime", "ColocBoostResult", function(x) { x@computingTime }) #' @title Region-Wide Variant Colocalization Probabilities #' @description The marginal \code{vcp} for every variant in the analysed #' region, not just the confidence-set members. Distinct from -#' \code{\link{getColocVariants}}, which reports the per-set \code{vcp} of +#' \code{\link{colocVariants}}, which reports the per-set \code{vcp} of #' members only. #' @param x A \code{\linkS4class{ColocBoostResult}}. #' @param ... Ignored. #' @return A \code{GRanges} carrying a \code{vcp} column, or \code{NULL}. #' @examples -#' methods::existsMethod("getRegionVcp", "ColocBoostResult") +#' methods::existsMethod("regionVcp", "ColocBoostResult") #' @export -setGeneric("getRegionVcp", function(x, ...) standardGeneric("getRegionVcp")) +setGeneric("regionVcp", function(x, ...) standardGeneric("regionVcp")) -#' @rdname getRegionVcp +#' @rdname regionVcp #' @export -setMethod("getRegionVcp", "ColocBoostResult", function(x) x@regionVcp) +setMethod("regionVcp", "ColocBoostResult", function(x) x@regionVcp) diff --git a/R/ColocResult.R b/R/ColocResult.R index 878e6730..867e1640 100644 --- a/R/ColocResult.R +++ b/R/ColocResult.R @@ -43,8 +43,8 @@ NULL #' normalized posterior over an arbitrary-sized set of outcomes -- so neither #' can be expressed in the other's schema. What they share is the shape (one #' element per colocalization unit, its variants inside) and therefore the -#' projection surface: both answer \code{\link{getColocPairs}} and -#' \code{\link{getColocVariants}}, so code that only needs "which variants +#' projection surface: both answer \code{\link{colocPairs}} and +#' \code{\link{colocVariants}}, so code that only needs "which variants #' colocalized, and how strongly" works against either. #' @slot ldSketch The LD reference panel the underlying fits were computed #' against, or \code{NULL}. Shared by both subclasses: coloc and ColocBoost @@ -58,17 +58,17 @@ setClass( prototype(ldSketch = NULL) ) -#' @rdname getLdSketch +#' @rdname ldSketch #' @export -setMethod("getLdSketch", "ColocResultBase", function(x) x@ldSketch) +setMethod("ldSketch", "ColocResultBase", function(x) x@ldSketch) #' @title Colocalization Result #' @description A collection of colocalization results, one element per tested #' (QTL credible set, GWAS credible set, block) pair. Build the four views -#' with \code{\link{getColocPairs}}, \code{\link{getColocVariants}}, -#' \code{\link{getColocCredibleSets}} and \code{\link{getColocGenes}}. +#' with \code{\link{colocPairs}}, \code{\link{colocVariants}}, +#' \code{\link{colocCredibleSets}} and \code{\link{colocGenes}}. #' @details The inherited \code{ldSketch} is what -#' \code{getColocCredibleSets()} uses to compute credible-set purity. +#' \code{colocCredibleSets()} uses to compute credible-set purity. #' @seealso \code{\link{colocPipeline}} #' @export setClass("ColocResult", contains = "ColocResultBase") @@ -198,7 +198,7 @@ setMethod("show", "ColocResult", function(object) { #' @param variants A list, parallel to \code{pairs}' rows, of per-pair data #' frames with a \code{variant_id} column and a \code{SNP.PP.H4} column. #' @param ldSketch Optional genotype panel (see \code{\link{readGenotypes}}) -#' for the LD reference, used by \code{\link{getColocCredibleSets}} to +#' for the LD reference, used by \code{\link{colocCredibleSets}} to #' compute purity. #' @return A \code{ColocResult}. #' @examples @@ -331,7 +331,7 @@ ColocResult <- function(pairs, variants, ldSketch = NULL) { #' @rdname colocViews #' @export -setMethod("getColocPairs", "ColocResult", function(x) { +setMethod("colocPairs", "ColocResult", function(x) { md <- mcols(x, use.names = FALSE) if (is.null(md) || length(x) == 0L) { return(tibble()) @@ -341,7 +341,7 @@ setMethod("getColocPairs", "ColocResult", function(x) { #' @rdname colocViews #' @export -setMethod("getColocVariants", "ColocResult", function(x, pooled = FALSE) { +setMethod("colocVariants", "ColocResult", function(x, pooled = FALSE) { long <- .crLongVariants(x) if (!isTRUE(pooled) || nrow(long) == 0L) { return(long) @@ -410,8 +410,8 @@ setMethod("getColocVariants", "ColocResult", function(x, pooled = FALSE) { #' @rdname colocViews #' @export -setMethod("getColocGenes", "ColocResult", function(x) { - pairs <- getColocPairs(x) +setMethod("colocGenes", "ColocResult", function(x) { + pairs <- colocPairs(x) if (nrow(pairs) == 0L) { return(tibble()) } @@ -439,7 +439,7 @@ setMethod("getColocGenes", "ColocResult", function(x) { #' @rdname colocViews #' @export setMethod( - "getColocCredibleSets", + "colocCredibleSets", "ColocResult", function( x, @@ -461,7 +461,7 @@ setMethod( } out <- bind_rows(sets) .crApplyPurityFilter( - mutate(out, purity = .crPuritiesFor(out, getLdSketch(x))), + mutate(out, purity = .crPuritiesFor(out, ldSketch(x))), minAbsCorr ) } @@ -553,7 +553,7 @@ setMethod( .ldFromSketch( ldSketch, ids, - label = "getColocCredibleSets", + label = "colocCredibleSets", onMissing = "drop" ), error = function(cnd) NULL @@ -607,6 +607,6 @@ setMethod( "as.data.frame", "ColocResult", function(x, row.names = NULL, optional = FALSE, ...) { - as.data.frame(getColocPairs(x)) + as.data.frame(colocPairs(x)) } ) diff --git a/R/CtwasResult.R b/R/CtwasResult.R index 9e05eeb1..59bcfdb3 100644 --- a/R/CtwasResult.R +++ b/R/CtwasResult.R @@ -141,7 +141,7 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { #' is one row; a multi-context run emits per-context rows sharing the same #' \code{jointContexts} set and jointly-estimated group priors. #' @param gwasStudy Character vector of GWAS (disease) study identifiers. -#' @param study Character vector of QTL study identifiers. +#' @param studyName Character vector of QTL study identifiers. #' @param context Character vector of context labels (scalar per row). #' @param method Character vector of weight-method names. #' @param entry List / \code{SimpleList} of \code{CtwasResultEntry} objects. @@ -153,15 +153,15 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { #' @return A \code{CtwasResult} object. #' @examples #' cre <- CtwasResultEntry( -#' finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), +#' posteriors = 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))) -#' cr <- CtwasResult(gwasStudy = "gwas1", study = "s1", context = "brain", +#' cr <- CtwasResult(gwasStudy = "gwas1", studyName = "s1", context = "brain", #' method = "susie", entry = list(cre)) #' cr #' @export CtwasResult <- function( gwasStudy, - study, + studyName, context, method, entry, @@ -170,7 +170,7 @@ CtwasResult <- function( ) { n <- length(gwasStudy) if ( - length(study) != n || + length(studyName) != n || length(context) != n || length(method) != n || length(entry) != n @@ -183,7 +183,7 @@ CtwasResult <- function( } cols <- list( gwasStudy = as.character(gwasStudy), - study = as.character(study), + study = as.character(studyName), context = as.character(context), method = as.character(method), entry = S4Vectors::SimpleList(entry) @@ -204,19 +204,19 @@ CtwasResult <- function( obj } -#' @rdname getMethodNames +#' @rdname methodNames #' @export -setMethod("getMethodNames", "CtwasResult", function(x) { +setMethod("methodNames", "CtwasResult", function(x) { unique(as.character(x$method)) }) -#' @rdname getStudy +#' @rdname studyName #' @export -setMethod("getStudy", "CtwasResult", function(x) unique(as.character(x$study))) +setMethod("studyName", "CtwasResult", function(x) unique(as.character(x$study))) -#' @rdname getContexts +#' @rdname contexts #' @export -setMethod("getContexts", "CtwasResult", function(x) { +setMethod("contexts", "CtwasResult", function(x) { unique(as.character(x$context)) }) @@ -237,16 +237,16 @@ setMethod("getContexts", "CtwasResult", function(x) { .rbindAligned(parts) } -#' @rdname getFinemap +#' @rdname ctwasPosteriors #' @export -setMethod("getFinemap", "CtwasResult", function(x) { - .ctwasAggregateRows(x, getFinemap) +setMethod("ctwasPosteriors", "CtwasResult", function(x) { + .ctwasAggregateRows(x, ctwasPosteriors) }) -#' @rdname getSusieAlpha +#' @rdname susieAlpha #' @export -setMethod("getSusieAlpha", "CtwasResult", function(x) { - .ctwasAggregateRows(x, getSusieAlpha) +setMethod("susieAlpha", "CtwasResult", function(x) { + .ctwasAggregateRows(x, susieAlpha) }) #' @rdname show-methods diff --git a/R/CtwasResultEntry.R b/R/CtwasResultEntry.R index 5784a587..f651d7ff 100644 --- a/R/CtwasResultEntry.R +++ b/R/CtwasResultEntry.R @@ -15,7 +15,8 @@ NULL #' full per-effect susie alpha table, the jointly-estimated group prior(s), #' and per-region metadata. One entry sits in every row of a #' \code{\linkS4class{CtwasResult}} collection. -#' @slot finemap The per-gene (and, when SNPs are retained, per-SNP) posterior +#' @slot posteriors The per-gene (and, when SNPs are retained, +#' per-SNP) posterior #' summary table (\code{ctwas::finemap_regions} \code{finemap_res} shape), #' or \code{NULL}. #' @slot susieAlpha The per-effect susie alpha table @@ -31,14 +32,14 @@ NULL setClass( "CtwasResultEntry", representation( - finemap = "ANY", # per-gene/SNP posterior summary (ctwas finemap_res) + posteriors = "ANY", # per-gene/SNP posterior summary (ctwas finemap_res) # per-effect susie alpha table (ctwas susie_alpha_res) susieAlpha = "ANY", groupPriors = "ANY", # group_prior / group_prior_var for this run regionInfo = "ANY" # per-region metadata (optional) ), prototype = prototype( - finemap = NULL, + posteriors = NULL, susieAlpha = NULL, groupPriors = NULL, regionInfo = NULL @@ -50,7 +51,8 @@ setClass( #' the full per-effect susie alpha table, the estimated group prior(s), and #' region metadata. Held in every row of a \code{\link{CtwasResult}} #' collection. -#' @param finemap The per-gene (and, when SNPs are retained, per-SNP) posterior +#' @param posteriors The per-gene (and, when SNPs are retained, +#' per-SNP) posterior #' summary table (\code{ctwas::finemap_regions} \code{finemap_res} shape), or #' \code{NULL}. #' @param susieAlpha The per-effect susie alpha table @@ -63,37 +65,37 @@ setClass( #' @return A \code{CtwasResultEntry} object. #' @examples #' cre <- CtwasResultEntry( -#' finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), +#' posteriors = 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))) #' cre #' @export CtwasResultEntry <- function( - finemap = NULL, + posteriors = NULL, susieAlpha = NULL, groupPriors = NULL, regionInfo = NULL ) { new( "CtwasResultEntry", - finemap = finemap, + posteriors = posteriors, susieAlpha = susieAlpha, groupPriors = groupPriors, regionInfo = regionInfo ) } -#' @rdname getFinemap +#' @rdname ctwasPosteriors #' @export -setMethod("getFinemap", "CtwasResultEntry", function(x) x@finemap) +setMethod("ctwasPosteriors", "CtwasResultEntry", function(x) x@posteriors) -#' @rdname getSusieAlpha +#' @rdname susieAlpha #' @export -setMethod("getSusieAlpha", "CtwasResultEntry", function(x) x@susieAlpha) +setMethod("susieAlpha", "CtwasResultEntry", function(x) x@susieAlpha) -#' @rdname getCtwasGroupPriors +#' @rdname ctwasGroupPriors #' @export setMethod( - "getCtwasGroupPriors", + "ctwasGroupPriors", "CtwasResultEntry", function(x) x@groupPriors ) diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index 229a96df..1b837321 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -298,7 +298,7 @@ GenotypeHandle <- function( # erroring on no-coverage, multi-row spans, or a pre-computed .cor(.xz) matrix. # @noRd .ghResolveLdPath <- function(ldMeta, region) { - ldPaths <- getRegionalLdMeta(ldMeta, region)$intersections$LD_file_paths + ldPaths <- regionalLdMeta(ldMeta, region)$intersections$LD_file_paths if (length(ldPaths) == 0L) { regionStr <- deparse(region) msg <- glue( @@ -427,7 +427,7 @@ GenotypeHandle <- function( #' @importFrom purrr possibly .genotypeChromPaths <- function(handle) { # A handle with no chromosome paths is an ordinary outcome, not a fault. - possibly(getChromPaths, otherwise = character(0))(handle) + possibly(chromPaths, otherwise = character(0))(handle) } # Case-insensitive match of the first of `aliases` present in `cols`; falls @@ -611,8 +611,8 @@ GenotypeHandle <- function( path = .chromMetaPath(genoMeta), format = sharedFormat, snpInfo = unifiedSnpInfo, - nSamples = getNSamples(shards[[1L]]), - sampleIds = getSampleIds(shards[[1L]]), + nSamples = nSamples(shards[[1L]]), + sampleIds = sampleIds(shards[[1L]]), pgenPtr = NULL, chromPaths = .chromMetaPaths(shards) ) @@ -670,8 +670,8 @@ GenotypeHandle <- function( # One shard's chromosome -> path mapping. # @noRd .chromShardPaths <- function(shard) { - chroms <- unique(canonChrom(getSnpInfo(shard)$CHR)) - set_names(rep(getPath(shard), length(chroms)), chroms) + chroms <- unique(canonChrom(snpInfo(shard)$CHR)) + set_names(rep(path(shard), length(chroms)), chroms) } # A chromosome may only come from one file; two shards claiming it means the @@ -707,21 +707,49 @@ GenotypeHandle <- function( if (.isChromMetaFile(genoMeta)) normalizePath(genoMeta) else "" } -#' @rdname getSnpInfo +#' @rdname snpInfo #' @keywords internal -setMethod("getSnpInfo", "GenotypeHandle", function(x) x@snpInfo) +setMethod("snpInfo", "GenotypeHandle", function(x) x@snpInfo) -#' @rdname getFormat +#' @rdname genotypeFormat #' @keywords internal -setMethod("getFormat", "GenotypeHandle", function(x) x@format) +setMethod("genotypeFormat", "GenotypeHandle", function(x) x@format) -#' @rdname getPath -#' @keywords internal -setMethod("getPath", "GenotypeHandle", function(x) x@path) +# Adopts BiocGenerics' `path` generic rather than defining a pecotmr one: +# a file-backed handle is exactly what that generic is for. Deliberately not +# exported -- GenotypeHandle is internal, so only package code dispatches +# here. The generic's first formal is `object`, not `x`. +#' @importFrom BiocGenerics path +#' @noRd +setMethod("path", "GenotypeHandle", function(object, ...) object@path) -#' @rdname getChromPaths +#' @rdname chromPaths #' @keywords internal -setMethod("getChromPaths", "GenotypeHandle", function(x) x@chromPaths) +setMethod("chromPaths", "GenotypeHandle", function(x) x@chromPaths) + +# A stem-based genotype format is named by a companion file rather than by +# the stem itself: plink1 writes .bed, plink2 writes .pgen. +# Returns the stem when one of those is bundled, NULL otherwise -- a +# single-file format (a .gds) is the stem, and the caller handles that. +# +# plink2 was missing here, so a .pgen panel could not be referenced +# portably at all and had to bake an absolute build-machine path. +# @noRd +.resolveBundledStem <- function(stem) { + exts <- c(".bed", ".pgen") + paths <- map_chr(exts, .bundledExtdataPath, stem = stem) + hit <- which(str_length(paths) > 0L) + if (length(hit) == 0L) { + return(NULL) + } + first <- hit[[1L]] + str_remove(paths[[first]], str_c("\\", exts[[first]], "$")) +} + +# @noRd +.bundledExtdataPath <- function(ext, stem) { + system.file("extdata", str_c(stem, ext), package = "pecotmr") +} # Resolve a portable bundled-resource reference of the form # "pecotmr://extdata/" to a concrete filesystem path via @@ -738,9 +766,9 @@ setMethod("getChromPaths", "GenotypeHandle", function(x) x@chromPaths) return(path) } stem <- m[[2L]] - bed <- system.file("extdata", str_c(stem, ".bed"), package = "pecotmr") - if (str_length(bed) > 0L) { - return(str_remove(bed, "\\.bed$")) + byStem <- .resolveBundledStem(stem) + if (!is.null(byStem)) { + return(byStem) } resolved <- system.file("extdata", stem, package = "pecotmr") if (str_length(resolved) == 0L) { @@ -755,23 +783,25 @@ setMethod("getChromPaths", "GenotypeHandle", function(x) x@chromPaths) # The concrete filesystem path/stem to open for a handle's data. Resolves a # bundled-resource reference; ordinary paths pass through. Used by the block -# extractors and LD-panel keying, so `getPath()` keeps returning the stored +# extractors and LD-panel keying, so `path()` keeps returning the stored # (portable) value for display/provenance while file access resolves it. .genotypeReadPath <- function(handle) { - .resolveGenotypeResourcePath(getPath(handle)) + .resolveGenotypeResourcePath(path(handle)) } -#' @rdname getSampleIds +#' @rdname sampleIds #' @keywords internal -setMethod("getSampleIds", "GenotypeHandle", function(x) x@sampleIds) +setMethod("sampleIds", "GenotypeHandle", function(x) x@sampleIds) -#' @rdname getPgenPtr +#' @rdname pgenPtr #' @keywords internal -setMethod("getPgenPtr", "GenotypeHandle", function(x) x@pgenPtr) +setMethod("pgenPtr", "GenotypeHandle", function(x) x@pgenPtr) -#' @rdname getNSamples -#' @keywords internal -setMethod("getNSamples", "GenotypeHandle", function(x) x@nSamples) +# Shares the public `nSamples` page: the generic's @details already records +# that the handle is the seed layer behind a panel, and a @keywords internal +# here would mark that whole merged page internal. +#' @rdname nSamples +setMethod("nSamples", "GenotypeHandle", function(x) x@nSamples) # ---- map/apply helpers (lambda-free callbacks) --------------------------- @@ -794,13 +824,13 @@ setMethod("getNSamples", "GenotypeHandle", function(x) x@nSamples) # The snpInfo slot of one genotype shard. # @noRd .ghSnpInfo <- function(h) { - getSnpInfo(h) + snpInfo(h) } # The format slot of one genotype shard. # @noRd .ghFormat <- function(h) { - getFormat(h) + genotypeFormat(h) } @@ -818,7 +848,7 @@ setMethod("getNSamples", "GenotypeHandle", function(x) x@nSamples) # features x samples, and `assay(se, "dosage")` is already variants x samples. # The seed therefore reports variants as rows. Getting this backwards returns a # plausible-looking matrix and a silently transposed LD matrix, so the tests -# pin it against getGenotypes(). +# pin it against genotypes(). # ============================================================================= #' DelayedArray seed over a GenotypeHandle @@ -844,9 +874,9 @@ setMethod("dimnames", "GhSeed", function(x) { # The sample axis is derived from the handle, not stored a second time. # handle@sampleIds is the single copy; storing dn[[2]] as well would # duplicate ~10k anonymous projection-dimension names in every serialised - # sketch (see genotypeDelayedArray()). getSampleIds() is character(0) on an + # sketch (see genotypeDelayedArray()). sampleIds() is character(0) on an # emptied handle, so this stays consistent with dm = c(nVar, 0). - list(x@dn[[1L]], as.character(getSampleIds(x@handle))) + list(x@dn[[1L]], as.character(sampleIds(x@handle))) }) # The handle a seed reads through. Internal accessor: GhSeed is not exported, @@ -883,7 +913,7 @@ setMethod("extract_array", "GhSeed", function(x, index) { #' an operation actually touches are fetched. #' #' The result is \strong{variants x samples}, the Bioconductor assay -#' orientation, which is the transpose of what \code{\link{getGenotypes}} +#' orientation, which is the transpose of what \code{\link{genotypes}} #' returns. #' #' @param handle A \code{\link{GenotypeHandle}}. @@ -896,11 +926,11 @@ genotypeDelayedArray <- function(handle) { ) abort(msg) } - si <- getSnpInfo(handle) + si <- snpInfo(handle) seed <- methods::new( "GhSeed", handle = handle, - dm = c(nrow(si), as.integer(getNSamples(handle))), + dm = c(nrow(si), as.integer(nSamples(handle))), # Only the variant axis is stored; the sample axis is derived from the # handle in the dimnames() method above, so the ~10k sample ids are not # duplicated between dn[[2]] and handle@sampleIds. diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index 22ed1e54..d072008c 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -118,7 +118,7 @@ setClass( #' own range, which is derived from the variants rather than stored, so it #' cannot drift out of step with them and stays correct after #' \code{\link{subsetRegion}}. -#' @param study Character vector of study identifiers (per tuple). +#' @param studyName Character vector of study identifiers (per tuple). #' @param method Character vector of fine-mapping method names (per tuple). #' @param entry List / \code{SimpleList} of \code{FineMappingRow} objects. #' @param blockId Optional character vector (per tuple) keying the external LD @@ -137,27 +137,27 @@ setClass( #' pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) #' fe <- fineMappingRow( #' variantIds = tl$variant_id, susieFit = list(), topLoci = tl) -#' GwasFineMappingResult(study = "t1", method = "susie", entry = list(fe)) +#' GwasFineMappingResult(studyName = "t1", method = "susie", entry = list(fe)) #' @export GwasFineMappingResult <- function( - study, + studyName, method, entry, blockId = NULL, traitPos = NULL, ldSketch = NULL ) { - n <- length(study) + n <- length(studyName) if (length(method) != n || length(entry) != n) { abort("`study`, `method`, and `entry` must all have the same length.") } entry <- map(entry, .asFmRowPayload) .checkRowPayloads(entry, "FineMappingRow", "fine-mapping") cols <- list( - study = as.character(study), + study = as.character(studyName), method = as.character(method), - susieFit = S4Vectors::SimpleList(map(entry, getSusieFit)), - cvResult = S4Vectors::SimpleList(map(entry, getCvResult)) + susieFit = S4Vectors::SimpleList(map(entry, susieFit)), + cvResult = S4Vectors::SimpleList(map(entry, cvResult)) ) |> .appendBlockIdCol(blockId, n) |> .appendTraitPosCol(traitPos, n) @@ -165,7 +165,7 @@ GwasFineMappingResult <- function( # 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)) + split <- .rtlSplitBySeqname(map(entry, variants)) md <- exec(S4Vectors::DataFrame, !!!dfArgs) grl <- S4Vectors::`mcols<-`( GenomicRanges::GRangesList(split$entry), @@ -188,38 +188,38 @@ GwasFineMappingResult <- function( # GwasFineMappingResult has no context / trait columns; the generic # returns NULL so callers can write generic code that handles either # class without conditionals. -#' @rdname getContexts +#' @rdname contexts #' @export -setMethod("getContexts", "GwasFineMappingResult", function(x) NULL) +setMethod("contexts", "GwasFineMappingResult", function(x) NULL) -#' @rdname getTraits +#' @rdname traitNames #' @export -setMethod("getTraits", "GwasFineMappingResult", function(x) NULL) +setMethod("traitNames", "GwasFineMappingResult", function(x) NULL) # Per-tuple lookup keyed by (study, method, blockId). The generic # 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 +# sumStats(GwasSumStats) does. `region` is the per-block disambiguator # for multi-block genome-wide collections. -#' @rdname getFineMappingResult +#' @rdname fineMappingResult #' @export setMethod( - "getFineMappingResult", + "fineMappingResult", "GwasFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { + function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { .gwasFmrRefuseQtlSelectors(context, trait) - x[.tupleSelectRowGwasFmr(x, study, method)] + x[.tupleSelectRowGwasFmr(x, studyName, method)] } ) -#' @rdname getPip +#' @rdname pip #' @export setMethod( - "getPip", + "pip", "GwasFineMappingResult", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -227,7 +227,7 @@ setMethod( returnList = FALSE ) { .gwasFmrRefuseQtlSelectors(context, trait) - idx <- .tupleSelectRowGwasFmr(x, study, method, region) + idx <- .tupleSelectRowGwasFmr(x, studyName, method, region) pip <- .fmrRowPip(.fmrRowParts(x, idx)) if (!isTRUE(returnList)) { return(pip) @@ -273,15 +273,15 @@ setMethod( !is.null(v) && !all(is.na(v)) } -# Row selector for the base delegating accessors (getCs / getTopLoci / -# getMarginalEffects / getSusieFit / getVariantIds live on +# Row selector for the base delegating accessors (credibleSets / topLoci / +# marginalEffects / susieFit / variantIds live on # FineMappingResultBase, AllClasses.R). The Gwas selector threads `region`. setMethod( ".fmrSelectEntry", "GwasFineMappingResult", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -292,7 +292,7 @@ setMethod( # 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)) + .fmrRowParts(x, .tupleSelectRowGwasFmr(x, studyName, method, region)) } ) diff --git a/R/H2Estimate.R b/R/H2Estimate.R index 8ea3e5ee..10438284 100644 --- a/R/H2Estimate.R +++ b/R/H2Estimate.R @@ -11,19 +11,30 @@ #' @title Heritability Estimate #' @description Container for univariate heritability estimation results. Holds #' global, local, and annotation-stratified estimates. -#' @slot h2 Numeric, global SNP heritability estimate. -#' @slot h2Se Numeric, standard error of global h2. +#' @slot estimate Numeric, global SNP heritability estimate. +#' @slot estimateSe Numeric, standard error of global h2. #' @slot intercept Numeric, confounding intercept estimate (NA if method does #' not estimate one). #' @slot interceptSe Numeric, SE of intercept. -#' @slot local A \code{data.frame} with per-block local heritability estimates +#' @slot localBlocks A \code{data.frame} with per-block local +#' heritability estimates #' (columns: \code{blockId}, \code{h2Local}, \code{h2LocalSe}). NULL if #' \code{local = FALSE}. -#' @slot enrichment A \code{data.frame} with baseline annotation enrichment -#' estimates (columns: \code{annotation}, \code{tau}, \code{tauSe}, -#' \code{enrichment}, \code{enrichmentSe}, \code{enrichmentP}, \code{propH2}, -#' \code{propSnps}). NULL if unstratified. -#' @slot tauBlocks A numeric matrix (nBlocks x n_annotations) of per-block +#' @slot enrichment A \code{data.frame} of per-annotation enrichment results, +#' NULL if unstratified. Two shapes are possible, depending on which route +#' produced the estimate: +#' \describe{ +#' \item{partitioned}{tau-based enrichment of the baseline annotations +#' (\code{computeBaselineEnrichment}, \code{.gldscEnrichmentDf}), with +#' columns \code{annotation}, \code{tau}, \code{tauSe}, +#' \code{enrichment}, \code{enrichmentSe}, \code{enrichmentP}, +#' \code{propH2}, \code{propSnps}.} +#' \item{score test}{the score test over the tested (candidate) +#' annotations, with columns \code{annotation}, \code{scoreZ}, +#' \code{scoreP}.} +#' } +#' @slot annotationJackknifeCoefs A numeric matrix +#' (nBlocks x n_annotations) of per-block #' jackknife tau values. Required for Gazal tauStar standardization #' downstream. NULL if not available (e.g., unstratified analysis). #' @slot scoreStats A list with score statistics for candidate annotations, @@ -41,13 +52,13 @@ setClass( "H2Estimate", representation( - h2 = "numeric", - h2Se = "numeric", + estimate = "numeric", + estimateSe = "numeric", intercept = "numeric", interceptSe = "numeric", - local = "ANY", # data.frame or NULL + localBlocks = "ANY", # data.frame or NULL enrichment = "ANY", # data.frame or NULL - tauBlocks = "ANY", # matrix or NULL + annotationJackknifeCoefs = "ANY", # matrix or NULL scoreStats = "ANY", # list or NULL method = "character", nSnps = "integer", @@ -60,53 +71,55 @@ setClass( # Accessors # ============================================================================= -#' @rdname getH2 +#' @rdname heritabilityEstimate #' @export -setMethod("getH2", "H2Estimate", function(x) x@h2) +setMethod("heritabilityEstimate", "H2Estimate", function(x) x@estimate) -#' @rdname getH2Se +#' @rdname heritabilityEstimateSe #' @export -setMethod("getH2Se", "H2Estimate", function(x) x@h2Se) +setMethod("heritabilityEstimateSe", "H2Estimate", function(x) x@estimateSe) -#' @rdname getIntercept +#' @rdname heritabilityIntercept #' @export -setMethod("getIntercept", "H2Estimate", function(x) x@intercept) +setMethod("heritabilityIntercept", "H2Estimate", function(x) x@intercept) -#' @rdname getInterceptSe +#' @rdname heritabilityInterceptSe #' @export -setMethod("getInterceptSe", "H2Estimate", function(x) x@interceptSe) +setMethod("heritabilityInterceptSe", "H2Estimate", function(x) x@interceptSe) -#' @rdname getNSnps +#' @rdname nSnps #' @export -setMethod("getNSnps", "H2Estimate", function(x) x@nSnps) +setMethod("nSnps", "H2Estimate", function(x) x@nSnps) -#' @rdname getTraitName +#' @rdname traitNames #' @export -setMethod("getTraitName", "H2Estimate", function(x) x@traitName) +setMethod("traitNames", "H2Estimate", function(x) x@traitName) -#' @rdname getMethodNames +#' @rdname methodNames #' @export -setMethod("getMethodNames", "H2Estimate", function(x) x@method) +setMethod("methodNames", "H2Estimate", function(x) x@method) -#' @rdname getTauBlocks +#' @rdname annotationJackknifeCoefs #' @export -setMethod("getTauBlocks", "H2Estimate", function(x) x@tauBlocks) +setMethod("annotationJackknifeCoefs", "H2Estimate", function(x) { + x@annotationJackknifeCoefs +}) -#' @rdname getLocal +#' @rdname localH2Blocks #' @export -setMethod("getLocal", "H2Estimate", function(object) { - object@local +setMethod("localH2Blocks", "H2Estimate", function(object) { + object@localBlocks }) -#' @rdname getEnrichment +#' @rdname stratifiedHeritabilityEnrichment #' @export -setMethod("getEnrichment", "H2Estimate", function(object) { +setMethod("stratifiedHeritabilityEnrichment", "H2Estimate", function(object) { object@enrichment }) -#' @rdname getScoreStats +#' @rdname scoreStats #' @export -setMethod("getScoreStats", "H2Estimate", function(object) { +setMethod("scoreStats", "H2Estimate", function(object) { object@scoreStats }) @@ -123,7 +136,11 @@ setMethod("show", "H2Estimate", function(object) { "(method: {object@method})\n", .trim = FALSE )) - cat(sprintf(" h2 = %.4f (SE = %.4f)\n", object@h2, object@h2Se)) + cat(sprintf( + " h2 = %.4f (SE = %.4f)\n", + object@estimate, + object@estimateSe + )) if (!is.na(object@intercept)) { cat(sprintf( " intercept = %.4f (SE = %.4f)\n", @@ -131,12 +148,12 @@ setMethod("show", "H2Estimate", function(object) { object@interceptSe )) } - has_local <- !is.null(object@local) + has_local <- !is.null(object@localBlocks) has_enrich <- !is.null(object@enrichment) - has_tau_blocks <- !is.null(object@tauBlocks) + has_tau_blocks <- !is.null(object@annotationJackknifeCoefs) cat(glue( " Local: {has_local}, Enrichment: {has_enrich}, ", - "tauBlocks: {has_tau_blocks}\n", + "annotationJackknifeCoefs: {has_tau_blocks}\n", .trim = FALSE )) cat(glue(" N SNPs: {object@nSnps}\n", .trim = FALSE)) diff --git a/R/LdData.R b/R/LdData.R index 43ebc31a..07a119ff 100644 --- a/R/LdData.R +++ b/R/LdData.R @@ -41,13 +41,13 @@ NULL #' 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 nSamples Integer, reference panel sample size. #' @slot mixtureWeights NULL when \code{genotypeHandle} is a single #' \code{GenotypeHandle}; a numeric vector of mixing proportions (one per #' panel, summing to 1) when \code{genotypeHandle} is a list of -#' \code{GenotypeHandle}s. Used by \code{getCorrelation()} to compute a +#' \code{GenotypeHandle}s. Used by \code{ldMatrix()} to compute a #' weighted-average mixture LD matrix; required whenever \code{genotypeHandle} -#' is a list and \code{getCorrelation()} will be called. +#' is a list and \code{ldMatrix()} will be called. #' @export setClass( "LdData", @@ -57,7 +57,7 @@ setClass( genotypeHandle = "LdGenotypeSource", snpIdx = "LdSnpIndex", blockMetadata = "GRanges", - nRef = "integer", + nSamples = "integer", mixtureWeights = "LdMixtureWeights" ), validity = function(object) { @@ -140,7 +140,7 @@ setMethod("show", "LdData", function(object) { "Genotype handle: {if (has_geno) 'available' else 'NULL'}\n", .trim = FALSE )) - cat(glue(" Reference N: {object@nRef}\n", .trim = FALSE)) + cat(glue(" Reference N: {object@nSamples}\n", .trim = FALSE)) }) # One element of a mixture list: unwrap a panel, pass anything else through @@ -464,11 +464,11 @@ setMethod("show", "LdData", function(object) { #' -- 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 nSamples 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 #' sum to 1. Required whenever \code{genotypeHandle} is a list and downstream -#' code will call \code{getCorrelation()}. +#' code will call \code{ldMatrix()}. #' @return An \code{LdData} object. #' @examples #' data(eqtlRegionExample) @@ -488,7 +488,7 @@ LdData <- function( snpIdx = NULL, variants, blockMetadata, - nRef = 0L, + nSamples = 0L, mixtureWeights = NULL ) { # correlation is documented as a matrix OR a list of matrices OR NULL, @@ -507,7 +507,7 @@ LdData <- function( genotypeHandle = .ldDataGenotypeSource(genotypeHandle), snpIdx = if (is.null(snpIdx)) NULL else as.integer(snpIdx), blockMetadata = .ldBlockMetadata(blockMetadata, variants), - nRef = as.integer(nRef), + nSamples = as.integer(nSamples), mixtureWeights = mixtureWeights ) validObject(obj) @@ -550,9 +550,9 @@ LdData <- function( w * panel } -#' @rdname getCorrelation +#' @rdname ldMatrix #' @export -setMethod("getCorrelation", "LdData", function(x) { +setMethod("ldMatrix", "LdData", function(x) { if (!is.null(x@correlation)) { return(x@correlation) } @@ -592,9 +592,9 @@ setMethod("getCorrelation", "LdData", function(x) { computeLd(.ldSourceDosages(x@genotypeHandle, x@snpIdx), method = "sample") }) -#' @rdname getGenotypes +#' @rdname genotypes #' @export -setMethod("getGenotypes", "LdData", function(x) { +setMethod("genotypes", "LdData", function(x) { if (is.null(x@genotypeHandle)) { return(NULL) } @@ -609,32 +609,32 @@ setMethod("getGenotypes", "LdData", function(x) { #' @rdname hasGenotypes #' @export setMethod("hasGenotypes", "LdData", function(x) { - !is.null(getGenotypeHandle(x)) + !is.null(genotypeHandle(x)) }) -#' @rdname getVariantIds +#' @rdname variantIds #' @export -setMethod("getVariantIds", "LdData", function(x) { +setMethod("variantIds", "LdData", function(x) { mcols(x)$variant_id }) -#' @rdname getVariantInfo +#' @rdname variantInfo #' @export -setMethod("getVariantInfo", "LdData", function(x) { +setMethod("variantInfo", "LdData", function(x) { # A plain GRanges view: callers subset and re-wrap it, and carrying the # LD payload along would make those copies quietly expensive. as(x, "GRanges") }) -#' @rdname getBlockMetadata +#' @rdname blockMetadata #' @export -setMethod("getBlockMetadata", "LdData", function(x) { +setMethod("blockMetadata", "LdData", function(x) { x@blockMetadata }) -#' @rdname getRefPanel +#' @rdname refPanel #' @export -setMethod("getRefPanel", "LdData", function(x) { +setMethod("refPanel", "LdData", function(x) { mutate( as_tibble(as.data.frame(mcols(x))), chrom = as.character(seqnames(x)), @@ -642,21 +642,21 @@ setMethod("getRefPanel", "LdData", function(x) { ) }) -#' @rdname getGenotypeHandle +#' @rdname genotypeHandle #' @keywords internal -setMethod("getGenotypeHandle", "LdData", function(x) x@genotypeHandle) +setMethod("genotypeHandle", "LdData", function(x) x@genotypeHandle) -#' @rdname getMixtureWeights +#' @rdname mixtureWeights #' @export -setMethod("getMixtureWeights", "LdData", function(x) x@mixtureWeights) +setMethod("mixtureWeights", "LdData", function(x) x@mixtureWeights) -#' @rdname getSnpIdx +#' @rdname snpIdx #' @export -setMethod("getSnpIdx", "LdData", function(x) x@snpIdx) +setMethod("snpIdx", "LdData", function(x) x@snpIdx) -#' @rdname getNRef +#' @rdname ldPanelNSamples #' @export -setMethod("getNRef", "LdData", function(x) x@nRef) +setMethod("ldPanelNSamples", "LdData", function(x) x@nSamples) # ---- map/apply helpers (lambda-free callbacks) --------------------------- diff --git a/R/LdEigen.R b/R/LdEigen.R index 1edb1661..1d37f3e7 100644 --- a/R/LdEigen.R +++ b/R/LdEigen.R @@ -71,7 +71,7 @@ setClass( #' \code{BP}, \code{A1}, \code{A2} (and optionally \code{MAF}). #' @param eigenList A list with one entry per LD block. #' @param ldBlocks A \code{GRanges} of LD block intervals. -#' @param nRef Integer, sample size of the LD reference panel. +#' @param nSamples Integer, sample size of the LD reference panel. #' @param inSample Logical, whether the reference is the GWAS cohort. #' @param genome Character, genome build; recorded in \code{seqinfo()}. #' @param eigenvalueTruncation Numeric in (0, 1]; proportion of variance @@ -86,28 +86,28 @@ setClass( #' vectors = diag(length(idx)), snpIdx = idx) #' le <- LdEigen(snpInfo = snpInfo, #' eigenList = list(mkBlock(1:2), mkBlock(3:4)), -#' ldBlocks = blocks, nRef = 100L, genome = "hg19") +#' ldBlocks = blocks, nSamples = 100L, genome = "hg19") #' length(le) -#' length(getEigenList(le)) +#' length(eigenList(le)) #' @importFrom checkmate assertDataFrame assertList assertCount #' @export LdEigen <- function( snpInfo, eigenList, ldBlocks, - nRef, + nSamples, inSample = FALSE, genome = NA_character_, eigenvalueTruncation = 1 ) { assertDataFrame(snpInfo) assertList(eigenList) - assertCount(nRef, positive = TRUE) + assertCount(nSamples, positive = TRUE) obj <- methods::new( "LdEigen", .ldStatRanges(snpInfo, genome), ldBlocks = .asLdBlockRanges(ldBlocks), - nRef = as.integer(nRef), + nSamples = as.integer(nSamples), inSample = isTRUE(inSample), eigenList = eigenList, eigenvalueTruncation = as.numeric(eigenvalueTruncation) @@ -138,7 +138,7 @@ LdEigen <- function( #' standard error from a delete-one-block jackknife, so it requires at #' least two blocks and wants many more. Loading a whole region as one #' dense matrix yields a single block. -#' @param nRef Integer, the LD reference panel sample size. Defaults to the +#' @param nSamples Integer, the LD reference panel sample size. Defaults to the #' size recorded by the supplied \code{LdData}; required when they record #' none, and an error when they disagree. #' @param inSample Logical, whether the reference is the GWAS cohort itself. @@ -158,18 +158,18 @@ LdEigen <- function( #' ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") #' ldEigen <- buildLdEigen(ld, genome = "hg38") #' ldEigen -#' length(getEigenList(ldEigen)) +#' length(eigenList(ldEigen)) #' @export buildLdEigen <- function( ldBlockData, - nRef = NULL, + nSamples = NULL, inSample = FALSE, genome = NA_character_, eigenvalueTruncation = 1 ) { - assertCount(nRef, positive = TRUE, null.ok = TRUE) + assertCount(nSamples, positive = TRUE, null.ok = TRUE) assertFlag(inSample) - prep <- .ldRefPrepare(ldBlockData, nRef, genome) + prep <- .ldRefPrepare(ldBlockData, nSamples, genome) eigenList <- map2( prep$blocks, prep$snpIdx, @@ -180,7 +180,7 @@ buildLdEigen <- function( snpInfo = prep$snpInfo, eigenList = eigenList, ldBlocks = prep$ldBlocks, - nRef = prep$nRef, + nSamples = prep$nRef, inSample = inSample, genome = prep$genome, eigenvalueTruncation = eigenvalueTruncation @@ -243,11 +243,11 @@ setMethod("show", "LdEigen", function(object) { )) cat(sprintf(" Eigenvalue truncation: %.2f\n", object@eigenvalueTruncation)) cat(glue( - " Reference N: {object@nRef}, In-sample: {object@inSample}\n", + " Reference N: {object@nSamples}, In-sample: {object@inSample}\n", .trim = FALSE )) }) -#' @rdname getEigenList +#' @rdname eigenList #' @export -setMethod("getEigenList", "LdEigen", function(x) x@eigenList) +setMethod("eigenList", "LdEigen", function(x) x@eigenList) diff --git a/R/LdScore.R b/R/LdScore.R index 1c1a7c09..80223afc 100644 --- a/R/LdScore.R +++ b/R/LdScore.R @@ -54,7 +54,7 @@ setClass( #' annotation-stratified scores. #' @param ldScoreWeights Numeric regression weights, one per variant. #' @param ldBlocks A \code{GRanges} of LD block intervals. -#' @param nRef Integer, sample size of the LD reference panel. +#' @param nSamples Integer, sample size of the LD reference panel. #' @param inSample Logical, whether the reference is the GWAS cohort. #' @param genome Character, genome build; recorded in \code{seqinfo()}. #' @param ldMatrixList Optional list of per-block LD matrices (g-LDSC only). @@ -66,10 +66,10 @@ setClass( #' IRanges::IRanges(c(1L, 200L), c(199L, 400L))) #' ls <- LdScore(snpInfo = snpInfo, #' ldScores = matrix(runif(4), ncol = 1, dimnames = list(NULL, "base_l2")), -#' ldScoreWeights = rep(1, 4), ldBlocks = blocks, nRef = 100L, +#' ldScoreWeights = rep(1, 4), ldBlocks = blocks, nSamples = 100L, #' inSample = FALSE, genome = "hg19") #' length(ls) -#' head(getLdScores(ls)) +#' head(S4Vectors::mcols(ls)$ldScores) #' @importFrom checkmate assertMatrix assertNumeric #' @export LdScore <- function( @@ -77,7 +77,7 @@ LdScore <- function( ldScores, ldScoreWeights, ldBlocks, - nRef, + nSamples, inSample = FALSE, genome = NA_character_, ldMatrixList = list() @@ -100,7 +100,7 @@ LdScore <- function( "LdScore", scored, ldBlocks = .asLdBlockRanges(ldBlocks), - nRef = as.integer(nRef), + nSamples = as.integer(nSamples), inSample = isTRUE(inSample), ldMatrixList = ldMatrixList ) @@ -133,7 +133,7 @@ LdScore <- function( #' standard error from a delete-one-block jackknife, so it requires at #' least two blocks and wants many more. Loading a whole region as one #' dense matrix yields a single block. -#' @param nRef Integer, the LD reference panel sample size. Defaults to the +#' @param nSamples Integer, the LD reference panel sample size. Defaults to the #' size recorded by the supplied \code{LdData}; required when they record #' none, and an error when they disagree. #' @param inSample Logical, whether the reference is the GWAS cohort itself. @@ -155,20 +155,20 @@ LdScore <- function( #' ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") #' ldScore <- buildLdScore(ld, genome = "hg38") #' ldScore -#' head(getLdScores(ldScore)) +#' head(S4Vectors::mcols(ldScore)$ldScores) #' @export buildLdScore <- function( ldBlockData, - nRef = NULL, + nSamples = NULL, inSample = FALSE, genome = NA_character_, ldScoreWeights = NULL, keepLdMatrices = TRUE ) { - assertCount(nRef, positive = TRUE, null.ok = TRUE) + assertCount(nSamples, positive = TRUE, null.ok = TRUE) assertFlag(inSample) assertFlag(keepLdMatrices) - prep <- .ldRefPrepare(ldBlockData, nRef, genome) + prep <- .ldRefPrepare(ldBlockData, nSamples, genome) l2 <- .ldScoreVector(prep$blocks, prep$snpIdx, nrow(prep$snpInfo)) ldMatrixList <- if (isTRUE(keepLdMatrices)) { map2(prep$blocks, prep$snpIdx, .ldScoreKeepMatrix) @@ -180,7 +180,7 @@ buildLdScore <- function( ldScores = matrix(l2, ncol = 1, dimnames = list(NULL, "base_l2")), ldScoreWeights = .ldScoreResolveWeights(ldScoreWeights, l2), ldBlocks = prep$ldBlocks, - nRef = prep$nRef, + nSamples = prep$nRef, inSample = inSample, genome = prep$genome, ldMatrixList = ldMatrixList @@ -227,7 +227,7 @@ buildLdScore <- function( #' @rdname show-methods #' @export setMethod("show", "LdScore", function(object) { - scores <- getLdScores(object) + scores <- mcols(object)$ldScores cat(glue( "LdScore: {length(object)} SNPs, ", "{ncol(scores)} LD score columns\n", @@ -239,23 +239,11 @@ setMethod("show", "LdScore", function(object) { .trim = FALSE )) cat(glue( - " Reference N: {object@nRef}, In-sample: {object@inSample}\n", + " Reference N: {object@nSamples}, In-sample: {object@inSample}\n", .trim = FALSE )) }) -#' @rdname getLdScores +#' @rdname ldMatrixList #' @export -setMethod("getLdScores", "LdScore", function(x) { - S4Vectors::mcols(x, use.names = FALSE)$ldScores -}) - -#' @rdname getLdScoreWeights -#' @export -setMethod("getLdScoreWeights", "LdScore", function(x) { - S4Vectors::mcols(x, use.names = FALSE)$ldScoreWeights -}) - -#' @rdname getLdMatrixList -#' @export -setMethod("getLdMatrixList", "LdScore", function(x) x@ldMatrixList) +setMethod("ldMatrixList", "LdScore", function(x) x@ldMatrixList) diff --git a/R/LdStatistic.R b/R/LdStatistic.R index 722c8de4..c324cf17 100644 --- a/R/LdStatistic.R +++ b/R/LdStatistic.R @@ -22,7 +22,7 @@ NULL #' statistics together. The genome build comes from \code{seqinfo()} rather #' than a slot of its own. #' @slot ldBlocks A \code{GRanges} of LD block intervals. -#' @slot nRef Integer, sample size of the LD reference panel. +#' @slot nSamples Integer, sample size of the LD reference panel. #' @slot inSample Logical, whether the LD reference is from the same cohort as #' the GWAS (affects bias correction). #' @export @@ -31,7 +31,7 @@ setClass( contains = c("VIRTUAL", "GRanges"), representation( ldBlocks = "GRanges", - nRef = "integer", + nSamples = "integer", inSample = "logical" ), validity = function(object) .validateLdStatistic(object) @@ -41,7 +41,12 @@ setClass( #' @importFrom checkmate makeAssertCollection assertCount assertLogical .validateLdStatistic <- function(object) { coll <- makeAssertCollection() - assertCount(object@nRef, positive = TRUE, .var.name = "nRef", add = coll) + assertCount( + object@nSamples, + positive = TRUE, + .var.name = "nSamples", + 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) @@ -105,7 +110,7 @@ setClass( # Shared front half of buildLdEigen()/buildLdScore(): validate the input, # split it into blocks, and resolve what the LdStatistic base needs. # @noRd -.ldRefPrepare <- function(ldBlockData, nRef, genome) { +.ldRefPrepare <- function(ldBlockData, nSamples, genome) { dataList <- .ldRefAsDataList(ldBlockData) blocks <- list_flatten(map(dataList, .ldRefBlocksOf)) resolvedGenome <- .ldRefResolveGenome(dataList, genome) @@ -114,7 +119,7 @@ setClass( snpInfo = .ldRefSnpInfo(blocks), snpIdx = .ldRefSnpIdx(blocks), ldBlocks = .ldRefBlockRanges(blocks, resolvedGenome), - nRef = .ldRefResolveNRef(dataList, nRef), + nRef = .ldRefResolveNRef(dataList, nSamples), genome = resolvedGenome ) } @@ -146,8 +151,8 @@ setClass( # them (block-diagonal LD across a multi-block region). # @noRd .ldRefBlocksOf <- function(x) { - R <- getCorrelation(x) - gr <- getVariantInfo(x) + R <- ldMatrix(x) + gr <- variantInfo(x) if (!is.list(R)) { return(list(.ldRefOneBlock(R, gr))) } @@ -180,7 +185,7 @@ setClass( "LdData carries {nVariants}." )) } - md <- getBlockMetadata(x) + md <- blockMetadata(x) # blockMetadata is a GRanges: the index payload is in mcols. hasIdx <- all(is_in( c("startIdx", "endIdx"), @@ -313,9 +318,9 @@ setClass( # sizes are an error rather than a silent pick: nRef drives HDL's # finite-reference correction, so the wrong one shifts h2. # @noRd -.ldRefResolveNRef <- function(dataList, nRef) { - if (!is.null(nRef)) { - return(as.integer(nRef)) +.ldRefResolveNRef <- function(dataList, nSamples) { + if (!is.null(nSamples)) { + return(as.integer(nSamples)) } found <- discard(unique(map_int(dataList, .ldRefNRefOf)), is.na) if (length(found) == 0L) { @@ -335,7 +340,7 @@ setClass( # @noRd .ldRefNRefOf <- function(x) { - n <- getNRef(x) + n <- ldPanelNSamples(x) if (length(n) == 0L) NA_integer_ else as.integer(n[[1L]]) } @@ -354,23 +359,14 @@ setClass( if (length(g) == 1L) g[[1L]] else NA_character_ } -#' @rdname getNRef -#' @export -setMethod("getNRef", "LdStatistic", function(x) x@nRef) - -#' @rdname getInSample +#' @rdname ldPanelNSamples #' @export -setMethod("getInSample", "LdStatistic", function(x) x@inSample) +setMethod("ldPanelNSamples", "LdStatistic", function(x) x@nSamples) -#' @rdname getLdBlocks +#' @rdname inSample #' @export -setMethod("getLdBlocks", "LdStatistic", function(x) x@ldBlocks) +setMethod("inSample", "LdStatistic", function(x) x@inSample) -#' @rdname getGenome +#' @rdname ldBlocks #' @export -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 <- discard(unique(GenomeInfoDb::genome(x)), is.na) - if (length(build) == 0L) NA_character_ else build[[1L]] -}) +setMethod("ldBlocks", "LdStatistic", function(x) x@ldBlocks) diff --git a/R/MashPrior.R b/R/MashPrior.R index 84254723..878f45e5 100644 --- a/R/MashPrior.R +++ b/R/MashPrior.R @@ -135,13 +135,13 @@ MashPrior <- function(fullFit = NULL, cvFits = NULL) { obj } -#' @rdname getFullFit +#' @rdname fullFit #' @export -setMethod("getFullFit", "MashPrior", function(x) x@fullFit) +setMethod("fullFit", "MashPrior", function(x) x@fullFit) -#' @rdname getCvFits +#' @rdname cvFits #' @export -setMethod("getCvFits", "MashPrior", function(x) x@cvFits) +setMethod("cvFits", "MashPrior", function(x) x@cvFits) #' @rdname show-methods #' @export diff --git a/R/MethodOptions.R b/R/MethodOptions.R index 09b6a63a..44811cd6 100644 --- a/R/MethodOptions.R +++ b/R/MethodOptions.R @@ -124,9 +124,21 @@ setClass("MethodOptions", contains = "SimpleList") return(NULL) } fm <- tryCatch(names(formals(fn)), error = function(cnd) NULL) - if (is.null(fm) || is_in("...", fm)) { + if (is.null(fm)) { return(NULL) } + # `filtered` says the call site already restricts the bundle to the + # callee's explicit formals, so `...` is not a reason to stop checking. + # Honoured for ONE callee as well as several: a single dots-taking step + # (ctwas's finemap_regions) is the same situation as a dots-taking member + # of a set, and leaving it unchecked made the record claim "NOT checked" + # while .engineCheckExtra() was in fact checking it. + if (is_in("...", fm)) { + if (!filtered) { + return(NULL) + } + return(setdiff(fm, "...")) + } fm } @@ -357,7 +369,7 @@ setClass("MethodOptions", contains = "SimpleList") } # Refuse names the caller cannot usefully set, naming where the setting -# lives instead. Same shape as .ctwasRefusePipelineOwned: a real formal of +# lives instead: 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. @@ -593,7 +605,7 @@ setClass("MethodOptions", contains = "SimpleList") if (is.null(fm)) { return("argument names NOT checked: the engine's formals are unknown") } - if (is_in("...", fm)) { + if (is_in("...", fm) && !filtered) { return(glue( "argument names NOT checked: {callee}() takes `...`, ", "so any name is accepted" diff --git a/R/MethodParam.R b/R/MethodParam.R index 4f49d684..e9048d21 100644 --- a/R/MethodParam.R +++ b/R/MethodParam.R @@ -624,6 +624,11 @@ setValidity("MethodsSelectionParam", function(object) { # One slot's own problems: shape, vocabulary, element class, and -- for the # two path slots -- that each record is actually usable on that path. +# +# The first two stages stop on the first problem because the stages are +# ordered: a slot whose names are malformed has nothing to compare against +# the method vocabulary, and a name that is not a method of this pipeline +# cannot be asked whether it is usable on a given input path. # @noRd .methodsSlotProblems <- function(slotName, object, cls) { entries <- slot(object, slotName) @@ -631,32 +636,71 @@ setValidity("MethodsSelectionParam", function(object) { return(character(0)) } nms <- names(entries) + shape <- .methodsSlotShapeProblem(slotName, nms) + if (length(shape) > 0L) { + return(shape) + } + inputKind <- .methodsSlotInput(slotName) + vocabulary <- .methodsSlotVocabularyProblem( + slotName, + nms, + cls, + inputKind + ) + if (length(vocabulary) > 0L) { + return(vocabulary) + } + .methodsSlotEntryProblems(nms, entries, slotName, cls, inputKind) +} + +# Every entry named, exactly once. +# @noRd +.methodsSlotShapeProblem <- function(slotName, nms) { 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" - )) + if (length(dup) == 0L) { + return(character(0)) } - inputKind <- .methodsSlotInput(slotName) + glue( + "`{slotName}`: {str_flatten(dup, ', ')} given more than once; ", + "one set of options per method" + ) +} + +# Every name a method this pipeline runs -- on `inputKind` for a path slot, +# anywhere for the shared one. +# @noRd +.methodsSlotVocabularyProblem <- function(slotName, nms, cls, inputKind) { 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, ', ')}." - )) + if (length(unknown) == 0L) { + return(character(0)) } + 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, ', ')}." + ) +} + +# Each entry's own problems. Unlike the two stages above these are collected +# rather than short-circuited: one bad entry says nothing about the others. +# @noRd +.methodsSlotEntryProblems <- function( + nms, + entries, + slotName, + cls, + inputKind +) { c( unlist(map( nms, @@ -671,36 +715,52 @@ setValidity("MethodsSelectionParam", function(object) { 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 - )) - ) + if (is.null(inputKind)) { + NULL + } else { + .methodsSlotPathProblems(nms, entries, slotName, inputKind, cls) } ) } +# The checks that only mean anything on a path slot: the record has to be +# usable on `inputKind`, name arguments that method accepts, and declare an +# engine that path provides. +# @noRd +.methodsSlotPathProblems <- function( + nms, + entries, + slotName, + inputKind, + cls +) { + 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 diff --git a/R/MultiStudyQtlDataset.R b/R/MultiStudyQtlDataset.R index 342206e8..8136251e 100644 --- a/R/MultiStudyQtlDataset.R +++ b/R/MultiStudyQtlDataset.R @@ -134,7 +134,7 @@ setClass( # Per-dataset trait -> rowRanges map (first occurrence of each trait id). # @noRd .msqdTraitRanges <- function(qd) { - pairs <- .msqdConcat(map(getContexts(qd), .msqdContextTraitRanges, qd = qd)) + pairs <- .msqdConcat(map(contexts(qd), .msqdContextTraitRanges, qd = qd)) if (length(pairs) == 0L) { return(list()) } @@ -161,7 +161,7 @@ setClass( # One context's (trait, range) pairs in row order. # @noRd .msqdContextTraitRanges <- function(ctx, qd) { - se <- getPhenotypes(qd, ctx) + se <- molecularTraits(qd, ctx) map( seq_along(rownames(se)), .msqdTraitRangePair, @@ -239,10 +239,10 @@ setClass( #' rowRanges = rng #' ) #' qd1 <- QtlDataset( -#' study = "s1", genotypes = panel, phenotypes = list(brain = se) +#' studyName = "s1", genotypes = panel, phenotypes = list(brain = se) #' ) #' qd2 <- QtlDataset( -#' study = "s2", genotypes = panel, phenotypes = list(brain = se) +#' studyName = "s2", genotypes = panel, phenotypes = list(brain = se) #' ) #' MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) #' @importFrom checkmate assertList @@ -258,21 +258,21 @@ MultiStudyQtlDataset <- function(qtlDatasets, sumStats = NULL) { obj } -#' @rdname getQtlDatasets +#' @rdname qtlDatasets #' @export -setMethod("getQtlDatasets", "MultiStudyQtlDataset", function(x) x@qtlDatasets) +setMethod("qtlDatasets", "MultiStudyQtlDataset", function(x) x@qtlDatasets) -#' @rdname getSumStats +#' @rdname sumStats #' @export # No selectors: this returns the embedded QtlSumStats collection whole, and -# one entry is fetched by calling getSumStats() on that result. Taking no +# one entry is fetched by calling sumStats() 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) +setMethod("sumStats", "MultiStudyQtlDataset", function(x) x@sumStats) -#' @rdname getStudy +#' @rdname studyName #' @export -setMethod("getStudy", "MultiStudyQtlDataset", function(x) { +setMethod("studyName", "MultiStudyQtlDataset", function(x) { fromQtl <- names(x@qtlDatasets) fromSs <- if (is.null(x@sumStats)) { character(0) diff --git a/R/QtlDataset.R b/R/QtlDataset.R index ab06169b..b2a5edc6 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -5,7 +5,7 @@ # one RangedSummarizedExperiment per QTL context, plus a `genotype` experiment # whose assay reads lazily through a GenotypeHandle. Adds the handle itself and # constructor-level QC knobs (mafCutoff, macCutoff, xvarCutoff, imissCutoff, -# keepVariants, keepIndel), which the getGenotypes / getResidualizedGenotypes +# keepVariants, keepIndel), which the genotypes / residualizedGenotypes # accessors apply at extraction time. The entry point for individual-level # fine-mapping (fineMappingPipeline), TWAS weight learning # (twasWeightsPipeline), and multi-study composition (MultiStudyQtlDataset). @@ -44,7 +44,7 @@ NULL #' it is rarely what you want regardless; anything that materialises a tidy #' view of that experiment reads its dosages. #' -#' @slot study Character (length 1). Study identifier; used in collection +#' @slot studyName Character (length 1). Study identifier; used in collection #' classes to tag downstream \code{FineMappingResult} / \code{TwasWeights} #' entries. #' The \code{genotype} experiment's assay reads through this handle; the @@ -54,7 +54,7 @@ NULL #' scale residuals to unit variance. #' @slot 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 +#' \code{genotypes()} / \code{residualizedGenotypes()}. Default 0 (no #' filter). #' @slot macCutoff Numeric (length 1). Minor allele count threshold; converted #' to a MAF threshold using \code{max(mafCutoff, macCutoff / (2 * n))} where @@ -77,7 +77,7 @@ setClass( "QtlDataset", contains = "MultiAssayExperiment", representation( - study = "character", + studyName = "character", scaleResiduals = "logical", mafCutoff = "numeric", macCutoff = "numeric", @@ -124,7 +124,12 @@ setClass( #' @importFrom purrr walk .qtlValidateScalars <- function(object) { coll <- makeAssertCollection() - assertString(object@study, min.chars = 1L, .var.name = "study", add = coll) + assertString( + object@studyName, + min.chars = 1L, + .var.name = "studyName", + add = coll + ) assertLogical( object@scaleResiduals, len = 1L, @@ -360,7 +365,7 @@ setClass( if (!methods::is(genotypes, "RangedSummarizedExperiment")) { return(invisible(NULL)) } - full <- c(nrow(getSnpInfo(handle)), getNSamples(handle)) + full <- c(nrow(snpInfo(handle)), nSamples(handle)) got <- c(nrow(genotypes), ncol(genotypes)) if (identical(as.integer(got), as.integer(full))) { return(invisible(NULL)) @@ -380,7 +385,7 @@ setClass( #' context experiment. The \code{sampleMap} is derived from the column #' names actually present in each, so contexts observing different sample #' subsets are recorded rather than assumed away. -#' @param study Character (length 1). Study identifier. +#' @param studyName Character (length 1). Study identifier. #' @param genotypes A genotype panel (see \code{\link{readGenotypes}}). #' @param phenotypes Named list of \code{SummarizedExperiment} objects, keyed by #' context. Each SE must have \code{rowRanges} carrying trait positions and @@ -390,11 +395,11 @@ 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 genotypeFilterArgs Which variants and samples to keep, built with +#' @param genotypeFilterParam 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()}: +#' lazily, at extraction time inside \code{genotypes()} / +#' \code{residualizedGenotypes()}: #' \itemize{ #' \item \code{mafCutoff} --- drop variants with #' \code{MAF < mafCutoff}. Unset means 0 (no filter). @@ -431,22 +436,24 @@ setClass( #' )), #' rowRanges = rng #' ) -#' QtlDataset(study = "s1", genotypes = panel, phenotypes = list(brain = se)) +#' QtlDataset( +#' studyName = "s1", genotypes = panel, phenotypes = list(brain = se) +#' ) #' @export QtlDataset <- function( - study, + studyName, genotypes, phenotypes, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0), scaleResiduals = TRUE, - genotypeFilterArgs = GenotypeFilterParam() + genotypeFilterParam = GenotypeFilterParam() ) { .assertMethodParam( - genotypeFilterArgs, + genotypeFilterParam, "GenotypeFilterParam", "genotypeFilter" ) - filt <- .qtlResolveFilter(genotypeFilterArgs) + filt <- .qtlResolveFilter(genotypeFilterParam) handle <- .qtlValidateInputs(phenotypes, genotypes) experiments <- c( set_names( @@ -463,7 +470,7 @@ QtlDataset <- function( obj <- methods::new( "QtlDataset", .qtlRestrictSamples(mae, filt$keepSamples), - study = as.character(study), + studyName = as.character(studyName), scaleResiduals = isTRUE(scaleResiduals), mafCutoff = as.numeric(filt$mafCutoff), macCutoff = as.numeric(filt$macCutoff), @@ -552,7 +559,7 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { if (isTRUE(genotype)) { return(.qtlRealizeDosages(mae)) } - .qtlMuffleDrop(MultiAssayExperiment::subsetByAssay(mae, getContexts(x))) + .qtlMuffleDrop(MultiAssayExperiment::subsetByAssay(mae, contexts(x))) } # Silence the warning and the message the drop is guaranteed to raise -- @@ -638,7 +645,7 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { # Replace the genotype handle by rebuilding the genotype experiment around # it. The handle lives in exactly one place -- the assay's seed -- so there -# is no second copy to keep in step; getGenotypeHandle() reads it back. +# is no second copy to keep in step; genotypeHandle() reads it back. # @noRd .qtlWithGenotypeHandle <- function(x, handle) { exps <- MultiAssayExperiment::experiments(x) @@ -681,19 +688,19 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { ) } -#' @rdname getStudy +#' @rdname studyName #' @export -setMethod("getStudy", "QtlDataset", function(x) x@study) +setMethod("studyName", "QtlDataset", function(x) x@studyName) -#' @rdname getContexts +#' @rdname contexts #' @export -setMethod("getContexts", "QtlDataset", function(x) { +setMethod("contexts", "QtlDataset", function(x) { names(.qtlPhenotypeList(x)) }) -#' @rdname getGenotypeCovariates +#' @rdname genotypeCovariates #' @export -setMethod("getGenotypeCovariates", "QtlDataset", function(x) { +setMethod("genotypeCovariates", "QtlDataset", function(x) { .qtlSuppliedCovariates(.qtlColDataMatrix(.qtlGenotypeSe(x))) }) @@ -726,13 +733,13 @@ setMethod("getGenotypeCovariates", "QtlDataset", function(x) { `rownames<-`(as.matrix(as.data.frame(cd)), rownames(cd)) } -#' @rdname getScaleResiduals +#' @rdname scaleResiduals #' @export -setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals) +setMethod("scaleResiduals", "QtlDataset", function(x) x@scaleResiduals) -#' @rdname getGenotypeHandle +#' @rdname genotypeHandle #' @keywords internal -setMethod("getGenotypeHandle", "QtlDataset", function(x) { +setMethod("genotypeHandle", "QtlDataset", function(x) { # Derived, not stored. The handle already lives inside the genotype # assay's seed -- that is what lets the dosages read lazily -- so a # parallel slot was a second copy that had to be kept in step by hand. @@ -744,27 +751,27 @@ setMethod("getGenotypeHandle", "QtlDataset", function(x) { #' @rdname qtlDatasetFilters #' @export -setMethod("getMafCutoff", "QtlDataset", function(x) x@mafCutoff) +setMethod("mafCutoff", "QtlDataset", function(x) x@mafCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getMacCutoff", "QtlDataset", function(x) x@macCutoff) +setMethod("macCutoff", "QtlDataset", function(x) x@macCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getXvarCutoff", "QtlDataset", function(x) x@xvarCutoff) +setMethod("xvarCutoff", "QtlDataset", function(x) x@xvarCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getImissCutoff", "QtlDataset", function(x) x@imissCutoff) +setMethod("imissCutoff", "QtlDataset", function(x) x@imissCutoff) #' @rdname qtlDatasetFilters #' @export -setMethod("getKeepVariants", "QtlDataset", function(x) x@keepVariants) +setMethod("keepVariants", "QtlDataset", function(x) x@keepVariants) #' @rdname qtlDatasetFilters #' @export -setMethod("getKeepIndel", "QtlDataset", function(x) x@keepIndel) +setMethod("keepIndel", "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 @@ -799,7 +806,7 @@ setMethod("getKeepIndel", "QtlDataset", function(x) x@keepIndel) # none of them. # @noRd .qtlTraitRangesInContext <- function(ctx, x, traitId) { - se <- getPhenotypes(x, ctx) + se <- molecularTraits(x, ctx) hits <- .qtlPresentIndices(traitId, rownames(se)) if (length(hits) == 0L) { return(NULL) @@ -823,7 +830,7 @@ setMethod("getKeepIndel", "QtlDataset", function(x) x@keepIndel) abort(msg) } perTraitRanges <- compact(map( - getContexts(x), + contexts(x), .qtlTraitRangesInContext, x = x, traitId = traitId @@ -881,7 +888,7 @@ 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. - spans <- map(traitIds, .qtlTraitSpan, x = x, contexts = getContexts(x)) + spans <- map(traitIds, .qtlTraitSpan, x = x, contexts = contexts(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. @@ -934,9 +941,9 @@ setMethod("getKeepIndel", "QtlDataset", function(x) x@keepIndel) max(GenomicRanges::end(rr)) } -#' @rdname getTraitPosition +#' @rdname traitPosition #' @export -setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { +setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { tids <- if (is.null(traitId)) { unique(list_c(map(.qtlPhenotypeList(x), rownames))) } else { @@ -949,11 +956,11 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { # handle@snpInfo. Indices are unioned across ranges in range order (first # occurrence wins), so overlapping ranges contribute each variant once. .qtlVariantIndices <- function(x, region = NULL) { - handle <- getGenotypeHandle(x) + handle <- genotypeHandle(x) if (is.null(region)) { - return(seq_len(nrow(getSnpInfo(handle)))) + return(seq_len(nrow(snpInfo(handle)))) } - snpInfo <- getSnpInfo(handle) + snpInfo <- snpInfo(handle) siChr <- canonChrom(snpInfo$CHR) bp <- as.integer(snpInfo$BP) rChr <- canonChrom(GenomicRanges::seqnames(region)) @@ -983,7 +990,7 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { # before the slot existed (treat a missing slot as TRUE = keep indels). #' @importFrom purrr possibly .qtlKeepIndel <- function(x) { - isTRUE(possibly(getKeepIndel, otherwise = TRUE)(x)) + isTRUE(possibly(keepIndel, otherwise = TRUE)(x)) } # A GenotypeFilterParam() bundle with every field resolved. Unset fields @@ -991,15 +998,15 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { # 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) { +.qtlResolveFilter <- function(genotypeFilterParam) { 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 + mafCutoff = genotypeFilterParam$mafCutoff %||% 0, + macCutoff = genotypeFilterParam$macCutoff %||% 0, + xvarCutoff = genotypeFilterParam$xvarCutoff %||% 0, + imissCutoff = genotypeFilterParam$imissCutoff %||% 0, + keepSamples = genotypeFilterParam$keepSamples %||% character(0), + keepVariants = genotypeFilterParam$keepVariants %||% character(0), + keepIndel = genotypeFilterParam$keepIndel %||% TRUE ) } @@ -1026,9 +1033,9 @@ 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, genotypeFilterArgs) { +.qtlApplyFilterOverrides <- function(data, genotypeFilterParam) { .assertMethodParam( - genotypeFilterArgs, + genotypeFilterParam, "GenotypeFilterParam", "genotypeFilter" ) @@ -1040,17 +1047,17 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { 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) + mafCutoff = .qtlNumOverride(genotypeFilterParam$mafCutoff), + macCutoff = .qtlNumOverride(genotypeFilterParam$macCutoff), + xvarCutoff = .qtlNumOverride(genotypeFilterParam$xvarCutoff), + imissCutoff = .qtlNumOverride(genotypeFilterParam$imissCutoff), + keepIndel = .qtlLglOverride(genotypeFilterParam$keepIndel), + keepVariants = .qtlChrOverride(genotypeFilterParam$keepVariants) ), is.null ) ) - keepSamples <- genotypeFilterArgs$keepSamples + keepSamples <- genotypeFilterParam$keepSamples restricted <- if (is.null(keepSamples)) { overridden } else { @@ -1064,17 +1071,17 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { # 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) { + if (imissCutoff(x) <= 0 || nrow(dosage) == 0L || ncol(dosage) == 0L) { return(dosage) } - dosage[rowMeans(is.na(dosage)) <= getImissCutoff(x), , drop = FALSE] + dosage[rowMeans(is.na(dosage)) <= imissCutoff(x), , drop = FALSE] } # Internal: extract the panel dosage block (samples x variants) for the # requested region, narrow to the requested sample set, and apply lazy QC # (per-sample imiss filter, then per-variant max(mafCutoff, -# macCutoff / (2 * n)) and xvarCutoff filters). Used by getGenotypes, -# getResidualizedGenotypes (via getGenotypes), and getMaf so all three +# macCutoff / (2 * n)) and xvarCutoff filters). Used by genotypes, +# residualizedGenotypes (via genotypes), and maf so all three # share a single variant/sample selection result. # # Returns a list: @@ -1110,7 +1117,7 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { if (length(snpIdx) == 0L) { return(.qtlEmptyBlock()) } - handle <- getGenotypeHandle(x) + handle <- genotypeHandle(x) dosage <- .dosageMatrix(handle, snpIdx, meanImpute = FALSE) keep <- .qtlResolveSamples(dosage, x, samples) if (length(keep) == 0L) { @@ -1131,16 +1138,16 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { # Empty block preserving the full panel sample set (no variants selected). # @noRd .qtlEmptyBlockAllSamples <- function(x) { - handle <- getGenotypeHandle(x) + handle <- genotypeHandle(x) list( geno = matrix( numeric(0), - nrow = getNSamples(handle), + nrow = nSamples(handle), ncol = 0L, - dimnames = list(getSampleIds(handle), character(0)) + dimnames = list(sampleIds(handle), character(0)) ), variantIds = character(0), - sampleIds = getSampleIds(handle), + sampleIds = sampleIds(handle), maf = numeric(0), af = numeric(0) ) @@ -1179,18 +1186,18 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { # allele) and, unless kept, by dropping indels. Done before materialization. # @noRd .qtlNarrowSnpIdx <- function(x, snpIdx) { - handle <- getGenotypeHandle(x) - kept <- if (length(getKeepVariants(x)) == 0L) { + handle <- genotypeHandle(x) + kept <- if (length(keepVariants(x)) == 0L) { snpIdx } else { - snpAll <- as.character(getSnpInfo(handle)$SNP[snpIdx]) - km <- matchVariants(snpAll, as.character(getKeepVariants(x))) + snpAll <- as.character(snpInfo(handle)$SNP[snpIdx]) + km <- matchVariants(snpAll, as.character(keepVariants(x))) snpIdx[replace(logical(length(snpAll)), km$idxA, TRUE)] } if (length(kept) == 0L || .qtlKeepIndel(x)) { return(kept) } - si <- getSnpInfo(handle) + si <- snpInfo(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 & @@ -1232,11 +1239,11 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { afVec <- p mafVec <- pmin(p, 1 - p) effectiveMaf <- max( - getMafCutoff(x), - if (nSamp > 0L) getMacCutoff(x) / (2 * nSamp) else 0 + mafCutoff(x), + if (nSamp > 0L) macCutoff(x) / (2 * nSamp) else 0 ) byMaf <- !is.na(mafVec) & mafVec >= effectiveMaf - keepVarMask <- if (getXvarCutoff(x) <= 0 || nSamp <= 1L) { + keepVarMask <- if (xvarCutoff(x) <= 0 || nSamp <= 1L) { byMaf } else { mu <- if_else(nObs > 0L, sumD / nObs, 0) @@ -1248,7 +1255,7 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { 0 ) varVec <- colSums(centered * centered) / (nSamp - 1L) - byMaf & varVec >= getXvarCutoff(x) + byMaf & varVec >= xvarCutoff(x) } list( dosage = dosage[, keepVarMask, drop = FALSE], @@ -1273,10 +1280,10 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL) { replace(dosage, naMask, means[col(dosage)[naMask]]) } -#' @rdname getGenotypes +#' @rdname genotypes #' @export setMethod( - "getGenotypes", + "genotypes", "QtlDataset", function( x, @@ -1295,10 +1302,10 @@ setMethod( } ) -#' @rdname getMaf +#' @rdname maf #' @export setMethod( - "getMaf", + "maf", "QtlDataset", function(x, region = NULL, cisWindow = NULL, samples = NULL) { block <- .qtlExtractBlock( @@ -1312,10 +1319,10 @@ setMethod( } ) -#' @rdname getAf +#' @rdname af #' @export setMethod( - "getAf", + "af", "QtlDataset", function( x, @@ -1335,10 +1342,10 @@ setMethod( } ) -#' @rdname getPhenotypes +#' @rdname molecularTraits #' @export setMethod( - "getPhenotypes", + "molecularTraits", "QtlDataset", function( x, @@ -1373,13 +1380,13 @@ setMethod( .qtlValidateContexts <- function(x, contexts) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { msg <- glue( - "`contexts` is required for getPhenotypes(QtlDataset). Pass a ", + "`contexts` is required for molecularTraits(QtlDataset). Pass a ", "character vector of one or more context names; use ", - "getContexts(x) to list the available contexts." + "contexts(x) to list the available contexts." ) abort(msg) } - available <- getContexts(x) + available <- contexts(x) bad <- setdiff(contexts, available) if (length(bad) > 0L) { msg <- glue( @@ -1502,8 +1509,8 @@ setMethod( #' @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}}. +#' \code{\link{molecularTraits}} and +#' \code{\link{residualizedPhenotypes}}. #' @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} @@ -1513,8 +1520,8 @@ setMethod( #' \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}} +#' @seealso \code{\link{molecularTraits}}, +#' \code{\link{residualizedPhenotypes}} #' @examples #' CovMcdOptions(alpha = 0.75) #' @export @@ -1630,13 +1637,13 @@ CovMcdOptions <- function(...) { se[, keep, drop = FALSE] } -#' @rdname getPhenotypeCovariates +#' @rdname phenotypeCovariates #' @export -setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { +setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { abort("`contexts` is required.") } - available <- getContexts(x) + available <- contexts(x) bad <- setdiff(contexts, available) if (length(bad) > 0L) { msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") @@ -1689,7 +1696,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { # all available covariates; otherwise validate the requested names are present. # @noRd .qtlResolveOne <- function(ctx, requested, x) { - se <- getPhenotypes(x, ctx) + se <- molecularTraits(x, ctx) avail <- colnames(SummarizedExperiment::colData(se)) if (is.null(requested)) { return(avail) @@ -1781,7 +1788,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)) %||% character(0) + avail <- colnames(genotypeCovariates(x)) %||% character(0) if (is.null(toResidualize)) { return(avail) } @@ -1821,7 +1828,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { list() } gCov <- if (includeGeno && length(genoSelection) > 0L) { - getGenotypeCovariates(x)[, genoSelection, drop = FALSE] + genotypeCovariates(x)[, genoSelection, drop = FALSE] } else { matrix(numeric(0), nrow = 0, ncol = 0) } @@ -1869,7 +1876,7 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(keep) == 0L) { return(NULL) } - se <- getPhenotypes(x, ctx) + se <- molecularTraits(x, ctx) cd <- as.matrix(as.data.frame(SummarizedExperiment::colData(se))) block <- cd[, keep, drop = FALSE] `colnames<-`(block, str_c(ctx, ".", colnames(block))) @@ -1982,8 +1989,8 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { 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. ", + "residualizedGenotypes(QtlDataset). ", + "Use contexts(x) to list the available contexts. ", "Pass a single context for per-context mode or multiple ", "contexts for joint mode (sample intersection)." ) @@ -1994,12 +2001,12 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { "ResidualizationParam", "residualizationArgs" ) - bad <- setdiff(contexts, getContexts(x)) + bad <- setdiff(contexts, contexts(x)) if (length(bad) > 0L) { msg <- glue("Unknown context(s): {str_flatten(bad, \', \')}") abort(msg) } - G <- getGenotypes( + G <- genotypes( x, traitId = traitId, region = region, @@ -2014,14 +2021,14 @@ setMethod("getPhenotypeCovariates", "QtlDataset", function(x, contexts) { .qtlResidualizeQr( aligned$G, aligned$C, - scaleResiduals = getScaleResiduals(x) + scaleResiduals = scaleResiduals(x) ) } -#' @rdname getResidualizedGenotypes +#' @rdname residualizedGenotypes #' @export setMethod( - "getResidualizedGenotypes", + "residualizedGenotypes", "QtlDataset", .qtlResidualizedGenotypesImpl ) @@ -2030,7 +2037,7 @@ setMethod( # multi-context callers see the same shape). # @noRd .qtlResidPhenoY <- function(x, contexts, traitId, region, naAction) { - fetched <- getPhenotypes( + fetched <- molecularTraits( x, contexts = contexts, traitId = traitId, @@ -2096,7 +2103,7 @@ setMethod( allRes[keep, , drop = FALSE] } -# getResidualizedPhenotypes worker: resolve covariate inclusion + selections, +# residualizedPhenotypes 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 @@ -2112,7 +2119,7 @@ setMethod( residualizationArgs = ResidualizationParam() ) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { - abort("`contexts` is required for getResidualizedPhenotypes().") + abort("`contexts` is required for residualizedPhenotypes().") } naAction <- arg_match(naAction) outlierAction <- arg_match(outlierAction) @@ -2122,7 +2129,7 @@ setMethod( "ResidualizationParam", "residualizationArgs" ) - bad <- setdiff(contexts, getContexts(x)) + bad <- setdiff(contexts, contexts(x)) if (length(bad) > 0L) { msg <- glue("Unknown context(s): {str_flatten(bad, \', \')}") abort(msg) @@ -2146,10 +2153,10 @@ setMethod( ) } -#' @rdname getResidualizedPhenotypes +#' @rdname residualizedPhenotypes #' @export setMethod( - "getResidualizedPhenotypes", + "residualizedPhenotypes", "QtlDataset", .qtlResidualizedPhenotypesImpl ) @@ -2221,20 +2228,23 @@ setMethod("show", "QtlDataset", function(object) { nCtx <- length(pheno) ctxNames <- names(pheno) totalTraits <- length(unique(unname(list_c(map(pheno, rownames))))) - cat(glue("QtlDataset for study '{object@study}'\n", .trim = FALSE)) + cat(glue( + "QtlDataset for study '{object@studyName}'\n", + .trim = FALSE + )) cat(glue( " {nCtx} context(s): {str_flatten(ctxNames, ', ')}\n", .trim = FALSE )) cat(glue(" {totalTraits} unique traits across contexts\n", .trim = FALSE)) - gh <- getGenotypeHandle(object) + gh <- genotypeHandle(object) cat(glue( - " Genotypes: {getFormat(gh)} @ {getPath(gh)}\n", + " Genotypes: {genotypeFormat(gh)} @ {path(gh)}\n", .trim = FALSE )) cat(glue( " Genotype covariates: ", - "{ncol(getGenotypeCovariates(object))} cols\n", + "{ncol(genotypeCovariates(object))} cols\n", .trim = FALSE )) cat(glue( @@ -2273,7 +2283,7 @@ setMethod("show", "QtlDataset", function(object) { # One context's covariate matrix (colData of its phenotype SE). # @noRd .qtlContextColData <- function(ctx, x) { - se <- getPhenotypes(x, ctx) + se <- molecularTraits(x, ctx) cd <- SummarizedExperiment::colData(se) as.matrix(as.data.frame(cd)) } @@ -2301,7 +2311,7 @@ setMethod("show", "QtlDataset", function(object) { ctx, outlierAction, outlierPvalThreshold, - getScaleResiduals(x), + scaleResiduals(x), outlierArgs ) } diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index 8d49d6ab..2ec638d2 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -143,8 +143,8 @@ setClass( # (study, context, trait, method). A length mismatch would otherwise surface as # a recycling artefact deep inside the DataFrame assembly. # @noRd -.qfmrCheckTupleLengths <- function(study, context, trait, method, entry) { - n <- length(study) +.qfmrCheckTupleLengths <- function(studyName, context, trait, method, entry) { + n <- length(studyName) ok <- length(context) == n && length(trait) == n && length(method) == n && @@ -165,7 +165,7 @@ setClass( #' payloads (one per tuple). The optional \code{ldSketch} slot records the LD #' reference used for RSS-derived fits; pass \code{NULL} (the default) for #' individual-level fits. -#' @param study Character vector of study identifiers (per tuple). Use the +#' @param studyName Character vector of study identifiers (per tuple). Use the #' sentinel \code{"joint"} for rows produced by a cross-study joint fit. #' @param context Character vector of context labels (per tuple). Use #' \code{"joint"} for rows produced by a cross-context joint fit. @@ -193,13 +193,13 @@ setClass( #' pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) #' fe <- fineMappingRow( #' variantIds = tl$variant_id, susieFit = list(), topLoci = tl) -#' QtlFineMappingResult(study = "s1", context = "brain", trait = "g1", +#' QtlFineMappingResult(studyName = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(fe)) #' @importFrom checkmate assertCharacter assert checkList #' @importFrom checkmate checkClass #' @export QtlFineMappingResult <- function( - study, + studyName, context, trait, method, @@ -211,7 +211,7 @@ QtlFineMappingResult <- function( ldSketch = NULL ) { .qfmrAssertArgs( - study, + studyName, context, trait, method, @@ -220,12 +220,12 @@ QtlFineMappingResult <- function( jointContexts, jointTraits ) - n <- length(study) - .qfmrCheckTupleLengths(study, context, trait, method, entry) + n <- length(studyName) + .qfmrCheckTupleLengths(studyName, context, trait, method, entry) payloads <- map(entry, .asFmRowPayload) .checkRowPayloads(payloads, "FineMappingRow", "fine-mapping") cols <- .qfmrMetadataCols( - study, + studyName, context, trait, method, @@ -248,7 +248,7 @@ QtlFineMappingResult <- function( # Every argument's type contract, checked before anything is built. # @noRd .qfmrAssertArgs <- function( - study, + studyName, context, trait, method, @@ -257,7 +257,7 @@ QtlFineMappingResult <- function( jointContexts, jointTraits ) { - assertCharacter(study, any.missing = FALSE) + assertCharacter(studyName, any.missing = FALSE) assertCharacter(context, any.missing = FALSE) assertCharacter(trait, any.missing = FALSE) assertCharacter(method, any.missing = FALSE) @@ -277,7 +277,7 @@ QtlFineMappingResult <- function( # payload, and any joint-provenance or trait-position columns. # @noRd .qfmrMetadataCols <- function( - study, + studyName, context, trait, method, @@ -289,12 +289,12 @@ QtlFineMappingResult <- function( n ) { baseCols <- list( - study = as.character(study), + study = as.character(studyName), context = as.character(context), trait = as.character(trait), method = as.character(method), - susieFit = S4Vectors::SimpleList(map(payloads, getSusieFit)), - cvResult = S4Vectors::SimpleList(map(payloads, getCvResult)) + susieFit = S4Vectors::SimpleList(map(payloads, susieFit)), + cvResult = S4Vectors::SimpleList(map(payloads, cvResult)) ) withJoint <- .qfmrAppendJointCols( baseCols, @@ -337,10 +337,10 @@ QtlFineMappingResult <- function( # The single row a (study, context, trait, method) selector pins. # @noRd -.qfmrSelectRowIndex <- function(x, study, context, trait, method) { +.qfmrSelectRowIndex <- function(x, studyName, context, trait, method) { .tupleSelectRow( x, - study, + studyName, context, trait, method, @@ -348,25 +348,25 @@ QtlFineMappingResult <- function( ) } -#' @rdname getFineMappingResult +#' @rdname fineMappingResult setMethod( - "getFineMappingResult", + "fineMappingResult", "QtlFineMappingResult", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { - x[.qfmrSelectRowIndex(x, study, context, trait, method)] + function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + x[.qfmrSelectRowIndex(x, studyName, context, trait, method)] } ) # Derived collection-level accessors (delegate to entry-level methods). -#' @rdname getPip +#' @rdname pip #' @export setMethod( - "getPip", + "pip", "QtlFineMappingResult", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -375,7 +375,7 @@ setMethod( pip <- .fmrRowPip( .fmrRowParts( x, - .qfmrSelectRowIndex(x, study, context, trait, method) + .qfmrSelectRowIndex(x, studyName, context, trait, method) ) ) if (isTRUE(returnList)) { @@ -389,15 +389,15 @@ setMethod( } ) -# Row selector for the base delegating accessors (getCs / getTopLoci / -# getMarginalEffects / getSusieFit / getVariantIds now live on +# Row selector for the base delegating accessors (credibleSets / topLoci / +# marginalEffects / susieFit / variantIds now live on # FineMappingResultBase, AllClasses.R). setMethod( ".fmrSelectEntry", "QtlFineMappingResult", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -416,42 +416,42 @@ setMethod( } .fmrRowParts( x, - .qfmrSelectRowIndex(x, study, context, trait, method) + .qfmrSelectRowIndex(x, studyName, context, trait, method) ) } ) -#' @rdname getCvResult +#' @rdname cvResult #' @export setMethod( - "getCvResult", + "cvResult", "QtlFineMappingResult", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL ) { - getCvResult(.fmrRowParts( + cvResult(.fmrRowParts( x, - .qfmrSelectRowIndex(x, study, context, trait, method) + .qfmrSelectRowIndex(x, studyName, context, trait, method) )) } ) -# getTopLoci / getMarginalEffects / getSusieFit / getVariantIds are defined once +# topLoci / marginalEffects / susieFit / variantIds are defined once # on FineMappingResultBase (AllClasses.R), routing through .fmrSelectEntry. -#' @rdname getContexts +#' @rdname contexts #' @export -setMethod("getContexts", "QtlFineMappingResult", function(x) { +setMethod("contexts", "QtlFineMappingResult", function(x) { unique(as.character(x$context)) }) -#' @rdname getTraits +#' @rdname traitNames #' @export -setMethod("getTraits", "QtlFineMappingResult", function(x) { +setMethod("traitNames", "QtlFineMappingResult", function(x) { unique(as.character(x$trait)) }) #' @rdname show-methods diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index a2447fce..b0cb29bf 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -413,7 +413,7 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { # constructors, whose assembly differs only in the columns handed in. # @noRd .rtlGrlWithMetadata <- function(payloads, cols) { - split <- .rtlSplitBySeqname(map(payloads, rowVariants)) + split <- .rtlSplitBySeqname(map(payloads, variants)) md <- exec(S4Vectors::DataFrame, !!!c(cols, list(check.names = FALSE))) S4Vectors::`mcols<-`( GenomicRanges::GRangesList(split$entry), @@ -688,7 +688,7 @@ setMethod( #' Non-atomic \code{mcols} columns -- the per-element \code{susieFit} / #' \code{cvResult} payloads -- are dropped. They describe an element, not a #' range, so there is no row to broadcast them onto. Use the accessors -#' (\code{\link{getSusieFit}}, \code{\link{getCvResult}}) for those. +#' (\code{\link{susieFit}}, \code{\link{cvResult}}) for those. #' #' @param x A \code{RangedTupleList}. #' @return A \code{GRanges}. diff --git a/R/SldscData.R b/R/SldscData.R index 5caab186..bfa440f6 100644 --- a/R/SldscData.R +++ b/R/SldscData.R @@ -5,10 +5,10 @@ #' \code{\link{sldscPostprocessingPipeline}}. The class itself performs no #' file I/O: the user runs the readers, then constructs an \code{SldscData} #' from those in-memory objects, and the pipeline does all computation on it. -#' @slot annot A \code{data.frame} of target annotations with at least +#' @slot annotData A \code{data.frame} of target annotations with at least #' \code{CHR} and \code{SNP} columns plus one or more annotation columns #' (\code{BP}/\code{CM} optional). -#' @slot frq A \code{data.frame} of reference-panel allele frequencies with +#' @slot frqData A \code{data.frame} of reference-panel allele frequencies with #' \code{SNP} and \code{MAF} columns (a 0-row frame when no \code{.frq} data #' was supplied). #' @slot traits A named list, one entry per trait, each a list with a @@ -20,13 +20,13 @@ setClass( "SldscData", slots = c( - annot = "data.frame", - frq = "data.frame", + annotData = "data.frame", + frqData = "data.frame", traits = "list" ), prototype = list( - annot = tibble(), - frq = tibble(), + annotData = tibble(), + frqData = tibble(), traits = list() ) ) @@ -38,8 +38,8 @@ setValidity("SldscData", function(object) .validateSldscData(object)) # @noRd .validateSldscData <- function(object) { errs <- c( - .sldscDataCheckAnnot(object@annot), - .sldscDataCheckFrq(object@frq), + .sldscDataCheckAnnot(object@annotData), + .sldscDataCheckFrq(object@frqData), .sldscDataCheckTraits(object@traits) ) if (length(errs)) errs else TRUE @@ -47,9 +47,9 @@ setValidity("SldscData", function(object) .validateSldscData(object)) # @noRd #' @importFrom checkmate checkNames -.sldscDataCheckAnnot <- function(annot) { - cols <- checkNames(names(annot), must.include = c("CHR", "SNP")) - annotCols <- setdiff(names(annot), c("CHR", "SNP", "BP", "CM")) +.sldscDataCheckAnnot <- function(annotData) { + cols <- checkNames(names(annotData), must.include = c("CHR", "SNP")) + annotCols <- setdiff(names(annotData), c("CHR", "SNP", "BP", "CM")) c( if (!isTRUE(cols)) { str_c("`annot` must have columns CHR and SNP: ", cols) @@ -65,11 +65,11 @@ setValidity("SldscData", function(object) .validateSldscData(object)) } # @noRd -.sldscDataCheckFrq <- function(frq) { - if (nrow(frq) == 0L) { +.sldscDataCheckFrq <- function(frqData) { + if (nrow(frqData) == 0L) { return(NULL) } - cols <- checkNames(names(frq), must.include = c("SNP", "MAF")) + cols <- checkNames(names(frqData), must.include = c("SNP", "MAF")) if (isTRUE(cols)) { return(NULL) } @@ -110,10 +110,11 @@ setValidity("SldscData", function(object) .validateSldscData(object)) #' Bundles the in-memory outputs of the S-LDSC readers into a single object for #' \code{\link{sldscPostprocessingPipeline}}. Performs no file I/O. #' -#' @param annot A target-annotation \code{data.frame} (e.g. from +#' @param annotData A target-annotation \code{data.frame} (e.g. from #' \code{\link{readSldscAnnot}}): \code{CHR}, \code{SNP}, and one or more #' annotation columns. -#' @param frq Optional reference-panel allele-frequency \code{data.frame} (e.g. +#' @param frqData Optional reference-panel allele-frequency +#' \code{data.frame} (e.g. #' from \code{\link{readSldscFrq}}): \code{SNP}, \code{MAF}. \code{NULL} (the #' default) stores an empty frame, which disables MAF-based filtering. #' @param traits A named list of per-trait runs; each entry a list with a @@ -134,8 +135,8 @@ setValidity("SldscData", function(object) .validateSldscData(object)) #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -147,20 +148,20 @@ setValidity("SldscData", function(object) .validateSldscData(object)) #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) #' sd #' @export -SldscData <- function(annot, frq = NULL, traits = list()) { - if (missing(annot)) { - abort("SldscData: `annot` is required.") +SldscData <- function(annotData, frqData = NULL, traits = list()) { + if (missing(annotData)) { + abort("SldscData: `annotData` is required.") } - if (is.null(frq)) { - frq <- tibble() + if (is.null(frqData)) { + frqData <- tibble() } obj <- new( "SldscData", - annot = as_tibble(annot), - frq = as_tibble(frq), + annotData = as_tibble(annotData), + frqData = as_tibble(frqData), traits = traits ) validObject(obj) @@ -169,49 +170,48 @@ SldscData <- function(annot, frq = NULL, traits = list()) { # ---- accessors ---- -#' @rdname getAnnotData +#' @rdname annotData #' @export -setMethod("getAnnotData", "SldscData", function(x) x@annot) +setMethod("annotData", "SldscData", function(x) x@annotData) -#' @rdname getFrqData +#' @rdname frqData #' @export -setMethod("getFrqData", "SldscData", function(x) x@frq) +setMethod("frqData", "SldscData", function(x) x@frqData) -#' @rdname getTraitRuns +#' @rdname traitNames #' @export -setMethod("getTraitRuns", "SldscData", function(x) x@traits) +setMethod("traitNames", "SldscData", function(x) names(x@traits)) -#' @rdname getTraits +#' @rdname annotCols #' @export -setMethod("getTraits", "SldscData", function(x) names(x@traits)) - -#' @rdname getAnnotCols -#' @export -setMethod("getAnnotCols", "SldscData", function(x) { - setdiff(names(x@annot), c("CHR", "SNP", "BP", "CM")) +setMethod("annotCols", "SldscData", function(x) { + setdiff(names(x@annotData), c("CHR", "SNP", "BP", "CM")) }) -#' @rdname getTraitRun +#' @rdname sldscResults #' @export setMethod( - "getTraitRun", + "sldscResults", "SldscData", - function(x, trait, mode = c("single", "joint"), idx = NULL) { + function(x, trait = NULL, mode = c("single", "joint"), idx = NULL) { + if (is.null(trait)) { + return(x@traits) + } mode <- arg_match(mode) - t <- x@traits[[trait]] - if (is.null(t)) { + runs <- x@traits[[trait]] + if (is.null(runs)) { return(NULL) } if (mode == "joint") { - return(t$joint) + return(runs$joint) } if (is.null(idx)) { - return(t$single) + return(runs$single) } - if (idx > length(t$single)) { + if (idx > length(runs$single)) { return(NULL) } - t$single[[idx]] + runs$single[[idx]] } ) @@ -219,13 +219,13 @@ setMethod( setMethod("show", "SldscData", function(object) { cat("SldscData\n") cat(glue( - " annotations ({length(getAnnotCols(object))}): ", - "{str_flatten(getAnnotCols(object), ', ')}\n", + " annotations ({length(annotCols(object))}): ", + "{str_flatten(annotCols(object), ', ')}\n", .trim = FALSE )) cat(glue( - " annot SNPs: {nrow(object@annot)} | ", - "frq SNPs: {nrow(object@frq)}\n", + " annot SNPs: {nrow(object@annotData)} | ", + "frq SNPs: {nrow(object@frqData)}\n", .trim = FALSE )) cat(glue( diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index dd15af59..97e2f0dc 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -47,7 +47,7 @@ NULL #' } #' #' @param gwasSumStats A \code{\link{GwasSumStats}} object. Must be QC'd -#' (\code{length(getQcInfo(x)) > 0L}). +#' (\code{length(qcInfo(x)) > 0L}). #' @param twasWeights Optional \code{\link{TwasWeights}} carrying per-(study, #' context, trait, method) weights. When supplied, drives the TWAS-Z #' computation. @@ -164,10 +164,10 @@ causalInferencePipeline <- function( #' @importFrom checkmate assertClass checkClass .cipValidateInputs <- function(gwasSumStats, twasWeights, fineMappingResult) { assertClass(gwasSumStats, "GwasSumStats") - if (length(getQcInfo(gwasSumStats)) == 0L) { + if (length(qcInfo(gwasSumStats)) == 0L) { msg <- glue( "causalInferencePipeline: gwasSumStats has no QC record ", - "(getQcInfo() is empty). Call summaryStatsQc() first." + "(qcInfo() is empty). Call summaryStatsQc() first." ) abort(msg) } @@ -200,17 +200,17 @@ causalInferencePipeline <- function( # returns the GWAS LD sketch. # @noRd .cipCheckLdSketches <- function(gwasSumStats, twasWeights, fineMappingResult) { - gwasLd <- getLdSketch(gwasSumStats) + gwasLd <- ldSketch(gwasSumStats) if (!is.null(twasWeights)) { .cipRequireMatchingLdSketches( - getLdSketch(twasWeights), + ldSketch(twasWeights), gwasLd, label = "twasWeights" ) } if (!is.null(fineMappingResult)) { .cipRequireMatchingLdSketches( - getLdSketch(fineMappingResult), + ldSketch(fineMappingResult), gwasLd, label = "fineMappingResult" ) @@ -320,7 +320,7 @@ causalInferencePipeline <- function( weightsInfo <- .cipExtractWeights( twasWeights = twasWeights, fineMappingResult = fineMappingResult, - study = tuple$qStudy, + studyName = tuple$qStudy, context = tuple$qContext, trait = tuple$qTrait, method = tuple$qMethod, @@ -363,9 +363,9 @@ causalInferencePipeline <- function( if (!hasTuple) { return(NULL) } - getFineMappingResult( + fineMappingResult( fineMappingResult, - study = qStudy, + studyName = qStudy, context = qContext, trait = qTrait, method = qMethod @@ -386,9 +386,9 @@ causalInferencePipeline <- function( mrArgs ) { gStudy <- as.character(gwasSumStats$study)[[gi]] - gdf <- getSumStatsDf( + gdf <- as.data.frame( gwasSumStats, - study = gStudy, + studyName = gStudy, require = c("SNP", "Z") ) twasOut <- .cipComputeTwasZ( @@ -565,11 +565,18 @@ causalInferencePipeline <- function( # 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) { +.cipCvMetric <- function( + twasWeights, + studyName, + context, + trait, + method, + which +) { perf <- try_fetch( - getCvResult( + cvResult( twasWeights, - study = study, + studyName = studyName, context = context, trait = trait, method = method @@ -723,10 +730,15 @@ causalInferencePipeline <- function( if (length(fin) > 0L) ord[[fin[[1L]]]] else ord[[1L]] } -.cipFmrHasTuple <- function(fmr, study, context, trait, method) { +.cipFmrHasTuple <- function(fmr, studyName, context, trait, method) { length(.matchTupleRows( fmr, - list(study = study, context = context, trait = trait, method = method) + list( + study = studyName, + context = context, + trait = trait, + method = method + ) )) > 0L } @@ -739,16 +751,16 @@ causalInferencePipeline <- function( .cipExtractWeights <- function( twasWeights, fineMappingResult, - study, + studyName, context, trait, method, useFmr ) { ent <- if (!useFmr) { - .cipWeightsFromTwas(twasWeights, study, context, trait, method) + .cipWeightsFromTwas(twasWeights, studyName, context, trait, method) } else { - .cipWeightsFromFmr(fineMappingResult, study, context, trait, method) + .cipWeightsFromFmr(fineMappingResult, studyName, context, trait, method) } if (is.null(ent)) { return(NULL) @@ -762,9 +774,15 @@ causalInferencePipeline <- function( # TwasWeights entry for a tuple (NULL when absent). # @noRd -.cipWeightsFromTwas <- function(twasWeights, study, context, trait, method) { +.cipWeightsFromTwas <- function( + twasWeights, + studyName, + context, + trait, + method +) { tuple <- list( - study = study, + study = studyName, context = context, trait = trait, method = method @@ -772,9 +790,9 @@ causalInferencePipeline <- function( if (length(.matchTupleRows(twasWeights, tuple)) == 0L) { return(NULL) } - getTwasWeights( + twasWeights( twasWeights, - study = study, + studyName = studyName, context = context, trait = trait, method = method @@ -785,17 +803,19 @@ causalInferencePipeline <- function( # @noRd .cipWeightsFromFmr <- function( fineMappingResult, - study, + studyName, context, trait, method ) { - if (!.cipFmrHasTuple(fineMappingResult, study, context, trait, method)) { + if ( + !.cipFmrHasTuple(fineMappingResult, studyName, context, trait, method) + ) { return(NULL) } - getFineMappingResult( + fineMappingResult( fineMappingResult, - study = study, + studyName = studyName, context = context, trait = trait, method = method @@ -803,7 +823,7 @@ causalInferencePipeline <- function( } # Compute the per-tuple TWAS Z from a single GwasSumStats tuple's -# unpacked data.frame (produced by getSumStatsDf upstream). Returns +# unpacked data.frame (produced by as.data.frame upstream). Returns # NULL when the overlap is too small. .cipComputeTwasZ <- function( weights, @@ -888,14 +908,20 @@ causalInferencePipeline <- function( if (length(m$idxA) == 0L) { return(.cipEmptyMrRatio()) } - # Align the QTL exposure effect to the GWAS allele coding (sign = -1 on an - # allele swap) so the Wald ratio betaY / betaX has the correct sign. - betaX <- iv$betaX[m$idxA] * m$sign - seX <- iv$seX[m$idxA] gIdx <- m$idxB gZ <- gwasDf$z[gIdx] gN <- .cipGwasCol(gwasDf$N, gIdx) gMaf <- .cipGwasCol(gwasDf$maf, gIdx) + # Align the QTL exposure effect to the GWAS allele coding (sign = -1 on an + # allele swap) so the Wald ratio betaY / betaX has the correct sign, and + # put it on the same scale the outcome lands on. + exposure <- .cipMrExposureScale( + iv$betaX[m$idxA] * m$sign, + iv$seX[m$idxA], + .cipGwasHasScale(gMaf, gN) + ) + betaX <- exposure$beta + seX <- exposure$se betaY <- .cipZToBeta(gZ, gMaf, gN) seY <- .cipZToSe(gZ, gMaf, gN) ratio <- betaY / betaX @@ -928,8 +954,19 @@ causalInferencePipeline <- function( # Instrumental variables from a FineMappingRow's topLoci: variants with PIP > # pipCutoff. Returns list(ivVars, betaX, seX) or NULL when none qualify. # @noRd +# The per-variant top-loci table of one entry. topLoci() returns ranges and +# mcols() is exactly the pre-conversion table -- as.data.frame() on the +# ranges would add the standard seqnames/start/end/width/strand columns the +# MR column matching does not expect. Both instrument builders read through +# here, so the equivalence is stated once and the tests have one seam to +# substitute a controlled table at. +# @noRd +.cipTopLociTable <- function(fmrEntry) { + as.data.frame(S4Vectors::mcols(topLoci(fmrEntry))) +} + .cipMrInstruments <- function(fmrEntry, pipCutoff) { - tl <- getTopLoci(fmrEntry) + tl <- .cipTopLociTable(fmrEntry) if (is.null(tl) || nrow(tl) == 0L) { return(NULL) } @@ -1025,7 +1062,7 @@ causalInferencePipeline <- function( # unit-SE-standardized (cs, pip, bhatX, sbhatX, bhatY, sbhatY) or NULL. # @noRd .cipCsAwareInstruments <- function(fmrEntry, gwasDf, alleleFlip) { - tl <- getTopLoci(fmrEntry) + tl <- .cipTopLociTable(fmrEntry) if (is.null(tl) || nrow(tl) == 0L) { return(NULL) } @@ -1068,8 +1105,13 @@ causalInferencePipeline <- function( } # Match the exposure variants to the GWAS sumstats (allele-aware), derive the -# outcome beta/se, and standardize the exposure to unit SE. Returns NULL when +# outcome beta/se, and put the exposure on the same scale. Returns NULL when # nothing matches. +# +# The exposure used to be standardized to unit SE unconditionally, which left +# csAware dividing a real-scale outcome by a z-scale exposure whenever the +# GWAS did carry maf and N -- the mirror of the ivwPerVariant mismatch. It is +# conditional now, on the same test the outcome conversion uses. # @noRd .cipCsAwareAlign <- function(raw, gwasDf, alleleFlip) { m <- matchVariants(raw$vids, gwasDf$variant_id, allowFlip = alleleFlip) @@ -1080,13 +1122,16 @@ causalInferencePipeline <- function( gZ <- gwasDf$z[gIdx] gN <- .cipGwasCol(gwasDf$N, gIdx) gMaf <- .cipGwasCol(gwasDf$maf, gIdx) - # Standardize bhatX -> z; sbhatX -> 1 (legacy mrAnalysis rescaling). - bhatX <- (raw$bhatX[m$idxA] * m$sign) / raw$sbhatX[m$idxA] + exposure <- .cipMrExposureScale( + raw$bhatX[m$idxA] * m$sign, + raw$sbhatX[m$idxA], + .cipGwasHasScale(gMaf, gN) + ) list( cs = raw$cs[m$idxA], pip = raw$pip[m$idxA], - bhatX = bhatX, - sbhatX = rep(1, length(bhatX)), + bhatX = exposure$beta, + sbhatX = exposure$se, bhatY = .cipZToBeta(gZ, gMaf, gN), sbhatY = .cipZToSe(gZ, gMaf, gN) ) @@ -1147,22 +1192,52 @@ causalInferencePipeline <- function( } +# Whether the GWAS can be put on an effect-size scale at all, which needs +# both maf and N. All-or-nothing per call, matching how the conversions below +# behave. +# +# Stated once because three callers have to agree on it: the outcome beta, the +# outcome se, and the EXPOSURE scaling. While the exposure had no such test, +# a z-scale outcome was divided by a raw-scale QTL effect and the Wald ratio +# came out inflated by 1/seX -- answers like -1094 +/- 1105 for a tight +# instrument. +# @noRd +.cipGwasHasScale <- function(maf, n) { + !any(is.na(maf)) && !any(is.na(n)) +} + # Derive beta / se from z using maf + n via the shared zToBetaSe() (model-exact # se = 1/sqrt(2*p*q*(N + z^2)), beta = z*se). Fall back to z as a beta surrogate # / se = 1 when maf or n is unavailable. .cipZToBeta <- function(z, maf, n) { - if (any(is.na(maf)) || any(is.na(n))) { + if (!.cipGwasHasScale(maf, n)) { return(z) - } # fall back to z as a beta surrogate when no maf/n + } .zToBetaSe(z, maf, n)$beta } .cipZToSe <- function(z, maf, n) { - if (any(is.na(maf)) || any(is.na(n))) { + if (!.cipGwasHasScale(maf, n)) { return(rep(1, length(z))) } .zToBetaSe(z, maf, n)$se } +# The exposure on whatever scale the outcome ended up on. With maf and N both +# sides are real effect sizes, so the Wald ratio is an effect-size ratio and +# the raw QTL estimate is the one worth having. Without them the outcome is a +# z with unit se, so the exposure standardizes to z as well. +# +# Both MR methods route through this, so neither can end up on a scale the +# other is not on -- which is how ivwPerVariant paired a z outcome with a raw +# exposure, and csAware a real-scale outcome with a standardized one. +# @noRd +.cipMrExposureScale <- function(beta, se, gwasHasScale) { + if (gwasHasScale) { + return(list(beta = beta, se = se)) + } + list(beta = beta / se, se = rep(1, length(beta))) +} + # Fixed-effect inverse-variance-weighted (IVW) pooling of per-instrument # effects. Weights 1/se^2, drops non-finite / non-positive weights, and # returns the pooled effect, its SE (1/sqrt(sum w)), two-tailed p-value, diff --git a/R/colocPipeline.R b/R/colocPipeline.R index f07d8c6b..a44f1d3c 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -160,10 +160,10 @@ setClass( contains = "MethodParam", slots = c( methods = "MethodSelection", - credibleSetArgs = "CredibleSetParam", - rssArgs = "SusieRssParam", - panelFilterArgs = "PanelFilterParam", - addSusieInf = "logical", + credibleSetParam = "CredibleSetParam", + susieRssParam = "SusieRssParam", + panelFilterParam = "PanelFilterParam", + initializeWithSusieInf = "logical", fitRetention = "character" ) ) @@ -182,47 +182,50 @@ setClass( #' 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 +#' @param credibleSetParam 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 +#' @param susieRssParam 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 +#' @param panelFilterParam 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 initializeWithSusieInf 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. +#' Each accessor returns that setting's value --- for the three nested +#' bundles, the \code{MethodParam} itself --- and each replacement form +#' returns a modified copy. #' @examples -#' GwasFineMappingParam(credibleSet = CredibleSetParam(coverage = 0.9)) +#' GwasFineMappingParam( +#' credibleSetParam = CredibleSetParam(coverage = 0.9) +#' ) #' @export GwasFineMappingParam <- function( methods = "susie", - credibleSetArgs = CredibleSetParam(), - rssArgs = SusieRssParam(), - panelFilterArgs = PanelFilterParam(), - addSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), + susieRssParam = SusieRssParam(), + panelFilterParam = PanelFilterParam(), + initializeWithSusieInf = TRUE, fitRetention = c("slim", "full") ) { fitRetention <- arg_match(fitRetention) new( "GwasFineMappingParam", methods = methods, - credibleSetArgs = credibleSetArgs, - rssArgs = rssArgs, - panelFilterArgs = panelFilterArgs, - addSusieInf = addSusieInf, + credibleSetParam = credibleSetParam, + susieRssParam = susieRssParam, + panelFilterParam = panelFilterParam, + initializeWithSusieInf = initializeWithSusieInf, fitRetention = fitRetention ) } @@ -280,7 +283,7 @@ GwasFineMappingParam <- function( #' } #' #' @section LD-sketch compatibility check: If -#' \code{getLdSketch(qtlFineMappingResult)} is non-\code{NULL}, it must come +#' \code{ldSketch(qtlFineMappingResult)} is non-\code{NULL}, it must come #' from the same reference panel as the LD sketch on \code{gwasInput}: the #' same samples, and the same allele orientation on the variants the two #' carry in common. The two need NOT carry the same variants --- running @@ -317,10 +320,12 @@ GwasFineMappingParam <- function( #' @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 +#' \code{credibleSetParam}, \code{susieRssParam}, +#' \code{panelFilterParam}, \code{initializeWithSusieInf} and +#' \code{fitRetention}. Inert when \code{gwasInput} is already +#' fine-mapped. \code{credibleSetParam} is the one to check: its +#' \code{coverage} / \code{maxNumSingleEffects} 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 @@ -380,10 +385,10 @@ GwasFineMappingParam <- function( #' \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 +#' Project it with \code{\link{colocPairs}} (the flat table this #' pipeline used to return, also available as \code{as.data.frame}), -#' \code{\link{getColocVariants}}, \code{\link{getColocCredibleSets}} or -#' \code{\link{getColocGenes}}. +#' \code{\link{colocVariants}}, \code{\link{colocCredibleSets}} or +#' \code{\link{colocGenes}}. #' @examples #' data(qtlFineMappingLbfExample) #' data(gwasFineMappingLbfExample) @@ -394,7 +399,7 @@ GwasFineMappingParam <- function( #' # trait in gwasContext / gwasTrait. #' res <- colocPipeline(qtlFineMappingLbfExample, #' gwasInput = qtlFineMappingLbfExample) -#' unique(getColocPairs(res)[, c("context", "gwasContext")]) +#' unique(colocPairs(res)[, c("context", "gwasContext")]) #' @export colocPipeline <- function( qtlFineMappingResult, @@ -497,8 +502,8 @@ colocPipeline <- function( ) rawGwasFmr <- .colocResolveGwasFmr(gwasInput, gwasFineMappingArgs) .colocRequireMatchingLdSketches( - getLdSketch(qtlFineMappingResult), - getLdSketch(rawGwasFmr) + ldSketch(qtlFineMappingResult), + ldSketch(rawGwasFmr) ) adjusted <- .colocMaybeAdjustPips( adjustPips = adjustPips, @@ -605,7 +610,7 @@ colocPipeline <- function( "GwasFineMappingParam", "gwasFineMapping" ) - if (length(getQcInfo(gwasInput)) == 0L) { + if (length(qcInfo(gwasInput)) == 0L) { msg <- glue( "colocPipeline: gwasInput ({class(gwasInput)[[1L]]}) has no QC ", "record. Call summaryStatsQc() first." @@ -617,12 +622,13 @@ colocPipeline <- function( fineMappingPipeline( gwasInput, methods = gwasFineMappingArgs$methods %||% "susie", - credibleSetArgs = gwasFineMappingArgs$credibleSetArgs %||% + credibleSetParam = gwasFineMappingArgs$credibleSetParam %||% CredibleSetParam(), - rssArgs = gwasFineMappingArgs$rssArgs %||% SusieRssParam(), - panelFilterArgs = gwasFineMappingArgs$panelFilterArgs %||% + susieRssParam = gwasFineMappingArgs$susieRssParam %||% SusieRssParam(), + panelFilterParam = gwasFineMappingArgs$panelFilterParam %||% PanelFilterParam(), - addSusieInf = gwasFineMappingArgs$addSusieInf %||% TRUE, + initializeWithSusieInf = gwasFineMappingArgs$initializeWithSusieInf %||% + TRUE, fitRetention = gwasFineMappingArgs$fitRetention %||% "slim" ) } @@ -686,7 +692,7 @@ colocPipeline <- function( list(qtlFineMappingResult = both$x, gwasFmr = both$y) } -# The LD reference the result carries forward, so getColocCredibleSets() can +# The LD reference the result carries forward, so colocCredibleSets() can # recompute purity (section 3.7) without being handed a sketch separately. The # two sides' sketches are already required to match by # .colocRequireMatchingLdSketches, so either one identifies the panel -- but a @@ -694,7 +700,7 @@ colocPipeline <- function( # side's panel is the only one there is. # @noRd .colocLdSketch <- function(qtlFineMappingResult, gwasFmr) { - getLdSketch(qtlFineMappingResult) %||% getLdSketch(gwasFmr) + ldSketch(qtlFineMappingResult) %||% ldSketch(gwasFmr) } # Empty-result early return (attaching the GWAS fine-mapping when requested). @@ -1143,7 +1149,7 @@ colocPipeline <- function( lbfFilterArgs, label = "entry" ) { - fit <- getSusieFit(parts) + fit <- susieFit(parts) if (is.null(fit)) { msg <- glue("colocPipeline: {label} has no trimmedFit; skipping.") warn(msg) @@ -1579,69 +1585,88 @@ colocPipeline <- function( # --- 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)). +# own replacement methods and hands it back: +# cs <- credibleSetParam(g); csCoverage(cs) <- 0.9; credibleSetParam(g) <- cs #' @rdname GwasFineMappingParam -setMethod("getFineMappingMethods", "GwasFineMappingParam", function(x) { +setMethod("fineMappingMethods", "GwasFineMappingParam", function(x) { x@methods }) #' @rdname GwasFineMappingParam -setMethod("setFineMappingMethods", "GwasFineMappingParam", function(x, value) { - x@methods <- value - validObject(x) - x -}) +setReplaceMethod( + "fineMappingMethods", + "GwasFineMappingParam", + function(x, value) { + x@methods <- value + validObject(x) + x + } +) #' @rdname GwasFineMappingParam -setMethod("getCredibleSetArgs", "GwasFineMappingParam", function(x) { - x@credibleSetArgs +setMethod("credibleSetParam", "GwasFineMappingParam", function(x) { + x@credibleSetParam }) #' @rdname GwasFineMappingParam -setMethod("setCredibleSetArgs", "GwasFineMappingParam", function(x, value) { - x@credibleSetArgs <- value - validObject(x) - x -}) +setReplaceMethod( + "credibleSetParam", + "GwasFineMappingParam", + function(x, value) { + x@credibleSetParam <- value + validObject(x) + x + } +) #' @rdname GwasFineMappingParam -setMethod("getRssArgs", "GwasFineMappingParam", function(x) x@rssArgs) +setMethod("susieRssParam", "GwasFineMappingParam", function(x) x@susieRssParam) #' @rdname GwasFineMappingParam -setMethod("setRssArgs", "GwasFineMappingParam", function(x, value) { - x@rssArgs <- value +setReplaceMethod("susieRssParam", "GwasFineMappingParam", function(x, value) { + x@susieRssParam <- value validObject(x) x }) #' @rdname GwasFineMappingParam -setMethod("getPanelFilterArgs", "GwasFineMappingParam", function(x) { - x@panelFilterArgs +setMethod("panelFilterParam", "GwasFineMappingParam", function(x) { + x@panelFilterParam }) #' @rdname GwasFineMappingParam -setMethod("setPanelFilterArgs", "GwasFineMappingParam", function(x, value) { - x@panelFilterArgs <- value - validObject(x) - x -}) +setReplaceMethod( + "panelFilterParam", + "GwasFineMappingParam", + function(x, value) { + x@panelFilterParam <- value + validObject(x) + x + } +) #' @rdname GwasFineMappingParam -setMethod("getAddSusieInf", "GwasFineMappingParam", function(x) x@addSusieInf) +setMethod("initializeWithSusieInf", "GwasFineMappingParam", function(x) { + x@initializeWithSusieInf +}) #' @rdname GwasFineMappingParam -setMethod("setAddSusieInf", "GwasFineMappingParam", function(x, value) { - x@addSusieInf <- value - validObject(x) - x -}) +setReplaceMethod( + "initializeWithSusieInf", + "GwasFineMappingParam", + function(x, value) { + x@initializeWithSusieInf <- value + validObject(x) + x + } +) #' @rdname GwasFineMappingParam -setMethod("getFitRetention", "GwasFineMappingParam", function(x) x@fitRetention) +setMethod("fitRetention", "GwasFineMappingParam", function(x) x@fitRetention) #' @rdname GwasFineMappingParam -setMethod("setFitRetention", "GwasFineMappingParam", function(x, value) { +setReplaceMethod("fitRetention", "GwasFineMappingParam", function(x, value) { x@fitRetention <- value validObject(x) x @@ -1660,6 +1685,18 @@ setMethod("setFitRetention", "GwasFineMappingParam", function(x, value) { #' ColocOptions(trim_by_posterior = FALSE) #' @export ColocOptions <- function(overlap.min = NULL, trim_by_posterior = NULL, ...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + bf1 = "supplied from the data by the pipeline", + bf2 = "supplied from the data by the pipeline", + p1 = "`colocP1` on the pipeline", + p2 = "`colocP2` on the pipeline", + p12 = "`colocP12` on the pipeline" + ), + "ColocOptions" + ) .newMethodOptions( "coloc::coloc.bf_bf", defaults = list( diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index 7ceaa986..9cecffbd 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -10,7 +10,7 @@ #' \item \code{QtlSumStats} -- summary-statistic-only QTL data with a #' shared LD reference (\code{ldSketch}). Must already have #' been passed through \code{\link{summaryStatsQc}} (the -#' pipeline rejects inputs whose \code{getQcInfo()} is empty). +#' pipeline rejects inputs whose \code{qcInfo()} is empty). #' Every analysis variant is available on this input, including #' \code{xqtlColoc}, which colocalizes the QTL studies against #' each other with no GWAS involved. @@ -29,7 +29,7 @@ #' \item Individual-level QC (MAF / MAC / X-variance / per-sample #' missingness, sample / variant restrictions) lives on the #' \code{QtlDataset} constructor and is applied lazily inside -#' \code{getGenotypes()} / \code{getResidualizedGenotypes()}. +#' \code{genotypes()} / \code{residualizedGenotypes()}. #' The pipeline does \emph{not} run a separate #' individual-level QC pass. #' \item \code{panelFilter} acts at ANALYSIS time on the sumstat @@ -46,7 +46,7 @@ #' imputation, etc.) lives in #' \code{\link{summaryStatsQc}}. The pipeline rejects any #' \code{QtlSumStats} or \code{GwasSumStats} where -#' \code{length(getQcInfo(x)) == 0L}. +#' \code{length(qcInfo(x)) == 0L}. #' } #' #' @section Analysis variants: @@ -76,7 +76,7 @@ #' @param traitId Optional character vector of trait identifiers to restrict the #' analysis to. When supplied with an individual-level \code{QtlDataset} #' input, \code{cisWindow} is required (passed to -#' \code{getResidualizedGenotypes} / \code{getPhenotypes} for the +#' \code{residualizedGenotypes} / \code{molecularTraits} for the #' variant-window selection). #' @param region Optional single-range \code{GRanges} describing the analysis #' window. Mutually exclusive with \code{traitId} (see the \code{QtlDataset} @@ -115,8 +115,8 @@ #' \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 +#' @param panelFilterParam 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 @@ -142,11 +142,11 @@ #' \code{separate_gwas} runs. Outcome-specific (uncolocalized) sets are #' included with \code{isColocalized = FALSE}. #' -#' Project it with \code{\link{getColocPairs}} (also available as -#' \code{as.data.frame}), \code{\link{getColocVariants}} or -#' \code{\link{getColocBoostOutcomes}}; timings are on -#' \code{\link{getComputingTime}} and the region-wide marginal -#' probabilities on \code{\link{getRegionVcp}}. +#' Project it with \code{\link{colocPairs}} (also available as +#' \code{as.data.frame}), \code{\link{colocVariants}} or +#' \code{\link{colocBoostOutcomes}}; timings are on +#' \code{\link{computingTime}} and the region-wide marginal +#' probabilities on \code{\link{regionVcp}}. #' @name colocboostPipeline #' @importFrom methods is setGeneric setMethod #' @importFrom S4Vectors mcols @@ -246,16 +246,16 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } # Reject SumStats objects that have not been passed through -# summaryStatsQc(). Both QtlSumStats and GwasSumStats expose getQcInfo(); +# summaryStatsQc(). Both QtlSumStats and GwasSumStats expose qcInfo(); # an empty list (the constructor default) signals "no QC run". .cbRequireSumStatsQc <- function(x, what) { if (is.null(x)) { return(invisible(NULL)) } - if (length(getQcInfo(x)) == 0L) { + if (length(qcInfo(x)) == 0L) { msg <- glue( "{what} must be passed through summaryStatsQc() before ", - "reaching colocboostPipeline (getQcInfo() returned an empty ", + "reaching colocboostPipeline (qcInfo() returned an empty ", "list). Call summaryStatsQc(x, ...) and pass the result." ) abort(msg) @@ -318,7 +318,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { split <- .cbSplitY(YperCtx, dedup$xMatch) outcomeInfo <- mutate( split$outcomeInfo, - study = getStudy(qd), + study = studyName(qd), dataForm = "individual" ) list( @@ -335,12 +335,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # @noRd .cbResolveBundleContexts <- function(qd, contexts) { if (is.null(contexts) || length(contexts) == 0L) { - return(getContexts(qd)) + return(contexts(qd)) } - available <- getContexts(qd) + available <- contexts(qd) bad <- setdiff(contexts, available) if (length(bad) > 0L) { - qdStudy <- getStudy(qd) + qdStudy <- studyName(qd) badStr <- str_flatten(bad, ", ") availStr <- str_flatten(available, ", ") msg <- glue( @@ -403,7 +403,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # @noRd .cbResidualizedY <- function(qd, ctx, traitId, region) { try_fetch( - getResidualizedPhenotypes( + residualizedPhenotypes( qd, contexts = ctx, traitId = traitId, @@ -424,7 +424,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # @noRd .cbResidualizedX <- function(qd, ctx, traitId, region, cisWindow, samples) { try_fetch( - getResidualizedGenotypes( + residualizedGenotypes( qd, contexts = ctx, traitId = traitId, @@ -699,7 +699,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { if (is.null(ss) || nrow(ss) == 0L) { return(list()) } - ldSketch <- getLdSketch(ss) + ldSketch <- ldSketch(ss) byContext <- if (!is.null(contexts) && length(contexts) > 0L) { is_in(as.character(ss$context), contexts) } else { @@ -742,9 +742,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # @noRd .cbQtlEntryPair <- function(i, ss, ldSketch, cutoffs) { .cbSumstatPair( - df = getSumStatsDf( + df = as.data.frame( ss, - study = as.character(ss$study)[[i]], + studyName = as.character(ss$study)[[i]], context = as.character(ss$context)[[i]], trait = as.character(ss$trait)[[i]], require = "Z" @@ -772,7 +772,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { if (is.null(gws) || nrow(gws) == 0L) { return(list()) } - ldSketch <- getLdSketch(gws) + ldSketch <- ldSketch(gws) compact(set_names( map( seq_len(nrow(gws)), @@ -789,9 +789,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # @noRd .cbGwasEntryPair <- function(i, gws, ldSketch, cutoffs) { .cbSumstatPair( - df = getSumStatsDf( + df = as.data.frame( gws, - study = as.character(gws$study)[[i]], + studyName = as.character(gws$study)[[i]], require = "Z" ), ldSketch = ldSketch, @@ -843,6 +843,14 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ) } +# One focal separate-GWAS run's sumstat bundle: every QTL pair plus the one +# GWAS under test, in that order, so the GWAS is the LAST outcome and its +# focal index is simply the outcome count. +# @noRd +.cbGwasRunBundle <- function(gwasKey, pairs, qtlKeys) { + .cbMergeSumstatBundles(pairs[c(qtlKeys, gwasKey)]) +} + # Build an empty result skeleton consistent with what the per-method # dispatch fills in. .cbEmptyResult <- function() { @@ -861,7 +869,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } # A requested analysis with nothing to run on would otherwise be a silent -# no-op: the caller gets an empty ColocBoostResult whose getComputingTime() +# no-op: the caller gets an empty ColocBoostResult whose computingTime() # 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 @@ -884,7 +892,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { "colocboostPipeline: {flag} = TRUE was requested, but there is no ", "{needed} to run it on. Skipping it -- the returned ", "ColocBoostResult will hold no confidence sets from this analysis ", - "and its getComputingTime() entry will be NULL." + "and its computingTime() entry will be NULL." ) warn(msg) } @@ -909,7 +917,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { hasSs, hasQtlSs, focalTrait, - methodArgs + methodArgs, + gwasRunBundles = list(), + hasGwasSs = FALSE ) { # Resolved first, in the order the runs are listed: .cbCanRun() warns # when a requested analysis has no data for it, and hoisting keeps those @@ -922,7 +932,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { "QTL data" ) runJoint <- .cbCanRun(jointGwas, hasSs, "jointGwas", ssNeeded) - runSeparate <- .cbCanRun(separateGwas, hasSs, "separateGwas", ssNeeded) + runSeparate <- .cbCanRun( + separateGwas, hasGwasSs, "separateGwas", "GWAS summary statistics" + ) compact(list( xqtl_coloc = if (runXqtl) { .cbRunXqtlOnly( @@ -934,12 +946,18 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ) }, joint_gwas = if (runJoint) { - .cbRunJointGwas(individualBundle, sumstatBundle, hasInd, methodArgs) + .cbRunJointGwas( + individualBundle, + sumstatBundle, + hasInd, + methodArgs, + gwasNames = names(gwasRunBundles) + ) }, separate_gwas = if (runSeparate) { .cbRunSeparateGwas( individualBundle, - sumstatBundle, + gwasRunBundles, hasInd, methodArgs ) @@ -998,13 +1016,18 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { focalTrait, methodArgs, qtlLdSketch = NULL, - qtlSumstatBundle = NULL + qtlSumstatBundle = NULL, + gwasRunBundles = list() ) { empty <- .cbEmptyResult() hasInd <- !is.null(individualBundle) hasSs <- length(sumstatBundle$sumstat) > 0L qtlSumstatBundle <- qtlSumstatBundle %||% .cbMergeSumstatBundles(list()) hasQtlSs <- length(qtlSumstatBundle$sumstat) > 0L + # separateGwas needs a GWAS, not merely "some summary statistics": a + # QTL-only sumstat input used to satisfy the old `hasSs` guard and then + # run one focal pass per QTL study. + hasGwasSs <- length(gwasRunBundles) > 0L if (!hasInd && !hasSs) { msg <- glue( "colocboostPipeline: no QTL inputs remain after selection. ", @@ -1024,7 +1047,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { hasSs, hasQtlSs, focalTrait, - methodArgs + methodArgs, + gwasRunBundles = gwasRunBundles, + hasGwasSs = hasGwasSs ) results <- .cbMergeRuns(empty, runs) .cbToResultObject( @@ -1227,15 +1252,21 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle, sumstatBundle, hasInd, - methodArgs + methodArgs, + gwasNames = character() ) { + ssNames <- names(sumstatBundle$sumstat) traits <- c( if (hasInd) individualBundle$outcomeNames else character(), - names(sumstatBundle$sumstat) + ssNames ) ldArgs <- .cbBuildLdArgs(sumstatBundle$LD) - nContexts <- if (hasInd) length(individualBundle$Y) else 0L - nGwas <- length(sumstatBundle$sumstat) + # The merged bundle holds QTL sumstats as well as GWAS, so split the + # labels rather than calling every sumstat a GWAS: a context is any + # outcome that is not one of the GWAS studies, whether it arrived as + # individual-level data or as summary statistics. + nGwas <- length(intersect(ssNames, gwasNames)) + nContexts <- length(traits) - nGwas msg <- glue( "====== Performing non-focal GWAS-xQTL ColocBoost on ", "{nContexts} contexts and {nGwas} GWAS. =====" @@ -1266,19 +1297,20 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # @noRd .cbRunSeparateGwas <- function( individualBundle, - sumstatBundle, + gwasRunBundles, hasInd, methodArgs ) { - ssNames <- names(sumstatBundle$sumstat) + # One run per GWAS study -- NOT per merged sumstat label. Each bundle + # already holds the QTL side plus its own GWAS. + ssNames <- names(gwasRunBundles) t1 <- Sys.time() separate <- set_names( map( - seq_along(ssNames), + ssNames, .cbSeparateGwasAt, - ssNames = ssNames, + gwasRunBundles = gwasRunBundles, individualBundle = individualBundle, - sumstatBundle = sumstatBundle, hasInd = hasInd, methodArgs = methodArgs ), @@ -1302,31 +1334,38 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # One focal GWAS-xQTL ColocBoost run -> its result. # @noRd .cbRunOneSeparateGwas <- function( - i, - study, + studyName, + runBundle, individualBundle, - sumstatBundle, hasInd, methodArgs ) { - ldIdx <- sumstatBundle$dict_sumstatLD[i, 2L] - ldArgs <- .cbBuildLdArgs(sumstatBundle$LD[ldIdx]) + # `runBundle` carries every QTL sumstat followed by this one GWAS, so the + # whole LD list and its dict come along -- the same shape as the joint + # run, but focal on the last outcome. + ldArgs <- .cbBuildLdArgs(runBundle$LD) traits <- c( if (hasInd) individualBundle$outcomeNames else character(), - study - ) - nContexts <- if (hasInd) length(individualBundle$Y) else 0L + names(runBundle$sumstat) + ) + # Every outcome but the focal GWAS is a context, whether it arrived as + # individual-level data or as summary statistics. Counting only + # individualBundle$Y reported "0 contexts" for a summary-statistic QTL + # run -- which was accurate about the call, because the QTL sumstats were + # not being passed at all. + nContexts <- length(traits) - 1L msg <- glue( "====== Performing focal GWAS-xQTL ColocBoost on {nContexts} ", - "contexts and {study} GWAS. =====" + "contexts and {studyName} GWAS. =====" ) inform(msg) args <- c( list( X = if (hasInd) individualBundle$X else NULL, Y = if (hasInd) individualBundle$Y else NULL, - sumstat = sumstatBundle$sumstat[i], + sumstat = runBundle$sumstat, dict_YX = if (hasInd) individualBundle$dict_YX else NULL, + dict_sumstatLD = runBundle$dict_sumstatLD, outcome_names = traits, focal_outcome_idx = length(traits), output_level = 2 @@ -1337,7 +1376,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # that object to colocboost as a positional argument. as.list(methodArgs) ) - .cbRun(str_c("Separate GWAS ColocBoost for ", study), args)$result + .cbRun(str_c("Separate GWAS ColocBoost for ", studyName), args)$result } # ============================================================================= @@ -1486,6 +1525,19 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # deduplicated LD list and dict_sumstatLD consistent for the subset. qtlKeys <- intersect(names(harmonized$pairs), names(qtlPairs)) qtlSumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs[qtlKeys]) + # The separate-GWAS runs are FOCAL: each is one GWAS tested against the + # whole QTL side, so each needs its own bundle of (every QTL pair + that + # one GWAS). Built the same way and for the same reason as the xQTL + # bundle above -- the deduplicated LD list and dict_sumstatLD have to + # match the subset, which subsetting the merged bundle would not give. + # Without this the separate loop ran over EVERY merged label and treated + # each QTL study as a focal GWAS in its own right. + gwasKeys <- setdiff(names(harmonized$pairs), qtlKeys) + gwasRunBundles <- set_names( + map(gwasKeys, .cbGwasRunBundle, pairs = harmonized$pairs, + qtlKeys = qtlKeys), + gwasKeys + ) .cbRunVariants( harmonized$individualBundle, sumstatBundle, @@ -1495,7 +1547,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { focalTrait, methodArgs, qtlLdSketch = qtlLdSketch, - qtlSumstatBundle = qtlSumstatBundle + qtlSumstatBundle = qtlSumstatBundle, + gwasRunBundles = gwasRunBundles ) } @@ -1514,7 +1567,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } .cbRequireSumStatsQc(gwasSumStats, "gwasSumStats") if (!is.null(qtlLdSketch)) { - .cbRequireMatchingLdSketches(qtlLdSketch, getLdSketch(gwasSumStats)) + .cbRequireMatchingLdSketches(qtlLdSketch, ldSketch(gwasSumStats)) } gwasPairs <- .cbGwasSumStatsBundle(gwasSumStats, cutoffs = cutoffs) if (length(gwasPairs) == 0L) { @@ -1551,7 +1604,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { jointGwas, separateGwas, samples, - panelFilterArgs, + panelFilterParam, signalScreenArgs, alleleFlip, methodArgs @@ -1578,7 +1631,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { 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(panelFilterArgs) + cutoffs = .panelCutoffs(panelFilterParam) ) } @@ -1600,7 +1653,7 @@ setMethod( jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, # `list()`, not ColocboostOptions(): the formal shadows the @@ -1623,7 +1676,7 @@ setMethod( jointGwas = jointGwas, separateGwas = separateGwas, samples = samples, - panelFilterArgs = panelFilterArgs, + panelFilterParam = panelFilterParam, signalScreenArgs = signalScreenArgs, alleleFlip = alleleFlip, methodArgs = methodArgs @@ -1646,13 +1699,13 @@ setMethod( jointGwas = FALSE, separateGwas = FALSE, alleleFlip = TRUE, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), methodArgs = ColocboostOptions() ) { .assertMethodOptions(methodArgs, "ColocboostOptions", "methodArgs") .cbAssertAnyRun(xqtlColoc, jointGwas, separateGwas) .cbRequireSumStatsQc(qtlData, "qtlData") - cutoffs <- .panelCutoffs(panelFilterArgs) + cutoffs <- .panelCutoffs(panelFilterParam) qtlPairs <- .cbQtlSumStatsBundle( qtlData, contexts = contexts, @@ -1668,7 +1721,7 @@ setMethod( separateGwas = separateGwas, focalTrait = focalTrait, methodArgs = methodArgs, - qtlLdSketch = getLdSketch(qtlData), + qtlLdSketch = ldSketch(qtlData), alleleFlip = alleleFlip, cutoffs = cutoffs ) @@ -1692,7 +1745,7 @@ setMethod( jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, # `list()`, not ColocboostOptions(): the formal shadows the @@ -1715,7 +1768,7 @@ setMethod( jointGwas = jointGwas, separateGwas = separateGwas, samples = samples, - panelFilterArgs = panelFilterArgs, + panelFilterParam = panelFilterParam, signalScreenArgs = signalScreenArgs, alleleFlip = alleleFlip, methodArgs = methodArgs @@ -1738,7 +1791,7 @@ setMethod( jointGwas, separateGwas, samples, - panelFilterArgs, + panelFilterParam, signalScreenArgs, alleleFlip, methodArgs @@ -1753,7 +1806,7 @@ setMethod( samples = samples, screenSpec = screenSpec ) - cutoffs <- .panelCutoffs(panelFilterArgs) + cutoffs <- .panelCutoffs(panelFilterParam) ss <- .cbMultiStudySumstats( qtlData, contexts, @@ -1784,7 +1837,7 @@ setMethod( # nothing to contribute. # @noRd .cbStudyBundle <- function( - study, + studyName, qtlDatasets, contexts, traitId, @@ -1794,7 +1847,7 @@ setMethod( screenSpec ) { sub <- .cbIndividualBundle( - qtlDatasets[[study]], + qtlDatasets[[studyName]], contexts = contexts, traitId = traitId, region = region, @@ -1805,7 +1858,7 @@ setMethod( if (is.null(sub)) { return(NULL) } - .cbPrefixStudyNames(sub, study) + .cbPrefixStudyNames(sub, studyName) } # @noRd @@ -1835,7 +1888,7 @@ setMethod( samples, screenSpec ) { - qtlDatasets <- getQtlDatasets(qtlData) + qtlDatasets <- qtlDatasets(qtlData) subs <- compact(map( names(qtlDatasets), .cbStudyBundle, @@ -1880,11 +1933,11 @@ setMethod( # Prefix a study's X names + outcome names with "{study}:" (Y names track the # outcome names). # @noRd -.cbPrefixStudyNames <- function(sub, study) { - outcomeNames <- str_c(study, sub$outcomeNames, sep = ":") +.cbPrefixStudyNames <- function(sub, studyName) { + outcomeNames <- str_c(studyName, sub$outcomeNames, sep = ":") renamed <- list_assign( sub, - X = set_names(sub$X, str_c(study, names(sub$X), sep = ":")), + X = set_names(sub$X, str_c(studyName, names(sub$X), sep = ":")), Y = set_names(sub$Y, outcomeNames), outcomeNames = outcomeNames ) @@ -1895,7 +1948,7 @@ setMethod( return(renamed) } # `studyLabel` so the data mask cannot shadow it with the `study` column. - studyLabel <- study + studyLabel <- studyName list_assign( renamed, outcomeInfo = mutate( @@ -1915,7 +1968,7 @@ setMethod( traitId, cutoffs = NULL ) { - embeddedSs <- getSumStats(qtlData) + embeddedSs <- sumStats(qtlData) if (is.null(embeddedSs)) { return(list(qtlPairs = list(), qtlLdSketch = NULL)) } @@ -1927,7 +1980,7 @@ setMethod( traitId = traitId, cutoffs = cutoffs ), - qtlLdSketch = getLdSketch(embeddedSs) + qtlLdSketch = ldSketch(embeddedSs) ) } @@ -1945,21 +1998,19 @@ setMethod( .fmSerScreen(X, Y[, j], spec, fallback = FALSE) } -# Run one separate-GWAS colocboost fit for sumstat index `i`. +# Run one separate-GWAS colocboost fit for GWAS study `gwasName`. # @noRd .cbSeparateGwasAt <- function( - i, - ssNames, + gwasName, + gwasRunBundles, individualBundle, - sumstatBundle, hasInd, methodArgs ) { .cbRunOneSeparateGwas( - i, - ssNames[[i]], + gwasName, + gwasRunBundles[[gwasName]], individualBundle, - sumstatBundle, hasInd, methodArgs ) @@ -1981,6 +2032,21 @@ setMethod( #' @export ColocboostOptions <- function(...) { extra <- list(...) + .configRefuseOwned( + extra, + c( + X = "supplied from the data by the pipeline", + Y = "supplied from the data by the pipeline", + dict_YX = "supplied from the data by the pipeline", + dict_sumstatLD = "supplied from the data by the pipeline", + sumstat = "supplied from the data by the pipeline", + LD = "supplied from the data by the pipeline", + outcome_names = "supplied from the data by the pipeline", + focal_outcome_idx = "supplied from the data by the pipeline", + output_level = "supplied from the data by the pipeline" + ), + "ColocboostOptions" + ) .cbRefusePipelineOwned(extra) .newMethodOptions( "colocboost::colocboost", diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index 163835b6..f4b0599e 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -154,43 +154,6 @@ BoundaryMergeParam <- function( ) } -# 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 @@ -234,8 +197,8 @@ BoundaryMergeParam <- function( #' blocks. #' #' @section LD-sketch compatibility check: Per block: -#' \code{getLdSketch(twasWeights)} (when non-NULL) must come from the same -#' reference panel as \code{getLdSketch(gwasSumStats)} --- same samples, same +#' \code{ldSketch(twasWeights)} (when non-NULL) must come from the same +#' reference panel as \code{ldSketch(gwasSumStats)} --- same samples, same #' allele orientation on the shared variants. The two need NOT carry the same #' variants; a partial overlap, which is what QC-ing the two sides separately #' produces, only warns. A different sample set, a swapped A1/A2 on a shared @@ -243,7 +206,7 @@ BoundaryMergeParam <- function( #' #' @param gwasSumStats A \code{\link{GwasSumStats}} whose elements are LD #' blocks (at least two), keyed by its \code{blockId} column, with -#' \code{getQcInfo()} non-empty. Build it with +#' \code{qcInfo()} non-empty. Build it with #' \code{loadGwasSumStatsFromManifest(..., ldBlocks = )} and pass it #' through \code{\link{summaryStatsQc}}. #' @param twasWeights The per-gene weight source. Either (a) a FLAT @@ -275,8 +238,9 @@ BoundaryMergeParam <- function( #' 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 L Integer. Max number of single effects in cTWAS fine-mapping. -#' Default \code{5}. Pass-through to \code{ctwas::ctwas_sumstats}. +#' @param maxNumSingleEffects 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}, @@ -297,7 +261,7 @@ BoundaryMergeParam <- function( #' context-agnostic SNP background of each run as one extra \code{CtwasResult} #' row (\code{study = context = "SNP"}, mirroring cTWAS's own \code{"SNP"} #' group) so the full ctwas output is reconstructable from -#' \code{\link{getFinemap}} / \code{getSusieAlpha}. Default \code{FALSE} -- +#' \code{\link{ctwasPosteriors}} / \code{susieAlpha}. Default \code{FALSE} -- #' the SNP rows are the null background and are dropped from the structured #' gene-level result. #' @param methodArgs Additional arguments forwarded to ctwas, built @@ -329,12 +293,17 @@ BoundaryMergeParam <- function( #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", #' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) #' gwasByRegion <- summaryStatsQc(gss, -#' panelFilter = PanelFilterParam(mafCutoff = 0.0025)) +#' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' ctwasPipeline(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample), #' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), -#' methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) +#' methodArgs = CtwasOptions( +#' regionData = CtwasRegionDataOptions(min_group_size = 1), +#' estParam = CtwasEstParamOptions( +#' min_group_size = 1, min_p_single_effect = 0 +#' ) +#' )) #' @export ctwasPipeline <- function( gwasSumStats, @@ -342,7 +311,7 @@ ctwasPipeline <- function( twasZ = NULL, fineMappingResult = NULL, method = NULL, - L = 5L, + maxNumSingleEffects = 5L, numThreads = 1L, ctwasPriorArgs = CtwasPriorParam(), variantPruningArgs = VariantPruningParam(), @@ -369,7 +338,7 @@ ctwasPipeline <- function( variantPruningArgs = variantPruningArgs, ctwasPriorArgs = ctwasPriorArgs, numThreads = numThreads, - L = L, + maxNumSingleEffects = maxNumSingleEffects, boundaryMergeArgs = boundaryMergeArgs, gwasStudy = gwasStudy, keepSnps = keepSnps, @@ -395,7 +364,7 @@ ctwasPipeline <- function( inputs, ctwasPriorArgs, boundaryMergeArgs, - L, + maxNumSingleEffects, numThreads, methodArgs ) { @@ -412,7 +381,7 @@ ctwasPipeline <- function( ) finemap <- finemapCtwasRegions( screened, - L = L, + maxNumSingleEffects = maxNumSingleEffects, numThreads = numThreads, methodArgs = methodArgs ) @@ -422,7 +391,7 @@ ctwasPipeline <- function( .ctwasMaybeMerge( finemap, boundaryMergeArgs = boundaryMergeArgs, - L = L, + maxNumSingleEffects = maxNumSingleEffects, numThreads = numThreads, methodArgs = methodArgs ) @@ -441,7 +410,7 @@ ctwasPipeline <- function( variantPruningArgs, ctwasPriorArgs, numThreads, - L, + maxNumSingleEffects, boundaryMergeArgs, gwasStudy, keepSnps, @@ -459,7 +428,7 @@ ctwasPipeline <- function( inputs, ctwasPriorArgs = ctwasPriorArgs, boundaryMergeArgs = boundaryMergeArgs, - L = L, + maxNumSingleEffects = maxNumSingleEffects, numThreads = numThreads, methodArgs = methodArgs ) @@ -475,9 +444,9 @@ ctwasPipeline <- function( # regions and re-fine-map. Merge-transparent downstream (keyed by gene id). # @noRd .ctwasMaybeMerge <- function( - finemap, + posteriors, boundaryMergeArgs, - L, + maxNumSingleEffects, numThreads, methodArgs ) { @@ -489,11 +458,11 @@ ctwasPipeline <- function( # 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, + posteriors, pipThresh = mergePipThresh, filterCs = mergeFilterCs, maxSNP = mergeMaxSNP, - L = L, + maxNumSingleEffects = maxNumSingleEffects, numThreads = numThreads, methodArgs = methodArgs ) @@ -532,7 +501,7 @@ ctwasPipeline <- function( #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", #' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) #' gwasByRegion <- summaryStatsQc(gss, -#' panelFilter = PanelFilterParam(mafCutoff = 0.0025)) +#' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' assembleCtwasInputs(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample)) #' @export @@ -555,14 +524,18 @@ assembleCtwasInputs <- function( 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. + globalPanelInfo <- .ctwasGlobalPanelInfo(gwasSumStats) gwasSumStats <- .ctwasGwasByBlock(gwasSumStats) twasWeights <- .ctwasResolveAndValidateWeights(twasWeights, gwasSumStats) .ctwasValidateOptional(twasZ, fineMappingResult) regionIds <- names(gwasSumStats) resolvedMethod <- .ctwasResolveMethod(twasWeights, method) - fp <- .ctwasFirstPass(regionIds, gwasSumStats, twasWeights) + fp <- .ctwasFirstPass( + regionIds, + gwasSumStats, + twasWeights, + globalPanelInfo + ) globalGwasSnpIds <- unique(list_c(map(fp$zSnpPieces, "id"))) cutoffs <- list( twasWeightCutoff = twasWeightCutoff, @@ -622,7 +595,7 @@ assembleCtwasInputs <- function( # The collection must be QC'd, and its block keys must be usable as region ids. # @noRd .ctwasValidateGwasEntries <- function(gwasSumStats) { - if (length(getQcInfo(gwasSumStats)) == 0L) { + if (length(qcInfo(gwasSumStats)) == 0L) { msg <- glue( "assembleCtwasInputs: `gwasSumStats` has no QC record. ", "Call summaryStatsQc() first." @@ -655,9 +628,23 @@ assembleCtwasInputs <- function( ) } +# One block's slice of the collection. `[` carries the collection-level +# ldSketch through verbatim, and combineGwasSumStats() deliberately UNIONS +# the per-piece panels, so without narrowing here every block references the +# whole chromosome and its LD panel would cover all of it (a +# chr19-wide panel runs to ~155 GB). Narrowed to the block's own variants +# the same way summaryStatsQc narrows the sketch it retains. # @noRd .ctwasPickBlock <- function(i, x) { - x[i] + block <- x[i] + sketch <- ldSketch(block) + if (is.null(sketch)) { + return(block) + } + methods::initialize( + block, + ldSketch = .subsetSketchToIds(sketch, as.list(block)) + ) } # Resolve a flat weight source into per-region buckets (cTWAS's p0 start-of- @@ -742,9 +729,26 @@ assembleCtwasInputs <- function( # ldFileByRegion). # @noRd # One region's GWAS LD sketch, checked against the region's weights. +# The ctwas-shaped snpInfo for the whole collection's panel, captured BEFORE +# .ctwasGwasByBlock() narrows each block's sketch to its own variants. A +# gene's cis SPAN has to cover every block it reaches or +# ctwas::get_boundary_genes cannot route it to merge_regions, so the span is +# measured against this table rather than against any one block's panel. +# +# NULL when the collection carries no sketch -- .ctwasRegionGwasLd() reports +# that case with its own message, so this must not pre-empt it. +# @noRd +.ctwasGlobalPanelInfo <- function(gwasSumStats) { + sketch <- ldSketch(gwasSumStats) + if (is.null(sketch)) { + return(NULL) + } + .ctwasSnpInfoForBlock(sketch) +} + # @noRd .ctwasRegionGwasLd <- function(rid, gwasSumStats, twasWeights) { - gwasLd <- getLdSketch(gwasSumStats[[rid]]) + gwasLd <- ldSketch(gwasSumStats[[rid]]) if (is.null(gwasLd)) { msg <- glue( "ctwasPipeline: GwasSumStats for region '{rid}' carries no ", @@ -754,7 +758,7 @@ assembleCtwasInputs <- function( } tw <- twasWeights[[rid]] if (!is.null(tw)) { - .ctwasRequireMatchingLdSketches(getLdSketch(tw), gwasLd) + .ctwasRequireMatchingLdSketches(ldSketch(tw), gwasLd) } gwasLd } @@ -774,24 +778,40 @@ assembleCtwasInputs <- function( .ctwasBuildSingleRegionInfo(rid, gwasSumStats[[rid]]) } -.ctwasFirstPass <- function(regionIds, gwasSumStats, twasWeights) { +# First pass: one LD panel per region, plus the z_snp / region_info / snp_map +# pieces built from them. +# +# Each region gets a token of its own. The panel cache used to be keyed on the +# genotype file backing the sketch, which every block on a chromosome shares, +# so only the first block's panel was ever computed and every other region +# silently read that one back out. +# +# `globalVariance` is assembled from the per-block variance vectors rather +# than re-read: a boundary gene needs the variance of its out-of-block weight +# variants too, and the blocks partition the panel, so their union is exactly +# the global vector. It costs nothing beyond the panels themselves. +# @noRd +.ctwasFirstPass <- function( + regionIds, + gwasSumStats, + twasWeights, + globalPanelInfo = NULL +) { 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) + ldTokens <- .ctwasRegionLdTokens(regionIds, sketches) ldPanelsByRegion <- set_names( - map(sketches[firstOfKey], .ctwasComputeFullPanelLd), - ldKeys[firstOfKey] + map(sketches, .ctwasPanelFor), + unname(ldTokens) ) - panels <- unname(ldPanelsByRegion[ldKeys]) + panels <- unname(ldPanelsByRegion) list( + globalPanelInfo = globalPanelInfo, + globalVariance = list_c(map(panels, "variance")), ldPanelsByRegion = ldPanelsByRegion, zSnpPieces = set_names( map2(regionIds, panels, .ctwasZSnpAt, gwasSumStats = gwasSumStats), @@ -810,7 +830,7 @@ assembleCtwasInputs <- function( ), regionIds ), - ldFileByRegion = set_names(ldKeys, regionIds) + ldFileByRegion = ldTokens ) } @@ -880,7 +900,9 @@ assembleCtwasInputs <- function( minPipCutoff = cutoffs$minPipCutoff, maxNumVariants = cutoffs$maxNumVariants, gwasSnpIds = globalGwasSnpIds, - regionSnpIds = fp$snpMap[[rid]]$id + regionSnpIds = fp$snpMap[[rid]]$id, + globalPanelInfo = fp$globalPanelInfo, + globalVariance = fp$globalVariance ) if (length(blockWeights) == 0L) { return(NULL) @@ -951,7 +973,12 @@ assembleCtwasInputs <- function( #' estCtwasGroupPriors(ctwasInputsExample, #' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), -#' methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) +#' methodArgs = CtwasOptions( +#' regionData = CtwasRegionDataOptions(min_group_size = 1), +#' estParam = CtwasEstParamOptions( +#' min_group_size = 1, min_p_single_effect = 0 +#' ) +#' )) #' @export estCtwasGroupPriors <- function( inputs, @@ -972,15 +999,19 @@ estCtwasGroupPriors <- function( } numThreads <- as.integer(numThreads) inputs <- .ctwasResolveLdPaths(inputs) - zGene <- .ctwasEnsureZGene(inputs, numThreads, methodArgs) + zGene <- .ctwasEnsureZGene(inputs, numThreads, methodArgs$geneZ) regionData <- .ctwasAssembleRegionData( inputs, zGene, thin, numThreads, - methodArgs + methodArgs$regionData + ) + boundaryGenes <- .ctwasBoundaryGenes( + inputs, + numThreads, + methodArgs$boundaryGenes ) - boundaryGenes <- .ctwasBoundaryGenes(inputs, numThreads, methodArgs) paramRes <- .ctwasEstParamOrFallback( regionData, niterPrefit, @@ -989,7 +1020,7 @@ estCtwasGroupPriors <- function( numThreads, thin, fallbackToPrefit, - methodArgs + methodArgs$estParam ) # 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 @@ -1070,7 +1101,7 @@ estCtwasGroupPriors <- function( #' \code{screen_res}). #' #' @param screenResult A list returned by \code{\link{screenCtwasRegions}}. -#' @param L Pass-through. +#' @param maxNumSingleEffects Pass-through. #' @param numThreads Number of cores. #' @param methodArgs Additional arguments forwarded to ctwas, built #' with \code{\link{CtwasOptions}}. Names are checked against what @@ -1092,19 +1123,24 @@ estCtwasGroupPriors <- function( #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", #' ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) #' gwasByRegion <- summaryStatsQc(gss, -#' panelFilter = PanelFilterParam(mafCutoff = 0.0025)) +#' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, #' twasWeights = list(ctwasWeightsExample)) #' est <- estCtwasGroupPriors(inp, #' ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), -#' methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) +#' methodArgs = CtwasOptions( +#' regionData = CtwasRegionDataOptions(min_group_size = 1), +#' estParam = CtwasEstParamOptions( +#' min_group_size = 1, min_p_single_effect = 0 +#' ) +#' )) #' screened <- screenCtwasRegions(est) -#' finemapCtwasRegions(screened, L = 5L) +#' finemapCtwasRegions(screened, maxNumSingleEffects = 5L) #' @export finemapCtwasRegions <- function( screenResult, - L = 5L, + maxNumSingleEffects = 5L, numThreads = 1L, methodArgs = CtwasOptions() ) { @@ -1113,7 +1149,12 @@ finemapCtwasRegions <- function( abort("Package 'ctwas' is required for finemapCtwasRegions.") } screenResult <- .ctwasResolveLdPaths(screenResult) - fmRes <- .ctwasFinemapOrEmpty(screenResult, L, numThreads, methodArgs) + fmRes <- .ctwasFinemapOrEmpty( + screenResult, + maxNumSingleEffects, + numThreads, + methodArgs + ) # Repair cTWAS's molecular_id mislabel (first-"|" split of our composite # id). list( @@ -1163,8 +1204,8 @@ finemapCtwasRegions <- function( #' \code{FALSE}. #' @param maxSNP Numeric (length 1). Per-merged-region SNP cap. Default #' \code{Inf}. -#' @param L Integer. Max number of single effects for the merged-region -#' re-fine-mapping (LD path only). Default \code{5}. +#' @param maxNumSingleEffects Integer. Max number of single effects for the +#' merged-region re-fine-mapping (LD path only). Default \code{5}. #' @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 @@ -1184,7 +1225,7 @@ mergeCtwasBoundaryRegions <- function( pipThresh = 0.5, filterCs = FALSE, maxSNP = Inf, - L = 5L, + maxNumSingleEffects = 5L, numThreads = 1L, methodArgs = CtwasOptions() ) { @@ -1209,12 +1250,12 @@ mergeCtwasBoundaryRegions <- function( maxSNP, numThreads ) - fa <- .ctwasMergeDispatch(finemapResult, common, L) + fa <- .ctwasMergeDispatch(finemapResult, common, maxNumSingleEffects) # 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) + user <- as.list(methodArgs$merge) callArgs <- c(fa$args, user[setdiff(names(user), names(fa$args))]) res <- exec(fa$fn, !!!callArgs) .ctwasApplyMergeResult(finemapResult, res) @@ -1652,7 +1693,7 @@ mergeCtwasBoundaryRegions <- function( `slot<-`( combined[idx, ], "ldSketch", - value = getLdSketch(gwasSumStats[[rid]]) + value = ldSketch(gwasSumStats[[rid]]) ) } @@ -1674,7 +1715,7 @@ mergeCtwasBoundaryRegions <- function( abort(msg) } home <- .ctwasPlaceByAnchor( - getTraitPosition(combined), + traitPosition(combined), gwasSumStats ) unplaced <- sum(is.na(home)) @@ -2017,7 +2058,7 @@ mergeCtwasBoundaryRegions <- function( .ctwasMkEntry <- function(fm, sa, runResult) { geneCoords <- .ctwasGeneCoords(runResult$weights) CtwasResultEntry( - finemap = .ctwasRangePayload(fm, geneCoords), + posteriors = .ctwasRangePayload(fm, geneCoords), susieAlpha = .ctwasRangePayload(sa, geneCoords), groupPriors = runResult$param, regionInfo = .ctwasRangeRegionInfo(runResult$region_info) @@ -2060,7 +2101,7 @@ mergeCtwasBoundaryRegions <- function( # background as ONE extra row (study = context = "SNP"), mirroring cTWAS's own # "SNP" group in `group_prior`. Kept off by default because the SNP rows are the # null background and bloat the structured gene-level result; when on, the full -# ctwas run is reconstructable from `getFinemap()` / `getSusieAlpha()`. +# ctwas run is reconstructable from `ctwasPosteriors()` / `susieAlpha()`. # @noRd .ctwasRunToRows <- function(runResult, gwasStudy, method, keepSnps = FALSE) { geneIds <- names(runResult$weights) @@ -2174,7 +2215,7 @@ mergeCtwasBoundaryRegions <- function( jointContexts <- map_chr(rows, "jointContexts") CtwasResult( gwasStudy = map_chr(rows, "gwasStudy"), - study = map_chr(rows, "study"), + studyName = map_chr(rows, "study"), context = map_chr(rows, "context"), method = map_chr(rows, "method"), entry = map(rows, "entry"), @@ -2274,7 +2315,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } # Row subset carries every column forward (joint* / region / ...); the old # hand-listed rebuild silently dropped them. - methods::initialize(tw[keep, ], ldSketch = getLdSketch(tw)) + methods::initialize(tw[keep, ], ldSketch = ldSketch(tw)) } # Build the per-variant Z data.frame ctwas expects from a GwasSumStats. @@ -2391,7 +2432,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # Derive the block's [start, stop] from the GWAS variants actually in this # block (the GwasSumStats entry GRanges) -- NOT the LD sketch. When many # blocks share one whole-chromosome LD payload (the common one-file-per-chr - # layout), getSnpInfo(ldSketch) spans the entire chromosome, so every region + # layout), snpInfo(ldSketch) spans the entire chromosome, so every region # 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). @@ -2457,38 +2498,102 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } -# Compute the full-panel LD ONCE and return everything the rest of the -# pipeline needs to consume it. Returns a list with: -# R : full-panel correlation matrix (n_var x n_var, dimnames = -# SNP IDs). Single source of truth for both the per-region -# LD loader closure and the per-gene R_wgt submatrices. +# Everything about a block's LD panel that is cheap, plus the sketch it came +# from so the expensive part can be built later. Returns a list with: # snpInfo : ctwas-shaped per-block table (chrom, id, pos, alt, ref) # -- both the snp_map element and the snpinfo loader return. -# variance : named numeric vector of per-variant dosage variance from -# the LD reference. Used to scale non-standardized TWAS -# weights to the correlation scale that ctwas expects. +# variance : named numeric vector of per-variant dosage variance from the +# LD reference, used to scale non-standardized TWAS weights to +# the correlation scale ctwas expects. +# sketch : the block's narrowed LD sketch, retained because the n x n +# correlation is deliberately NOT built here. +# +# ctwas pulls a region's LD only while fine-mapping, and only for the regions +# that survive screening, so building every block's matrix up front spent +# O(n^2) apiece on panels that are frequently never read at all. # @noRd -.ctwasComputeFullPanelLd <- function(gwasLd) { +.ctwasPanelFor <- function(gwasLd) { # Share the validator with `.ldFromSketch()`, the entry point every other - # pipeline uses. This function cannot use `.ldFromSketch()` itself -- it - # needs the whole panel rather than a matched subset, and returns the - # per-variant variance alongside R -- but skipping the guard meant a NULL - # or non-panel sketch surfaced as "unable to find an inherited method for - # 'getSnpInfo'" instead of saying the LD reference was missing. + # pipeline uses: skipping the guard meant a NULL or non-panel sketch + # surfaced as "unable to find an inherited method for 'snpInfo'" + # instead of saying the LD reference was missing. .ldFromSketchValidate(gwasLd, "ctwasPipeline") - snpInfoCtwas <- .ctwasSnpInfoForBlock(gwasLd) + snpInfo <- .ctwasSnpInfoForBlock(gwasLd) geno <- .ldSketchDosage( gwasLd, - seq_len(nrow(snpInfoCtwas)), + seq_len(nrow(snpInfo)), meanImpute = TRUE ) - snpIds <- snpInfoCtwas$id - R <- `dimnames<-`( + list( + snpInfo = snpInfo, + variance = set_names( + apply(geno, 2, stats::var, na.rm = TRUE), + snpInfo$id + ), + sketch = gwasLd + ) +} + +# The block's full n x n correlation, built on request. A panel that already +# carries one -- a caller who computed it, or a payload it travelled with -- +# is used as it stands rather than rebuilt. +# @noRd +.ctwasPanelLd <- function(panel) { + if (!is.null(panel$R)) { + return(panel$R) + } + .ctwasPanelLdFor( + panel, + seq_len(nrow(panel$snpInfo)), + panel$snpInfo$id + ) +} + +# The correlation over `vids` alone. Identical to slicing the full matrix -- +# mean imputation is per column, so correlating a subset of the dosages gives +# the same pairwise values -- at O(|vids|^2) instead of O(n^2). +# @noRd +.ctwasPanelLdSubset <- function(panel, vids) { + idx <- match(vids, panel$snpInfo$id) + if (anyNA(idx)) { + msg <- glue( + "ctwasPipeline: {sum(is.na(idx))} weight variant(s) absent from ", + "the block's LD panel." + ) + abort(msg) + } + if (!is.null(panel$R)) { + return(panel$R[vids, vids, drop = FALSE]) + } + .ctwasPanelLdFor(panel, idx, vids) +} + +# @noRd +.ctwasPanelLdFor <- function(panel, idx, ids) { + geno <- .ldSketchDosage(panel$sketch, idx, meanImpute = TRUE) + `dimnames<-`( computeLd(geno, method = "sample"), - list(snpIds, snpIds) + list(ids, ids) ) - variance <- set_names(apply(geno, 2, stats::var, na.rm = TRUE), snpIds) - list(R = R, snpInfo = snpInfoCtwas, variance = variance) +} + +# Whether to build the block's full correlation once and slice it per gene, +# or to compute one small correlation per gene. Per-gene submatrices are what +# keep a block ctwas never fine-maps from ever forming its n x n matrix, but +# g genes on |vids| variants each cost sum(|vids|^2) against n^2 for the +# whole block, so the full matrix wins once the weights are dense enough. +# Returns the full matrix in that case and NULL in the other. +# @noRd +.ctwasRWgtSource <- function(ldPanel, nVids) { + # Already built: slicing it is free, so there is nothing to weigh up. + if (!is.null(ldPanel$R)) { + return(ldPanel$R) + } + n <- as.numeric(nrow(ldPanel$snpInfo)) + if (length(nVids) == 0L || sum(as.numeric(nVids)^2) < n^2) { + return(NULL) + } + .ctwasPanelLd(ldPanel) } # Harmonize TWAS weight variants against the LD reference panel. Same @@ -2647,9 +2752,29 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { panelSnps[sort(m$idxA)] } -# R_wgt is sliced from the cached full-panel LD by SNP ID -- no -# per-gene genotype re-extraction. Variants absent from the panel -# are dropped from that gene's row set. +# The ctwas per-gene weight entries for one block. +# +# Two variant sets, because they answer different questions. `gwasSnpIds` is +# the GLOBAL set: it bounds each gene's cis SPAN, which has to cover every +# block the gene reaches for boundary detection to work. `regionSnpIds` is +# this block's own set: it bounds the weight vector actually FITTED, because +# ctwas fine-maps one region at a time. +# +# So anything feeding the SPAN is read off the whole panel rather than off +# `ldPanel`, whose sketch is narrowed to this block -- `globalPanelInfo` for +# the coordinates, `globalVariance` for the scaling, and the same table for +# allele harmonization, since an out-of-block weight variant has to survive +# matching to be counted in p0/p1 at all. Reading any of them off the block +# would clip a boundary gene back to its home region, which is exactly what +# p0/p1 exist to prevent. The allele columns agree with the block's own +# table wherever the two overlap, so nothing about the in-block result +# changes. +# +# Genes are prepared in one sweep and given their `R_wgt` in a second, so +# that choice is made with every gene's fitted size in hand -- which is what +# lets a block no gene needs densely skip its n x n correlation entirely. +# .ctwasRWgtSource() picks, and says why. Variants absent from the panel are +# dropped from that gene's row set. # @noRd .ctwasBuildWeights <- function( twasWeights, @@ -2660,19 +2785,19 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { minPipCutoff = 0, maxNumVariants = Inf, gwasSnpIds = NULL, - regionSnpIds = NULL + regionSnpIds = NULL, + globalPanelInfo = NULL, + globalVariance = NULL ) { - # Two variant sets, because they answer different questions. `gwasSnpIds` is - # the GLOBAL set: it bounds the gene's cis SPAN, which has to cover every - # block the gene reaches for boundary detection to work. `regionSnpIds` is - # this block's own set: it bounds the weight vector actually FITTED, because - # ctwas fine-maps one region at a time. - panelSnps <- .ctwasPanelSnpsForGwas(rownames(ldPanel$R), gwasSnpIds) + spanInfo <- globalPanelInfo %||% ldPanel$snpInfo + panelSnps <- .ctwasPanelSnpsForGwas(spanInfo$id, gwasSnpIds) ctx <- list( ldPanel = ldPanel, + spanInfo = spanInfo, panelSnps = panelSnps, regionSnps = regionSnpIds, - refVariants = .ctwasRefVariants(ldPanel$snpInfo), + refVariants = .ctwasRefVariants(spanInfo), + spanVariance = globalVariance %||% ldPanel$variance, fineMappingResult = fineMappingResult, cutoffs = list( twasWeightCutoff = twasWeightCutoff, @@ -2681,12 +2806,20 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { maxNumVariants = maxNumVariants ) ) - genes <- compact(map( + prepared <- compact(map( seq_len(nrow(twasWeights)), - .ctwasGeneWeight, + .ctwasGenePrepared, twasWeights = twasWeights, ctx = ctx )) + fullR <- .ctwasRWgtSource(ldPanel, map_int(prepared, .ctwasPreparedSize)) + genes <- map( + prepared, + .ctwasGeneEntryFor, + ldPanel = ldPanel, + fullR = fullR, + spanInfo = spanInfo + ) # 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")) @@ -2709,17 +2842,17 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # study/context/trait/method identity for gene row `i` + its collection key. # @noRd .ctwasGeneMeta <- function(twasWeights, i) { - study <- as.character(twasWeights$study)[[i]] + studyName <- as.character(twasWeights$study)[[i]] context <- as.character(twasWeights$context)[[i]] trait <- as.character(twasWeights$trait)[[i]] method <- as.character(twasWeights$method)[[i]] list( - study = study, + study = studyName, context = context, trait = trait, method = method, traitPos = .ctwasTraitPosAt(twasWeights, i), - key = as.character(glue("{study}|{context}|{trait}|{method}")) + key = as.character(glue("{studyName}|{context}|{trait}|{method}")) ) } @@ -2758,7 +2891,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # fit) and variance scaling for non-standardized weights (w * sqrt(per-variant # genotype variance from the LD panel)). Returns the adjusted weight vector. # @noRd -.ctwasAdjustGeneWeights <- function(parts, aligned, ldPanel) { +.ctwasAdjustGeneWeights <- function(parts, aligned, spanVariance) { fits <- .rowFits(parts) shrank <- length(aligned$keptIdx) < length(aligned$origVids) # A NULL renormalization means the fit could not be re-keyed onto the @@ -2776,7 +2909,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (.rowStandardized(parts)) { return(renormalized) } - varLookup <- ldPanel$variance[aligned$vids] + varLookup <- spanVariance[aligned$vids] if (anyNA(varLookup)) { msg <- glue( ".ctwasBuildWeights: missing genotype variance for ", @@ -2797,12 +2930,22 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # region boundary. Measuring the span over the fitted subset would clip a # boundary gene down to its home region and hide it from merge_regions. # @noRd -.ctwasGeneEntry <- function(vids, w, ldPanel, meta, spanVids = vids) { - panelInfo <- ldPanel$snpInfo +.ctwasGeneEntry <- function( + vids, + w, + rWgt, + meta, + spanVids = vids, + spanInfo +) { + # Span coordinates come from the whole-panel table, while `rWgt` was + # computed on the block's own panel: ctwas fine-maps one region at a + # time, but a boundary gene's span has to reach past it. + panelInfo <- spanInfo rowIdx <- match(spanVids, panelInfo$id) list( wgt = matrix(w, ncol = 1L, dimnames = list(vids, "wgt")), - R_wgt = ldPanel$R[vids, vids, drop = FALSE], + R_wgt = rWgt, type = meta$context, context = meta$context, gene_name = meta$trait, @@ -2828,7 +2971,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (!is_in("traitPos", .tupleColumnNames(twasWeights))) { return(NULL) } - tp <- getTraitPosition(twasWeights) + tp <- traitPosition(twasWeights) if (!methods::is(tp, "GRanges") || length(tp) < i) { return(NULL) } @@ -2839,7 +2982,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # (PIP/CS + magnitude + cap) -> entry. Returns list(key, entry), or NULL when # the gene contributes no usable variants. # @noRd -.ctwasGeneWeight <- function(i, twasWeights, ctx) { +.ctwasGenePrepared <- function(i, twasWeights, ctx) { # Polymorphic: the weight source may be a TwasWeights or a # FineMappingResult, so the payload comes from the class-aware bridge. parts <- .rowParts(twasWeights, i) @@ -2847,7 +2990,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (is.null(aligned)) { return(NULL) } - w <- .ctwasAdjustGeneWeights(parts, aligned, ctx$ldPanel) + w <- .ctwasAdjustGeneWeights(parts, aligned, ctx$spanVariance) meta <- .ctwasGeneMeta(twasWeights, i) finemapAux <- .ctwasGetFinemapAux( ctx$fineMappingResult, @@ -2878,14 +3021,42 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (!any(inRegion)) { return(NULL) } + # No LD yet. R_wgt is built in a second sweep, once every gene's fitted + # size is known and the block can choose between forming one full + # correlation and one small correlation per gene. list( key = meta$key, + vids = kept$vids[inRegion], + w = kept$w[inRegion], + spanVids = kept$vids, + meta = meta + ) +} + +# @noRd +.ctwasPreparedSize <- function(g) { + length(g$vids) +} + +# One prepared gene's ctwas entry. `fullR` is the block's correlation when +# .ctwasRWgtSource() chose to form it, and NULL when each gene computes its +# own small one. +# @noRd +.ctwasGeneEntryFor <- function(g, ldPanel, fullR, spanInfo) { + rWgt <- if (is.null(fullR)) { + .ctwasPanelLdSubset(ldPanel, g$vids) + } else { + fullR[g$vids, g$vids, drop = FALSE] + } + list( + key = g$key, entry = .ctwasGeneEntry( - kept$vids[inRegion], - kept$w[inRegion], - ctx$ldPanel, - meta, - spanVids = kept$vids + g$vids, + g$w, + rWgt, + g$meta, + spanVids = g$spanVids, + spanInfo = spanInfo ) ) } @@ -2909,32 +3080,33 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # csPurity : numeric vector aligned with csMembers # @noRd .ctwasGetFinemapAux <- function( - fineMappingResult, - study, + fmr, + studyName, context, trait, method ) { - if (is.null(fineMappingResult)) { + if (is.null(fmr)) { return(NULL) } - cols <- .tupleColumnNames(fineMappingResult) + cols <- .tupleColumnNames(fmr) selectors <- c( - list(study = study, method = method), + list(study = studyName, method = method), compact(list( context = if (is_in("context", cols)) context, trait = if (is_in("trait", cols)) trait )) ) - selArgs <- c(list(fineMappingResult), selectors) + # `fineMappingResult` here is the accessor generic, not the `fmr` + # argument -- the two must not be conflated. entry <- try_fetch( - exec(getFineMappingResult, !!!selArgs), + exec(fineMappingResult, fmr, !!!selectors), error = function(cnd) NULL ) if (is.null(entry)) { return(NULL) } - tl <- getTopLoci(entry, raw = TRUE) + tl <- topLoci(entry, raw = TRUE) if (nrow(tl) == 0L) { return(NULL) } @@ -3195,6 +3367,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } stored <- as.character(ldMap[["LD_file"]]) resolved <- map_chr(stored, .resolveCtwasLdToken) + resolved <- .ctwasRemintMissingTokens( + resolved, + .ctwasLdMapRegionIds(ldMap, length(resolved)) + ) if (identical(resolved, stored)) { return(payload) } @@ -3210,6 +3386,17 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasRekeyLdLoaders(rekeyed, keyMap) } +# The region ids an LD_map carries, falling back to positions when the table +# has no region_id column (the granular steps accept hand-built stubs). +# @noRd +.ctwasLdMapRegionIds <- function(ldMap, n) { + rid <- ldMap[["region_id"]] + if (is.null(rid) || length(rid) != n) { + return(as.character(seq_len(n))) + } + as.character(rid) +} + # Only "pecotmr://" tokens move; an ordinary path is the caller's own and is # left alone (an unresolvable bundled reference is an error worth hearing). # @noRd @@ -3267,7 +3454,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) abort(msg) } - panel$R + # Built here rather than up front: this is the only place a region's + # full LD is actually needed, and ctwas reaches it only for regions + # that survived screening. + .ctwasPanelLd(panel) } # Published explicitly so .ctwasCachedPanels can recover the cache from a # loader we built, instead of looking the name up inside the closure's @@ -3301,7 +3491,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # @noRd .ctwasLdPanelKey <- function(sketch) { handle <- .ldSketchHandle(sketch) - fmt <- getFormat(handle) + fmt <- genotypeFormat(handle) stem <- .genotypeReadPath(handle) candidates <- switch( fmt, @@ -3323,6 +3513,65 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { hit[[1L]] } +# ctwas asserts `file.exists()` on every `LD_map$LD_file` / `SNP_file` and +# then dispatches `LD_loader_fun(LD_file)` on that same string, so a token +# has to be BOTH an existing path and unique per region. The genotype file +# backing a sketch is shared by every block on a chromosome, which is why +# using it directly handed every block the first one's panel. A per-region +# empty sentinel satisfies both constraints, and nothing ever reads it -- +# the panels travel inside the loader closures. +# @noRd +.ctwasRegionLdTokens <- function(regionIds, sketches) { + # Fail here, with the sketch-specific message, if a block's panel has no + # readable payload: the panel builder is about to read dosages + # out of it. + walk(sketches, .ctwasLdPanelKey) + .ctwasMintLdTokens(regionIds) +} + +# The sentinels themselves. Separate from the validation above so the payload +# resolver can re-mint them without a sketch in hand. +# @noRd +.ctwasMintLdTokens <- function(regionIds) { + dir <- file.path(tempdir(), "pecotmr-ctwas-ld") + dir.create(dir, recursive = TRUE, showWarnings = FALSE) + tokens <- file.path(dir, str_c(.ctwasTokenSlug(regionIds), ".ld")) + walk(tokens, .ctwasTouchToken) + set_names(tokens, regionIds) +} + +# Sentinels live in the session tempdir, so a payload serialised in one +# session carries tokens that no longer exist in the next -- and ctwas +# asserts file.exists() on every one. Mint replacements; the caller re-keys +# the cached panels onto them, exactly as it does for a "pecotmr://" move. +# @noRd +.ctwasRemintMissingTokens <- function(tokens, regionIds) { + gone <- !file.exists(tokens) + if (!any(gone)) { + return(tokens) + } + replace(tokens, gone, unname(.ctwasMintLdTokens(regionIds[gone]))) +} + +# A filesystem-safe stem per region. The index prefix keeps two region ids +# that sanitize to the same string apart. +# @noRd +.ctwasTokenSlug <- function(regionIds) { + str_c( + seq_along(regionIds), + "_", + str_replace_all(as.character(regionIds), "[^A-Za-z0-9._-]+", "_") + ) +} + +# @noRd +.ctwasTouchToken <- function(path) { + if (!file.exists(path)) { + file.create(path) + } + invisible(NULL) +} + # Build a per-block snpInfo table restricted to variants present in the # GwasSumStats entry. Mirrors `.ctwasSnpInfoForBlock` but restricts to # the block's GWAS variants (intersected against the cached panel) so diff --git a/R/ctwasWrapper.R b/R/ctwasWrapper.R index 32ba3e4b..e0c03ce4 100644 --- a/R/ctwasWrapper.R +++ b/R/ctwasWrapper.R @@ -7,23 +7,6 @@ # 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 -- @@ -152,7 +135,7 @@ screenCtwasRegions <- function( z_snp = estResult$z_snp, ncore = as.integer(numThreads) ), - extra = methodArgs + extra = methodArgs$expand ) } else { estResult$region_data @@ -165,7 +148,7 @@ screenCtwasRegions <- function( group_prior_var = estResult$param$group_prior_var, ncore = as.integer(numThreads) ), - extra = methodArgs + extra = methodArgs$screen ) c( estResult, @@ -180,7 +163,12 @@ screenCtwasRegions <- function( # 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) { +.ctwasFinemapOrEmpty <- function( + screenResult, + maxNumSingleEffects, + numThreads, + methodArgs +) { rd <- screenResult$screened_region_data if (length(rd) == 0L) { return(list(finemap_res = NULL, susie_alpha_res = NULL)) @@ -193,13 +181,13 @@ screenCtwasRegions <- function( weights = screenResult$weights, group_prior = screenResult$param$group_prior, group_prior_var = screenResult$param$group_prior_var, - L = as.integer(L), + L = as.integer(maxNumSingleEffects), LD_format = "custom", LD_loader_fun = screenResult$LD_loader_fun, snpinfo_loader_fun = screenResult$snpinfo_loader_fun, ncore = as.integer(numThreads) ), - extra = methodArgs + extra = methodArgs$finemap ) } @@ -207,7 +195,7 @@ screenCtwasRegions <- function( # 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) { +.ctwasMergeDispatch <- function(finemapResult, common, maxNumSingleEffects) { if (is.null(finemapResult$LD_loader_fun)) { return(list( fn = ctwas::postprocess_region_merging_noLD, @@ -218,7 +206,7 @@ screenCtwasRegions <- function( common, list( LD_map = finemapResult$LD_map, - L = as.integer(L), + L = as.integer(maxNumSingleEffects), LD_format = "custom", LD_loader_fun = finemapResult$LD_loader_fun, snpinfo_loader_fun = finemapResult$snpinfo_loader_fun @@ -227,37 +215,330 @@ screenCtwasRegions <- function( list(fn = ctwas::postprocess_region_merging, args = args) } +# Every ctwas step bundle is built the same way: refuse what the pipeline +# supplies, then check the rest against that step's live formals. +# +# `filtered = TRUE` because several ctwas steps take `...`, which would +# otherwise make the record accept any name -- exactly what the per-step +# split exists to prevent. For the steps .ctwasInvoke() drives it is literally +# true (it intersects the bundle with the running callee's formals); for the +# merge step nothing filters, but every name the bundle accepts is a formal +# of either the merge call or the fine-mapping rerun it forwards to, so the +# union is the right set either way. +# @noRd +.ctwasStepOptions <- function(extra, owned, label, engine, callees) { + .configRefuseOwned(extra, owned, label) + .newMethodOptions( + callees, + defaults = list(), + extra = extra, + label = label, + engine = engine, + filtered = TRUE + ) +} + +# What the pipeline itself supplies at each step's call site -- taken from the +# base `list()` handed to .ctwasInvoke(), which is exactly the set that gets +# deduped away. `ncore` is the pipeline's `numThreads` everywhere. +# @noRd +.ctwasOwnedGeneZ <- function() { + c( + z_snp = "supplied from the data by the pipeline", + weights = "supplied from the data by the pipeline", + ncore = "the pipeline's own `numThreads`" + ) +} + +#' @title Arguments For ctwas's Gene Z-Score Step +#' @description Arguments for \code{ctwas::compute_gene_z()}, which derives +#' gene-level z-scores from the SNP z-scores and the TWAS weights. +#' @param ... Any \code{ctwas::compute_gene_z()} argument, under ctwas's own +#' names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasGeneZOptions(logfile = "gene-z.log") +#' @export +CtwasGeneZOptions <- function(...) { + .ctwasStepOptions( + list(...), .ctwasOwnedGeneZ(), "CtwasGeneZOptions", "ctwasGeneZ", + "ctwas::compute_gene_z" + ) +} + +#' @title Arguments For ctwas's Region-Assembly Step +#' @description Arguments for \code{ctwas::assemble_region_data()}, which +#' builds the per-region list the EM and fine-mapping steps consume. +#' +#' This step was absent from the flat bundle's callee set, so four of its +#' real options --- \code{trim_by}, \code{thin_by}, +#' \code{adjust_boundary_genes}, \code{seed} --- were rejected as unknown +#' even though the pipeline does call it. +#' @param ... Any \code{ctwas::assemble_region_data()} argument, under +#' ctwas's own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasRegionDataOptions(trim_by = "z", seed = 1L) +#' @export +CtwasRegionDataOptions <- function(...) { + .ctwasStepOptions( + list(...), + c( + region_info = "supplied from the data by the pipeline", + z_snp = "supplied from the data by the pipeline", + z_gene = "computed by the pipeline from the TWAS weights", + weights = "supplied from the data by the pipeline", + snp_map = "supplied from the data by the pipeline", + thin = "CtwasPriorParam(thin =)", + ncore = "the pipeline's own `numThreads`" + ), + "CtwasRegionDataOptions", "ctwasRegionData", + "ctwas::assemble_region_data" + ) +} + +#' @title Arguments For ctwas's Group-Prior EM +#' @description Arguments for the EM that estimates ctwas's group priors. +#' Two callees, because the pipeline falls back from +#' \code{ctwas::est_param()} to ctwas's internal \code{fit_EM()} when the +#' accurate EM diverges; \code{fit_EM()} is not a subset of +#' \code{est_param()} (\code{groups}, \code{types}, \code{contexts}, +#' \code{warn_converge_fail} are its own), so the bundle is checked against +#' both and \code{.ctwasInvoke()} drops whichever the running step does not +#' take. +#' @param ... Any argument of either EM entry point, under ctwas's own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasEstParamOptions(min_group_size = 1, EM_tol = 1e-4) +#' @export +CtwasEstParamOptions <- function(...) { + .ctwasStepOptions( + list(...), + c( + region_data = "supplied from the data by the pipeline", + niter_prefit = "CtwasPriorParam(niterPrefit =)", + niter = "CtwasPriorParam(niter =)", + group_prior_var_structure = "CtwasPriorParam(varStructure =)", + ncore = "the pipeline's own `numThreads`" + ), + "CtwasEstParamOptions", "ctwasEstParam", + c("ctwas::est_param", "ctwas::fit_EM") + ) +} + +#' @title Arguments For ctwas's Region-Screening Step +#' @description Arguments for \code{ctwas::screen_regions()}. +#' @param ... Any \code{ctwas::screen_regions()} argument, under ctwas's own +#' names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasScreenOptions(min_nonSNP_PIP = 0, min_gene = 1) +#' @export +CtwasScreenOptions <- function(...) { + .ctwasStepOptions( + list(...), + c( + region_data = "supplied from the data by the pipeline", + group_prior = "estimated by the EM step", + group_prior_var = "estimated by the EM step", + ncore = "the pipeline's own `numThreads`" + ), + "CtwasScreenOptions", "ctwasScreen", "ctwas::screen_regions" + ) +} + +#' @title Arguments For ctwas's Region-Expansion Step +#' @description Arguments for \code{ctwas::expand_region_data()}, run before +#' screening when the region data was assembled with \code{thin < 1}. +#' @param ... Any \code{ctwas::expand_region_data()} argument, under ctwas's +#' own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasExpandOptions(maxSNP = 1000L) +#' @export +CtwasExpandOptions <- function(...) { + .ctwasStepOptions( + list(...), + c( + region_data = "supplied from the data by the pipeline", + snp_map = "supplied from the data by the pipeline", + z_snp = "supplied from the data by the pipeline", + ncore = "the pipeline's own `numThreads`" + ), + "CtwasExpandOptions", "ctwasExpand", "ctwas::expand_region_data" + ) +} + +#' @title Arguments For ctwas's Fine-Mapping Step +#' @description Arguments for \code{ctwas::finemap_regions()}. +#' @param ... Any \code{ctwas::finemap_regions()} argument, under ctwas's own +#' names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasFinemapOptions(min_abs_corr = 0.1, include_cs = TRUE) +#' @export +CtwasFinemapOptions <- function(...) { + .ctwasStepOptions( + list(...), + c( + region_data = "supplied from the data by the pipeline", + LD_map = "supplied from the data by the pipeline", + weights = "supplied from the data by the pipeline", + group_prior = "estimated by the EM step", + group_prior_var = "estimated by the EM step", + L = "the pipeline's own `maxNumSingleEffects`", + LD_format = "fixed by the pipeline's LD loaders", + LD_loader_fun = "fixed by the pipeline's LD loaders", + snpinfo_loader_fun = "fixed by the pipeline's LD loaders", + ncore = "the pipeline's own `numThreads`" + ), + "CtwasFinemapOptions", "ctwasFinemap", "ctwas::finemap_regions" + ) +} + +#' @title Arguments For ctwas's Region-Merging Postprocess +#' @description Arguments for \code{ctwas::postprocess_region_merging()} (or +#' its \code{_noLD} twin, whose formals are a strict subset). +#' +#' The accepted set is deliberately WIDER than those functions' own +#' formals: both of them forward \code{...} into a fine-mapping rerun for +#' the merged regions, so \code{ctwas::finemap_regions()}'s formals are +#' legitimate here too --- twelve names (\code{min_abs_corr}, +#' \code{include_cs}, \code{coverage}, ...) reach the rerun and nothing +#' else. That is why this step's call must NOT be filtered down to the +#' merge function's explicit formals. +#' @param ... Any argument of the merging postprocess, or of the fine-mapping +#' rerun it forwards to, under ctwas's own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasMergeOptions(combine_PIPs = TRUE, min_abs_corr = 0.1) +#' @export +CtwasMergeOptions <- function(...) { + .ctwasStepOptions( + list(...), + c( + region_info = "supplied from the data by the pipeline", + region_data = "supplied from the data by the pipeline", + z_snp = "supplied from the data by the pipeline", + z_gene = "computed by the pipeline from the TWAS weights", + weights = "supplied from the data by the pipeline", + snp_map = "supplied from the data by the pipeline", + finemap_res = "the first-pass fine-mapping result", + susie_alpha_res = "the first-pass fine-mapping result", + group_prior = "estimated by the EM step", + group_prior_var = "estimated by the EM step", + pip_thresh = "the wrapper's `pipThresh`", + filter_cs = "the wrapper's `filterCs`", + maxSNP = "BoundaryMergeParam(maxSnp =)", + L = "the pipeline's own `maxNumSingleEffects`", + LD_map = "supplied from the data by the pipeline", + LD_format = "fixed by the pipeline's LD loaders", + LD_loader_fun = "fixed by the pipeline's LD loaders", + snpinfo_loader_fun = "fixed by the pipeline's LD loaders", + ncore = "the pipeline's own `numThreads`" + ), + "CtwasMergeOptions", "ctwasMerge", + c( + "ctwas::postprocess_region_merging", + "ctwas::postprocess_region_merging_noLD", + "ctwas::finemap_regions" + ) + ) +} + +#' @title Arguments For ctwas's Boundary-Gene Step +#' @description Arguments for \code{ctwas::get_boundary_genes()}, which +#' recovers the boundary genes \code{assemble_region_data()} computes but +#' does not return. +#' @param ... Any \code{ctwas::get_boundary_genes()} argument, under ctwas's +#' own names. +#' @return A \code{\link{MethodOptions}} object. +#' @examples +#' CtwasBoundaryGenesOptions(show_mapping = TRUE) +#' @export +CtwasBoundaryGenesOptions <- function(...) { + .ctwasStepOptions( + list(...), + c( + region_info = "supplied from the data by the pipeline", + weights = "supplied from the data by the pipeline", + ncore = "the pipeline's own `numThreads`" + ), + "CtwasBoundaryGenesOptions", "ctwasBoundaryGenes", + "ctwas::get_boundary_genes" + ) +} + #' @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}. +#' @description ctwas is not one function but nine, run in sequence, so each +#' step's arguments travel in their own bundle and are checked against that +#' step's own live formals --- the same shape as +#' \code{\link{CovUdrOptions}}. #' -#' 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. +#' This replaces a single flat bundle that was checked against the +#' \emph{union} of every step's formals. That mirrored ctwas's own +#' \code{ctwas_sumstats}, which takes forty arguments in one signature, but +#' it could not tell which step a name was meant for: of the 55 names in +#' the union, 29 are accepted by exactly one step, so a name aimed at the +#' wrong step was accepted and then silently dropped. Per-step bundles make +#' that a construction-time error instead. +#' @param geneZ Arguments for \code{ctwas::compute_gene_z()}, built with +#' \code{\link{CtwasGeneZOptions}}. +#' @param regionData Arguments for \code{ctwas::assemble_region_data()}, +#' built with \code{\link{CtwasRegionDataOptions}}. +#' @param estParam Arguments for the group-prior EM, built with +#' \code{\link{CtwasEstParamOptions}}. +#' @param screen Arguments for \code{ctwas::screen_regions()}, built with +#' \code{\link{CtwasScreenOptions}}. +#' @param expand Arguments for \code{ctwas::expand_region_data()}, built with +#' \code{\link{CtwasExpandOptions}}. +#' @param finemap Arguments for \code{ctwas::finemap_regions()}, built with +#' \code{\link{CtwasFinemapOptions}}. +#' @param merge Arguments for the region-merging postprocess, built with +#' \code{\link{CtwasMergeOptions}}. +#' @param boundaryGenes Arguments for \code{ctwas::get_boundary_genes()}, +#' built with \code{\link{CtwasBoundaryGenesOptions}}. #' @return A \code{\link{MethodOptions}} object. #' @examples -#' CtwasOptions(min_group_size = 1, min_gene = 1) +#' CtwasOptions( +#' estParam = CtwasEstParamOptions(min_group_size = 1), +#' screen = CtwasScreenOptions(min_gene = 1) +#' ) #' @export -CtwasOptions <- function(...) { - extra <- list(...) - .ctwasRefusePipelineOwned(extra) +CtwasOptions <- function( + geneZ = CtwasGeneZOptions(), + regionData = CtwasRegionDataOptions(), + estParam = CtwasEstParamOptions(), + screen = CtwasScreenOptions(), + expand = CtwasExpandOptions(), + finemap = CtwasFinemapOptions(), + merge = CtwasMergeOptions(), + boundaryGenes = CtwasBoundaryGenesOptions() +) { + .assertMethodOptions(geneZ, "CtwasGeneZOptions", "geneZ") + .assertMethodOptions(regionData, "CtwasRegionDataOptions", "regionData") + .assertMethodOptions(estParam, "CtwasEstParamOptions", "estParam") + .assertMethodOptions(screen, "CtwasScreenOptions", "screen") + .assertMethodOptions(expand, "CtwasExpandOptions", "expand") + .assertMethodOptions(finemap, "CtwasFinemapOptions", "finemap") + .assertMethodOptions(merge, "CtwasMergeOptions", "merge") + .assertMethodOptions( + boundaryGenes, "CtwasBoundaryGenesOptions", "boundaryGenes" + ) .newMethodOptions( - .ctwasCallees(), - defaults = list(), - extra = extra, + NULL, + defaults = list( + geneZ = geneZ, + regionData = regionData, + estParam = estParam, + screen = screen, + expand = expand, + finemap = finemap, + merge = merge, + boundaryGenes = boundaryGenes + ), + extra = list(), 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 + engine = "ctwas" ) } diff --git a/R/exampleData.R b/R/exampleData.R index 845ca3fe..3527bba3 100644 --- a/R/exampleData.R +++ b/R/exampleData.R @@ -91,7 +91,7 @@ NULL #' @examples #' data(gwasFineMappingExample) #' gwasFineMappingExample -#' head(getTopLoci(gwasFineMappingExample)) +#' head(topLoci(gwasFineMappingExample)) #' NULL @@ -119,7 +119,7 @@ NULL #' One credible set of 42 variants. Its \code{min.abs.corr} is 0.626, below the #' pipeline default of 0.8, so the fixture was built at \code{minAbsCorr = 0.5} #' to keep the set labelled; \code{cs_95_purity} records the true value, so -#' \code{getCs(x, minPurity = 0.8)} still filters it out. Built by +#' \code{credibleSets(x, minPurity = 0.8)} still filters it out. Built by #' \code{inst/scripts/prepare_example_data.R}. #' #' @keywords data @@ -127,7 +127,7 @@ NULL #' @examples #' data(qtlFineMappingExample) #' qtlFineMappingExample -#' head(getTopLoci(qtlFineMappingExample)) +#' head(topLoci(qtlFineMappingExample)) #' NULL @@ -161,7 +161,7 @@ NULL #' @examples #' data(qtlFineMappingPairedExample) #' data(qtlSumStatsExample) -#' fe <- getFineMappingResult(qtlFineMappingPairedExample) +#' fe <- fineMappingResult(qtlFineMappingPairedExample) #' computeCsCorrelation(fe, qtlSumStatsExample) #' NULL @@ -304,7 +304,7 @@ NULL #' @examples #' data(qtlSumStatsMulticontextExample) #' qtlSumStatsMulticontextExample -#' getContexts(qtlSumStatsMulticontextExample) +#' contexts(qtlSumStatsMulticontextExample) #' NULL @@ -384,7 +384,7 @@ NULL #' @examples #' data(qtlFineMappingLbfExample) #' qtlFineMappingLbfExample -#' head(getTopLoci(qtlFineMappingLbfExample)) +#' head(topLoci(qtlFineMappingLbfExample)) #' NULL @@ -679,7 +679,7 @@ NULL #' same variants as \code{\link{ldScoreExample}}, so the four estimators can #' be compared on one reference. #' -#' The panel behind it has \code{nRef = 1000}. That is small enough that +#' The panel behind it has \code{nSamples = 1000}. That is small enough that #' \code{method = "hdl"}, which models reference-panel noise explicitly, #' shrinks its estimate hard -- correct behaviour for a panel this size #' rather than a fault. @@ -741,8 +741,8 @@ NULL #' synthetic. #' #' @format An \code{H2Estimate} object with \code{h2}, \code{h2Se}, -#' \code{intercept}, an \code{enrichment} data frame, and \code{tauBlocks}. -#' +#' \code{intercept}, an \code{enrichment} data frame, and +#' \code{annotationJackknifeCoefs}. #' @keywords data #' #' @examples diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index d0afdc34..d35b1022 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -53,7 +53,8 @@ #' #' @section Chained initialisation: When \code{susieInf} is requested alongside #' \code{susie} and/or \code{susieAsh} and -#' \code{addSusieInf = TRUE} (the default), the SuSiE-inf fit is computed +#' \code{initializeWithSusieInf = 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 @@ -62,7 +63,7 @@ #' #' @section QC contract: All \code{QtlSumStats} and \code{GwasSumStats} inputs #' must have been QC'd via \code{\link{summaryStatsQc}}; the pipeline errors -#' on inputs where \code{length(getQcInfo(x)) == 0L}. \code{summaryStatsQc} +#' on inputs where \code{length(qcInfo(x)) == 0L}. \code{summaryStatsQc} #' also drops variants absent from the \code{ldSketch}, so by the time #' per-entry processing runs every variant is guaranteed to be present in the #' LD panel and a local LD matrix can be built with @@ -148,25 +149,27 @@ #' labels are renumbered to stay unique. \code{TRUE} concatenates the ranges' #' 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}, 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 +#' @param initializeWithSusieInf Logical. When \code{susieInf} is in +#' \code{methods} 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 credibleSetParam 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. +#' variant-level columns to \code{topLoci}. +#' \code{maxNumSingleEffects} bounds how many credible sets can exist +#' (default \code{10}) and \code{maxNumSingleEffectsGreedy} the greedy +#' 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 +#' refitting. \code{maxNumSingleEffects} / +#' \code{maxNumSingleEffectsGreedy} 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 @@ -243,13 +246,13 @@ #' RAISS will impute. Use it when the panel cannot support the LD estimate a #' rare variant would need. #' -#' @param genotypeFilterArgs Per-call overrides of the \code{QtlDataset}'s own +#' @param genotypeFilterParam 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 +#' @param panelFilterParam LD-reference-panel filters for the summary-statistics #' and GWAS methods, built with \code{\link{PanelFilterParam}}. See #' \emph{Panel filters on the RSS path} above. #' @param mrmashPrior Optional \code{\link{TwasWeights}} from a previous @@ -283,14 +286,15 @@ #' 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 +#' \code{susie()} return, so \code{susieFit()} and +#' non-default-coverage \code{credibleSets()} 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{ +#' @param susieRssParam 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 @@ -301,13 +305,13 @@ #' 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{susieFit(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)}. +#' \code{nSamples(ldSketch)}. #' \item \code{rMismatch} (default \code{"none"}) --- LD-mismatch #' correction forwarded as \code{R_mismatch}: also \code{"eb"} or #' \code{"eb_mix"}. @@ -449,12 +453,18 @@ setGeneric("fineMappingPipeline", function(data, ...) { # # Mirrors the convention of .twasNormalizeMethods so the two pipelines # expose the same shape on the user side. +# +# 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. A retired FineMappingMethodsParam() record is still accepted +# too. # @noRd .fmNormalizeMethods <- function( methods, inputKind, - L = 10L, - Lgreedy = NULL + maxNumSingleEffects = 10L, + maxNumSingleEffectsGreedy = NULL ) { if (is.null(methods) || length(methods) == 0L) { msg <- glue( @@ -467,10 +477,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { 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, @@ -481,7 +487,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { inputKind ) } else if (.isMethodOptions(methods)) { - # The retired FineMappingMethodsParam() record. list( tokens = names(methods), methodArgs = map(as.list(methods), as.list) @@ -500,8 +505,8 @@ setGeneric("fineMappingPipeline", function(data, ...) { methodArgs = .fmSeedSusieDefaults( parsed$methodArgs, parsed$tokens, - L, - Lgreedy + maxNumSingleEffects, + maxNumSingleEffectsGreedy ) ) } @@ -520,7 +525,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { # wrappers: seed L / L_greedy on every susie-family token whose kwargs did not # already set them. # @noRd -.fmSeedSusieDefaults <- function(methodArgs, tokens, L, Lgreedy) { +.fmSeedSusieDefaults <- function( + methodArgs, + tokens, + maxNumSingleEffects, + maxNumSingleEffectsGreedy +) { seeded <- intersect(tokens, c("susie", "susieInf", "susieAsh")) if (length(seeded) == 0L) { return(methodArgs) @@ -532,8 +542,8 @@ setGeneric("fineMappingPipeline", function(data, ...) { seeded, .fmSeedTokenDefaults, methodArgs = methodArgs, - L = L, - Lgreedy = Lgreedy + maxNumSingleEffects = maxNumSingleEffects, + maxNumSingleEffectsGreedy = maxNumSingleEffectsGreedy ), seeded ) @@ -543,12 +553,17 @@ setGeneric("fineMappingPipeline", function(data, ...) { # 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) { +.fmSeedTokenDefaults <- function( + tk, + methodArgs, + maxNumSingleEffects, + maxNumSingleEffectsGreedy +) { args <- methodArgs[[tk]] %||% list() list_assign( args, - L = args[["L"]] %||% L, - L_greedy = args[["L_greedy"]] %||% Lgreedy + L = args[["L"]] %||% maxNumSingleEffects, + L_greedy = args[["L_greedy"]] %||% maxNumSingleEffectsGreedy ) } @@ -714,7 +729,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { # Reject SumStats inputs that have not been QC'd via summaryStatsQc. # @noRd .fmAssertQcd <- function(sumstats) { - if (length(getQcInfo(sumstats)) == 0L) { + if (length(qcInfo(sumstats)) == 0L) { cls <- class(sumstats)[[1L]] msg <- glue( "fineMappingPipeline: the supplied {cls} has no QC record ", @@ -731,12 +746,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { # requested it OR a chained init needs it); keepInf is TRUE when the # user asked for "susieInf" in `methods` directly. # @noRd -.fmResolveSusieChain <- function(tokens, addSusieInf) { +.fmResolveSusieChain <- function(tokens, initializeWithSusieInf) { hasInf <- is_in("susieInf", tokens) hasSu <- is_in("susie", tokens) hasAsh <- is_in("susieAsh", tokens) - chainSusie <- isTRUE(addSusieInf) && hasInf && hasSu - chainAsh <- isTRUE(addSusieInf) && hasInf && hasAsh + chainSusie <- isTRUE(initializeWithSusieInf) && hasInf && hasSu + chainAsh <- isTRUE(initializeWithSusieInf) && hasInf && hasAsh runInf <- hasInf || chainSusie || chainAsh keepInf <- hasInf list( @@ -752,7 +767,13 @@ setGeneric("fineMappingPipeline", function(data, ...) { # NULL when there is no hit. Returns NULL silently when fineMappingResult # is NULL or not a QtlFineMappingResult. # @noRd -.fmCacheLookup <- function(fineMappingResult, study, context, trait, method) { +.fmCacheLookup <- function( + fineMappingResult, + studyName, + context, + trait, + method +) { if (is.null(fineMappingResult)) { return(NULL) } @@ -761,7 +782,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { } idx <- .matchTupleRows( fineMappingResult, - list(study = study, context = context, trait = trait, method = method) + list( + study = studyName, + context = context, + trait = trait, + method = method + ) ) if (length(idx) == 0L) { return(NULL) @@ -775,7 +801,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { # label, which means the cache cannot miss because a label was absent or # spelled differently. # @noRd -.fmCacheLookupGwas <- function(fineMappingResult, study, method, blockId) { +.fmCacheLookupGwas <- function(fineMappingResult, studyName, method, blockId) { if (is.null(fineMappingResult)) { return(NULL) } @@ -784,7 +810,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { } matched <- .matchTupleRows( fineMappingResult, - list(study = study, method = method) + list(study = studyName, method = method) ) if (length(matched) == 0L) { return(NULL) @@ -829,7 +855,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { abort(msg) } QtlFineMappingResult( - study = studies, + studyName = studies, context = contexts, trait = traits, method = methods, @@ -862,7 +888,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { abort(msg) } GwasFineMappingResult( - study = studies, + studyName = studies, method = methods, blockId = blockIds, entry = entries, @@ -874,9 +900,9 @@ setGeneric("fineMappingPipeline", function(data, ...) { # + the FineMappingRow). Dispatch helpers RETURN these; the orchestrator # flattens them and extracts the parallel vectors -- no mutable accumulator. # @noRd -.fmQtlRow <- function(study, context, trait, method, entry) { +.fmQtlRow <- function(studyName, context, trait, method, entry) { list( - study = study, + study = studyName, context = context, trait = trait, method = method, @@ -888,8 +914,8 @@ setGeneric("fineMappingPipeline", function(data, ...) { # FineMappingRow). blockId is provenance for the external block manifest; # row identity comes from (study, method) plus the element's own range. # @noRd -.fmGwasRow <- function(study, method, blockId, entry) { - list(study = study, method = method, blockId = blockId, entry = entry) +.fmGwasRow <- function(studyName, method, blockId, entry) { + list(study = studyName, method = method, blockId = blockId, entry = entry) } # Effect-allele frequency vector aligned to `variantIds` from an entry's @@ -966,7 +992,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { gr, glue("fineMappingPipeline(GwasSumStats): study='{st}'"), ldSketch = cfg$ldSketch, - cutoffs = .panelCutoffs(cfg$panelFilterArgs) + cutoffs = .panelCutoffs(cfg$panelFilterParam) ) blockId <- .fmGwasBlockId(gr) lookups <- map( @@ -997,19 +1023,19 @@ setGeneric("fineMappingPipeline", function(data, ...) { # @noRd .fmSsCommonCfg <- function( data, - credibleSetArgs, + credibleSetParam, fineMappingResult, fitRetention, verbose, - panelFilterArgs + panelFilterParam ) { list( data = data, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, fitRetention = fitRetention, verbose = verbose, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam ) } @@ -1022,17 +1048,17 @@ setGeneric("fineMappingPipeline", function(data, ...) { .fmRssRunCfg <- function( common, ldSketch, - addSusieInf, + initializeWithSusieInf, methodArgs, - rssArgs + susieRssParam ) { c( common, list( ldSketch = ldSketch, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, - rssArgs = rssArgs + susieRssParam = susieRssParam ) ) } @@ -1051,15 +1077,15 @@ setGeneric("fineMappingPipeline", function(data, ...) { ldMat, zn$n, toRun, - cfg$addSusieInf, + cfg$initializeWithSusieInf, cfg$methodArgs, cfg$verbose, label = label, af = af, nVar = zn$nVar, - credibleSetArgs = cfg$credibleSetArgs, + credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention, - rssArgs = cfg$rssArgs + susieRssParam = cfg$susieRssParam ) } @@ -1075,7 +1101,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { "context='{ctx}', trait='{tr}')" ), ldSketch = cfg$ldSketch, - cutoffs = .panelCutoffs(cfg$panelFilterArgs) + cutoffs = .panelCutoffs(cfg$panelFilterParam) ) ents <- .fmFitRssBlockP( set_names(zn$z, zn$variantIds), @@ -1197,7 +1223,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { is.null ) exec( - getResidualizedPhenotypes, + residualizedPhenotypes, !!!c( list( x = x, @@ -1229,7 +1255,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { is.null ) exec( - getResidualizedGenotypes, + residualizedGenotypes, !!!c( list( x = x, @@ -1245,9 +1271,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # genotype block `X` (samples x variants, post-residualization and post # sample-intersection). Re-extracts the allele frequency from the dataset # `data` over the SAME selection used to build `X` and aligns it to -# `colnames(X)`; variants `getAf` does not return (e.g. dropped by a +# `colnames(X)`; variants `af` does not return (e.g. dropped by a # borderline MAF re-check on the final sample set) come back as NA. Returns -# NULL when `X` is empty or the dataset exposes no `getAf` (non-QtlDataset +# NULL when `X` is empty or the dataset exposes no `af` (non-QtlDataset # 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. @@ -1267,14 +1293,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { } afAll <- try_fetch( if (is.null(region)) { - getAf( + af( data, traitId = traitId, cisWindow = cisWindow, samples = rownames(X) ) } else { - getAf(data, region = region, samples = rownames(X)) + af(data, region = region, samples = rownames(X)) }, error = function(cnd) NULL ) @@ -1289,7 +1315,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { method, dataX, dataY, - credibleSetArgs, + credibleSetParam, fitRetention, csInput = NULL, af = NULL, @@ -1307,7 +1333,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { n, csInput, conditionIdx, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fitRetention = fitRetention ) } @@ -1325,7 +1351,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { n, csInput, conditionIdx, - credibleSetArgs, + credibleSetParam, fitRetention ) { post <- postprocessFinemappingFits( @@ -1341,7 +1367,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # so every caller's credible-set settings (coverage, purity, # signalCutoff, perCsColumns, ...) and retention level were replaced # by postprocessFinemappingFits()'s own defaults. - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fitRetention = fitRetention ) out <- formatFinemappingOutput(post, primaryMethod = method) @@ -1385,8 +1411,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # 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 -.fmMrmashSelector <- function(mrmashPrior, study, trait, context) { - axes <- compact(list(study = study, trait = trait, context = context)) +.fmMrmashSelector <- function(mrmashPrior, studyName, trait, context) { + axes <- compact(list(study = studyName, trait = trait, context = context)) reduce( names(axes), .fmMrmashNarrow, @@ -1421,7 +1447,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # @noRd .fmLookupMrmashFit <- function( mrmashPrior, - study = NULL, + studyName = NULL, trait = NULL, context = NULL ) { @@ -1431,9 +1457,9 @@ combineFineMappingResults <- function(..., ldSketch = 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 "skip that axis". - sel <- .fmMrmashSelector(mrmashPrior, study, trait, context) + sel <- .fmMrmashSelector(mrmashPrior, studyName, trait, context) for (i in which(sel)) { - f <- getFits(.twrRowParts(mrmashPrior, i)) + f <- methodFits(.twrRowParts(mrmashPrior, i)) if (!is.null(f)) return(f) } NULL @@ -1448,16 +1474,16 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # @noRd .fmLookupMrmashCv <- function( mrmashPrior, - study = NULL, + studyName = NULL, trait = NULL, context = NULL ) { if (is.null(mrmashPrior)) { return(NULL) } - sel <- .fmMrmashSelector(mrmashPrior, study, trait, context) + sel <- .fmMrmashSelector(mrmashPrior, studyName, trait, context) for (i in which(sel)) { - cv <- getCvResult(.twrRowParts(mrmashPrior, i)) + cv <- cvResult(.twrRowParts(mrmashPrior, i)) if (!is.null(cv) && !is.null(cv$foldFits)) return(cv) } NULL @@ -1816,7 +1842,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # pipScreenReason); # an entry may also be empty for other reasons. Returns list(skipped, reason). .fmEntrySkipInfo <- function(data, i) { - ea <- try_fetch(getQcInfo(data)$entryAudit[[i]], error = function(cnd) NULL) + ea <- try_fetch(qcInfo(data)$entryAudit[[i]], error = function(cnd) NULL) screened <- isTRUE(ea$pipScreenSkipped) entry <- .collectionEntry(data, i) empty <- is.null(entry) || length(entry) == 0L @@ -2216,11 +2242,11 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # merged via .fmMergeEntries. Reused for univariate tokens and the single PCA # "susie" token (trait = the PC name). # @noRd -.fmMergeTokenRows <- function(study, ctx, trait, tokens, blockEntries) { +.fmMergeTokenRows <- function(studyName, ctx, trait, tokens, blockEntries) { compact(map( tokens, .fmMergeTokenRow, - study = study, + study = studyName, ctx = ctx, trait = trait, blockEntries = blockEntries @@ -2231,12 +2257,21 @@ 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(X, y, tokens, addSusieInf, ctx, label, afVec, cfg) { +.fmFitXBlockP <- function( + X, + y, + tokens, + initializeWithSusieInf, + ctx, + label, + afVec, + cfg +) { .fmFitXBlock( X, y, tokens, - addSusieInf, + initializeWithSusieInf, cfg$methodArgs, cfg$verbose, ctx, @@ -2245,7 +2280,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { cvThreads = cfg$crossValidationArgs$numThreads, samplePartition = cfg$crossValidationArgs$samplePartition, af = afVec, - credibleSetArgs = cfg$credibleSetArgs, + credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention, seed = cfg$seed ) @@ -2295,7 +2330,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { region = rg, cisWindow = cfg$cisWindow ) - .fmFitXBlockP(X, y, toRun, cfg$addSusieInf, ctx, tid, afVec, cfg) + .fmFitXBlockP(X, y, toRun, cfg$initializeWithSusieInf, ctx, tid, afVec, cfg) } # All univariate row-records for one (context, trait): cache hits, then (when @@ -2488,7 +2523,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { residualizationArgs = cfg$residualizationArgs, pipCutoffToSkip = cfg$screen, fineMappingResult = cfg$fineMappingResult, - credibleSetArgs = cfg$credibleSetArgs, + credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention, seed = cfg$seed ) @@ -2501,14 +2536,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { .fmQdsResolveInputs <- function( data, signalScreenArgs, - genotypeFilterArgs, + genotypeFilterParam, region, cisWindow, jointRegions ) { .assertMethodParam(signalScreenArgs, "SignalScreenParam", "signalScreen") screen <- .screenResolve(signalScreenArgs) - data <- .qtlApplyFilterOverrides(data, genotypeFilterArgs) + data <- .qtlApplyFilterOverrides(data, genotypeFilterParam) if (!is.null(region) && !is.null(cisWindow)) { msg <- glue( "fineMappingPipeline(QtlDataset): specify either `region` or ", @@ -2572,13 +2607,19 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } -.fmQdsResolveTokens <- function(jointSpecification, methods, L, Lgreedy, cfg) { +.fmQdsResolveTokens <- function( + jointSpecification, + methods, + maxNumSingleEffects, + maxNumSingleEffectsGreedy, + cfg +) { parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) norm <- .fmNormalizeMethods( methods, inputKind = "QtlDataset", - L = L, - Lgreedy = Lgreedy + maxNumSingleEffects = maxNumSingleEffects, + maxNumSingleEffectsGreedy = maxNumSingleEffectsGreedy ) .fmCheckMethodCapabilities(norm$tokens, "QtlDataset") .fmCheckMethodArgsForInput(norm$methodArgs, "QtlDataset") @@ -2600,7 +2641,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # overlapping the requested region (mirrors twasWeightsPipeline). # @noRd .fmQdsTraitsForContext <- function(ctx, data, traitId, region) { - se <- getPhenotypes(data, contexts = ctx) + se <- molecularTraits(data, contexts = ctx) allIds <- rownames(se) ids <- if (!is.null(traitId)) { intersect(allIds, traitId) @@ -2620,7 +2661,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # perCtxTraits / nCtx / nTraits. # @noRd .fmQdsResolveContexts <- function(data, contexts, traitId, region) { - allCtx <- getContexts(data) + allCtx <- contexts(data) useCtx <- if (is.null(contexts)) { allCtx } else { @@ -2650,7 +2691,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { abort("fineMappingPipeline(QtlDataset): no traits selected.") } list( - study = getStudy(data), + study = studyName(data), useCtx = useCtx, perCtxTraits = perCtxTraits, nCtx = length(useCtx), @@ -2699,12 +2740,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # @noRd .fmQdsRunCfg <- function( common, - addSusieInf, + initializeWithSusieInf, methodArgs, nPCs, naAction, perCtxTraits, - study, + studyName, univTokens, useCtx, usePCA @@ -2712,12 +2753,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { c( common, list( - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, nPCs = nPCs, naAction = naAction, perCtxTraits = perCtxTraits, - study = study, + study = studyName, univTokens = univTokens, useCtx = useCtx, usePCA = usePCA @@ -2825,7 +2866,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { tokens, methodArgs, jointResult, - addSusieInf, + initializeWithSusieInf, nPCs, naAction, usePCA @@ -2839,12 +2880,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { split <- .fmQdsSplitTokens(tokens, ctxInfo$nCtx, ctxInfo$nTraits) rows <- .fmQdsDispatchRows(.fmQdsRunCfg( commonCfg, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, nPCs = nPCs, naAction = naAction, perCtxTraits = ctxInfo$perCtxTraits, - study = ctxInfo$study, + studyName = ctxInfo$study, univTokens = split$univTokens, useCtx = ctxInfo$useCtx, usePCA = usePCA @@ -2879,11 +2920,11 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { cisWindow = NULL, # Per-call genotype-filter overrides; NULL = use the QtlDataset's # construct-time slot value (applied lazily at extraction). - genotypeFilterArgs = GenotypeFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), jointRegions = FALSE, jointSpecification = NULL, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam(), @@ -2907,7 +2948,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { resolved <- .fmQdsResolveInputs( data = data, signalScreenArgs = signalScreenArgs, - genotypeFilterArgs = genotypeFilterArgs, + genotypeFilterParam = genotypeFilterParam, region = region, cisWindow = cisWindow, jointRegions = jointRegions @@ -2923,7 +2964,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { commonCfg <- list( data = data, cisWindow = cisWindow, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, screen = screen, xRegions = xRegions, crossValidationArgs = cvCfg, @@ -2943,8 +2984,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { rt <- .fmQdsResolveTokens( jointSpecification, methods, - credibleSetArgs$L %||% 10L, - credibleSetArgs$Lgreedy, + credibleSetParam$maxNumSingleEffects %||% 10L, + credibleSetParam$maxNumSingleEffectsGreedy, jointCfg ) if (rt$done) { @@ -2960,7 +3001,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { tokens = rt$tokens, methodArgs = rt$methodArgs, jointResult = rt$result, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, nPCs = nPCs, naAction = naAction, usePCA = usePCA @@ -2990,9 +3031,10 @@ setMethod( if (length(m) == 0L) { return(NULL) } - # Every setting is named. `cfg` also carries panelFilterArgs and rssArgs, + # Every setting is named. `cfg` also carries panelFilterParam and + # susieRssParam, # which belong to the summary-statistics path: a study's own genotypes - # are filtered by genotypeFilterArgs, so those two are deliberately not + # are filtered by genotypeFilterParam, 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. @@ -3005,8 +3047,8 @@ setMethod( region = cfg$region, cisWindow = cfg$cisWindow, jointRegions = cfg$jointRegions, - addSusieInf = cfg$addSusieInf, - credibleSetArgs = cfg$credibleSetArgs, + initializeWithSusieInf = cfg$initializeWithSusieInf, + credibleSetParam = cfg$credibleSetParam, fineMappingResult = cfg$fineMappingResult, verbose = cfg$verbose, crossValidationArgs = cfg$crossValidationArgs, @@ -3014,7 +3056,7 @@ setMethod( seed = cfg$seed, naAction = cfg$naAction, signalScreenArgs = cfg$signalScreenArgs, - genotypeFilterArgs = cfg$genotypeFilterArgs, + genotypeFilterParam = cfg$genotypeFilterParam, usePCA = cfg$usePCA, nPCs = cfg$nPCs, fitRetention = cfg$fitRetention, @@ -3042,12 +3084,12 @@ setMethod( jointSpecification = NULL, contexts = cfg$contexts, traitId = cfg$traitId, - addSusieInf = cfg$addSusieInf, - credibleSetArgs = cfg$credibleSetArgs, + initializeWithSusieInf = cfg$initializeWithSusieInf, + credibleSetParam = cfg$credibleSetParam, fineMappingResult = cfg$fineMappingResult, verbose = cfg$verbose, - panelFilterArgs = cfg$panelFilterArgs, - rssArgs = cfg$rssArgs, + panelFilterParam = cfg$panelFilterParam, + susieRssParam = cfg$susieRssParam, fitRetention = cfg$fitRetention, mrmashPrior = cfg$mrmashPrior, dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff @@ -3140,7 +3182,13 @@ setMethod( # 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) { +.fmMsResolveTokens <- function( + jointSpecification, + methods, + maxNumSingleEffects, + maxNumSingleEffectsGreedy, + 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 @@ -3151,13 +3199,13 @@ setMethod( methods, "FineMappingMethodsParam", "fineMappingPipeline", - !is.null(getSumStats(cfg$data)) + !is.null(sumStats(cfg$data)) ) norm <- .fmNormalizeMethods( methods, inputKind = "QtlDataset", - L = L, - Lgreedy = Lgreedy + maxNumSingleEffects = maxNumSingleEffects, + maxNumSingleEffectsGreedy = maxNumSingleEffectsGreedy ) .fmCheckMethodCapabilities(norm$tokens, "MultiStudyQtlDataset") .fmCheckMethodArgsForInput(norm$methodArgs, "MultiStudyQtlDataset") @@ -3193,19 +3241,19 @@ setMethod( traitId = NULL, region = NULL, cisWindow = NULL, - genotypeFilterArgs = GenotypeFilterParam(), - panelFilterArgs = PanelFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), + panelFilterParam = PanelFilterParam(), jointRegions = FALSE, jointSpecification = NULL, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam(), signalScreenArgs = SignalScreenParam(), - rssArgs = SusieRssParam(), + susieRssParam = SusieRssParam(), usePCA = FALSE, nPCs = 10L, seed = NULL, @@ -3223,7 +3271,7 @@ setMethod( contexts = contexts, traitId = traitId, cisWindow = cisWindow, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, verbose = verbose, xRegions = inputs$xRegions, mrmashPrior = mrmashPrior, @@ -3232,8 +3280,8 @@ setMethod( rt <- .fmMsResolveTokens( jointSpecification, methods, - credibleSetArgs$L %||% 10L, - credibleSetArgs$Lgreedy, + credibleSetParam$maxNumSingleEffects %||% 10L, + credibleSetParam$maxNumSingleEffectsGreedy, jointCfg ) if (rt$done) { @@ -3252,8 +3300,8 @@ setMethod( region = region, cisWindow = cisWindow, jointRegions = jointRegions, - addSusieInf = addSusieInf, - credibleSetArgs = credibleSetArgs, + initializeWithSusieInf = initializeWithSusieInf, + credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, verbose = verbose, crossValidationArgs = crossValidationArgs, @@ -3261,9 +3309,9 @@ setMethod( seed = seed, naAction = naAction, signalScreenArgs = signalScreenArgs, - genotypeFilterArgs = genotypeFilterArgs, - panelFilterArgs = panelFilterArgs, - rssArgs = rssArgs, + genotypeFilterParam = genotypeFilterParam, + panelFilterParam = panelFilterParam, + susieRssParam = susieRssParam, usePCA = usePCA, nPCs = nPCs, fitRetention = fitRetention, @@ -3326,9 +3374,9 @@ setMethod( mrmashPrior = cfg$mrmashPrior, dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, fineMappingResult = cfg$fineMappingResult, - credibleSetArgs = cfg$credibleSetArgs, + credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention, - panelFilterArgs = cfg$panelFilterArgs %||% PanelFilterParam() + panelFilterParam = cfg$panelFilterParam %||% PanelFilterParam() ) } @@ -3399,7 +3447,76 @@ setMethod( # and mvsusie could not be checked at all, since mvsusie_rss takes `...` and # a union containing it accepts anything. # @noRd +# Engine arguments pecotmr supplies itself, per engine, with where the caller +# sets each one instead. Keyed on the engine rather than the token because one +# engine serves several tokens, and derived from what the wrappers actually +# pass: the structural inputs come from the data, while `L` / `L_greedy` / +# `coverage` have a user-facing home on CredibleSetParam. Without this a +# caller's `SusieOptions(L = 3)` is a valid susie formal that pecotmr then +# overwrites (or, on the mvsusie path, that silently overwrites pecotmr's own +# X / Y). +# @noRd +.fmOwnedEngineArgs <- function(callee) { + fromData <- "supplied from the data by the pipeline" + csHome <- c( + coverage = "`csCoverage()` on CredibleSetParam", + L = "`maxNumSingleEffects()` on CredibleSetParam", + L_greedy = "`maxNumSingleEffectsGreedy()` on CredibleSetParam" + ) + switch( + callee, + "susieR::susie" = c( + set_names(rep(fromData, 2L), c("X", "y")), + csHome + ), + "susieR::susie_rss" = c( + set_names( + rep(fromData, 5L), + c("z", "R", "n", "R_finite", "R_mismatch") + ), + csHome + ), + "susieR::susie_ser" = c( + set_names(rep(fromData, 2L), c("z", "n")), + csHome["coverage"] + ), + # `residual_variance` is deliberately NOT owned, though the pipeline + # does pass it: the prior's V can be NULL, compact() then drops it + # from the base, and a user value is the only source left. Refusing + # it would close the only path -- the QggOptions(nit=) mistake. + "mvsusieR::mvsusie" = c( + set_names( + rep(fromData, 3L), + c("X", "Y", "prior_variance") + ), + csHome + ), + # `L` does not reach mvsusie_rss, but `coverage` does: the pipeline + # threads csCoverage() into fitMvsusieRss()'s own `coverage` formal, + # so this engine takes that one entry of csHome and not the rest. + "mvsusieR::mvsusie_rss" = c( + set_names( + rep(fromData, 4L), + c("Z", "R", "N", "prior_variance") + ), + csHome["coverage"] + ), + "fsusieR::susiF" = c( + set_names(rep(fromData, 4L), c("X", "Y", "pos", "prior")), + c( + L = "`maxNumSingleEffects()` on CredibleSetParam", + min_purity = "the wrapper's `minPurity`", + max_SNP_EM = "the wrapper's `maxSnpEm`", + cov_lev = "the wrapper's `covLev`", + max_scale = "the wrapper's `maxScale`" + ) + ), + character(0) + ) +} + .fmMethodOptions <- function(callee, label, engine, extra) { + .configRefuseOwned(extra, .fmOwnedEngineArgs(callee), label) .newMethodOptions( callee, defaults = list(), @@ -3444,10 +3561,12 @@ setClass("FineMappingMethodsParam", contains = "MethodsSelectionParam") #' @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)) +#' methods = list(susie = SusieOptions(max_iter = 200)) +#' ) +#' FineMappingMethodsParam( +#' qtlDatasetMethods = list(susie = SusieOptions(max_iter = 200)), +#' qtlSumStatsMethods = list(susie = SusieRssOptions(max_iter = 200)) #' ) #' @export FineMappingMethodsParam <- function( @@ -3562,7 +3681,7 @@ FineMappingMethodsParam <- function( #' \code{coverage}, \code{max_iter}, ...). #' @return A \code{\link{MethodOptions}} object. #' @examples -#' SusieOptions(L = 5) +#' SusieOptions(max_iter = 200) #' SusieRssOptions(maf_thresh = 0.01) #' MvsusieOptions(prior_tol = 1e-9) #' @name fineMappingMethodOptions @@ -3589,13 +3708,19 @@ NULL # where an explicit spec consumed every method, so the caller returns the joint # result directly (or errors when it produced nothing). # @noRd -.fmQssResolveTokens <- function(jointSpecification, methods, L, Lgreedy, cfg) { +.fmQssResolveTokens <- function( + jointSpecification, + methods, + maxNumSingleEffects, + maxNumSingleEffectsGreedy, + cfg +) { parsedJointSpec <- parseJointSpecification(jointSpecification, cfg$data) norm <- .fmNormalizeMethods( methods, inputKind = "QtlSumStats", - L = L, - Lgreedy = Lgreedy + maxNumSingleEffects = maxNumSingleEffects, + maxNumSingleEffectsGreedy = maxNumSingleEffectsGreedy ) .fmCheckMethodCapabilities(norm$tokens, "QtlSumStats") .fmCheckMethodArgsForInput(norm$methodArgs, "QtlSumStats") @@ -3750,11 +3875,11 @@ NULL # @noRd .fmQssConfigs <- function( data, - credibleSetArgs, + credibleSetParam, fineMappingResult, fitRetention, verbose, - panelFilterArgs, + panelFilterParam, contexts, traitId, mrmashPrior, @@ -3762,11 +3887,11 @@ NULL ) { common <- .fmSsCommonCfg( data = data, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, fitRetention = fitRetention, verbose = verbose, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam ) list( common = common, @@ -3787,27 +3912,27 @@ NULL .fmPipelineQtlSumStats <- function( data, methods, - addSusieInf, + initializeWithSusieInf, contexts, traitId, jointSpecification, - credibleSetArgs, + credibleSetParam, fineMappingResult, mrmashPrior, dataDrivenPriorWeightsCutoff, verbose, fitRetention, - rssArgs, - panelFilterArgs + susieRssParam, + panelFilterParam ) { .fmAssertQcd(data) cfgs <- .fmQssConfigs( data = data, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, fitRetention = fitRetention, verbose = verbose, - panelFilterArgs = panelFilterArgs, + panelFilterParam = panelFilterParam, contexts = contexts, traitId = traitId, mrmashPrior = mrmashPrior, @@ -3818,8 +3943,8 @@ NULL rt <- .fmQssResolveTokens( jointSpecification, methods, - credibleSetArgs$L %||% 10L, - credibleSetArgs$Lgreedy, + credibleSetParam$maxNumSingleEffects %||% 10L, + credibleSetParam$maxNumSingleEffectsGreedy, jointCfg ) if (rt$done) { @@ -3832,8 +3957,8 @@ NULL jointCfg = jointCfg, contexts = contexts, traitId = traitId, - addSusieInf = addSusieInf, - rssArgs = rssArgs + initializeWithSusieInf = initializeWithSusieInf, + susieRssParam = susieRssParam ) } @@ -3849,17 +3974,17 @@ NULL jointCfg, contexts, traitId, - addSusieInf, - rssArgs + initializeWithSusieInf, + susieRssParam ) { sel <- .fmQssSelectRows(data = data, contexts = contexts, traitId = traitId) - ldSketch <- getLdSketch(data) + ldSketch <- ldSketch(data) cfg <- .fmRssRunCfg( commonCfg, ldSketch = ldSketch, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, methodArgs = rt$methodArgs, - rssArgs = .fmRssArgsResolved(rssArgs, ldSketch) + susieRssParam = .fmRssArgsResolved(susieRssParam, ldSketch) ) .fmQssRunRows( data, @@ -3927,15 +4052,15 @@ setMethod( contexts = NULL, traitId = NULL, jointSpecification = NULL, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, verbose = 1, fitRetention = c("slim", "full"), - rssArgs = SusieRssParam(), - panelFilterArgs = PanelFilterParam(), + susieRssParam = SusieRssParam(), + panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam() ) { @@ -3948,18 +4073,18 @@ setMethod( .fmPipelineQtlSumStats( data = data, methods = methods, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, contexts = contexts, traitId = traitId, jointSpecification = jointSpecification, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, mrmashPrior = mrmashPrior, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, verbose = verbose, fitRetention = fitRetention, - rssArgs = rssArgs, - panelFilterArgs = panelFilterArgs + susieRssParam = susieRssParam, + panelFilterParam = panelFilterParam ) } ) @@ -3978,17 +4103,17 @@ setMethod( # 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) { +.fmRssArgsResolved <- function(susieRssParam, ldSketch) { resolved <- .fmResolveRFinite( - rssArgs$rFinite, - rssArgs$serFallback, - rssArgs$rMismatch, + susieRssParam$rFinite, + susieRssParam$serFallback, + susieRssParam$rMismatch, ldSketch ) - if (identical(resolved, rssArgs$rFinite)) { - return(rssArgs) + if (identical(resolved, susieRssParam$rFinite)) { + return(susieRssParam) } - .rssParamWithRFinite(rssArgs, resolved) + .rssParamWithRFinite(susieRssParam, resolved) } .fmResolveRFinite <- function(rFinite, serFallback, rMismatch, ldSketch) { @@ -4012,35 +4137,35 @@ setMethod( .fmPipelineGwas <- function( data, methods, - addSusieInf, - credibleSetArgs, + initializeWithSusieInf, + credibleSetParam, fineMappingResult, verbose, fitRetention, - rssArgs, - panelFilterArgs + susieRssParam, + panelFilterParam ) { .fmAssertQcd(data) norm <- .fmNormalizeMethods( methods, - L = credibleSetArgs$L %||% 10L, - Lgreedy = credibleSetArgs$Lgreedy + maxNumSingleEffects = credibleSetParam$maxNumSingleEffects %||% 10L, + maxNumSingleEffectsGreedy = credibleSetParam$maxNumSingleEffectsGreedy ) .fmCheckMethodCapabilities(norm$tokens, "GwasSumStats") .fmCheckMethodArgsForInput(norm$methodArgs, "GwasSumStats") - ldSketch <- getLdSketch(data) + ldSketch <- ldSketch(data) # Derived values are ordinary locals now, not fields grafted onto a bundle. tokens <- norm$tokens methodArgs <- norm$methodArgs - rssArgs <- .fmRssArgsResolved(rssArgs, ldSketch) + susieRssParam <- .fmRssArgsResolved(susieRssParam, ldSketch) studyCol <- as.character(data$study) commonCfg <- .fmSsCommonCfg( data = data, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, fitRetention = fitRetention, verbose = verbose, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam ) .fmGwasRunEntries( data, @@ -4048,9 +4173,9 @@ setMethod( tokens = tokens, commonCfg = commonCfg, ldSketch = ldSketch, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, - rssArgs = rssArgs + susieRssParam = susieRssParam ) } @@ -4062,9 +4187,9 @@ setMethod( tokens, commonCfg, ldSketch, - addSusieInf, + initializeWithSusieInf, methodArgs, - rssArgs + susieRssParam ) { entryOut <- map( seq_len(nrow(data)), @@ -4074,9 +4199,9 @@ setMethod( cfg = .fmRssRunCfg( commonCfg, ldSketch = ldSketch, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, - rssArgs = rssArgs + susieRssParam = susieRssParam ) ) rows <- list_flatten(map(entryOut, "rows")) @@ -4101,13 +4226,13 @@ setMethod( function( data, methods, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, verbose = 1, fitRetention = c("slim", "full"), - rssArgs = SusieRssParam(), - panelFilterArgs = PanelFilterParam(), + susieRssParam = SusieRssParam(), + panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam() ) { @@ -4120,13 +4245,13 @@ setMethod( .fmPipelineGwas( data = data, methods = methods, - addSusieInf = addSusieInf, - credibleSetArgs = credibleSetArgs, + initializeWithSusieInf = initializeWithSusieInf, + credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, verbose = verbose, fitRetention = fitRetention, - rssArgs = rssArgs, - panelFilterArgs = panelFilterArgs + susieRssParam = susieRssParam, + panelFilterParam = panelFilterParam ) } ) @@ -4237,13 +4362,13 @@ setMethod( # One merged row-record for token `tk` across window block entries (NULL when # any window failed to fit the token). # @noRd -.fmMergeTokenRow <- function(tk, study, ctx, trait, blockEntries) { +.fmMergeTokenRow <- function(tk, studyName, ctx, trait, blockEntries) { ents <- map(blockEntries, .fmBlockToken, tk = tk) if (any(map_lgl(ents, is.null))) { return(NULL) } entry <- if (length(ents) == 1L) ents[[1L]] else .fmMergeEntries(ents) - .fmQtlRow(study, ctx, trait, tk, entry) + .fmQtlRow(studyName, ctx, trait, tk, entry) } # @noRd @@ -4252,16 +4377,16 @@ setMethod( } # @noRd -.fmUnivLookup <- function(tk, fineMappingResult, study, ctx, tid) { +.fmUnivLookup <- function(tk, fineMappingResult, studyName, ctx, tid) { list( tk = tk, - cached = .fmCacheLookup(fineMappingResult, study, ctx, tid, tk) + cached = .fmCacheLookup(fineMappingResult, studyName, ctx, tid, tk) ) } # @noRd -.fmUnivCachedRow <- function(l, study, ctx, tid) { - .fmQtlRow(study, ctx, tid, l$tk, l$cached) +.fmUnivCachedRow <- function(l, studyName, ctx, tid) { + .fmQtlRow(studyName, ctx, tid, l$tk, l$cached) } # All univariate row-records for one context (over its per-context traits). @@ -4302,82 +4427,86 @@ setMethod( # SignalScreenParam). #' @rdname CredibleSetParam -setMethod("getCoverage", "CredibleSetParam", function(x) x@coverage) +setMethod("csCoverage", "CredibleSetParam", function(x) x@coverage) #' @rdname CredibleSetParam -setMethod("setCoverage", "CredibleSetParam", function(x, value) { +setReplaceMethod("csCoverage", "CredibleSetParam", function(x, value) { x@coverage <- value validObject(x) x }) #' @rdname CredibleSetParam -setMethod("getSecondaryCoverage", "CredibleSetParam", function(x) { +setMethod("secondaryCoverage", "CredibleSetParam", function(x) { x@secondaryCoverage }) #' @rdname CredibleSetParam -setMethod("setSecondaryCoverage", "CredibleSetParam", function(x, value) { +setReplaceMethod("secondaryCoverage", "CredibleSetParam", function(x, value) { x@secondaryCoverage <- value validObject(x) x }) #' @rdname CredibleSetParam -setMethod("getSignalCutoff", "CredibleSetParam", function(x) x@signalCutoff) +setMethod("signalCutoff", "CredibleSetParam", function(x) x@signalCutoff) #' @rdname CredibleSetParam -setMethod("setSignalCutoff", "CredibleSetParam", function(x, value) { +setReplaceMethod("signalCutoff", "CredibleSetParam", function(x, value) { x@signalCutoff <- value validObject(x) x }) #' @rdname CredibleSetParam -setMethod("getMinAbsCorr", "CredibleSetParam", function(x) x@minAbsCorr) +setMethod("minAbsCorr", "CredibleSetParam", function(x) x@minAbsCorr) #' @rdname CredibleSetParam -setMethod("setMinAbsCorr", "CredibleSetParam", function(x, value) { +setReplaceMethod("minAbsCorr", "CredibleSetParam", function(x, value) { x@minAbsCorr <- value validObject(x) x }) #' @rdname CredibleSetParam -setMethod("getMedianAbsCorr", "CredibleSetParam", function(x) x@medianAbsCorr) +setMethod("medianAbsCorr", "CredibleSetParam", function(x) x@medianAbsCorr) #' @rdname CredibleSetParam -setMethod("setMedianAbsCorr", "CredibleSetParam", function(x, value) { +setReplaceMethod("medianAbsCorr", "CredibleSetParam", function(x, value) { x@medianAbsCorr <- value validObject(x) x }) #' @rdname CredibleSetParam -setMethod("getIncludeAllCs", "CredibleSetParam", function(x) x@includeAllCs) +setMethod("includeAllCs", "CredibleSetParam", function(x) x@includeAllCs) #' @rdname CredibleSetParam -setMethod("setIncludeAllCs", "CredibleSetParam", function(x, value) { +setReplaceMethod("includeAllCs", "CredibleSetParam", function(x, value) { x@includeAllCs <- value validObject(x) x }) #' @rdname CredibleSetParam -setMethod("getPerCsColumns", "CredibleSetParam", function(x) x@perCsColumns) +setMethod("perCsColumns", "CredibleSetParam", function(x) x@perCsColumns) #' @rdname CredibleSetParam -setMethod("setPerCsColumns", "CredibleSetParam", function(x, value) { +setReplaceMethod("perCsColumns", "CredibleSetParam", function(x, value) { x@perCsColumns <- value validObject(x) x }) #' @rdname CredibleSetParam -setMethod("getL", "CredibleSetParam", function(x) x@L) +setMethod("maxNumSingleEffects", "CredibleSetParam", function(x) { + x@maxNumSingleEffects +}) #' @rdname CredibleSetParam -setMethod("getLgreedy", "CredibleSetParam", function(x) x@Lgreedy) +setMethod("maxNumSingleEffectsGreedy", "CredibleSetParam", function(x) { + x@maxNumSingleEffectsGreedy +}) #' @rdname SignalScreenParam #' @aliases SignalScreenParam-class @@ -4501,11 +4630,106 @@ setClass( medianAbsCorr = "numeric_OR_NULL", includeAllCs = "logical", perCsColumns = "character", - L = "numeric", - Lgreedy = "numeric_OR_NULL" + maxNumSingleEffects = "numeric", + maxNumSingleEffectsGreedy = "numeric_OR_NULL" ) ) +# One proportion-valued slot: a single number in [0, 1]. The slot type +# already rejects a non-numeric, so what is left to catch is the wrong +# length and the out-of-range value -- neither of which `validObject()` +# would notice on its own, which is how `coverage(p) <- c(0.9, 0.95)` used +# to be accepted. +# @noRd +.csParamProportionProblem <- function(value, field) { + if (is.null(value)) { + return(character(0)) + } + if (length(value) != 1L || is.na(value)) { + return(glue( + "{field} must be a single non-missing number in [0, 1] ", + "(got length {length(value)})." + )) + } + if (value < 0 || value > 1) { + return(glue("{field} must lie in [0, 1] (got {value}).")) + } + character(0) +} + +# One count-valued slot: a single whole number >= 1. +# @noRd +.csParamCountProblem <- function(value, field) { + if (is.null(value)) { + return(character(0)) + } + if (length(value) != 1L || is.na(value)) { + return(glue( + "{field} must be a single non-missing whole number ", + "(got length {length(value)})." + )) + } + if (value < 1 || value != round(value)) { + return(glue("{field} must be a whole number >= 1 (got {value}).")) + } + character(0) +} + +# The non-scalar slots: the secondary coverages (a vector, possibly empty) +# and the two enumerated / flag fields. +# @noRd +.csParamVectorProblems <- function(object) { + sec <- object@secondaryCoverage + secBad <- if (length(sec) == 0L) { + character(0) + } else if (anyNA(sec) || any(sec < 0) || any(sec > 1)) { + glue("secondaryCoverage values must all lie in [0, 1].") + } else { + character(0) + } + flagBad <- if ( + length(object@includeAllCs) != 1L || is.na(object@includeAllCs) + ) { + glue("includeAllCs must be a single non-missing logical.") + } else { + character(0) + } + allowed <- c("none", "alpha", "full") + colBad <- if ( + length(object@perCsColumns) != 1L || + !is_in(object@perCsColumns, allowed) + ) { + glue( + "perCsColumns must be one of ", + "{str_flatten(allowed, ', ')}." + ) + } else { + character(0) + } + c(secBad, flagBad, colBad) +} + +# Validity for CredibleSetParam. The constructor validates only +# `perCsColumns` (via arg_match), and the replacement methods are +# `x@slot <- value; validObject(x)`, so without this every range and length +# check is missing on BOTH paths -- `CredibleSetParam(coverage = 1.5)` and +# `coverage(p) <- 1.5` were equally accepted. +setValidity("CredibleSetParam", function(object) { + problems <- c( + .csParamProportionProblem(object@coverage, "coverage"), + .csParamProportionProblem(object@signalCutoff, "signalCutoff"), + .csParamProportionProblem(object@minAbsCorr, "minAbsCorr"), + .csParamProportionProblem(object@medianAbsCorr, "medianAbsCorr"), + .csParamCountProblem(object@maxNumSingleEffects, "maxNumSingleEffects"), + .csParamCountProblem( + object@maxNumSingleEffectsGreedy, + "maxNumSingleEffectsGreedy" + ), + .csParamVectorProblems(object) + ) + if (length(problems) == 0L) TRUE else as.character(problems) +}) + #' @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 @@ -4530,18 +4754,21 @@ setClass( #' 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 +#' @param maxNumSingleEffects 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. +#' @param maxNumSingleEffectsGreedy 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. +#' object, a \code{\link{MethodParam}}. Each accessor returns that +#' setting's value; each replacement form returns a modified copy. +#' \code{maxNumSingleEffects} and \code{maxNumSingleEffectsGreedy} have +#' no replacement form: 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 @@ -4553,8 +4780,8 @@ CredibleSetParam <- function( medianAbsCorr = NULL, includeAllCs = FALSE, perCsColumns = c("none", "alpha", "full"), - L = 10L, - Lgreedy = NULL + maxNumSingleEffects = 10L, + maxNumSingleEffectsGreedy = NULL ) { perCsColumns <- arg_match(perCsColumns) new( @@ -4566,8 +4793,8 @@ CredibleSetParam <- function( medianAbsCorr = medianAbsCorr, includeAllCs = includeAllCs, perCsColumns = perCsColumns, - L = L, - Lgreedy = Lgreedy + maxNumSingleEffects = maxNumSingleEffects, + maxNumSingleEffectsGreedy = maxNumSingleEffectsGreedy ) } diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index 6781533d..f9ca2bb4 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -86,7 +86,7 @@ methods::setValidity("FineMappingRow", function(object) { #' ) #' row <- fineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) #' QtlFineMappingResult( -#' study = "s1", context = "c1", trait = "g1", method = "susie", +#' studyName = "s1", context = "c1", trait = "g1", method = "susie", #' entry = list(row) #' ) #' @export @@ -207,7 +207,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { !is.null(fit$alpha) } -# Chromosome of the fit's variants (matches getTopLoci's `chrom`, no "chr"). +# Chromosome of the fit's variants (matches topLoci's `chrom`, no "chr"). # @noRd .fsusieChrom <- function(fit) { vid <- names(fit$csd_X) @@ -393,7 +393,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { } -# ---- getCredibleSetSummary helpers ------------------------------------- +# ---- credibleSetSummary helpers ------------------------------------- .emptyCsSummary <- function() { tibble( @@ -436,7 +436,8 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # present), # the per-effect prior variance V, the CS log Bayes factor (max member logBF), # and the lead (highest-PIP) variant. Sourced primarily from the entry's topLoci -# so it stays consistent with getCs / getTopLoci; V / mean-purity come from the +# so it stays consistent with credibleSets / topLoci; V / mean-purity come +# from the # stored fit. The credible-set index in the `cs` label doubles as the effect (L) # index for susie-family fits (unfiltered CS are ordered by effect). # @noRd @@ -745,9 +746,17 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # Project a posterior-view data.frame to GRanges (empty GRanges when empty). # @noRd .fmeTopLociGRanges <- function(out) { - if (is.null(out) || nrow(out) == 0L) { + if (is.null(out)) { return(GenomicRanges::GRanges()) } + # Keep the column schema when there are no retained variants, so an + # empty result is inspectable the same way a populated one is. + if (nrow(out) == 0L) { + return(S4Vectors::`mcols<-`( + GenomicRanges::GRanges(), + value = S4Vectors::DataFrame(out) + )) + } parsed <- parseVariantId(out$variant_id) gr <- GenomicRanges::GRanges( seqnames = str_c("chr", parsed$chrom), @@ -1431,7 +1440,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # The entry view for a collection row (or rows). A tuple split across # chromosomes owns several elements; they are stitched back into the single -# entry callers expect, the same contract getSumStats() keeps. +# entry callers expect, the same contract sumStats() keeps. # @noRd # One element (plus its outer-mcols payload) -> the entry view. @@ -1456,12 +1465,12 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { #' @rdname adjustPips #' @noRd setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { - vids <- getVariantIds(x) + vids <- variantIds(x) keepIdx <- .adjustPipsKeepIdx(vids, keepVariants) common <- vids[keepIdx] - fit <- .adjustPipsSubsetFit(getSusieFit(x), keepIdx, length(vids)) + fit <- .adjustPipsSubsetFit(susieFit(x), keepIdx, length(vids)) newTopLoci <- .adjustPipsRebuildTopLoci( - .fmeTopLociFromElement(rowVariants(x)), + .fmeTopLociFromElement(variants(x)), fit, common ) @@ -1471,7 +1480,7 @@ setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { variantIds = common, susieFit = fit, topLoci = newTopLoci, - cvResult = getCvResult(x) + cvResult = cvResult(x) ) }) @@ -1479,19 +1488,19 @@ setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { # The only methods this class carries. `@` is confined to these bodies, which # is what keeps the slot-access rule satisfied everywhere else. -#' @rdname getVariantIds +#' @rdname variantIds #' @export -setMethod("getVariantIds", "FineMappingRow", function(x) { +setMethod("variantIds", "FineMappingRow", function(x) { .grVariantIds(x@variants) }) -#' @rdname getSusieFit +#' @rdname susieFit #' @export -setMethod("getSusieFit", "FineMappingRow", function(x) x@susieFit) +setMethod("susieFit", "FineMappingRow", function(x) x@susieFit) -#' @rdname getCvResult +#' @rdname cvResult #' @export -setMethod("getCvResult", "FineMappingRow", function(x) x@cvResult) +setMethod("cvResult", "FineMappingRow", function(x) x@cvResult) #' @rdname show-methods #' @export @@ -1518,7 +1527,7 @@ setMethod("show", "FineMappingRow", function(object) { # The element itself. Used by the collection constructors, which store it # directly as the row's element. # @noRd -setGeneric("rowVariants", function(x, ...) standardGeneric("rowVariants")) +setGeneric("variants", function(x, ...) standardGeneric("variants")) # @noRd -setMethod("rowVariants", "FineMappingRow", function(x) x@variants) +setMethod("variants", "FineMappingRow", function(x) x@variants) diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index a891179f..213ba716 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -360,7 +360,7 @@ 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 credibleSetArgs How credible sets are built and reported, built with +#' @param credibleSetParam 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 @@ -404,7 +404,7 @@ postprocessFinemappingFits <- function( yScalar = 1, af = NULL, n = NULL, - credibleSetArgs = CredibleSetParam(), + credibleSetParam = CredibleSetParam(), fitRetention = "slim", otherQuantities = NULL, region = NULL, @@ -427,7 +427,7 @@ postprocessFinemappingFits <- function( yScalar = yScalar, af = af, n = n, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fitRetention = fitRetention, otherQuantities = otherQuantities, region = region, @@ -447,7 +447,7 @@ postprocessFinemappingFits <- function( yScalar, af, n, - credibleSetArgs, + credibleSetParam, fitRetention, otherQuantities, region, @@ -465,7 +465,7 @@ postprocessFinemappingFits <- function( yScalar = yScalar, af = af, n = n, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fitRetention = fitRetention, otherQuantities = otherQuantities, region = region, @@ -592,7 +592,7 @@ postprocessFinemappingFit.susiF <- function( yScalar = 1, af = NULL, n = NULL, - credibleSetArgs = CredibleSetParam(), + credibleSetParam = CredibleSetParam(), fitRetention = "slim", otherQuantities = NULL, region = NULL, @@ -602,7 +602,7 @@ postprocessFinemappingFit.susiF <- function( ) { csInput <- arg_match(csInput) # "slim" keeps a trimmed view of the fit; "full" the whole susie() - # return, so getSusieFit() and non-default-coverage getCs() can read + # return, so susieFit() and non-default-coverage credibleSets() can read # the full posterior matrices. trim <- identical(arg_match(fitRetention, c("slim", "full")), "slim") variantNames <- extractVariantNames(fit) @@ -611,7 +611,7 @@ postprocessFinemappingFit.susiF <- function( csInput, fit = fit, dataX = dataX, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, method = method ) .ppFinish( @@ -626,7 +626,7 @@ postprocessFinemappingFit.susiF <- function( otherQuantities = otherQuantities, region = region, conditionIdx = conditionIdx, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, trim = trim, priorEffTol = priorEffTol ) @@ -649,7 +649,7 @@ postprocessFinemappingFit.susiF <- function( otherQuantities, region, conditionIdx, - credibleSetArgs, + credibleSetParam, trim, priorEffTol ) { @@ -665,7 +665,7 @@ postprocessFinemappingFit.susiF <- function( otherQuantities = otherQuantities, region = region, conditionIdx = conditionIdx, - credibleSetArgs = credibleSetArgs + credibleSetParam = credibleSetParam ) .ppEntryAndResult( topLociFull, @@ -676,7 +676,7 @@ postprocessFinemappingFit.susiF <- function( method = method, dataY = dataY, otherQuantities = otherQuantities, - signalCutoff = credibleSetArgs$signalCutoff, + signalCutoff = credibleSetParam$signalCutoff, trim = trim, priorEffTol = priorEffTol ) @@ -748,18 +748,18 @@ postprocessFinemappingFit.susiF <- function( csInput, fit, dataX, - credibleSetArgs, + credibleSetParam, method ) { computeCsTables( fit, dataX = dataX, - coverage = credibleSetArgs$coverage, - secondaryCoverage = credibleSetArgs$secondaryCoverage, + coverage = credibleSetParam$coverage, + secondaryCoverage = credibleSetParam$secondaryCoverage, method = method, csInput = csInput, - minAbsCorr = credibleSetArgs$minAbsCorr, - medianAbsCorr = credibleSetArgs$medianAbsCorr + minAbsCorr = credibleSetParam$minAbsCorr, + medianAbsCorr = credibleSetParam$medianAbsCorr ) } @@ -776,7 +776,7 @@ postprocessFinemappingFit.susiF <- function( otherQuantities, region, conditionIdx, - credibleSetArgs + credibleSetParam ) { buildTopLoci( fit, @@ -791,7 +791,7 @@ postprocessFinemappingFit.susiF <- function( otherQuantities = otherQuantities, region = region, conditionIdx = conditionIdx, - credibleSetArgs = credibleSetArgs + credibleSetParam = credibleSetParam ) } @@ -1072,7 +1072,7 @@ computeCsTable <- function( # The between-CS correlation is a view over the fit-time LD, which lives on the # QtlDataset (genotypes) / SumStats (LD sketch) -- it is NEVER stored on the # fit. get_cs_correlation() needs only the CS membership + PIP + the LD, with -# the LD columns/rows ALIGNED to the fit's variable order (getVariantIds). +# the LD columns/rows ALIGNED to the fit's variable order (variantIds). # TRUE when the fit has fewer than two credible sets (no between-CS corr). .csCountBelowTwo <- function(fit) { @@ -1100,7 +1100,7 @@ computeCsTable <- function( # order; errors if any fit variant is absent (a missing one would misalign the # 1..p credible-set indices with a shrunken genotype matrix). .csGenotypesForFit <- function(qtlDataset, variantIds) { - geno <- getGenotypes(qtlDataset, region = .csVariantRegion(variantIds)) + geno <- genotypes(qtlDataset, region = .csVariantRegion(variantIds)) absent <- setdiff(variantIds, colnames(geno)) if (length(absent) > 0L) { abort(glue( @@ -1127,7 +1127,7 @@ setMethod( if (.csCountBelowTwo(fit)) { return(NULL) } - ldSketch <- getLdSketch(ldSource) + ldSketch <- ldSketch(ldSource) if (is.null(ldSketch)) { abort(glue( "computeCsCorrelation(): the summary-statistics ldSource ", @@ -1202,9 +1202,9 @@ setMethod( scale, primaryCsPos, effectOf, - credibleSetArgs = CredibleSetParam(includeAllCs = FALSE) + credibleSetParam = CredibleSetParam(includeAllCs = FALSE) ) { - perCs <- credibleSetArgs$perCsColumns %||% "none" + perCs <- credibleSetParam$perCsColumns %||% "none" nV <- if (is.null(alpha) || length(dim(alpha)) < 2L) { length(primaryCsPos) } else { @@ -1226,7 +1226,7 @@ setMethod( effectOf, nV, identical(perCs, "alpha"), - credibleSetArgs$includeAllCs + credibleSetParam$includeAllCs ) } @@ -1551,7 +1551,7 @@ 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 credibleSetArgs How credible sets are built and reported, built with +#' @param credibleSetParam 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. @@ -1579,7 +1579,7 @@ buildTopLoci <- function( otherQuantities = NULL, region = NULL, conditionIdx = NULL, - credibleSetArgs = CredibleSetParam(includeAllCs = FALSE) + credibleSetParam = CredibleSetParam(includeAllCs = FALSE) ) { if (missing(method)) { method <- NULL @@ -1601,7 +1601,7 @@ buildTopLoci <- function( otherQuantities = otherQuantities, region = region, conditionIdx = conditionIdx, - credibleSetArgs = credibleSetArgs + credibleSetParam = credibleSetParam ) } @@ -1619,7 +1619,7 @@ buildTopLoci <- function( otherQuantities, region, conditionIdx, - credibleSetArgs + credibleSetParam ) { nV <- length(variantNames) cov <- .btlCoverage(csTables) @@ -1634,7 +1634,7 @@ buildTopLoci <- function( cs, csTables, nV, - list(credibleSetArgs = credibleSetArgs) + list(credibleSetParam = credibleSetParam) ) .btlAssembleFinal( variantNames, @@ -1739,7 +1739,7 @@ buildTopLoci <- function( } # The per-variant N column. Numeric, so a fractional *effective* N (e.g. -# 4 / (1 / nCase + 1 / nControl)) matches getSumStatsDf(entry)$N exactly rather +# 4 / (1 / nCase + 1 / nControl)) matches as.data.frame(entry)$N exactly rather # than being truncated. With no per-variant n this falls back to the fit's # scalar N (integer nrow on the QTL path, NA otherwise); a scalar n recycles. # @noRd @@ -2122,7 +2122,7 @@ buildTopLoci <- function( fit$X_column_scale_factors, primaryCsPos, effectOfPrim, - credibleSetArgs = opts$credibleSetArgs + credibleSetParam = opts$credibleSetParam ) } @@ -2397,7 +2397,7 @@ formatFinemappingOutput <- function(post, primaryMethod) { } #' @noRd -getCsIndex <- function(snpsIdx, susieCs) { +csIndex <- function(snpsIdx, susieCs) { # Return ALL CS indices that contain this variant (not just one) idx <- which(map_lgl(susieCs, .csContains, snpsIdx = snpsIdx)) if (length(idx) == 0) { @@ -2406,7 +2406,7 @@ getCsIndex <- function(snpsIdx, susieCs) { return(idx) } #' @noRd -getTopVariantsIdx <- function(susieOutput, signalCutoff) { +topVariantsIdx <- function(susieOutput, signalCutoff) { # `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()) @@ -2418,7 +2418,7 @@ getTopVariantsIdx <- function(susieOutput, signalCutoff) { # Variants in multiple CSs get multiple rows. #' @importFrom stringr str_replace #' @noRd -getCsInfo <- function(susieOutputSetsCs, topVariantsIdx) { +csInfo <- function(susieOutputSetsCs, topVariantsIdx) { csNames <- names(susieOutputSetsCs) rows <- map( topVariantsIdx, @@ -2511,7 +2511,7 @@ calPurity <- function(lCs, X, method = "min") { #' Similar to the SuSiE set output #' @examples #' data(fsusieFineMappingExample) -#' fit <- getSusieFit(fsusieFineMappingExample) +#' fit <- susieFit(fsusieFineMappingExample) #' fsusieGetCs(fit) #' @export fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { @@ -2563,7 +2563,7 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { #' @param Y Response phenotype matrix. #' @param pos Genomics position of phenotypes, used for specifying the wavelet #' model. -#' @param L The maximum number of the credible set. +#' @param maxNumSingleEffects The maximum number of the credible set. #' @param prior method to generate the prior. #' @param maxSnpEm maximum number of SNP used for learning the prior. #' @param covLev Coverage level for the credible sets. @@ -2585,7 +2585,7 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 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) -#' fsusieWrapper(X, Y, pos = pos, L = 2, +#' fsusieWrapper(X, Y, pos = pos, maxNumSingleEffects = 2, #' prior = "mixture_normal_per_scale", maxSnpEm = 10, #' covLev = 0.95, minPurity = 0.5, maxScale = 6) #' @export @@ -2593,7 +2593,7 @@ fsusieWrapper <- function( X, Y, pos, - L, + maxNumSingleEffects, prior, maxSnpEm, covLev, @@ -2610,7 +2610,7 @@ fsusieWrapper <- function( X = X, Y = Y, pos = pos, - L = L, + L = maxNumSingleEffects, prior = prior, max_SNP_EM = maxSnpEm, cov_lev = covLev, @@ -2781,7 +2781,7 @@ fitMvsusieRss <- function( #' 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, methodArgs = FsusieOptions(L = 2)) +#' fitFsusie(X, Y, pos = pos, methodArgs = FsusieOptions(maxit = 5)) #' @export fitFsusie <- function(X, Y, pos, methodArgs = FsusieOptions()) { .assertMethodOptions(methodArgs, "FsusieOptions", "methodArgs") @@ -3213,7 +3213,7 @@ susieAshRssWeights <- function( #' Y <- multiTraitData$Y #' fit <- fitMvsusie(X = X, Y = Y, #' prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y)), -#' methodArgs = MvsusieOptions(L = 5)) +#' methodArgs = MvsusieOptions(max_iter = 50)) #' mvsusieWeights(mvsusieFit = fit) #' } #' @export @@ -3314,7 +3314,7 @@ mvsusieWeights <- function(mvsusieFit = NULL) { #' Y <- matrix(rep(base, each = n), n, nPos) + #' X[, 1] %o% (0.5 * cos(seq(0, pi, length.out = nPos))) #' pos <- seq_len(nPos) -#' fit <- fsusieWrapper(X, Y, pos = pos, L = 2, +#' fit <- fsusieWrapper(X, Y, pos = pos, maxNumSingleEffects = 2, #' prior = "mixture_normal_per_scale", maxSnpEm = 10, #' covLev = 0.95, minPurity = 0.5, maxScale = 6) #' fsusieWeights(fsusieFit = fit, X = X, Y = Y, @@ -3805,10 +3805,10 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { #' @return The trimmed fit (a list with \code{pip}, \code{sets}, etc.) or NULL. #' @examples #' data(qtlSumStatsExample) -#' getSusieResult(qtlSumStatsExample) +#' susieResult(qtlSumStatsExample) #' @importFrom checkmate assertList #' @export -getSusieResult <- function(conData) { +susieResult <- 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. @@ -3833,12 +3833,12 @@ getSusieResult <- function(conData) { #' #' @param fmRow A \code{\link{fineMappingRow}}, or a single-row #' fine-mapping collection as returned by -#' \code{\link{getFineMappingResult}}, carrying the SuSiE fit and +#' \code{\link{fineMappingResult}}, 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 -#' \code{\link{getTopLoci}}) carrying \code{variant_id}, \code{pip}, and +#' \code{\link{topLoci}}) carrying \code{variant_id}, \code{pip}, and #' \code{z} columns. #' @param ldSource The LD source from which the between-credible-set correlation #' is derived on demand: a \code{QtlDataset} (individual-level) or a @@ -3910,7 +3910,7 @@ extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { #' #' @param fmRow A \code{\link{fineMappingRow}}, or a single-row #' fine-mapping collection as returned by -#' \code{\link{getFineMappingResult}}, carrying the SuSiE fit and +#' \code{\link{fineMappingResult}}, 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}). @@ -4267,7 +4267,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { infFit, X, y, - credibleSetArgs, + credibleSetParam, methodArgs, verbose, ctx, @@ -4281,7 +4281,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { infFit, X = X, y = y, - coverage = credibleSetArgs$coverage, + coverage = credibleSetParam$coverage, methodArgs = methodArgs, verbose = verbose, ctx = ctx, @@ -4295,7 +4295,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { tk, X = X, y = y, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, af = af, fitRetention = fitRetention ) @@ -4307,10 +4307,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { # @noRd .fmXFitAll <- function( toRun, - addSusieInf, + initializeWithSusieInf, X, y, - credibleSetArgs, + credibleSetParam, methodArgs, verbose, ctx, @@ -4318,12 +4318,12 @@ extractTopPipInfo <- function(fmRow, sumstats) { af, fitRetention ) { - chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) + chainLocal <- .fmResolveSusieChain(toRun, initializeWithSusieInf) infFit <- .fmXInfFit( chainLocal, X = X, y = y, - coverage = credibleSetArgs$coverage, + coverage = credibleSetParam$coverage, methodArgs = methodArgs, verbose = verbose, ctx = ctx, @@ -4337,7 +4337,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { infFit = infFit, X = X, y = y, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, methodArgs = methodArgs, verbose = verbose, ctx = ctx, @@ -4353,8 +4353,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { X, y, toRun, - addSusieInf, - credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), + initializeWithSusieInf, + credibleSetParam = CredibleSetParam(includeAllCs = FALSE), methodArgs, verbose, ctx, @@ -4368,10 +4368,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { ) { out <- .fmXFitAll( toRun, - addSusieInf = addSusieInf, + initializeWithSusieInf = initializeWithSusieInf, X = X, y = y, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, methodArgs = methodArgs, verbose = verbose, ctx = ctx, @@ -4383,7 +4383,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { out, X = X, y = y, - coverage = credibleSetArgs$coverage, + coverage = credibleSetParam$coverage, methodArgs = methodArgs, cvFolds = cvFolds, cvThreads = cvThreads, @@ -4473,7 +4473,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { tk, X, y, - credibleSetArgs, + credibleSetParam, af, fitRetention ) { @@ -4484,7 +4484,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { dataY = y, af = af, csInput = "X", - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fitRetention = fitRetention ) } @@ -4547,25 +4547,25 @@ extractTopPipInfo <- function(fmRow, sumstats) { R, n, toRun, - addSusieInf, - credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), + initializeWithSusieInf, + credibleSetParam = CredibleSetParam(includeAllCs = FALSE), methodArgs, verbose, label, af = NULL, nVar = NULL, fitRetention = "slim", - rssArgs + susieRssParam ) { - chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) + chainLocal <- .fmResolveSusieChain(toRun, initializeWithSusieInf) infFit <- .fmRssInfFit( chainLocal, z = z, R = R, n = n, - coverage = credibleSetArgs$coverage, + coverage = credibleSetParam$coverage, methodArgs = methodArgs, - rssArgs = rssArgs, + susieRssParam = susieRssParam, verbose = verbose, label = label ) @@ -4578,9 +4578,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { z = z, R = R, n = n, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, methodArgs = methodArgs, - rssArgs = rssArgs, + susieRssParam = susieRssParam, verbose = verbose, label = label, af = af, @@ -4601,9 +4601,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { z, R, n, - credibleSetArgs, + credibleSetParam, methodArgs, - rssArgs, + susieRssParam, verbose, label, af, @@ -4617,9 +4617,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { z = z, R = R, n = n, - coverage = credibleSetArgs$coverage, + coverage = credibleSetParam$coverage, methodArgs = methodArgs, - rssArgs = rssArgs, + susieRssParam = susieRssParam, verbose = verbose, label = label ) @@ -4630,13 +4630,13 @@ extractTopPipInfo <- function(fmRow, sumstats) { f$fit, R = R, z = z, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, af = af, nVar = nVar, fitRetention = fitRetention ) - if (f$isStd && isTRUE(rssArgs$serFallback)) { - return(.fmRssRecordFallback(entry, f, rssArgs$keepFullFit)) + if (f$isStd && isTRUE(susieRssParam$serFallback)) { + return(.fmRssRecordFallback(entry, f, susieRssParam$keepFullFit)) } entry } @@ -4649,7 +4649,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { n, coverage, methodArgs, - rssArgs, + susieRssParam, verbose, label ) { @@ -4667,9 +4667,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { "susieInf", coverage = coverage, userArgs = methodArgs[["susieInf"]], - rFinite = rssArgs$rFinite, - rMismatch = rssArgs$rMismatch, - rssControl = .rssControlList(rssArgs$control) + rFinite = susieRssParam$rFinite, + rMismatch = susieRssParam$rMismatch, + rssControl = .rssControlList(susieRssParam$control) ) } @@ -4684,7 +4684,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { n, coverage, methodArgs, - rssArgs, + susieRssParam, verbose, label ) { @@ -4708,11 +4708,11 @@ extractTopPipInfo <- function(fmRow, sumstats) { chainFromInf = chainFrom, coverage = coverage, userArgs = methodArgs[[tk]], - rFinite = rssArgs$rFinite, - rMismatch = rssArgs$rMismatch, - rssControl = .rssControlList(rssArgs$control) + rFinite = susieRssParam$rFinite, + rMismatch = susieRssParam$rMismatch, + rssControl = .rssControlList(susieRssParam$control) ) - .fmRssSerFallback(fit, rssArgs) + .fmRssSerFallback(fit, susieRssParam) } # An unreliable LD matrix makes the multi-effect fit untrustworthy, so with @@ -4720,7 +4720,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { # 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) { +.fmRssSerFallback <- function(fit, susieRssParam) { rfd <- fit$R_finite_diagnostics flag <- if (!is.null(rfd) && !is.null(rfd$R_reliability_flag)) { isTRUE(rfd$R_reliability_flag) @@ -4728,7 +4728,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { NA } if ( - !isTRUE(rssArgs$serFallback) || !isTRUE(flag) || is.null(rfd$ser_model) + !isTRUE(susieRssParam$serFallback) || + !isTRUE(flag) || + is.null(rfd$ser_model) ) { return(list(fit = fit, flag = flag, multiFit = NULL)) } @@ -4749,7 +4751,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { n, coverage, methodArgs, - rssArgs, + susieRssParam, verbose, label ) { @@ -4781,7 +4783,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { n = n, coverage = coverage, methodArgs = methodArgs, - rssArgs = rssArgs, + susieRssParam = susieRssParam, verbose = verbose, label = label ) @@ -4793,7 +4795,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { fit, R, z, - credibleSetArgs, + credibleSetParam, af, nVar, fitRetention @@ -4809,7 +4811,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { # never 1. This is NOT `n` (the scalar median the RSS fit consumes). n = nVar, csInput = "Xcorr", - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fitRetention = fitRetention ) } @@ -4837,10 +4839,10 @@ extractTopPipInfo <- function(fmRow, sumstats) { # assigning into it. The variants and topLoci are unchanged, so this # round-trips them through the same builder the caller used. fineMappingRow( - variantIds = getVariantIds(ent), + variantIds = variantIds(ent), susieFit = sf, topLoci = .fmrPartsTopLoci(ent), - cvResult = getCvResult(ent) + cvResult = cvResult(ent) ) } @@ -4878,7 +4880,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { yScalar, af, n, - credibleSetArgs, + credibleSetParam, fitRetention, otherQuantities, region, @@ -4896,7 +4898,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { yScalar = yScalar, af = af, n = n, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, fitRetention = fitRetention, otherQuantities = otherQuantities, region = region, @@ -4974,7 +4976,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { # One (variant, CS) block of rows for variant `vi`. # @noRd .csInfoRow <- function(vi, susieOutputSetsCs, csNames) { - idx <- getCsIndex(vi, susieOutputSetsCs) + idx <- csIndex(vi, susieOutputSetsCs) if (length(idx) == 1 && is.na(idx)) { return(tibble( variant_idx = vi, diff --git a/R/genotypeIo.R b/R/genotypeIo.R index 17149aa7..cc5d515c 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -145,7 +145,7 @@ setMethod( # via .emptySketch (the empty / PIP-skip path), never on a surviving region. methods::initialize( handle, - snpInfo = slice(getSnpInfo(handle), integer(0)), + snpInfo = slice(snpInfo(handle), integer(0)), sampleIds = character(0), nSamples = 0L ) @@ -155,7 +155,7 @@ setMethod( if (is.null(handle)) { return(NULL) } - si <- getSnpInfo(handle) + si <- snpInfo(handle) keepIdx <- if (is.logical(keep)) which(keep) else as.integer(keep) if (length(keepIdx) >= nrow(si)) { return(handle) @@ -382,7 +382,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # tryCatch could see. The sharded branch above already returns early for # the same reason; this is the single-file path catching up. if (length(snpIdx) == 0L) { - return(.emptyBlockSe(getSampleIds(handle))) + return(.emptyBlockSe(sampleIds(handle))) } # Read ascending, then put the columns back in the requested order. See # .restoreRequestedOrder() for why this is not merely tidiness. @@ -402,7 +402,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # with what the ID-selecting backends actually hand back. # @noRd .genotypeFilePos <- function(handle, snpIdx) { - fileIdx <- getSnpInfo(handle)$fileIdx + fileIdx <- snpInfo(handle)$fileIdx if (is.null(fileIdx)) snpIdx else fileIdx[snpIdx] } @@ -518,7 +518,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # describe variants the same way, and overlaps between the two actually hit. # @noRd .genotypeSnpRanges <- function(genotypes, variantIds) { - si <- getSnpInfo(genotypes) + si <- snpInfo(genotypes) `names<-`( GenomicRanges::GRanges( seqnames = withChrPrefix(as.character(si$CHR)), @@ -534,7 +534,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # Dispatch block extraction to the format-specific backend (samples x variants). # @noRd .extractBlockByFormat <- function(handle, snpIdx) { - fmt <- getFormat(handle) + fmt <- genotypeFormat(handle) switch( fmt, "gds" = .extractBlockGds(handle, snpIdx), @@ -549,7 +549,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # SummarizedExperiment with per-variant rowRanges + sample colData. # @noRd .blockGenotypesToSe <- function(geno, handle, snpIdx) { - si <- slice(getSnpInfo(handle), snpIdx) + si <- slice(snpInfo(handle), snpIdx) chr <- str_c( "chr", str_remove(as.character(si$CHR), regex("^chr", ignore_case = TRUE)) @@ -561,7 +561,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { A1 = si$A1, A2 = si$A2 ) - sampleIds <- getSampleIds(handle) + sampleIds <- sampleIds(handle) # Transpose to Bioc convention: variants x samples. dosage <- `dimnames<-`(t(geno), list(si$SNP, sampleIds)) SummarizedExperiment( @@ -582,7 +582,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { unifiedChr, meanImpute ) { - if (!is_in(chrom, names(getChromPaths(handle)))) { + if (!is_in(chrom, names(chromPaths(handle)))) { msg <- glue( "extractBlockGenotypes: no per-chromosome file for chromosome ", "'{chrom}' (have: ", @@ -612,11 +612,11 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # case -- returns its one SE directly. #' @keywords internal .extractBlockSharded <- function(handle, snpIdx, meanImpute = TRUE) { - sampleIds <- getSampleIds(handle) + sampleIds <- sampleIds(handle) if (length(snpIdx) == 0L) { return(.emptyBlockSe(sampleIds)) } - unifiedChr <- canonChrom(getSnpInfo(handle)$CHR) + unifiedChr <- canonChrom(snpInfo(handle)$CHR) groups <- split(seq_along(snpIdx), unifiedChr[snpIdx]) ses <- set_names( map2( @@ -680,7 +680,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @keywords internal .extractBlockVcf <- function(handle, snpIdx) { - si <- slice(getSnpInfo(handle), snpIdx) + si <- slice(snpInfo(handle), snpIdx) gr <- GRanges( seqnames = si$CHR, ranges = IRanges(start = si$BP, end = si$BP) @@ -709,7 +709,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @keywords internal .extractBlockPlink1 <- function(handle, snpIdx) { - snpIds <- getSnpInfo(handle)$SNP[snpIdx] + snpIds <- snpInfo(handle)$SNP[snpIdx] pathStem <- .genotypeReadPath(handle) plinkData <- snpStats::read.plink( bed = str_c(pathStem, ".bed"), @@ -727,7 +727,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { .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 + # become stale), so we re-open from path() on the fly if the cached # pointer errors out. Opening is cheap relative to dosage extraction. paths <- resolvePlink2Paths(.genotypeReadPath(handle)) # `variant_subset` indexes the .pgen by FILE position. `snpIdx` is a @@ -735,12 +735,12 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # fileIdx to recover the true .pgen index. For a full handle fileIdx == # seq_len(nrow), so this is a no-op. Older RDS handles predate the column -> # fall back to snpIdx. - fileIdx <- getSnpInfo(handle)$fileIdx + fileIdx <- snpInfo(handle)$fileIdx variantSubset <- if (is.null(fileIdx)) snpIdx else fileIdx[snpIdx] # 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. - ptr <- getPgenPtr(handle) %||% pgenlibr::NewPgen(paths$pgen) + ptr <- pgenPtr(handle) %||% pgenlibr::NewPgen(paths$pgen) geno <- try_fetch( pgenlibr::ReadList( ptr, @@ -949,7 +949,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # ----------------------------------------------------------------------------- # Low-level PLINK / VCF / GDS variant-metadata readers, the stochastic # genotype sidecar helpers (.afreq / .stochastic_meta.tsv), and the -# top-level dispatchers loadGenotypeRegion + getRefVariantInfo that +# top-level dispatchers loadGenotypeRegion + refVariantInfo that # auto-detect the underlying format and route to the correct reader. # ============================================================================= @@ -1276,9 +1276,9 @@ readVariantMetadata <- function(snpFilePath) { #' @examples #' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", #' package = "pecotmr") -#' getRefVariantInfo(meta, region = "chr22:10000000-19000000") +#' refVariantInfo(meta, region = "chr22:10000000-19000000") #' @export -getRefVariantInfo <- function(source, region = NULL) { +refVariantInfo <- function(source, region = NULL) { resolved <- resolveLdSource(source) dataPath <- .refDataPath(resolved, region) if (resolved$type == "plink2") { @@ -1352,10 +1352,10 @@ getRefVariantInfo <- function(source, region = NULL) { } # Pre-computed LD variant info: read the per-intersection bim/pvar metadata -# (already region-filtered by getRegionalLdMeta). +# (already region-filtered by regionalLdMeta). # @noRd .refInfoPrecomputedLd <- function(resolved, region) { - bimPaths <- getRegionalLdMeta( + bimPaths <- regionalLdMeta( resolved$metaPath, region )$intersections$bimFilePaths @@ -1522,7 +1522,7 @@ loadGenotypeRegion <- function( stochasticMetaFormat = NULL ) { handle <- .loadGenoHandle(genotype) - handleSnpInfo <- getSnpInfo(handle) + handleSnpInfo <- snpInfo(handle) snpIdx <- .loadGenoSnpIdx(handleSnpInfo, region) # Samples x variants matrix (pecotmr convention); callers handle missing. extracted <- list( @@ -1584,7 +1584,7 @@ loadGenotypeRegion <- function( #' @importFrom dplyr left_join #' @noRd .loadGenoAttachAfreq <- function(handle, variantInfo) { - if (getFormat(handle) != "plink2") { + if (genotypeFormat(handle) != "plink2") { return(variantInfo) } afreq <- readAfreq(.genotypeReadPath(handle)) @@ -1757,7 +1757,7 @@ loadGenotypeRegion <- function( # is needed; it also handles non-contiguous SNP selection. # @noRd .gdsBlockGeno <- function(gds, handle, snpIdx) { - snpIds <- getSnpInfo(handle)$SNP[snpIdx] + snpIds <- snpInfo(handle)$SNP[snpIdx] geno <- SNPRelate::snpgdsGetGeno( gds, snp.id = snpIds, @@ -1777,7 +1777,7 @@ loadGenotypeRegion <- function( # given in, and labels nothing. Ask in ascending order and permute back, # exactly as the block readers do, so the matrix agrees with its names. ord <- order(.genotypeFilePos(handle, snpIdx)) - snpIds <- getSnpInfo(handle)$SNP[snpIdx[ord]] + snpIds <- snpInfo(handle)$SNP[snpIdx[ord]] ldMat <- SNPRelate::snpgdsLDMat( gds, snp.id = snpIds, @@ -1787,7 +1787,7 @@ loadGenotypeRegion <- function( ) raw <- replace(ldMat$LD, is.na(ldMat$LD), 0) inv <- order(ord) - ids <- getSnpInfo(handle)$SNP[snpIdx] + ids <- snpInfo(handle)$SNP[snpIdx] `dimnames<-`(raw[inv, inv, drop = FALSE], list(ids, ids)) } diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index 2cd533f6..e9a3694f 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -62,7 +62,7 @@ setClass( setMethod("show", "GwasSumStats", function(object) { cat(glue( "GwasSumStats: {nrow(object)} studies, ", - "genome build {getGenome(object)}\n", + "genome build {GenomeInfoDb::genome(object)}\n", .trim = FALSE )) ld <- object@ldSketch @@ -93,11 +93,11 @@ NULL # Recycle a length-1 per-study scalar to one value per study (or validate an # already-per-study vector), coerced to numeric. # @noRd -.recyclePerStudy <- function(v, nm, study) { - if (length(v) == 1L && length(study) > 1L) { - v <- rep(v, length(study)) +.recyclePerStudy <- function(v, nm, studyName) { + if (length(v) == 1L && length(studyName) > 1L) { + v <- rep(v, length(studyName)) } - if (length(v) != length(study)) { + if (length(v) != length(studyName)) { msg <- glue("`{nm}` must have length 1 or length(study).") abort(msg) } @@ -113,7 +113,7 @@ NULL #' Each \code{GRanges} entry must carry per-variant statistics in its mcols (at #' minimum \code{SNP}, \code{A1}, \code{A2}, \code{Z}, \code{N}; optionally #' \code{MAF}, \code{INFO}, \code{BETA}, \code{SE}, \code{P}). -#' @param study Character vector of study identifiers (must be unique). +#' @param studyName Character vector of study identifiers (must be unique). #' @param entry A \code{SimpleList} or \code{list} of \code{GRanges}, one per #' study. #' @param genome Single character string giving the genome build (e.g., @@ -135,7 +135,7 @@ NULL #' \code{NULL}). Attached only when supplied (length 1 or length(study)). Used #' as the study-level fallback for the per-variant \code{N} when a study has #' no per-variant \code{N} column and no case/control counts. Named -#' \code{nSample} to avoid clashing with \code{getNSamples()} (the LD-panel +#' \code{nSample} to avoid clashing with \code{nSamples()} (the LD-panel #' sample size). #' @param ldBlocks Optional LD-block specification: an \code{LdBlocks}, a #' \code{GRanges}, a data.frame with \code{chrom}/\code{start}/\code{end} @@ -161,7 +161,7 @@ NULL #' @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 -#' \code{length(getQcInfo(x)) == 0}. +#' \code{length(qcInfo(x)) == 0}. #' @return A \code{GwasSumStats} object. #' @examples #' panel <- readGenotypes( @@ -169,11 +169,11 @@ NULL #' gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100 * 1:3, width = 1)) #' S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:3), #' A1 = "A", A2 = "G", Z = rnorm(3), N = 100L) -#' GwasSumStats(study = "t1", entry = list(gr), genome = "hg38", +#' GwasSumStats(studyName = "t1", entry = list(gr), genome = "hg38", #' ldSketch = panel) #' @export GwasSumStats <- function( - study, + studyName, entry, genome, ldSketch = NULL, @@ -186,15 +186,15 @@ GwasSumStats <- function( blockId = NULL, extraCols = list() ) { - if (missing(study) || missing(entry) || missing(genome)) { + if (missing(studyName) || missing(entry) || missing(genome)) { abort("`study`, `entry`, and `genome` are all required.") } - varY <- .gwasValidateArgs(study, entry, genome, varY) + varY <- .gwasValidateArgs(studyName, entry, genome, varY) cols <- list( - study = as.character(study), + study = as.character(studyName), varY = varY ) |> - .gwasAppendOptional(nCase, nControl, nSample, study) |> + .gwasAppendOptional(nCase, nControl, nSample, studyName) |> .gwasAppendExtras(extraCols) dfArgs <- c(cols, list(check.names = FALSE)) # The per-study GRanges become the collection's ELEMENTS; everything else @@ -298,7 +298,7 @@ GwasSumStats <- function( # Validate genome / entry / length consistency; returns the recycled varY. # @noRd -.gwasValidateArgs <- function(study, entry, genome, varY) { +.gwasValidateArgs <- function(studyName, entry, genome, varY) { if (length(genome) != 1L) { msg <- glue( "`genome` must be a single character string (one build per ", @@ -311,31 +311,31 @@ GwasSumStats <- function( "`entry` must be a list (or SimpleList) of GRanges, one per study." ) } - if (length(entry) != length(study)) { + if (length(entry) != length(studyName)) { msg <- glue( "length(entry) ({length(entry)}) must equal ", - "length(study) ({length(study)})." + "length(studyName) ({length(studyName)})." ) abort(msg) } - .recyclePerStudy(varY, "varY", study) + .recyclePerStudy(varY, "varY", studyName) } # Attach the OPTIONAL per-study nCase / nControl / nSample columns (each only # when supplied; NA for the non-case/control studies in a mixed collection). # @noRd -.gwasAppendOptional <- function(cols, nCase, nControl, nSample, study) { +.gwasAppendOptional <- function(cols, nCase, nControl, nSample, studyName) { c( cols, compact(list( nCase = if (!is.null(nCase)) { - .recyclePerStudy(nCase, "nCase", study) + .recyclePerStudy(nCase, "nCase", studyName) }, nControl = if (!is.null(nControl)) { - .recyclePerStudy(nControl, "nControl", study) + .recyclePerStudy(nControl, "nControl", studyName) }, nSample = if (!is.null(nSample)) { - .recyclePerStudy(nSample, "nSample", study) + .recyclePerStudy(nSample, "nSample", studyName) } )) ) @@ -356,14 +356,14 @@ GwasSumStats <- function( # `study` is missing on a multi-study collection. # Element indices for one study. Returns a VECTOR, not a scalar: the seqname # split means one study can own several elements (one per chromosome), and -# getSumStats() stitches them back into the single GRanges callers expect. +# sumStats() stitches them back into the single GRanges callers expect. # @noRd -.gwasSelectStudy <- function(x, study) { +.gwasSelectStudy <- function(x, studyName) { if (nrow(x) == 0L) { abort("GwasSumStats has no rows.") } studies <- as.character(x$study) - if (missing(study) || is.null(study)) { + if (missing(studyName) || is.null(studyName)) { if (n_distinct(studies) == 1L) { return(seq_len(nrow(x))) } @@ -374,10 +374,10 @@ GwasSumStats <- function( ) abort(msg) } - idx <- which(studies == as.character(study)) + idx <- which(studies == as.character(studyName)) if (length(idx) == 0L) { msg <- glue( - "Unknown study: '{study}'. ", + "Unknown study: '{studyName}'. ", "Available: {str_flatten(unique(studies), ', ')}" ) abort(msg) @@ -389,7 +389,7 @@ GwasSumStats <- function( #' @description Return the per-variant \code{GRanges} of summary statistics for #' one study in a \code{GwasSumStats} collection. #' @param x A \code{GwasSumStats} object. -#' @param study Character (length 1) study identifier. Optional when the +#' @param studyName Character (length 1) study identifier. Optional when the #' 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. @@ -400,11 +400,11 @@ GwasSumStats <- function( #' @return A \code{GRanges} object. #' @export setMethod( - "getSumStats", + "sumStats", signature(x = "GwasSumStats"), function( x, - study = NULL, + studyName = NULL, ranges = NULL, context = NULL, trait = NULL, @@ -416,7 +416,7 @@ setMethod( # silently ignored request -- the shared SumStatsBase accessors pass # the union of both classes' selectors. .gwasRefuseQtlSelectors(context, trait, annotateSignificance) - .ssStitchElements(x, .gwasSelectStudy(x, study), ranges) + .ssStitchElements(x, .gwasSelectStudy(x, studyName), ranges) } ) @@ -431,45 +431,78 @@ setMethod( return(invisible(NULL)) } abort(glue( - "getSumStats(GwasSumStats): {str_flatten(names(given)[given], ', ')} ", + "sumStats(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). +# z / nSamples / maf / nSnps are provided once by SumStatsBase (AllClasses.R). -#' @rdname getSumStatsDf +#' @title Coerce Summary Statistics to a Data Frame +#' @description Coerce one tuple of a \code{GwasSumStats} or +#' \code{QtlSumStats} collection to a per-variant \code{data.frame} in the +#' standardized layout \code{variant_id, chrom, pos, A1, A2, z, beta, se, N, +#' maf} (optional columns omitted when absent on the entry). This is the +#' table view of \code{\link{sumStats}}, which returns the same selection as +#' a \code{GRanges}; coercion rather than a return-type argument is the +#' Bioconductor idiom for choosing a representation. +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @param row.names,optional Accepted for compatibility with +#' \code{as.data.frame} and ignored. +#' @param studyName 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 (\code{QtlSumStats} only). +#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to +#' this trait; \code{NULL} matches all traits (\code{QtlSumStats} only). +#' @param require Character vector. Columns that must be present (derived if +#' necessary) in the returned summary-statistics data frame. +#' @param derive Whether to derive missing standard columns from the available +#' ones; \code{"zFromBetaSe"} recovers \code{z} from \code{beta}/\code{se}. +#' @param keepChrPrefix Logical. If \code{TRUE}, keep the \code{chr} prefix on +#' chromosome names; otherwise strip it. +#' @param ... Unused. +#' @return A \code{data.frame}. +#' @examples +#' data(qtlSumStatsExample) +#' head(as.data.frame(qtlSumStatsExample)) +#' @rdname sumStatsDataFrame +#' @aliases sumStatsDataFrame #' @export setMethod( - "getSumStatsDf", + "as.data.frame", "GwasSumStats", function( x, - study = NULL, + row.names = NULL, + optional = FALSE, + studyName = NULL, require = character(0), derive = c("none", "zFromBetaSe"), - keepChrPrefix = TRUE + keepChrPrefix = TRUE, + ... ) { derive <- arg_match(derive) - gr <- getSumStats(x, study = study) + gr <- sumStats(x, studyName = studyName) .entryToSumstatDf( gr, require = require, derive = derive, keepChrPrefix = keepChrPrefix, label = glue( - "GwasSumStats[{if (is.null(study)) '' else study}]" + "GwasSumStats[", + "{if (is.null(studyName)) '' else studyName}]" ) ) } ) -#' @rdname getVarY +#' @rdname varY #' @export -setMethod("getVarY", "GwasSumStats", function(x, study = NULL) { - idx <- .gwasSelectStudy(x, study) +setMethod("varY", "GwasSumStats", function(x, studyName = NULL) { + idx <- .gwasSelectStudy(x, studyName) val <- x$varY[[idx]] if (is.na(val)) NULL else val }) @@ -478,37 +511,6 @@ setMethod("getVarY", "GwasSumStats", function(x, study = NULL) { # Coercion / converters # ============================================================================= -#' @title Convert GwasSumStats to data.frame -#' @description Extracts the per-variant statistics for one study (selected by -#' \code{study}) into a plain data.frame with columns SNP, CHR, BP, A1, A2, Z, -#' N (and any optional columns such as MAF, BETA, SE, P). -#' @param x A \code{GwasSumStats} object. -#' @param row.names Ignored (present for S3 generic compatibility). -#' @param optional Ignored. -#' @param study Character (length 1) study identifier. Optional when the -#' collection has a single row. -#' @param ... Ignored. -#' @return A data.frame. -#' @method as.data.frame GwasSumStats -#' @export -as.data.frame.GwasSumStats <- function( - x, - row.names = NULL, - optional = FALSE, - study = NULL, - ... -) { - gr <- getSumStats(x, study = study) - 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))) -} - #' Combine GwasSumStats collections #' #' Row-bind two or more \code{\link{GwasSumStats}} collections into one -- e.g. @@ -521,7 +523,7 @@ as.data.frame.GwasSumStats <- function( #' input: \code{genome} and the \code{\link{summaryStatsQc}} options must agree #' across the inputs (a mismatch is an error, not a silent first-wins), the #' per-element \code{qcInfo$entryAudit} concatenates in element order so -#' \code{\link{getQcDiagnostics}} keeps addressing the right element, and the +#' \code{\link{qcDiagnostics}} keeps addressing the right element, and the #' LD sketches union into one panel over the shared genotype handle. That last #' one matters: block-parallel pipelines narrow each piece's panel to its own #' block, so keeping only the first would leave a multi-block collection whose diff --git a/R/h2Annotations.R b/R/h2Annotations.R index 264de4e1..72179c11 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -188,7 +188,8 @@ setMethod( ) } -# (The AnnotationMatrix() constructor and the getBaseline / getCandidates tier +# (The AnnotationMatrix() constructor and the baselineAnnotations / +# testedAnnotations tier # accessors now live in R/AnnotationMatrix.R alongside the class definition.) # The mean BigWig score at one SNP (0 when the SNP has no overlapping diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index f0106bcb..6d7bfb1c 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -94,16 +94,22 @@ jackknifeSe <- function(estimatesFull, estimatesLoo) { # Enrichment SE: jackknife over per-block enrichment (preferred) or the # delta-method fallback tauSe * M / |h2| when no blocks are available. # @noRd -.baselineEnrichmentSe <- function(tauBlocks, tauSe, M_a, M, h2) { - if (is.null(tauBlocks)) { +.baselineEnrichmentSe <- function(annotationJackknifeCoefs, tauSe, M_a, M, h2) { + if (is.null(annotationJackknifeCoefs)) { return(tauSe * M / abs(h2)) } - nBlocks <- nrow(tauBlocks) - rawH2 <- as.vector(tauBlocks %*% M_a) + nBlocks <- nrow(annotationJackknifeCoefs) + rawH2 <- as.vector(annotationJackknifeCoefs %*% 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 + enrichmentBlocks <- sweep( + annotationJackknifeCoefs, + 1, + h2Blocks, + FUN = "/" + ) * + M enrichmentMean <- colMeans(enrichmentBlocks, na.rm = TRUE) enrichmentVar <- (nBlocks - 1) / nBlocks * @@ -117,8 +123,8 @@ jackknifeSe <- function(estimatesFull, estimatesLoo) { #' enrichment SE (from jackknife or delta method), and p-value. #' @param tau Numeric vector of per-annotation regression coefficients. #' @param tauSe Numeric vector of SE for tau. -#' @param tauBlocks Numeric matrix (nBlocks x nAnnotations) of jackknife -#' block-level tau values, or NULL. +#' @param annotationJackknifeCoefs Numeric matrix (nBlocks x nAnnotations) of +#' jackknife block-level tau values, or NULL. #' @param baselineMat Numeric matrix (nSnps x nAnnotations). #' @param annotNames Character vector of annotation names. #' @param h2 Numeric scalar, total estimated h2. @@ -128,7 +134,7 @@ jackknifeSe <- function(estimatesFull, estimatesLoo) { computeBaselineEnrichment <- function( tau, tauSe, - tauBlocks, + annotationJackknifeCoefs, baselineMat, annotNames, h2 @@ -139,7 +145,13 @@ computeBaselineEnrichment <- function( propH2 <- (tau * M_a) / h2 # Enrichment ratio (propH2 / propSnps) = tau * M / h2. enrichment <- tau * M / h2 - enrichmentSe <- .baselineEnrichmentSe(tauBlocks, tauSe, M_a, M, h2) + enrichmentSe <- .baselineEnrichmentSe( + annotationJackknifeCoefs, + tauSe, + M_a, + M, + h2 + ) enrichmentP <- .zToPvalue(enrichment / enrichmentSe) tibble( annotation = annotNames, @@ -161,27 +173,29 @@ computeBaselineEnrichment <- function( #' @description Apply shrinkage to sample LD matrix to reduce noise from finite #' reference panel size, following Wen & Stephens (2010). #' @param R Numeric matrix, sample LD correlation matrix. -#' @param nRef Integer, reference panel sample size. +#' @param nSamples Integer, reference panel sample size. #' @param shrinkageType Character, one of "wen_stephens", "constant". #' @param geneticMap Numeric vector, genetic map positions for SNPs in R. #' @return Shrunk LD correlation matrix. #' @keywords internal shrinkLd <- function( R, - nRef, + nSamples, shrinkageType = "wen_stephens", geneticMap = NULL ) { if (shrinkageType == "wen_stephens" && !is.null(geneticMap)) { # Wen & Stephens (2010) shrinkage based on genetic distance p <- nrow(R) - theta <- 2 * nRef / (22 * nRef + 16) # effective recombination + theta <- 2 * nSamples / (22 * nSamples + 16) # effective recombination distCm <- abs(outer(geneticMap, geneticMap, "-")) - shrinkFactor <- exp(-4 * nRef * distCm / (100 * (2 * nRef + 16))) + shrinkFactor <- exp( + -4 * nSamples * distCm / (100 * (2 * nSamples + 16)) + ) RShrunk <- `diag<-`(R * shrinkFactor, 1) } else { # Simple constant shrinkage - lambda <- 1 / sqrt(nRef) + lambda <- 1 / sqrt(nSamples) RShrunk <- (1 - lambda) * R + lambda * diag(nrow(R)) } RShrunk @@ -203,10 +217,35 @@ shrinkLd <- function( #' @keywords internal checkGenomeBuild <- function(...) { objects <- list(...) - genomes <- discard(map_chr(objects, .h2GenomeOfObject), is.na) - if (n_distinct(genomes) > 1L) { + # Everything supported keeps its build in seqinfo() rather than in a slot + # of its own (that redundancy is why the LdBlocks wrapper went away), so + # one seqinfo read serves them all. Reject anything else up front -- + # notably a plain list(genome = ...), the pre-seqinfo shape this check + # replaced -- instead of letting seqinfo() fail obscurely. + supported <- c( + "GenomicRanges", + "GwasSumStats", + "QtlSumStats", + "LdStatistic", + "AnnotationMatrix" + ) + known <- map_lgl(map(map(objects, methods::is), is_in, supported), any) + if (!all(known)) { + abort("Unknown object type for genome build check") + } + # genome() is per-seqlevel, so flatten across objects before uniquing: one + # object naming two builds and two objects disagreeing are the same error. + # An object naming none contributes NA and is skipped, because + # loadLdMatrix() leaves the build unset and demanding one here would + # reject every LD reference the package's own loader produces. The + # coordinate check in .h2CheckPositions() is the stronger guard regardless. + builds <- unname(discard( + unique(list_c(map(objects, GenomeInfoDb::genome))), + is.na + )) + if (length(builds) > 1L) { msg <- glue( - "Genome build mismatch: {str_flatten(genomes, ', ')}" + "Genome build mismatch: {str_flatten(builds, ', ')}" ) abort(msg) } @@ -222,8 +261,8 @@ checkGenomeBuild <- function(...) { #' \eqn{\tau^*_C = \tau_C \cdot sd_C \cdot M_{ref} / h^2_g}, with jackknife SE #' from block-level tau values. #' @param tau Numeric vector of per-annotation regression coefficients. -#' @param tauBlocks Numeric matrix (nBlocks x nAnnotations) of block-level tau -#' estimates from delete-one jackknife. +#' @param annotationJackknifeCoefs Numeric matrix (nBlocks x nAnnotations) of +#' block-level tau estimates from delete-one jackknife. #' @param sdAnnot Numeric vector of per-annotation standard deviations, same #' length as \code{tau}. #' @param MRef Scalar integer, total number of reference-panel SNPs. @@ -234,7 +273,13 @@ checkGenomeBuild <- function(...) { #' \item{tauStarSe}{Numeric vector of jackknife SE for tauStar.} #' } #' @keywords internal -standardizeTauStar <- function(tau, tauBlocks, sdAnnot, MRef, h2g) { +standardizeTauStar <- function( + tau, + annotationJackknifeCoefs, + sdAnnot, + MRef, + h2g +) { if (length(tau) != length(sdAnnot)) { abort("standardizeTauStar: tau and sdAnnot must have the same length.") } @@ -247,7 +292,7 @@ standardizeTauStar <- function(tau, tauBlocks, sdAnnot, MRef, h2g) { tauStar <- tau * coef # Jackknife SE from block-level tau - tauStarBlocks <- sweep(tauBlocks, 2L, coef, FUN = "*") + tauStarBlocks <- sweep(annotationJackknifeCoefs, 2L, coef, FUN = "*") nBlocks <- nrow(tauStarBlocks) jkVar <- apply(tauStarBlocks, 2L, var, na.rm = TRUE) tauStarSe <- sqrt((nBlocks - 1)^2 / nBlocks * jkVar) @@ -432,7 +477,7 @@ NULL #' + (1 + N a)}, so \eqn{Cov(z) = (N h2/M) R^2 + (1 + N a) R}. The IRWLS #' weight #' uses an in-sample (\eqn{\min(1,\lambda)}) or out-of-sample (logistic) form -#' selected by \code{getInSample}, and a two-stage step estimates the +#' selected by \code{inSample}, and a two-stage step estimates the #' confounding inflation \eqn{a} on a \eqn{\chi^2}-filtered subset. The #' stratified extension regresses on \eqn{\lambda_i \ell_{ia}} #' (\eqn{\ell_{ia} = \sum_j A_{ja} V_{ji}^2}) and reduces to the univariate @@ -451,7 +496,7 @@ NULL if (is.null(annotations)) { return(NULL) } - baseline <- getBaseline(annotations) + baseline <- baselineAnnotations(annotations) if (ncol(assay(baseline, "annotations")) > 0) { assay(baseline, "annotations") } else { @@ -599,22 +644,31 @@ NULL h2Loo <- map_dbl(loo, "h2") aLoo <- map_dbl(loo, "a") tauList <- map(loo, "tau") - tauBlocks <- exec(rbind, !!!tauList) + jkCoefs <- exec(rbind, !!!tauList) jkSe <- function(v) sqrt((nB - 1) / nB * sum((v - mean(v))^2)) list( h2Se = jkSe(h2Loo), aSe = jkSe(aLoo), - tauSe = apply(tauBlocks, 2, jkSe), - tauBlocks = tauBlocks + tauSe = apply(jkCoefs, 2, jkSe), + annotationJackknifeCoefs = jkCoefs ) } -# tau / tauSe / tauBlocks for the enrichment framework (univariate: tau = h2). +# tau / tauSe / annotationJackknifeCoefs for the enrichment framework +# (univariate: tau = h2). .lderEnrichParts <- function(fit, jk, baselineMat) { if (is.null(baselineMat)) { - return(list(tau = fit$h2, tauSe = jk$h2Se, tauBlocks = NULL)) + return(list( + tau = fit$h2, + tauSe = jk$h2Se, + annotationJackknifeCoefs = NULL + )) } - list(tau = fit$tau, tauSe = jk$tauSe, tauBlocks = jk$tauBlocks) + list( + tau = fit$tau, + tauSe = jk$tauSe, + annotationJackknifeCoefs = jk$annotationJackknifeCoefs + ) } # Local heritability for one block: single-slope fit with intercept fixed at @@ -682,7 +736,7 @@ NULL # LDER candidate-annotation score statistics against the fitted baseline. .lderScoreStats <- function(eigenRef, annotations, design, fit, N) { - candidate <- getCandidates(annotations) + candidate <- testedAnnotations(annotations) candMat <- assay(candidate, "annotations") nCand <- ncol(candMat) if (nCand == 0) { @@ -696,7 +750,7 @@ NULL w <- 1 / (2 * mu^2) resid <- design$x^2 - mu candCross <- map( - getEigenList(eigenRef), + eigenList(eigenRef), .h2EigenCandCrossprod, candMat = candMat ) @@ -723,10 +777,10 @@ lderUnivariate <- function( annotations = NULL, local = FALSE ) { - rough <- !getInSample(eigenRef) + rough <- !inSample(eigenRef) baselineMat <- .h2BaselineMat(annotations) blockStats <- map( - getEigenList(eigenRef), + eigenList(eigenRef), .lderBlockStats, z = z, baselineMat = baselineMat @@ -754,13 +808,13 @@ lderUnivariate <- function( jkRes <- list( se = c(jk$h2Se, jk$aSe), tauSe = ep$tauSe, - tauBlocks = ep$tauBlocks + annotationJackknifeCoefs = ep$annotationJackknifeCoefs ) enrichmentDf <- .h2Enrichment( baselineMat, ep$tau, ep$tauSe, - ep$tauBlocks, + ep$annotationJackknifeCoefs, fit$h2 ) .h2Result(fit$h2, jkRes, fit$a, ep$tau, localDf, enrichmentDf, scoreStats) @@ -799,7 +853,7 @@ lderUnivariate <- function( interceptSe = jkRes$se[2], tau = tau, tauSe = jkRes$tauSe, - tauBlocks = jkRes$tauBlocks, + annotationJackknifeCoefs = jkRes$annotationJackknifeCoefs, local = localDf, enrichment = enrichmentDf, scoreStats = scoreStats @@ -809,7 +863,13 @@ lderUnivariate <- function( # Per-annotation enrichment table via the shared tau-based framework (used by # HDL and LDER; g-LDSC builds its own from partitioned h2). NULL when # unstratified. -.h2Enrichment <- function(baselineMat, tau, tauSe, tauBlocks, h2) { +.h2Enrichment <- function( + baselineMat, + tau, + tauSe, + annotationJackknifeCoefs, + h2 +) { if (is.null(baselineMat)) { return(NULL) } @@ -821,7 +881,7 @@ lderUnivariate <- function( computeBaselineEnrichment( tau, tauSe, - tauBlocks, + annotationJackknifeCoefs, baselineMat, annotNames, h2 @@ -920,14 +980,14 @@ NULL estHList <- map(loo, "estH") estHBlocks <- exec(rbind, !!!estHList) tauList <- map(loo, "tau") - tauBlocks <- exec(rbind, !!!tauList) + jkCoefs <- exec(rbind, !!!tauList) intLoo <- map_dbl(loo, "intercept") jkSe <- function(v) sqrt(var(v) * (nB - 1)^2 / nB) list( h2Se = jkSe(estHBlocks[, 1]), intSe = jkSe(intLoo), - tauSe = apply(tauBlocks, 2, jkSe), - tauBlocks = tauBlocks, + tauSe = apply(jkCoefs, 2, jkSe), + annotationJackknifeCoefs = jkCoefs, estHBlocks = estHBlocks ) } @@ -1043,7 +1103,7 @@ gldscUnivariate <- function( annotations = NULL, local = FALSE ) { - ldMatrixList <- getLdMatrixList(ldRef) + ldMatrixList <- ldMatrixList(ldRef) if (length(ldMatrixList) == 0L) { msg <- glue( "g-LDSC requires full per-block LD matrices (ldMatrixList). ", @@ -1071,7 +1131,7 @@ gldscUnivariate <- function( if (is.null(annotations)) { return(NULL) } - candMat <- assay(getCandidates(annotations), "annotations") + candMat <- assay(testedAnnotations(annotations), "annotations") sc <- .gldscScoreStats(preps, candMat, rawNtau, fit$coef) if (is.null(sc)) { return(NULL) @@ -1080,7 +1140,7 @@ gldscUnivariate <- function( z = sc$scoreZ, R = sc$R, annotationNames = SummarizedExperiment::colData( - getCandidates(annotations) + testedAnnotations(annotations) )$name ) } @@ -1096,7 +1156,9 @@ gldscUnivariate <- function( fit, jk, baselineMat, - SummarizedExperiment::colData(getBaseline(annotations))$name, + SummarizedExperiment::colData( + baselineAnnotations(annotations) + )$name, M ) } @@ -1106,10 +1168,10 @@ gldscUnivariate <- function( jkRes <- list( se = c(jk$h2Se, jk$intSe), tauSe = tauSe, - tauBlocks = if (is.null(baselineMat)) { + annotationJackknifeCoefs = if (is.null(baselineMat)) { NULL } else { - jk$tauBlocks[, -1, drop = FALSE] + jk$annotationJackknifeCoefs[, -1, drop = FALSE] } ) .h2Result( @@ -1162,14 +1224,22 @@ NULL # `bstar^2 / lamh2` term it feeds dominates the likelihood -- a smaller floor # changes the objective by orders of magnitude and moves the optimum. # @noRd -.hdlNll <- function(param, n, nRef, lam, bstar, ldAnnotScaled, lim = exp(-10)) { +.hdlNll <- function( + param, + n, + nSamples, + lam, + bstar, + ldAnnotScaled, + lim = exp(-10) +) { nTau <- ncol(ldAnnotScaled) h2a <- param[seq_len(nTau)] int <- param[nTau + 1L] lamh2 <- pmax( as.vector(ldAnnotScaled %*% h2a) * lam^2 - - lam * sum(h2a) / nRef + + lam * sum(h2a) / nSamples + int * lam / n, lim ) @@ -1228,7 +1298,7 @@ NULL # Fit HDL by L-BFGS-B over (h2_1..h2_nTau, int); bounds h2_a in [0,1], int in # [0,10] (Ning et al. 2020). Parametrizing by per-annotation h2 (scale ~1) # keeps the L-BFGS-B finite differences well conditioned. -.hdlFit <- function(design, n, nRef, warnOnBound = TRUE) { +.hdlFit <- function(design, n, nSamples, warnOnBound = TRUE) { nTau <- ncol(design$ldAnnotScaled) lower <- c(rep(0, nTau), 0) upper <- c(rep(1, nTau), 10) @@ -1236,7 +1306,7 @@ NULL c(rep(0.1, nTau), 1), .hdlNll, n = n, - nRef = nRef, + nSamples = nSamples, lam = design$lam, bstar = design$bstar, ldAnnotScaled = design$ldAnnotScaled, @@ -1245,7 +1315,7 @@ NULL upper = upper ) if (warnOnBound) { - .hdlWarnIfAtBound(opt$par, upper, n, nRef) + .hdlWarnIfAtBound(opt$par, upper, n, nSamples) } h2a <- opt$par[seq_len(nTau)] list(h2a = h2a, int = opt$par[nTau + 1L], h2 = sum(h2a)) @@ -1268,7 +1338,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, upper, n, nRef) { +.hdlWarnIfAtBound <- function(par, upper, n, nSamples) { tol <- 1e-6 atUpper <- par >= upper - tol if (!any(atUpper)) { @@ -1283,8 +1353,9 @@ NULL "HDL: the fitted {which} sits at the top of its range, so the ", "estimate reflects that bound rather than the data. This usually ", "means the LD reference is too small for the GWAS -- the ", - "finite-reference correction scales as 1/nRef, and here nRef = ", - "{nRef} against N = {round(n)}. Compare the other estimators, or ", + "finite-reference correction scales as 1/nSamples, and here ", + "nSamples = {nSamples} against N = {round(n)}. Compare the other ", + "estimators, or ", "use a larger reference panel." )) invisible(TRUE) @@ -1292,10 +1363,13 @@ NULL # Baseline modeled variance lamh2_i at the fitted parameters (for local h2 and # the sHDL candidate score test). -.hdlBaselineVar <- function(design, ft, n, nRef, lim = exp(-10)) { +.hdlBaselineVar <- function(design, ft, n, nSamples, lim = exp(-10)) { s <- as.vector(design$ldAnnotScaled %*% ft$h2a) pmax( - s * design$lam^2 - design$lam * ft$h2 / nRef + ft$int * design$lam / n, + s * + design$lam^2 - + design$lam * ft$h2 / nSamples + + ft$int * design$lam / n, lim ) } @@ -1307,7 +1381,7 @@ NULL # Delete-one-block jackknife (Ning et al. 2020): refit leaving each block out, # SE = sqrt(mean((jack - mean)^2) * (nBlocks - 1)). Returns per-annotation and # total-h2 SEs, the intercept SE, and the LOO per-annotation blocks. -.hdlJackknife <- function(blockData, M, baselineMat, n, nRef) { +.hdlJackknife <- function(blockData, M, baselineMat, n, nSamples) { nBlocks <- length(blockData) loo <- map( seq_len(nBlocks), @@ -1316,7 +1390,7 @@ NULL M = M, baselineMat = baselineMat, n = n, - nRef = nRef + nSamples = nSamples ) h2aList <- map(loo, "h2a") h2aBlocks <- exec(rbind, !!!h2aList) @@ -1334,12 +1408,16 @@ NULL # enrichment framework (univariate: tau = h2 scalar, no blocks). .hdlEnrichParts <- function(ft, jk, design, baselineMat) { if (is.null(baselineMat)) { - return(list(tau = ft$h2, tauSe = jk$h2Se, tauBlocks = NULL)) + return(list( + tau = ft$h2, + tauSe = jk$h2Se, + annotationJackknifeCoefs = NULL + )) } list( tau = ft$h2a / design$M_a, tauSe = jk$h2aSe / design$M_a, - tauBlocks = sweep(jk$h2aBlocks, 2, design$M_a, "/") + annotationJackknifeCoefs = sweep(jk$h2aBlocks, 2, design$M_a, "/") ) } @@ -1350,14 +1428,17 @@ NULL # Local h2 for one block: MLE of the block's genome-wide-scaled h2 with the # intercept fixed at the global fit; SE from the Gaussian-variance Fisher # information sum((dlamh2/dh2)^2 / (2 lamh2^2)). -.hdlLocalBlock <- function(bd, b, n, nRef, int, M, lim = exp(-10)) { +.hdlLocalBlock <- function(bd, b, n, nSamples, int, M, lim = exp(-10)) { varOf <- function(h2) { - pmax(h2 / M * bd$lam^2 - h2 * bd$lam / nRef + int * bd$lam / n, lim) + pmax( + h2 / M * bd$lam^2 - h2 * bd$lam / nSamples + int * bd$lam / n, + lim + ) } nll <- function(h2) sum(log(varOf(h2)) + bd$bstar^2 / varOf(h2)) h2 <- optimize(nll, c(0, 1))$minimum lamh2 <- varOf(h2) - g <- bd$lam^2 / M - bd$lam / nRef + g <- bd$lam^2 / M - bd$lam / nSamples info <- sum(g^2 / (2 * lamh2^2)) tibble( blockId = b, @@ -1367,14 +1448,14 @@ NULL } # Per-block local heritability (NULL unless requested). -.hdlLocal <- function(blockData, n, nRef, int, M) { +.hdlLocal <- function(blockData, n, nSamples, int, M) { bind_rows( map( seq_along(blockData), .hdlLocalRow, blockData = blockData, n = n, - nRef = nRef, + nSamples = nSamples, int = int, M = M ) @@ -1390,26 +1471,26 @@ NULL lam, lamh2, scoreResid, - nRef, + nSamples, keep ) { - g <- ldCandCol[keep] * lam[keep]^2 / M_c - lam[keep] / nRef + g <- ldCandCol[keep] * lam[keep]^2 / M_c - lam[keep] / nSamples lh <- lamh2[keep] sum(g * scoreResid[keep]) / sqrt(2 * sum(g^2 / lh^2)) } # sHDL candidate-annotation score statistics + jackknife score correlation. .shdlStratified <- function(eigenRef, annotations, design, lamh2) { - candidate <- getCandidates(annotations) + candidate <- testedAnnotations(annotations) candMat <- assay(candidate, "annotations") nCand <- ncol(candMat) if (nCand == 0) { return(list(enrichment = NULL, scoreStats = NULL)) } - nRef <- getNRef(eigenRef) + nPanel <- ldPanelNSamples(eigenRef) M_c <- colSums(candMat) candCross <- map( - getEigenList(eigenRef), + eigenList(eigenRef), .h2EigenCandCrossprod, candMat = candMat ) @@ -1424,15 +1505,23 @@ NULL lam = design$lam, lamh2 = lamh2, scoreResid = scoreResid, - nRef = nRef, + nSamples = nPanel, keep = keepAll ) - R <- .shdlScoreCor(ldCand, M_c, design, lamh2, scoreResid, nRef, nCand) + R <- .shdlScoreCor(ldCand, M_c, design, lamh2, scoreResid, nPanel, nCand) .buildEnrichmentResult(SummarizedExperiment::colData(candidate), scoreZ, R) } # Jackknife (leave-one-block-out) correlation of the candidate score z's. -.shdlScoreCor <- function(ldCand, M_c, design, lamh2, scoreResid, nRef, nCand) { +.shdlScoreCor <- function( + ldCand, + M_c, + design, + lamh2, + scoreResid, + nSamples, + nCand +) { if (nCand == 1) { return(matrix(1, 1, 1)) } @@ -1446,7 +1535,7 @@ NULL lam = design$lam, lamh2 = lamh2, scoreResid = scoreResid, - nRef = nRef, + nSamples = nSamples, nCand = nCand ) looZ <- exec(rbind, !!!looRows) @@ -1465,9 +1554,9 @@ hdlUnivariate <- function( annotations = NULL, local = FALSE ) { - eigenList <- getEigenList(eigenRef) + eigenList <- eigenList(eigenRef) M <- length(eigenRef) - nRef <- getNRef(eigenRef) + nPanel <- ldPanelNSamples(eigenRef) baselineMat <- .h2BaselineMat(annotations) blockData <- map( eigenList, @@ -1477,26 +1566,26 @@ hdlUnivariate <- function( baselineMat = baselineMat ) design <- .hdlDesign(blockData, M, baselineMat) - ft <- .hdlFit(design, n, nRef) - jk <- .hdlJackknife(blockData, M, baselineMat, n, nRef) + ft <- .hdlFit(design, n, nPanel) + jk <- .hdlJackknife(blockData, M, baselineMat, n, nPanel) ep <- .hdlEnrichParts(ft, jk, design, baselineMat) - localDf <- if (local) .hdlLocal(blockData, n, nRef, ft$int, M) else NULL + localDf <- if (local) .hdlLocal(blockData, n, nPanel, ft$int, M) else NULL scoreStats <- if (is.null(annotations)) { NULL } else { - lamh2 <- .hdlBaselineVar(design, ft, n, nRef) + lamh2 <- .hdlBaselineVar(design, ft, n, nPanel) .shdlStratified(eigenRef, annotations, design, lamh2)$scoreStats } jkRes <- list( se = c(jk$h2Se, jk$intSe), tauSe = ep$tauSe, - tauBlocks = ep$tauBlocks + annotationJackknifeCoefs = ep$annotationJackknifeCoefs ) enrichmentDf <- .h2Enrichment( baselineMat, ep$tau, ep$tauSe, - ep$tauBlocks, + ep$annotationJackknifeCoefs, ft$h2 ) .h2Result(ft$h2, jkRes, ft$int, ep$tau, localDf, enrichmentDf, scoreStats) @@ -1613,11 +1702,11 @@ sldscUnivariate <- function( # matrices, the same source g-LDSC uses. # @noRd .sldscScoreMatrix <- function(ldRef, baselineMat, M) { - base <- as.vector(getLdScores(ldRef)[, 1L]) + base <- as.vector(mcols(ldRef)$ldScores[, 1L]) if (is.null(baselineMat)) { return(matrix(base, ncol = 1L, dimnames = list(NULL, "base_l2"))) } - ldMatrixList <- getLdMatrixList(ldRef) + ldMatrixList <- ldMatrixList(ldRef) if (length(ldMatrixList) == 0L) { msg <- glue( "stratified S-LDSC requires full per-block LD matrices ", @@ -1648,7 +1737,7 @@ sldscUnivariate <- function( # leaves one of these out at a time. # @noRd .sldscBlockIndex <- function(ldRef) { - ldMatrixList <- getLdMatrixList(ldRef) + ldMatrixList <- ldMatrixList(ldRef) if (length(ldMatrixList) > 0L) { return(map(ldMatrixList, "snpIdx")) } @@ -1656,7 +1745,7 @@ sldscUnivariate <- function( CHR = as.character(seqnames(ldRef)), BP = start(ldRef) ) - idx <- snpsPerBlock(snpInfo, getLdBlocks(ldRef)) + idx <- snpsPerBlock(snpInfo, ldBlocks(ldRef)) keep <- idx[map_int(idx, length) > 0L] if (length(keep) == 0L) { abort("S-LDSC: no LD block covers any reference variant.") @@ -1863,7 +1952,7 @@ sldscUnivariate <- function( A = A, nIter = nIter ) - tauBlocks <- exec(rbind, !!!map(loo, "tau")) + jkCoefs <- exec(rbind, !!!map(loo, "tau")) estHBlocks <- exec(rbind, !!!map(loo, "estH")) intLoo <- map_dbl(loo, "intercept") nB <- length(loo) @@ -1871,8 +1960,8 @@ sldscUnivariate <- function( list( h2Se = jkSe(estHBlocks[, 1L]), intSe = jkSe(intLoo), - tauSe = apply(tauBlocks, 2, jkSe), - tauBlocks = tauBlocks, + tauSe = apply(jkCoefs, 2, jkSe), + annotationJackknifeCoefs = jkCoefs, estHBlocks = estHBlocks ) } @@ -1911,7 +2000,9 @@ sldscUnivariate <- function( fit, jk, baselineMat, - SummarizedExperiment::colData(getBaseline(annotations))$name, + SummarizedExperiment::colData( + baselineAnnotations(annotations) + )$name, M ) } @@ -1920,10 +2011,10 @@ sldscUnivariate <- function( jkRes <- list( se = c(jk$h2Se, jk$intSe), tauSe = tauSe, - tauBlocks = if (is.null(baselineMat)) { + annotationJackknifeCoefs = if (is.null(baselineMat)) { NULL } else { - jk$tauBlocks[, -1, drop = FALSE] + jk$annotationJackknifeCoefs[, -1, drop = FALSE] } ) .h2Result(fit$h2, jkRes, fit$intercept, tau, localDf, enrichmentDf, NULL) @@ -1946,9 +2037,9 @@ sldscUnivariate <- function( # ============================================================================= # Resolve which study's stats to operate on; defaults to the single entry. -.estimateH2ResolveStudy <- function(sumstats, study) { - if (!is.null(study)) { - return(study) +.estimateH2ResolveStudy <- function(sumstats, studyName) { + if (!is.null(studyName)) { + return(studyName) } if (nrow(sumstats) != 1L) { msg <- glue( @@ -1993,12 +2084,16 @@ sldscUnivariate <- function( # reference's order, therefore yields a silently wrong h2 rather than an # error. This is the one place holding all three objects, so check here. # @noRd -.h2ValidateInputs <- function(sumstats, study, ldRef, annotations) { +.h2ValidateInputs <- function(sumstats, studyName, ldRef, annotations) { checkGenomeBuild(sumstats, ldRef) .h2CheckBlockCount(ldRef) - entry <- getSumStats(sumstats, study = study) - .h2CheckVariantCount(length(entry), length(ldRef), glue("study '{study}'")) - .h2CheckPositions(entry, ldRef, study) + entry <- sumStats(sumstats, studyName = studyName) + .h2CheckVariantCount( + length(entry), + length(ldRef), + glue("study '{studyName}'") + ) + .h2CheckPositions(entry, ldRef, studyName) if (is.null(annotations)) { return(invisible(TRUE)) } @@ -2013,7 +2108,7 @@ sldscUnivariate <- function( # say so here instead. # @noRd .h2CheckBlockCount <- function(ldRef) { - nBlocks <- length(getLdBlocks(ldRef)) + nBlocks <- length(ldBlocks(ldRef)) if (nBlocks >= 2L) { return(invisible(TRUE)) } @@ -2045,7 +2140,7 @@ sldscUnivariate <- function( # (rsid vs chr:pos:A2:A1), while the same variant always sits at the same # coordinate once the chr prefix is normalized. # @noRd -.h2CheckPositions <- function(entry, ldRef, study) { +.h2CheckPositions <- function(entry, ldRef, studyName) { same <- withChrPrefix(as.character(seqnames(entry))) == withChrPrefix(as.character(seqnames(ldRef))) & start(entry) == start(ldRef) @@ -2055,7 +2150,7 @@ sldscUnivariate <- function( nBad <- sum(!same) firstBad <- which(!same)[[1L]] msg <- glue( - "estimateH2: study '{study}' and the LD reference disagree at ", + "estimateH2: study '{studyName}' and the LD reference disagree at ", "{nBad} of {length(same)} position(s), the first at index ", "{firstBad}. The estimators index by the reference's variant ", "order, so both must hold the same variants in the same order." @@ -2064,20 +2159,20 @@ sldscUnivariate <- function( } # Wrap a univariate estimator result list into an H2Estimate S4 object. -.h2EstimateFromResult <- function(result, method, M, study) { +.h2EstimateFromResult <- function(result, method, M, studyName) { new( "H2Estimate", - h2 = result$h2, - h2Se = result$h2Se, + estimate = result$h2, + estimateSe = result$h2Se, intercept = result$intercept %||% NA_real_, interceptSe = result$interceptSe %||% NA_real_, - local = result$local, + localBlocks = result$local, enrichment = result$enrichment, - tauBlocks = result$tauBlocks, + annotationJackknifeCoefs = result$annotationJackknifeCoefs, scoreStats = result$scoreStats, method = method, nSnps = as.integer(M), - traitName = study + traitName = studyName ) } @@ -2092,19 +2187,19 @@ setMethod( method = "lder", annotations = NULL, local = FALSE, - study = NULL, + studyName = 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) - rawN <- median(getN(sumstats, study = study)) - M <- nSnps(sumstats, study = study) + studyName <- .estimateH2ResolveStudy(sumstats, studyName) + .h2ValidateInputs(sumstats, studyName, ldRef, annotations) + z <- z(sumstats, studyName = studyName) + rawN <- median(nSamples(sumstats, studyName = studyName)) + M <- nSnps(sumstats, studyName = studyName) # Legacy heritability-wrapper correction (separate from the SuSiE RSS # binaryTraitModel handling in the fine-mapping pipeline). - varY <- getVarY(sumstats, study = study) + varY <- varY(sumstats, studyName = studyName) n <- if (is.null(varY)) rawN else rawN / varY result <- .estimateH2Dispatch( method, @@ -2115,7 +2210,7 @@ setMethod( local, estimatorArgs = estimatorArgs ) - .h2EstimateFromResult(result, method, M, study) + .h2EstimateFromResult(result, method, M, studyName) } ) @@ -2210,7 +2305,7 @@ setMethod( # 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) - eigenList <- getEigenList(ldRef) + eigenList <- eigenList(ldRef) if (is.null(annotations)) { return(.computeLdScoresBase(eigenList, nSnps)) } @@ -2225,11 +2320,11 @@ setMethod( signature(ldRef = "LdScore"), function(ldRef, annotations = NULL) { if (is.null(annotations)) { - return(getLdScores(ldRef)) + return(mcols(ldRef)$ldScores) } # Compute annotation-stratified LD scores using LD matrices - ldMatrixList <- getLdMatrixList(ldRef) + ldMatrixList <- ldMatrixList(ldRef) if (length(ldMatrixList) == 0) { msg <- glue( "Annotation-stratified LD scores require ldMatrixList in ", @@ -2248,13 +2343,14 @@ setMethod( map(ldMatrixList, .h2BlockAnnotScores, baselineMat = annotMat) ) `colnames<-`( - cbind(getLdScores(ldRef)[, 1], strat), + cbind(mcols(ldRef)$ldScores[, 1], strat), c("base_l2", SummarizedExperiment::colData(annotations)$name) ) } ) -# H2Estimate accessor methods (getLocal/getEnrichment/getScoreStats) live +# H2Estimate accessor methods (localH2Blocks / +# stratifiedHeritabilityEnrichment / scoreStats) live # in R/h2Estimate.R alongside the class definition. # ============================================================================= @@ -2267,7 +2363,8 @@ setMethod( #' expected by \code{\link{standardizeSldscTrait}} and #' \code{\link{metaSldscRandom}}. This bridges the h2 estimation methods #' (LDER, gLDSC, HDL) into the sldscWrapper.R postprocessing pipeline. -#' @param h2Est An \code{H2Estimate} object with enrichment and tauBlocks. +#' @param h2Est An \code{H2Estimate} object with enrichment and +#' \code{annotationJackknifeCoefs}. #' @return A named list matching the format of \code{\link{readSldscTrait}}: #' \describe{ #' \item{categories}{Character vector of annotation names} @@ -2279,8 +2376,8 @@ setMethod( #' \item{propH2}{Named numeric vector of proportion of h2} #' \item{propSnps}{Named numeric vector of proportion of SNPs} #' \item{h2g}{Numeric scalar, global h2 estimate} -#' \item{tauBlocks}{Matrix (nBlocks x nCategories) for jackknife} -#' \item{nBlocks}{Integer, number of jackknife blocks} +#' \item{annotationJackknifeCoefs}{Matrix (nBlocks x nCategories) for +#' jackknife} \item{nBlocks}{Integer, number of jackknife blocks} #' } #' @examples #' data(h2EstimateExample) @@ -2289,7 +2386,7 @@ setMethod( h2EstimateToSldscTrait <- function(h2Est) { assertClass(h2Est, "H2Estimate") - enrichDf <- getEnrichment(h2Est) + enrichDf <- stratifiedHeritabilityEnrichment(h2Est) if (is.null(enrichDf)) { msg <- glue( "H2Estimate has no enrichment results. ", @@ -2301,13 +2398,13 @@ h2EstimateToSldscTrait <- function(h2Est) { cats <- as.character(enrichDf$annotation) nCats <- length(cats) - rawTau <- getTauBlocks(h2Est) + rawTau <- annotationJackknifeCoefs(h2Est) # Without per-block estimates the point estimates stand in as one block. - tauBlocks <- `colnames<-`( + jkCoefs <- `colnames<-`( rawTau %||% matrix(enrichDf$tau, nrow = 1), colnames(rawTau) %||% cats ) - nBlocks <- nrow(tauBlocks) + nBlocks <- nrow(jkCoefs) list( categories = cats, @@ -2318,57 +2415,14 @@ h2EstimateToSldscTrait <- function(h2Est) { enrichmentP = set_names(enrichDf$enrichmentP, cats), propH2 = set_names(enrichDf$propH2, cats), propSnps = set_names(enrichDf$propSnps, cats), - h2g = getH2(h2Est), - tauBlocks = tauBlocks, + h2g = heritabilityEstimate(h2Est), + annotationJackknifeCoefs = jkCoefs, nBlocks = nBlocks ) } # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# The genome build of one supported h2 input object; errors on an unknown type. -# -# LD blocks are a plain GRanges, which carries the build in seqinfo() rather -# than in a slot of its own -- that redundancy is why the LdBlocks wrapper -# went away. -# @noRd -.h2GenomeOfObject <- function(x) { - if (methods::is(x, "GenomicRanges")) { - return(.h2GenomeOfRanges(x)) - } - if ( - is(x, "GwasSumStats") || - is(x, "QtlSumStats") || - is(x, "LdStatistic") || - is(x, "AnnotationMatrix") - ) { - getGenome(x) - } else { - abort("Unknown object type for genome build check") - } -} - -# The single build named by a GRanges' seqinfo. A GRanges naming none returns -# NA and checkGenomeBuild() skips it: loadLdMatrix() leaves the build unset, -# so demanding one here would reject every LD reference the package's own -# loader produces. Naming more than one is still an error -- such an object -# is internally inconsistent rather than merely unlabelled, and the -# coordinate check in .h2CheckPositions() is the stronger guard regardless. -# @noRd -.h2GenomeOfRanges <- function(x) { - g <- discard(unique(GenomeInfoDb::genome(x)), is.na) - if (length(g) == 0L) { - return(NA_character_) - } - if (length(g) > 1L) { - abort(glue( - "genome build check: the GRanges names {length(g)} genome ", - "build(s) in seqinfo(); set one with genome(x) <- \"hg38\"." - )) - } - g -} - # crossprod of one eigen block's squared vectors against its # candidate-annotation # rows. Shared by the LDER and sHDL candidate-score assemblies. @@ -2444,21 +2498,21 @@ h2EstimateToSldscTrait <- function(h2Est) { # One HDL delete-one-block jackknife fold: refit leaving block `b` out. # @noRd -.hdlLooFit <- function(b, blockData, M, baselineMat, n, nRef) { +.hdlLooFit <- function(b, blockData, M, baselineMat, n, nSamples) { # The full-data fit already reported any bound it hit; repeating that # once per left-out block would bury it in noise. .hdlFit( .hdlDesign(blockData[-b], M, baselineMat), n, - nRef, + nSamples, warnOnBound = FALSE ) } # One HDL local-heritability row for block `b`. # @noRd -.hdlLocalRow <- function(b, blockData, n, nRef, int, M) { - .hdlLocalBlock(blockData[[b]], b, n, nRef, int, M) +.hdlLocalRow <- function(b, blockData, n, nSamples, int, M) { + .hdlLocalBlock(blockData[[b]], b, n, nSamples, int, M) } # sHDL score z for candidate column `c` under the `keep` block mask. @@ -2470,7 +2524,7 @@ h2EstimateToSldscTrait <- function(h2Est) { lam, lamh2, scoreResid, - nRef, + nSamples, keep ) { .shdlCandidateScore( @@ -2479,7 +2533,7 @@ h2EstimateToSldscTrait <- function(h2Est) { lam, lamh2, scoreResid, - nRef, + nSamples, keep ) } @@ -2494,7 +2548,7 @@ h2EstimateToSldscTrait <- function(h2Est) { lam, lamh2, scoreResid, - nRef, + nSamples, nCand ) { keep <- blockId != b @@ -2506,7 +2560,7 @@ h2EstimateToSldscTrait <- function(h2Est) { lam = lam, lamh2 = lamh2, scoreResid = scoreResid, - nRef = nRef, + nSamples = nSamples, keep = keep ) } diff --git a/R/jointEngine.R b/R/jointEngine.R index 6cf2b9ca..ad64cb90 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -116,7 +116,7 @@ NULL .traitPosFor <- function(data, context, trait) { if (methods::is(data, "QtlDataset")) { se <- try_fetch( - getPhenotypes(data, contexts = context), + molecularTraits(data, contexts = context), error = function(cnd) NULL ) if (is.null(se)) { @@ -217,7 +217,7 @@ NULL 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 + # so the builder omits the column entirely and traitPosition() reports # NA, # rather than a column full of chrUn sentinels. if (!anyFound) { @@ -331,7 +331,7 @@ setMethod( args$methodArgs, cvFolds, samplePartition = cfg$crossValidationArgs$samplePartition, - coverage = cfg$credibleSetArgs$coverage, + coverage = cfg$credibleSetParam$coverage, pos = .jgTraitPos(group), verbose = verbose, numThreads = cv$threads %||% 1L, @@ -348,7 +348,7 @@ setMethod( cvM, Xc, cfg, - credibleSetArgs, + credibleSetParam, fitRetention ) { bare <- .fmPostprocessOne( @@ -358,7 +358,7 @@ setMethod( dataY = NULL, conditionIdx = r, csInput = "fsusie", - credibleSetArgs = cfg$credibleSetArgs, + credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention ) e <- if (is.null(cvM)) { @@ -453,7 +453,7 @@ setMethod( X = Xc, Y = Ys, prior_variance = mvPrior$priorVariance, - coverage = cfg$credibleSetArgs$coverage + coverage = cfg$credibleSetParam$coverage ), compact(list(residual_variance = mvPrior$residualVariance)) ) @@ -505,7 +505,7 @@ setMethod( args$methodArgs, cvFolds, samplePartition = sp, - coverage = cfg$credibleSetArgs$coverage, + coverage = cfg$credibleSetParam$coverage, verbose = verbose, mvPrior = mvPrior, mvPriorCv = mvPriorCv, @@ -525,7 +525,7 @@ setMethod( keep, survivors, cfg, - credibleSetArgs, + credibleSetParam, fitRetention ) { if (!keep[i]) { @@ -539,7 +539,7 @@ setMethod( dataY = NULL, conditionIdx = r, csInput = "X", - credibleSetArgs = cfg$credibleSetArgs, + credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention ) e <- if (is.null(fitted$cvM)) { @@ -611,7 +611,7 @@ setMethod( R = ldMat, N = as.numeric(stats::median(.jgN(group))), prior_variance = mvPrior$priorVariance, - coverage = cfg$credibleSetArgs$coverage + coverage = cfg$credibleSetParam$coverage ) |> c(compact(list(residual_variance = mvPrior$residualVariance))) fitArgs <- .fmMergeUserArgs( @@ -639,7 +639,7 @@ setMethod( dataY = NULL, conditionIdx = r, csInput = "Xcorr", - credibleSetArgs = cfg$credibleSetArgs, + credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention ) } @@ -843,12 +843,12 @@ setMethod( Xc, Yc, weightMethods = list(mrash_weights = list()), - study = as.character(cond$study[1L]), + studyName = as.character(cond$study[1L]), context = as.character(cond$context[1L]), trait = as.character(cond$trait[1L]), fitRetention = "slim", - standardized = stdz, - dataType = cfg$dataType, + weightStandardized = stdz, + weightsDataType = cfg$dataType, verbose = 0, seed = cfg$seed ) @@ -898,25 +898,25 @@ setMethod( Xc, Yc, weightMethods = wm, - study = as.character(cond$study[1L]), + studyName = as.character(cond$study[1L]), context = as.character(cond$context[1L]), trait = as.character(cond$trait[1L]), fittedModels = fittedModels, fitRetention = retention, - standardized = stdz, - dataType = cfg$dataType, + weightStandardized = stdz, + weightsDataType = cfg$dataType, verbose = verbose, seed = cfg$seed ) base <- .twrRowParts(tw, 1L) vids <- .twrPartsVariantIds(base) - raw <- getWeights(base) + raw <- weights(base) W <- if (is.matrix(raw)) { raw } else { matrix(raw, ncol = nCond, dimnames = list(vids, NULL)) } - list(W = W, fitParts = getFits(base), vids = vids) + list(W = W, fitParts = methodFits(base), vids = vids) } # Warn when cross-validating mr.mash with a single full-data data-driven prior @@ -1058,17 +1058,17 @@ setMethod( variantIds = character(0), weights = NULL, cvResult = cvR, - standardized = stdz, - dataType = cfg$dataType + weightStandardized = stdz, + weightsDataType = cfg$dataType )) } twasWeightsRow( variantIds = full$vids, weights = full$W[, r], - fits = full$fitParts, + methodFits = full$fitParts, cvResult = cvR, - standardized = stdz, - dataType = cfg$dataType + weightStandardized = stdz, + weightsDataType = cfg$dataType ) } @@ -1147,12 +1147,12 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-context / individual: one group per scoped trait present in >= 2 scoped # contexts (the conditions are those (study, context, trait) rows). .enumCrossContextIndividual <- function(data, scope, args = list()) { - study <- getStudy(data) - if (!is_in(study, scope$studies)) { + studyName <- studyName(data) + if (!is_in(studyName, scope$studies)) { return(list()) } - scopedContexts <- scope$contexts[[study]] - scopedTraits <- scope$traits[[study]] + scopedContexts <- scope$contexts[[studyName]] + scopedTraits <- scope$traits[[studyName]] if (length(scopedContexts) < 2L) { return(list()) } @@ -1161,7 +1161,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scopedTraits, .enumCrossContextGroupFor, data = data, - study = study, + study = studyName, scopedContexts = scopedContexts, args = args, verbose = verbose @@ -1173,7 +1173,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .enumCrossContextGroupFor <- function( tid, data, - study, + studyName, scopedContexts, args, verbose @@ -1194,7 +1194,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { new( "IndividualJointGroup", conditions = tibble( - study = study, + study = studyName, context = xy$perTraitContexts, trait = tid ), @@ -1205,7 +1205,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-context / sumstats. .enumCrossContextSumstats <- function(data, scope, args = list()) { - ldSketch <- getLdSketch(data) + ldSketch <- ldSketch(data) studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) @@ -1302,18 +1302,18 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-trait / individual: one group per scoped context with >= 2 scoped # traits. .enumCrossTraitIndividual <- function(data, scope, args = list()) { - study <- getStudy(data) - if (!is_in(study, scope$studies)) { + studyName <- studyName(data) + if (!is_in(studyName, scope$studies)) { return(list()) } - scopedContexts <- scope$contexts[[study]] - scopedTraits <- scope$traits[[study]] + scopedContexts <- scope$contexts[[studyName]] + scopedTraits <- scope$traits[[studyName]] verbose <- if (is.null(args$verbose)) 1 else args$verbose compact(map( scopedContexts, .enumCrossTraitGroupFor, data = data, - study = study, + study = studyName, scopedTraits = scopedTraits, args = args, verbose = verbose @@ -1325,7 +1325,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .enumCrossTraitGroupFor <- function( cx, data, - study, + studyName, scopedTraits, args, verbose @@ -1337,7 +1337,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { args$cisWindow, verbose, label = "jointCrossTrait", - study = study, + studyName = studyName, region = args$region, residualizationArgs = args$residualizationArgs ) @@ -1352,7 +1352,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { new( "IndividualJointGroup", conditions = tibble( - study = study, + study = studyName, context = cx, trait = xy$traitsHere ), @@ -1366,7 +1366,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-trait / sumstats. .enumCrossTraitSumstats <- function(data, scope, args = list()) { - ldSketch <- getLdSketch(data) + ldSketch <- ldSketch(data) studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) @@ -1450,7 +1450,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # disjoint samples). One group per (context, trait) present in >= 2 scoped # studies; the study axis varies -> "joint" + jointStudies. .enumCrossStudySumstats <- function(data, scope, args = list()) { - ldSketch <- getLdSketch(data) + ldSketch <- ldSketch(data) cols <- list( study = as.character(data$study), context = as.character(data$context), @@ -1556,15 +1556,15 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # to "joint" (the conditions model handles multi-varying-axis uniformly; if the # tuples happen to share a context it degrades to cross-trait, and vice versa). .enumComposedIndividual <- function(data, scope, args = list()) { - study <- getStudy(data) - if (!is_in(study, scope$studies)) { + studyName <- studyName(data) + if (!is_in(studyName, scope$studies)) { return(list()) } verbose <- if (is.null(args$verbose)) 1 else args$verbose xy <- .buildComposedIndividualXy( data, scope, - study, + studyName, args$cisWindow, verbose, label = "composed", @@ -1579,7 +1579,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # are simple labels; trait ids may themselves contain ":"). labs <- colnames(xy$Y) conds <- tibble( - study = study, + study = studyName, context = str_remove(labs, ":.*$"), trait = str_remove(labs, "^[^:]*:") ) @@ -1591,32 +1591,39 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # univariate methods (lasso / enet / susie / ...) flow through the SAME per- # method fitter + ensemble layer as the joint ones (minGroup = 1). .enumUnivariateIndividual <- function(data, scope, args = list()) { - study <- getStudy(data) - if (!is_in(study, scope$studies)) { + studyName <- studyName(data) + if (!is_in(studyName, scope$studies)) { return(list()) } naAction <- if (is.null(args$naAction)) "drop" else args$naAction .jeConcat(map( - scope$contexts[[study]], + scope$contexts[[studyName]], .enumUnivariateForContext, data = data, scope = scope, args = args, - study = study, + study = studyName, 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) +.enumUnivariateForContext <- function( + cx, + data, + scope, + args, + studyName, + naAction +) { + se <- molecularTraits(data, contexts = cx) compact(map( - intersect(scope$traits[[study]], rownames(se)), + intersect(scope$traits[[studyName]], rownames(se)), .enumUnivariateGroupFor, data = data, args = args, - study = study, + study = studyName, cx = cx, naAction = naAction )) @@ -1625,7 +1632,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # 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) { +.enumUnivariateGroupFor <- function(tid, data, args, studyName, cx, naAction) { Y <- .fmResidPheno( data, contexts = cx, @@ -1655,7 +1662,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { } new( "IndividualJointGroup", - conditions = tibble(study = study, context = cx, trait = tid), + conditions = tibble(study = studyName, context = cx, trait = tid), X = X[common, , drop = FALSE], Y = Y[common, , drop = FALSE] ) @@ -1666,7 +1673,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # (fixed) axes form one group each. Reuses .enumerateComposedSumstatGroups. .enumComposedSumstats <- function(data, scope, args = list()) { axes <- args$axes %||% c("context", "trait") - ldSketch <- getLdSketch(data) + ldSketch <- ldSketch(data) gi <- .enumerateComposedSumstatGroups(list(axes = axes), data, scope) if (is.null(gi)) { return(list()) @@ -1754,7 +1761,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { 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) + af <- .twasFineMappingFits(fmRes, studyName = s1, context = c1, trait = t1) list( fittedModels = if (is.null(af)) { list() @@ -2112,7 +2119,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { } ew <- ens$ensembleTwasWeights vids <- (if (!is.null(names(ew))) names(ew) else rownames(ew)) %||% - getVariantIds(perTokenEntries[[passing[1L]]][[r]]) + variantIds(perTokenEntries[[passing[1L]]][[r]]) twasWeightsRow( variantIds = vids, weights = as.numeric(ew), @@ -2120,8 +2127,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { methodCoef = ens$methodCoef, methodPerformance = ens$methodPerformance ), - standardized = stdz, - dataType = cfg$dataType + weightStandardized = stdz, + weightsDataType = cfg$dataType ) } @@ -2133,26 +2140,26 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # fineMappingPipeline's .fmPcaContextRows, sharing .fmTopPcScores(). # @noRd .enumTopPcIndividual <- function(data, scope, args = list()) { - study <- getStudy(data) - if (!is_in(study, scope$studies)) { + studyName <- studyName(data) + if (!is_in(studyName, scope$studies)) { return(list()) } naAction <- if (is.null(args$naAction)) "drop" else args$naAction .jeConcat(map( - scope$contexts[[study]], + scope$contexts[[studyName]], .enumTopPcForContext, data = data, scope = scope, args = args, - study = study, + study = studyName, naAction = naAction )) } # @noRd -.enumTopPcForContext <- function(cx, data, scope, args, study, naAction) { - se <- getPhenotypes(data, contexts = cx) - traits <- intersect(scope$traits[[study]], rownames(se)) +.enumTopPcForContext <- function(cx, data, scope, args, studyName, naAction) { + se <- molecularTraits(data, contexts = cx) + traits <- intersect(scope$traits[[studyName]], rownames(se)) # PCA is undefined for a single trait, matching the fine-mapping rule. if (length(traits) < 2L) { return(list()) @@ -2178,7 +2185,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .enumTopPcGroup, X = X[common, , drop = FALSE], scores = scores[common, , drop = FALSE], - study = study, + study = studyName, cx = cx )) } @@ -2203,10 +2210,10 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { } # @noRd -.enumTopPcGroup <- function(pcName, X, scores, study, cx) { +.enumTopPcGroup <- function(pcName, X, scores, studyName, cx) { new( "IndividualJointGroup", - conditions = tibble(study = study, context = cx, trait = pcName), + conditions = tibble(study = studyName, context = cx, trait = pcName), X = X, Y = scores[, pcName, drop = FALSE] ) @@ -2416,7 +2423,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(ctxs) == 0L) { return(scope$traits[[st]]) } - se <- getPhenotypes(data, contexts = ctxs[[1L]]) + se <- molecularTraits(data, contexts = ctxs[[1L]]) .fmTraitsInRegion( se, intersect(scope$traits[[st]], rownames(se)), @@ -2483,9 +2490,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { twasWeightsRow( variantIds = vids, weights = weights[, r], - fits = fitParts, - standardized = TRUE, - dataType = cfg$dataType + methodFits = fitParts, + weightStandardized = TRUE, + weightsDataType = cfg$dataType ) } @@ -2523,7 +2530,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # One joint output record for condition `i`, or NULL when that entry is absent. # traitPos = the bare trait position (NULL when a QtlSumStats caller supplied -# none -> the column is omitted and getTraitPosition() reports NA). The +# none -> the column is omitted and traitPosition() reports NA). The # 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 diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 91082fec..1f2ecb6c 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -14,14 +14,14 @@ # @noRd .spListStudies <- function(data) { if (is(data, "QtlDataset")) { - return(getStudy(data)) + return(studyName(data)) } if (is(data, "QtlSumStats")) { return(unique(as.character(data$study))) } if (is(data, "MultiStudyQtlDataset")) { - indStudies <- names(getQtlDatasets(data)) - ss <- getSumStats(data) + indStudies <- names(qtlDatasets(data)) + ss <- sumStats(data) ssStudies <- if (is.null(ss)) { character(0) } else { @@ -37,12 +37,12 @@ # Return "individual" or "sumstats" for a single study in `data`. Errors if # the study is not present. # @noRd -.spStudyDataForm <- function(data, study) { +.spStudyDataForm <- function(data, studyName) { if (is(data, "QtlDataset")) { - if (!identical(study, getStudy(data))) { - dataStudy <- getStudy(data) + if (!identical(studyName, studyName(data))) { + dataStudy <- studyName(data) msg <- glue( - ".spStudyDataForm: study '{study}' not in QtlDataset ", + ".spStudyDataForm: study '{studyName}' not in QtlDataset ", "(study='{dataStudy}')" ) abort(msg) @@ -50,22 +50,24 @@ return("individual") } if (is(data, "QtlSumStats")) { - if (!is_in(study, unique(as.character(data$study)))) { - msg <- glue(".spStudyDataForm: study '{study}' not in QtlSumStats") + if (!is_in(studyName, unique(as.character(data$study)))) { + msg <- glue( + ".spStudyDataForm: study '{studyName}' not in QtlSumStats" + ) abort(msg) } return("sumstats") } if (is(data, "MultiStudyQtlDataset")) { - if (is_in(study, names(getQtlDatasets(data)))) { + if (is_in(studyName, names(qtlDatasets(data)))) { return("individual") } - ss <- getSumStats(data) - if (!is.null(ss) && is_in(study, unique(as.character(ss$study)))) { + ss <- sumStats(data) + if (!is.null(ss) && is_in(studyName, unique(as.character(ss$study)))) { return("sumstats") } msg <- glue( - ".spStudyDataForm: study '{study}' not in MultiStudyQtlDataset" + ".spStudyDataForm: study '{studyName}' not in MultiStudyQtlDataset" ) abort(msg) } @@ -87,27 +89,27 @@ list_c(pieces) } -.spListContexts <- function(data, study = NULL) { +.spListContexts <- function(data, studyName = NULL) { if (is(data, "QtlDataset")) { - if (!is.null(study) && !identical(study, getStudy(data))) { + if (!is.null(studyName) && !identical(studyName, studyName(data))) { return(character(0)) } - return(getContexts(data)) + return(contexts(data)) } if (is(data, "QtlSumStats")) { - if (is.null(study)) { + if (is.null(studyName)) { return(unique(as.character(data$context))) } return(unique(as.character( - data$context[as.character(data$study) == study] + data$context[as.character(data$study) == studyName] ))) } if (is(data, "MultiStudyQtlDataset")) { - indDatasets <- getQtlDatasets(data) - ss <- getSumStats(data) - if (is.null(study)) { + indDatasets <- qtlDatasets(data) + ss <- sumStats(data) + if (is.null(studyName)) { fromInd <- .spConcat( - map(indDatasets, getContexts), + map(indDatasets, contexts), empty = character(0) ) fromSs <- if (is.null(ss)) { @@ -117,12 +119,12 @@ } return(unique(c(fromInd, fromSs))) } - if (is_in(study, names(indDatasets))) { - return(getContexts(indDatasets[[study]])) + if (is_in(studyName, names(indDatasets))) { + return(contexts(indDatasets[[studyName]])) } - if (!is.null(ss) && is_in(study, unique(as.character(ss$study)))) { + if (!is.null(ss) && is_in(studyName, unique(as.character(ss$study)))) { return(unique(as.character( - ss$context[as.character(ss$study) == study] + ss$context[as.character(ss$study) == studyName] ))) } return(character(0)) @@ -138,38 +140,39 @@ # The trait ids present in one context of a QtlDataset. # @noRd .spTraitsInContext <- function(context, data) { - rownames(getPhenotypes(data, context)) + rownames(molecularTraits(data, context)) } # Traits available in a single individual-level QtlDataset (optionally scoped). -.spListTraitsQtlDataset <- function(data, study, context) { - if (!is.null(study) && !identical(study, getStudy(data))) { +.spListTraitsQtlDataset <- function(data, studyName, context) { + if (!is.null(studyName) && !identical(studyName, studyName(data))) { return(character(0)) } if (is.null(context)) { return(unique(unname(list_c( - map(getContexts(data), .spTraitsInContext, data = data) + map(contexts(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 # answer, not an error. The raw slot read this replaced returned NULL for - # an unknown context; getPhenotypes() rejects one, so the empty case has to + # an unknown context; molecularTraits() rejects one, so the empty case + # has to # be stated instead of falling out of a NULL. - if (!is_in(context, getContexts(data))) { + if (!is_in(context, contexts(data))) { return(character(0)) } - rownames(getPhenotypes(data, context)) + rownames(molecularTraits(data, context)) } # Traits across a MultiStudyQtlDataset (individual studies + sumstats). -.spListTraitsMultiStudy <- function(data, study, context) { - indDatasets <- getQtlDatasets(data) - ss <- getSumStats(data) +.spListTraitsMultiStudy <- function(data, studyName, context) { + indDatasets <- qtlDatasets(data) + ss <- sumStats(data) # No study filter: aggregate across every component (individual + sumstats). # 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)) { + if (is.null(studyName)) { fromInd <- .spConcat( map(indDatasets, .spListTraits, context = context), empty = character(0) @@ -181,24 +184,24 @@ } return(unique(c(fromInd, fromSs))) } - if (is_in(study, names(indDatasets))) { - return(.spListTraits(indDatasets[[study]], context = context)) + if (is_in(studyName, names(indDatasets))) { + return(.spListTraits(indDatasets[[studyName]], context = context)) } - if (!is.null(ss) && is_in(study, unique(as.character(ss$study)))) { - return(.spListTraits(ss, study = study, context = context)) + if (!is.null(ss) && is_in(studyName, unique(as.character(ss$study)))) { + return(.spListTraits(ss, studyName = studyName, context = context)) } character(0) } -.spListTraits <- function(data, study = NULL, context = NULL) { +.spListTraits <- function(data, studyName = NULL, context = NULL) { if (is(data, "QtlDataset")) { - return(.spListTraitsQtlDataset(data, study, context)) + return(.spListTraitsQtlDataset(data, studyName, context)) } if (is(data, "QtlSumStats")) { - byStudy <- if (is.null(study)) { + byStudy <- if (is.null(studyName)) { rep(TRUE, nrow(data)) } else { - as.character(data$study) == study + as.character(data$study) == studyName } byContext <- if (is.null(context)) { TRUE @@ -209,7 +212,7 @@ return(unique(as.character(data$trait[keep]))) } if (is(data, "MultiStudyQtlDataset")) { - return(.spListTraitsMultiStudy(data, study, context)) + return(.spListTraitsMultiStudy(data, studyName, context)) } cls <- class(data)[[1L]] msg <- glue(".spListTraits: unsupported class: {cls}") @@ -491,7 +494,7 @@ parseContexts <- function(contexts, data) { ) abort(msg) } - missing <- setdiff(v2, .spListTraits(data, study = s, context = cx)) + missing <- setdiff(v2, .spListTraits(data, studyName = s, context = cx)) if (length(missing) > 0L) { missingStr <- str_flatten(missing, ", ") msg <- glue( @@ -509,7 +512,7 @@ parseContexts <- function(contexts, data) { msg <- glue("traitId[['{s}']] must be a non-empty character vector") abort(msg) } - missing <- setdiff(val, .spListTraits(data, study = s)) + missing <- setdiff(val, .spListTraits(data, studyName = s)) if (length(missing) > 0L) { missingStr <- str_flatten(missing, ", ") msg <- glue("traitId[['{s}']] contains unknown traits: {missingStr}") @@ -820,7 +823,7 @@ parseTraitIds <- function(traitId, data) { return(invisible(NULL)) } tr <- leaf$path[[3L]] - if (!is_in(tr, .spListTraits(data, study = s, context = cx))) { + if (!is_in(tr, .spListTraits(data, studyName = s, context = cx))) { msg <- glue( "{lab}: unknown trait '{tr}' for (study '{s}', ", "context '{cx}')" @@ -1040,7 +1043,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # shape the context lister has. # @noRd .fmScopeTraits <- function(data, s) { - .spListTraits(data, study = s) + .spListTraits(data, studyName = s) } # What a pipeline-level `contexts` / `traitIds` argument narrows study `s` to, @@ -1099,9 +1102,9 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { context = as.character(data$context), trait = as.character(data$trait) ) - allDf <- getSumStatsDf( + allDf <- as.data.frame( data, - study = cols$study[[tupleRows[[1L]]]], + studyName = cols$study[[tupleRows[[1L]]]], context = cols$context[[tupleRows[[1L]]]], trait = cols$trait[[tupleRows[[1L]]]], require = c("SNP", "Z", "N") @@ -1137,9 +1140,9 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { errorLabel ) { i <- tupleRows[[kk]] - d <- getSumStatsDf( + d <- as.data.frame( data, - study = cols$study[[i]], + studyName = cols$study[[i]], context = cols$context[[i]], trait = cols$trait[[i]], require = c("SNP", "Z", "N") @@ -1204,7 +1207,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # Does context `cx` carry trait `tid`? # @noRd .ccContextHasTrait <- function(cx, data, tid) { - is_in(tid, rownames(getPhenotypes(data, contexts = cx))) + is_in(tid, rownames(molecularTraits(data, contexts = cx))) } .crossContextPerTrait <- function(data, tid, scopedContexts, verbose, label) { @@ -1338,14 +1341,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # subset is too small. # @noRd # Warn + signal skip when a context has fewer than 2 scoped traits. -.crossTraitTooFew <- function(traitsHere, cx, study, verbose, label) { +.crossTraitTooFew <- function(traitsHere, cx, studyName, verbose, label) { if (length(traitsHere) >= 2L) { return(FALSE) } if (verbose >= 1) { nTraits <- length(traitsHere) msg <- glue( - "{label}: context '{cx}' (study '{study}') has {nTraits} ", + "{label}: context '{cx}' (study '{studyName}') has {nTraits} ", "scoped trait(s); skipping." ) inform(msg) @@ -1360,15 +1363,15 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cisWindow, verbose, label, - study, + studyName, region = NULL, residualizationArgs ) { - se <- getPhenotypes(data, contexts = cx) + se <- molecularTraits(data, contexts = cx) # scopedTraits is already region-restricted upstream (.runJointSpecs) when # region mode is used without an explicit traitId. traitsHere <- intersect(scopedTraits, rownames(se)) - if (.crossTraitTooFew(traitsHere, cx, study, verbose, label)) { + if (.crossTraitTooFew(traitsHere, cx, studyName, verbose, label)) { return(NULL) } allX <- .buildResidGeno( @@ -1446,14 +1449,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # The (context, trait) tuples context `cx` contributes. # @noRd .composedTuplesForContext <- function(cx, data, scopedTraits) { - se <- getPhenotypes(data, contexts = cx) + se <- molecularTraits(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]] +.composedTuples <- function(data, scope, studyName, verbose, label) { + scopedContexts <- scope$contexts[[studyName]] + scopedTraits <- scope$traits[[studyName]] tuples <- .spConcat(map( scopedContexts, .composedTuplesForContext, @@ -1464,7 +1467,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (verbose >= 1) { nTuples <- length(tuples) msg <- glue( - "{label}: study '{study}' has {nTuples} (context, trait) ", + "{label}: study '{studyName}' has {nTuples} (context, trait) ", "tuple(s) in scope; skipping." ) inform(msg) @@ -1545,14 +1548,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { .buildComposedIndividualXy <- function( data, scope, - study, + studyName, cisWindow, verbose, label, region = NULL, residualizationArgs ) { - tuples <- .composedTuples(data, scope, study, verbose, label) + tuples <- .composedTuples(data, scope, studyName, verbose, label) if (is.null(tuples)) { return(NULL) } @@ -1768,7 +1771,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (is.null(ssRes)) { return(list(out = fromStudies, embeddedLd = NULL)) } - embeddedLd <- getLdSketch(ssRes) + embeddedLd <- ldSketch(ssRes) out <- if (is.null(fromStudies)) { ssRes } else { @@ -1807,8 +1810,8 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { noun = "a result" ) { acc <- .msDriverAccumulate( - getQtlDatasets(data), - getSumStats(data), + qtlDatasets(data), + sumStats(data), perStudyFn, sumStatsFn, cfg, @@ -1865,7 +1868,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), + credibleSetParam = CredibleSetParam(includeAllCs = FALSE), verbose, methodArgs = list(), xRegions = list(NULL), @@ -1892,7 +1895,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, verbose = verbose, methodArgs = methodArgs, mrmashPrior = mrmashPrior, @@ -1924,7 +1927,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # FmJointPipeline for individual-level fine-mapping, built from the call params. .fmJointPipeline <- function( - credibleSetArgs = CredibleSetParam(includeAllCs = FALSE), + credibleSetParam = CredibleSetParam(includeAllCs = FALSE), dataDrivenPriorWeightsCutoff, crossValidationArgs, residualizationArgs, @@ -1936,7 +1939,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { new( "FmJointPipeline", config = list( - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, crossValidationArgs = crossValidationArgs, residualizationArgs = residualizationArgs, @@ -1954,7 +1957,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # @noRd .fmJointPipelineChecked <- function( parsedJointSpec, - credibleSetArgs, + credibleSetParam, dataDrivenPriorWeightsCutoff, crossValidationArgs, residualizationArgs, @@ -1964,7 +1967,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) { .jointRejectStudyOnIndividual(parsedJointSpec) .fmJointPipeline( - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, crossValidationArgs = crossValidationArgs, residualizationArgs = residualizationArgs, @@ -1974,6 +1977,9 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { ) } +# Engine routing (jointEngine.R) for one region block; the caller loops the +# regions. +# @noRd .fmDispatchJointSpecsQtlDatasetOneRegion <- function( parsedJointSpec, data, @@ -1991,14 +1997,12 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { pipCutoffToSkip = 0, fineMappingResult = NULL, seed = NULL, - credibleSetArgs, + credibleSetParam, fitRetention ) { - # Engine routing (jointEngine.R); one region block (the caller loops - # regions). pipeline <- .fmJointPipelineChecked( parsedJointSpec, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, crossValidationArgs = crossValidationArgs, residualizationArgs = residualizationArgs, @@ -2034,7 +2038,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # LD sketch drawn from the data). .fmSumStatsPipeline <- function( data, - credibleSetArgs, + credibleSetParam, dataDrivenPriorWeightsCutoff, verbose, fitRetention @@ -2042,12 +2046,12 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { new( "FmJointPipeline", config = list( - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, verbose = verbose, fitRetention = fitRetention, crossValidationArgs = .cvResolve(CrossValidationParam()), - ldSketch = getLdSketch(data) + ldSketch = ldSketch(data) ) ) } @@ -2063,8 +2067,8 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, fineMappingResult = NULL, - panelFilterArgs = PanelFilterParam(), - credibleSetArgs, + panelFilterParam = PanelFilterParam(), + credibleSetParam, fitRetention ) { # Engine routing (jointEngine.R): the dispatch table + .runJointCell replace @@ -2072,7 +2076,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { # dispatchers. pipeline <- .fmSumStatsPipeline( data = data, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, verbose = verbose, fitRetention = fitRetention @@ -2091,7 +2095,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methodArgs = methodArgs, verbose = verbose, cache = fineMappingResult, - cutoffs = .panelCutoffs(panelFilterArgs) + cutoffs = .panelCutoffs(panelFilterParam) ) ) } @@ -2136,7 +2140,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - credibleSetArgs, + credibleSetParam, verbose, methodArgs, xRegions, @@ -2155,7 +2159,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, verbose = verbose, methodArgs = methodArgs, xRegions = xRegions, @@ -2180,7 +2184,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { xRegions, mrmashPrior, dataDrivenPriorWeightsCutoff, - credibleSetArgs + credibleSetParam ) { .fmDispatchJointSpecsQtlDataset( nonStudyAxisSpecs, @@ -2189,7 +2193,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, verbose = verbose, methodArgs = methodArgs, xRegions = xRegions, @@ -2211,7 +2215,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methodArgs, mrmashPrior, dataDrivenPriorWeightsCutoff, - credibleSetArgs + credibleSetParam ) { if (is.null(sumStats)) { if (length(studyAxisSpecs) > 0L && verbose >= 1) { @@ -2229,7 +2233,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methods = methods, contexts = contexts, traitIds = traitIds, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, verbose = verbose, methodArgs = methodArgs, mrmashPrior = mrmashPrior, @@ -2238,7 +2242,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { if (is.null(ssRes)) { return(out) } - embeddedLd <- getLdSketch(ssRes) + embeddedLd <- ldSketch(ssRes) if (is.null(out)) { ssRes } else { @@ -2253,15 +2257,15 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - credibleSetArgs, + credibleSetParam, verbose, methodArgs = list(), xRegions = list(NULL), mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10 ) { - qtlDatasets <- getQtlDatasets(data) - sumStats <- getSumStats(data) + qtlDatasets <- qtlDatasets(data) + sumStats <- sumStats(data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .fmMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) out <- .fmMultiStudyQtlLoop( @@ -2271,7 +2275,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, verbose = verbose, methodArgs = methodArgs, xRegions = xRegions, @@ -2341,7 +2345,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - dataType, + weightsDataType, verbose, xRegions = list(NULL), fitRetention = c("slim", "none", "full"), @@ -2360,7 +2364,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - dataType = dataType, + weightsDataType = weightsDataType, verbose = verbose, fitRetention = fitRetention, seed = seed @@ -2385,7 +2389,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - dataType, + weightsDataType, verbose, region = NULL, fitRetention = c("slim", "none", "full"), @@ -2398,7 +2402,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { pipeline <- new( "TwasJointPipeline", config = list( - dataType = dataType, + dataType = weightsDataType, crossValidationArgs = .cvResolve(CrossValidationParam()), fitFullData = TRUE, standardized = FALSE, @@ -2432,21 +2436,21 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methods, contexts, traitIds, - dataType, + weightsDataType, verbose, fitRetention = c("slim", "none", "full"), - panelFilterArgs = PanelFilterParam() + panelFilterParam = PanelFilterParam() ) { fitRetention <- arg_match(fitRetention) # Engine routing (jointEngine.R). pipeline <- new( "TwasJointPipeline", config = list( - dataType = dataType, + dataType = weightsDataType, crossValidationArgs = .cvResolve(CrossValidationParam()), fitFullData = TRUE, standardized = TRUE, - ldSketch = getLdSketch(data) + ldSketch = ldSketch(data) ) ) .runJointSpecs( @@ -2460,7 +2464,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { args = list( methodArgs = list(), verbose = verbose, - cutoffs = .panelCutoffs(panelFilterArgs) + cutoffs = .panelCutoffs(panelFilterParam) ) ) } @@ -2493,7 +2497,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - dataType, + weightsDataType, verbose, xRegions, fitRetention, @@ -2511,7 +2515,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - dataType = dataType, + weightsDataType = weightsDataType, verbose = verbose, xRegions = xRegions, fitRetention = fitRetention, @@ -2530,7 +2534,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - dataType, + weightsDataType, verbose, xRegions, fitRetention, @@ -2543,7 +2547,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - dataType = dataType, + weightsDataType = weightsDataType, verbose = verbose, xRegions = xRegions, fitRetention = fitRetention, @@ -2560,7 +2564,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methods, contexts, traitIds, - dataType, + weightsDataType, verbose, fitRetention ) { @@ -2580,14 +2584,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methods = methods, contexts = contexts, traitIds = traitIds, - dataType = dataType, + weightsDataType = weightsDataType, verbose = verbose, fitRetention = fitRetention ) if (is.null(ssRes)) { return(out) } - embeddedLd <- getLdSketch(ssRes) + embeddedLd <- ldSketch(ssRes) if (is.null(out)) { ssRes } else { @@ -2602,15 +2606,15 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - dataType, + weightsDataType, verbose, xRegions = list(NULL), fitRetention = c("slim", "none", "full"), seed = NULL ) { fitRetention <- arg_match(fitRetention) - qtlDatasets <- getQtlDatasets(data) - sumStats <- getSumStats(data) + qtlDatasets <- qtlDatasets(data) + sumStats <- sumStats(data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .twasMultiStudyWarnExcluded(specs$study, qtlDatasets, verbose) out <- .twasMultiStudyQtlLoop( @@ -2620,7 +2624,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - dataType = dataType, + weightsDataType = weightsDataType, verbose = verbose, xRegions = xRegions, fitRetention = fitRetention, @@ -2634,7 +2638,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methods = methods, contexts = contexts, traitIds = traitIds, - dataType = dataType, + weightsDataType = weightsDataType, verbose = verbose, fitRetention = fitRetention ) @@ -2722,7 +2726,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - credibleSetArgs, + credibleSetParam, verbose, methodArgs, mrmashPrior, @@ -2741,7 +2745,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts = contexts, traitIds = traitIds, cisWindow = cisWindow, - credibleSetArgs = credibleSetArgs, + credibleSetParam = credibleSetParam, verbose = verbose, methodArgs = methodArgs, mrmashPrior = mrmashPrior, @@ -2766,7 +2770,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - dataType, + weightsDataType, verbose, fitRetention, seed = NULL @@ -2778,7 +2782,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { contexts, traitIds, cisWindow, - dataType, + weightsDataType, verbose, region = rg, fitRetention = fitRetention, diff --git a/R/ld.R b/R/ld.R index 0379fba4..7b2c57f1 100644 --- a/R/ld.R +++ b/R/ld.R @@ -183,7 +183,7 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { ) } -getRegionalLdMeta <- function( +regionalLdMeta <- function( ldReferenceMetaFile, region, completeCoverageRequired = FALSE @@ -426,7 +426,7 @@ createLdMatrix <- function(ldMatrices, variants) { # Drop duplicate variant ids (boundary-overlap safety net). .loadLdDedup <- function(result) { - variantIds <- getVariantIds(result) + variantIds <- variantIds(result) if (is.null(variantIds)) { return(result) } @@ -434,7 +434,7 @@ createLdMatrix <- function(ldMatrices, variants) { if (length(dupIdx) == 0) { return(result) } - full <- getCorrelation(result) + full <- ldMatrix(result) corr <- if (is.null(full)) { NULL } else { @@ -442,11 +442,11 @@ createLdMatrix <- function(ldMatrices, variants) { } LdData( correlation = corr, - genotypeHandle = getGenotypeHandle(result), - snpIdx = getSnpIdx(result), - variants = getVariantInfo(result)[-dupIdx], - blockMetadata = getBlockMetadata(result), - nRef = getNRef(result) + genotypeHandle = genotypeHandle(result), + snpIdx = snpIdx(result), + variants = variantInfo(result)[-dupIdx], + blockMetadata = blockMetadata(result), + nSamples = ldPanelNSamples(result) ) } @@ -688,7 +688,7 @@ loadLdMatrix <- function( startIdx = 1L, endIdx = n ), - nRef = 0L + nSamples = 0L ) } @@ -711,7 +711,7 @@ loadLdMatrix <- function( genotypeHandle = if (isGenotype) mat else NULL, variants = gr, blockMetadata = tibble(blockId = 1L, size = n), - nRef = if (isGenotype) nrow(mat) else 0L + nSamples = if (isGenotype) nrow(mat) else 0L ) } @@ -722,7 +722,7 @@ loadLdMatrix <- function( if (!isTRUE(dropMonomorphic)) { return(ld) } - refPanel <- getRefPanel(ld) + refPanel <- refPanel(ld) if (is.null(refPanel) || !is_in("allele_freq", colnames(refPanel))) { return(ld) } @@ -755,7 +755,7 @@ loadLdMatrix <- function( if (!isTRUE(materializeGenotypes) || !hasGenotypes(ld)) { return(ld) } - X <- getGenotypes(ld) + X <- genotypes(ld) if (!is.matrix(X)) { return(ld) } @@ -763,9 +763,9 @@ loadLdMatrix <- function( correlation = NULL, genotypeHandle = X, snpIdx = NULL, - variants = getVariantInfo(ld), - blockMetadata = getBlockMetadata(ld), - nRef = getNRef(ld) + variants = variantInfo(ld), + blockMetadata = blockMetadata(ld), + nSamples = ldPanelNSamples(ld) ) } @@ -790,9 +790,9 @@ loadLdMatrix <- function( correlation = R, genotypeHandle = gh, snpIdx = if (is.matrix(gh)) NULL else snpIdx, - variants = getVariantInfo(ld)[idx], - blockMetadata = getBlockMetadata(ld), - nRef = getNRef(ld) + variants = variantInfo(ld)[idx], + blockMetadata = blockMetadata(ld), + nSamples = ldPanelNSamples(ld) ) } @@ -1050,14 +1050,14 @@ resolveGenotypePathForRegion <- function(metaPath, region) { X ) { handle <- .readGenotypeHandle(genotypePath) - snpIdx <- .regionToSnpIdx(getSnpInfo(handle), region) + snpIdx <- .regionToSnpIdx(snpInfo(handle), region) LdData( correlation = NULL, genotypeHandle = handle, snpIdx = snpIdx, variants = variantsGr, blockMetadata = blockMetadata, - nRef = as.integer(nrow(X)) + nSamples = as.integer(nrow(X)) ) } @@ -1105,7 +1105,7 @@ loadLdFromGenotype <- function( snpIdx = NULL, variants = variantsGr, blockMetadata = blockMetadata, - nRef = as.integer(nrow(X)) + nSamples = as.integer(nrow(X)) ) } @@ -1216,7 +1216,7 @@ loadLdFromGenotype <- function( # @noRd .ldSketchLabel <- function(x) { handle <- .ldSketchHandle(x) - glue("{getFormat(handle)} @ {getPath(handle)}") + glue("{genotypeFormat(handle)} @ {path(handle)}") } # TRUE for anything that can serve as an LD panel. A bare GenotypeHandle @@ -1262,7 +1262,7 @@ loadLdFromGenotype <- function( # The chokepoint every panel accessor funnels through, so the guard lives # here rather than being repeated at each entry point. Without it a NULL # or non-panel sketch surfaces as "unable to find an inherited method for - # 'getSnpInfo'" from whichever accessor happened to touch it first, which + # 'snpInfo'" from whichever accessor happened to touch it first, which # says nothing about the LD reference being the problem. Callers that # validate with their own label (`.ldFromSketch`, the ctwas assembler) do # so first, so their message wins. @@ -1270,7 +1270,7 @@ loadLdFromGenotype <- function( if (methods::is(x, "RangedSummarizedExperiment")) { return(SummarizedExperiment::rowRanges(x)) } - .genotypeSnpRanges(x, normalizeVariantId(as.character(getSnpInfo(x)$SNP))) + .genotypeSnpRanges(x, normalizeVariantId(as.character(snpInfo(x)$SNP))) } # The panel's variant ids in the panel's OWN labelling. This is the mcols @@ -1313,7 +1313,7 @@ loadLdFromGenotype <- function( if (methods::is(x, "RangedSummarizedExperiment")) { return(as.character(colnames(x))) } - as.character(getSampleIds(x)) + as.character(sampleIds(x)) } # @noRd @@ -1469,7 +1469,7 @@ loadLdFromGenotype <- function( if (length(chromPaths) == 0L) { return(.genotypeReadPath(handle)) } - spanned <- unique(canonChrom(as.character(getSnpInfo(handle)$CHR))) + spanned <- unique(canonChrom(as.character(snpInfo(handle)$CHR))) paths <- unname(chromPaths[is_in(names(chromPaths), spanned)]) map_chr(paths, .resolveGenotypeResourcePath) } @@ -1495,7 +1495,7 @@ loadLdFromGenotype <- function( # .afreq happens to omit would disagree with it about the same variant. # @noRd .panelAfreqMaf <- function(handle, variantIds) { - if (getFormat(handle) != "plink2") { + if (genotypeFormat(handle) != "plink2") { return(NULL) } tbls <- compact(map(.panelAfreqPrefixes(handle), .panelAfreqTable)) @@ -1520,8 +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, panelFilterArgs) { - imissCutoff <- panelFilterArgs$imissCutoff +.panelDropMask <- function(ldSketch, matched, panelFilterParam) { + imissCutoff <- panelFilterParam$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 @@ -1532,8 +1532,8 @@ loadLdFromGenotype <- function( maf <- .panelAfreqMaf(.ldSketchHandle(ldSketch), panelIds) if (!is.null(maf)) { effMaf <- .panelEffectiveMaf( - panelFilterArgs$mafCutoff, - panelFilterArgs$macCutoff, + panelFilterParam$mafCutoff, + panelFilterParam$macCutoff, .ldSketchNSamples(ldSketch) ) return(is.na(maf) | maf < effMaf) @@ -1542,8 +1542,8 @@ loadLdFromGenotype <- function( dosage <- .ldSketchDosage(ldSketch, matched$idx, meanImpute = FALSE) stats <- .panelVariantStats(dosage) effMaf <- .panelEffectiveMaf( - panelFilterArgs$mafCutoff, - panelFilterArgs$macCutoff, + panelFilterParam$mafCutoff, + panelFilterParam$macCutoff, nrow(dosage) ) is.na(stats$maf) | stats$maf < effMaf | stats$missRate > imissCutoff @@ -1560,12 +1560,12 @@ loadLdFromGenotype <- function( .panelVariantFilter <- function( ldSketch, variantIds, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), label = ".panelVariantFilter" ) { # .panelCutoffs answers NULL for a filter that would keep everything, # which is also the cheap exit here. - cutoffs <- .panelCutoffs(panelFilterArgs) + cutoffs <- .panelCutoffs(panelFilterParam) if (is.null(cutoffs)) { return(variantIds) } @@ -1603,13 +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(panelFilterArgs = PanelFilterParam()) { +.panelCutoffs <- function(panelFilterParam = 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 + maf <- panelFilterParam$mafCutoff %||% 0 + mac <- panelFilterParam$macCutoff %||% 0 + imiss <- panelFilterParam$imissCutoff %||% 1 if (maf <= 0 && mac <= 0 && imiss >= 1) { return(NULL) } @@ -2017,7 +2017,7 @@ loadLdFromBlocks <- function( extractCoordinates = NULL, nSample = NULL ) { - intersectedLdFiles <- getRegionalLdMeta(ldMetaFilePath, region) + intersectedLdFiles <- regionalLdMeta(ldMetaFilePath, region) ldFilePaths <- intersectedLdFiles$intersections$LD_file_paths bimFilePaths <- intersectedLdFiles$intersections$bimFilePaths blocks <- .loadLdBlocksLoop( @@ -2042,7 +2042,7 @@ loadLdFromBlocks <- function( snpIdx = NULL, variants = variantsGr, blockMetadata = blockMetadata, - nRef = if (is.null(nSample)) 0L else as.integer(nSample) + nSamples = if (is.null(nSample)) 0L else as.integer(nSample) ) } @@ -2083,7 +2083,7 @@ filterVariantsByLdReference <- function( summarise(start = min(.data$pos), end = max(.data$pos)) # Use shared helper -- no genotype loading - refInfo <- getRefVariantInfo(ldReferenceMetaFile, regionDf) + refInfo <- refVariantInfo(ldReferenceMetaFile, regionDf) refChrom <- canonChrom(refInfo$chrom) refKey <- str_c(refChrom, ":", refInfo$pos) @@ -2188,15 +2188,15 @@ partitionLdMatrix <- function( maxMergedBlockSize = 10000 ) { assertClass(ldData, "LdData") - variantIds <- getVariantIds(ldData) + variantIds <- variantIds(ldData) combinedMatrix <- .partitionValidateMatrix( - getCorrelation(ldData), + ldMatrix(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), + blockMetadata(ldData), length(variantIds) ) # Validate the block structure of the matrix (skip if only one block). @@ -3327,16 +3327,16 @@ ldClumpByScore <- function( #' Extract the LD or genotype matrix from an LdData S4 object. #' @param ld An LdData object. #' @param wantGenotype Logical; if TRUE, extract the genotype matrix (via -#' \code{getGenotypes()}). +#' \code{genotypes()}). #' @return A matrix. #' @importFrom checkmate assertClass #' @noRd extractLdMatrix <- function(ld, wantGenotype = FALSE) { assertClass(ld, "LdData") if (wantGenotype && hasGenotypes(ld)) { - return(getGenotypes(ld)) + return(genotypes(ld)) } - getCorrelation(ld) + ldMatrix(ld) } @@ -3425,7 +3425,7 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { "already in memory, which is what onDisk exists to avoid." )) } - fmt <- getFormat(.ldSketchHandle(X)) + fmt <- genotypeFormat(.ldSketchHandle(X)) if (fmt != "gds") { abort(glue( "computeLd(onDisk = TRUE) needs a GDS-backed panel; this one is ", @@ -3611,7 +3611,7 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { #' \code{dimnames} taken from the block where available. #' @examples #' data(qtlSumStatsExample) -#' panel <- getLdSketch(qtlSumStatsExample) +#' panel <- ldSketch(qtlSumStatsExample) #' R <- computeLd(panel, snpIdx = 1:5) #' dim(R) #' # A dosage matrix already in memory is correlated directly. diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index f7b9656d..9ce30d67 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -80,10 +80,10 @@ NULL # .qtlValidateScalars exactly, so this tightens nothing. # @noRd #' @importFrom checkmate assertLogical assertNumber assertFlag assertCharacter -.assertQtlPassThrough <- function(scaleResiduals, genotypeFilterArgs) { +.assertQtlPassThrough <- function(scaleResiduals, genotypeFilterParam) { assertLogical(scaleResiduals, len = 1L) .assertMethodParam( - genotypeFilterArgs, + genotypeFilterParam, "GenotypeFilterParam", "genotypeFilter" ) @@ -92,22 +92,22 @@ NULL walk( c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff"), .assertQtlFilterNumber, - genotypeFilterArgs = genotypeFilterArgs + genotypeFilterParam = genotypeFilterParam ) walk( c("keepSamples", "keepVariants"), .assertQtlFilterCharacter, - genotypeFilterArgs = genotypeFilterArgs + genotypeFilterParam = genotypeFilterParam ) - if (!is.null(genotypeFilterArgs$keepIndel)) { - assertFlag(genotypeFilterArgs$keepIndel) + if (!is.null(genotypeFilterParam$keepIndel)) { + assertFlag(genotypeFilterParam$keepIndel) } invisible(NULL) } # @noRd -.assertQtlFilterNumber <- function(field, genotypeFilterArgs) { - v <- genotypeFilterArgs[[field]] +.assertQtlFilterNumber <- function(field, genotypeFilterParam) { + v <- genotypeFilterParam[[field]] if (!is.null(v)) { assertNumber(v, lower = 0, finite = TRUE, .var.name = field) } @@ -115,8 +115,8 @@ NULL } # @noRd -.assertQtlFilterCharacter <- function(field, genotypeFilterArgs) { - v <- genotypeFilterArgs[[field]] +.assertQtlFilterCharacter <- function(field, genotypeFilterParam) { + v <- genotypeFilterParam[[field]] if (!is.null(v)) { assertCharacter(v, .var.name = field) } @@ -367,8 +367,8 @@ NULL # the chromPaths names; for a single-file handle the unique snpInfo chromosomes. .ldSketchChroms <- function(ldSketch) { handle <- .ldSketchHandle(ldSketch) - if (length(getChromPaths(handle)) > 0L) { - canonChrom(names(getChromPaths(handle))) + if (length(chromPaths(handle)) > 0L) { + canonChrom(names(chromPaths(handle))) } else { unique(.ldSketchChrom(ldSketch)) } @@ -1404,7 +1404,7 @@ NULL # genotypePath / genotypeCovariatePath columns when supplied as arguments. .buildQtlDatasetFromRows <- function( rows, - study, + studyName, base, transposeCov, qc, @@ -1417,23 +1417,23 @@ NULL contexts, .buildOneContextSe, rows = rows, - study = study, + study = studyName, base = base, transposeCov = transposeCov ), contexts ) - genoHandle <- .resolveGenoHandle(rows, study, base, genotypesOverride) + genoHandle <- .resolveGenoHandle(rows, studyName, base, genotypesOverride) genoCov <- .resolveGenoCov( rows, - study, + studyName, base, transposeCov, genoCovOverride ) qtlArgs <- c( list( - study = study, + study = studyName, genotypes = genoHandle, phenotypes = phenotypes, genotypeCovariates = genoCov @@ -1446,24 +1446,24 @@ NULL # The SummarizedExperiment for one context: exactly one phenotypePath (+ at most # one covariatePath) across its manifest rows. # @noRd -.buildOneContextSe <- function(cx, rows, study, base, transposeCov) { +.buildOneContextSe <- function(cx, rows, studyName, base, transposeCov) { sub <- rows[as.character(rows$context) == cx, , drop = FALSE] pths <- unique(sub$phenotypePath[!is.na(sub$phenotypePath)]) if (length(pths) != 1L) { msg <- glue( - "Context '{cx}' (study '{study}') must reference exactly one ", + "Context '{cx}' (study '{studyName}') must reference exactly one ", "phenotypePath; got: {str_flatten(pths, ', ')}" ) abort(msg) } - covPath <- .oneContextCovariatePath(sub, cx, study, base) + covPath <- .oneContextCovariatePath(sub, cx, studyName, 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) { +.oneContextCovariatePath <- function(sub, cx, studyName, base) { if (!is_in("covariatePath", names(sub))) { return(NULL) } @@ -1473,7 +1473,7 @@ NULL ]) if (length(covs) > 1L) { abort(glue( - "Context '{cx}' (study '{study}') references multiple ", + "Context '{cx}' (study '{studyName}') references multiple ", "covariatePath values: {str_flatten(covs, ', ')}" )) } @@ -1486,7 +1486,7 @@ NULL # The genotype handle: an override panel/path, else the study's single # genotypePath (auto-detecting the format). # @noRd -.resolveGenoHandle <- function(rows, study, base, genotypesOverride) { +.resolveGenoHandle <- function(rows, studyName, base, genotypesOverride) { open <- .openGenotypeHandle(genotypesOverride) if (!is.null(open)) { return(open) @@ -1497,7 +1497,7 @@ NULL v <- unique(as.character(rows$genotypePath[!is.na(rows$genotypePath)])) if (length(v) != 1L) { msg <- glue( - "study '{study}' must reference exactly one genotypePath; ", + "study '{studyName}' must reference exactly one genotypePath; ", "got: {str_flatten(v, ', ')}" ) abort(msg) @@ -1510,7 +1510,13 @@ NULL # The genotype covariate matrix: an override matrix/path, else the study's # single genotypeCovariatePath, else an empty matrix. # @noRd -.resolveGenoCov <- function(rows, study, base, transposeCov, genoCovOverride) { +.resolveGenoCov <- function( + rows, + studyName, + base, + transposeCov, + genoCovOverride +) { if (is.matrix(genoCovOverride)) { return(genoCovOverride) } @@ -1523,7 +1529,8 @@ NULL ])) if (length(v) > 1L) { msg <- glue( - "study '{study}' references multiple genotypeCovariatePath ", + "study '{studyName}' references multiple ", + "genotypeCovariatePath ", "values." ) abort(msg) @@ -1553,13 +1560,13 @@ NULL #' \code{covariatePath} (optional, per-context covariates), and the #' single-valued \code{study} / \code{genotypePath} / #' \code{genotypeCovariatePath}. -#' @param study Study identifier; reconciled with a \code{study} column. +#' @param studyName Study identifier; reconciled with a \code{study} column. #' @param genotypes A genotype panel (see \code{\link{readGenotypes}}) or #' 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 Pass-through \code{\link{QtlDataset}} argument. -#' @param genotypeFilterArgs Pass-through \code{\link{QtlDataset}} filtering +#' @param genotypeFilterParam 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 @@ -1570,22 +1577,22 @@ NULL #' manifest <- data.frame(context = "brain", #' phenotypePath = file.path(d, "example_geneexpr.bed.gz"), #' study = "s1", genotypePath = file.path(d, "example.chr22")) -#' loadQtlDatasetFromManifest(manifest = manifest, study = "s1") +#' loadQtlDatasetFromManifest(manifest = manifest, studyName = "s1") #' @importFrom stringr str_ends #' @importFrom checkmate assertString assertFlag #' @export loadQtlDatasetFromManifest <- function( manifest, - study = NULL, + studyName = NULL, genotypes = NULL, genotypeCovariates = NULL, scaleResiduals = TRUE, - genotypeFilterArgs = GenotypeFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), transposeCovariates = FALSE ) { - assertString(study, null.ok = TRUE) + assertString(studyName, null.ok = TRUE) assertFlag(transposeCovariates) - .assertQtlPassThrough(scaleResiduals, genotypeFilterArgs) + .assertQtlPassThrough(scaleResiduals, genotypeFilterParam) base <- .manifestBase(manifest) df <- .canonManifestCols( .readManifest(manifest), @@ -1595,11 +1602,11 @@ 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 <- .msqQcArgs(scaleResiduals, genotypeFilterArgs) + studyName <- .reconcileScalar(df[["study"]], studyName, "study") + qc <- .msqQcArgs(scaleResiduals, genotypeFilterParam) .buildQtlDatasetFromRows( df, - study, + studyName, base, transposeCovariates, qc, @@ -2084,7 +2091,7 @@ loadQtlSumStatsFromManifest <- function( #' @param transposeCovariates Transpose covariate TSVs (QTLtools layout). #' @param scaleResiduals Pass-through \code{\link{QtlDataset}} argument, #' applied to every study. -#' @param genotypeFilterArgs Pass-through \code{\link{QtlDataset}} filtering +#' @param genotypeFilterParam Pass-through \code{\link{QtlDataset}} filtering #' options, built with \code{\link{GenotypeFilterParam}} and applied to #' every study. #' @return A \code{MultiStudyQtlDataset} object. @@ -2108,12 +2115,12 @@ loadMultiStudyQtlDatasetFromManifest <- function( formatMapping = NULL, transposeCovariates = FALSE, scaleResiduals = TRUE, - genotypeFilterArgs = GenotypeFilterParam() + genotypeFilterParam = GenotypeFilterParam() ) { assertFlag(transposeCovariates) assertNumber(minLdOverlapWarn, lower = 0, upper = 1) - .assertQtlPassThrough(scaleResiduals, genotypeFilterArgs) - qc <- .msqQcArgs(scaleResiduals, genotypeFilterArgs) + .assertQtlPassThrough(scaleResiduals, genotypeFilterParam) + qc <- .msqQcArgs(scaleResiduals, genotypeFilterParam) qtlDatasets <- .msqBuildDatasets( qtlDatasetsManifest, transposeCovariates, @@ -2136,10 +2143,10 @@ loadMultiStudyQtlDatasetFromManifest <- function( # after GenotypeFilterParam() absorbed the seven filter fields: this is what is # spliced into QtlDataset(). # @noRd -.msqQcArgs <- function(scaleResiduals, genotypeFilterArgs) { +.msqQcArgs <- function(scaleResiduals, genotypeFilterParam) { list( scaleResiduals = scaleResiduals, - genotypeFilterArgs = genotypeFilterArgs + genotypeFilterParam = genotypeFilterParam ) } diff --git a/R/mashPipeline.R b/R/mashPipeline.R index 41c33167..6a97821f 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -1539,7 +1539,7 @@ mashPosteriorContrast <- function( #' mi <- mashInputExample #' mk <- function(b, s) { #' qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), -#' study = "mash") +#' studyName = "mash") #' } #' ssl <- list(strong = mk("strong.b", "strong.s"), #' random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) @@ -2518,9 +2518,10 @@ mergeMashData <- function(resData, oneData) { # 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 +# FineMappingResultBase -> pivot marginalEffects() into a # variants x context (beta, se) pair; strong = the lead (max PIP) variant -# of each credible set in each condition (getCs()), unioned. Conditions +# of each credible set in each condition (credibleSets()), 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. @@ -2555,11 +2556,11 @@ mergeMashData <- function(resData, oneData) { # PIP) variant. # @noRd .mashFmrMatrices <- function(obj, coverage) { - rawMe <- getMarginalEffects(obj) - rawCs <- getCs(obj, coverage = coverage) + rawMe <- marginalEffects(obj) + rawCs <- credibleSets(obj, coverage = coverage) if (!all(is_in(c("variant_id", "context", "beta", "se"), names(rawMe)))) { msg <- glue( - "mashInput: getMarginalEffects() must return variant_id/context/", + "mashInput: marginalEffects() must return variant_id/context/", "beta/se columns; a FineMappingResult with >= 2 contexts is ", "required." ) @@ -2957,7 +2958,7 @@ mashInput <- function( #' @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 studyName 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 @@ -2981,12 +2982,12 @@ mashInput <- function( #' 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, +#' qtlSumStatsFromZMatrix(z = z, studyName = "s1", ldSketch = panel, #' context = colnames(z), trait = "g1", genome = "hg38", n = 100) #' @export qtlSumStatsFromZMatrix <- function( z, - study, + studyName, ldSketch = NULL, context = colnames(z), trait = "mash", @@ -3007,7 +3008,7 @@ qtlSumStatsFromZMatrix <- function( .qtlSumStatsFromMatrix( vids = vids, nCond = ncol(z), - study = study, + studyName = studyName, ldSketch = ldSketch, context = context, trait = trait, @@ -3033,7 +3034,7 @@ qtlSumStatsFromZMatrix <- function( #' 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 studyName 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 @@ -3055,14 +3056,14 @@ qtlSumStatsFromZMatrix <- function( #' 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", +#' qtlSumStatsFromBetaMatrix(bhat = bhat, shat = shat, studyName = "s1", #' ldSketch = panel, context = colnames(bhat), trait = "g1", #' genome = "hg38", n = 100) #' @export qtlSumStatsFromBetaMatrix <- function( bhat, shat, - study, + studyName, ldSketch = NULL, context = colnames(bhat), trait = "mash", @@ -3077,7 +3078,7 @@ qtlSumStatsFromBetaMatrix <- function( .qtlSumStatsFromMatrix( vids = vids, nCond = ncol(bhat), - study = study, + studyName = studyName, ldSketch = ldSketch, context = context, trait = trait, @@ -3157,7 +3158,7 @@ qtlSumStatsFromBetaMatrix <- function( .qtlSumStatsFromMatrix <- function( vids, nCond, - study, + studyName, ldSketch, context, trait, @@ -3181,7 +3182,7 @@ qtlSumStatsFromBetaMatrix <- function( mcolArgs = mcolArgs ) QtlSumStats( - study = rep(as.character(study), nCond), + studyName = rep(as.character(studyName), nCond), context = context, trait = trait, entry = entries, @@ -3272,10 +3273,10 @@ qtlSumStatsFromBetaMatrix <- function( ) abort(msg) } - if (length(getQcInfo(x)) == 0L) { + if (length(qcInfo(x)) == 0L) { msg <- glue( "mashPipeline: '{role}' SumStats has no QC info ", - "(length(getQcInfo(x)) == 0L). ", + "(length(qcInfo(x)) == 0L). ", "Run summaryStatsQc() on the SumStats before passing it to ", "mashPipeline()." ) @@ -3450,15 +3451,19 @@ qtlSumStatsFromBetaMatrix <- function( # @noRd .mashRowDf <- function(x, rIdx, setup, requireCols) { if (setup$isQtl) { - getSumStatsDf( + as.data.frame( x, - study = setup$studyCol[[rIdx]], + studyName = setup$studyCol[[rIdx]], context = setup$contextCol[[rIdx]], trait = setup$traitCol[[rIdx]], require = requireCols ) } else { - getSumStatsDf(x, study = setup$studyCol[[rIdx]], require = requireCols) + as.data.frame( + x, + studyName = setup$studyCol[[rIdx]], + require = requireCols + ) } } diff --git a/R/mashWrapper.R b/R/mashWrapper.R index 663f1585..4caddc88 100644 --- a/R/mashWrapper.R +++ b/R/mashWrapper.R @@ -250,6 +250,14 @@ #' CovCanonicalOptions(cov_methods = c("identity", "equal_effects")) #' @export CovCanonicalOptions <- function(cov_methods = NULL, ...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + data = "supplied from the data by the pipeline" + ), + "CovCanonicalOptions" + ) .newMethodOptions( "mashr::cov_canonical", defaults = list(cov_methods = cov_methods), @@ -270,6 +278,14 @@ CovCanonicalOptions <- function(cov_methods = NULL, ...) { #' CovPcaOptions(subset = 1:50) #' @export CovPcaOptions <- function(subset = NULL, ...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + data = "supplied from the data by the pipeline" + ), + "CovPcaOptions" + ) .newMethodOptions( "mashr::cov_pca", defaults = list(subset = subset), @@ -303,6 +319,12 @@ CovFlashOptions <- function( backfit_args = list(), ... ) { + extra <- list(...) + .configRefuseOwned( + extra, + c(data = "supplied from the data by the pipeline"), + "CovFlashOptions" + ) .newMethodOptions( "mashr::cov_flash", defaults = list( @@ -335,6 +357,15 @@ CovFlashOptions <- function( #' CovEdOptions(algorithm = "teem") #' @export CovEdOptions <- function(subset = NULL, algorithm = "bovy", ...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + data = "supplied from the data by the pipeline", + Ulist_init = "the pipeline's data-driven priors" + ), + "CovEdOptions" + ) .newMethodOptions( "mashr::cov_ed", defaults = list(subset = subset, algorithm = algorithm), @@ -399,13 +430,24 @@ UdInitOptions <- function(...) { #' 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()}. +#' the rest of \code{udr::ud_fit_control_default()}. The one exception is +#' \code{lambda}, which pecotmr derives from the number of conditions and +#' so refuses here. #' @return A \code{\link{MethodOptions}} object. #' @examples #' UdFitOptions(unconstrained.update = "ted", maxiter = 500) #' @export UdFitOptions <- function(...) { extra <- list(...) + # `lambda` is the one control field pecotmr derives rather than fixes: + # .mashUdControl() sets it to the number of conditions, and the merge + # there lets a user value replace it. The rest are plain tunables, so + # this bundle has exactly one owned name. + .configRefuseOwned( + extra, + c(lambda = "the number of conditions in the mash data"), + "UdFitOptions" + ) .udAssertUnconstrainedUpdate(extra) .newMethodOptions( NULL, @@ -775,7 +817,7 @@ CorShrinkOptions <- function(...) { #' mi <- mashInputExample #' mk <- function(b, s) { #' qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), -#' study = "mash") +#' studyName = "mash") #' } #' ssl <- list(strong = mk("strong.b", "strong.s"), #' random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) @@ -879,7 +921,7 @@ mashModelFit <- function( #' mi <- mashInputExample #' mk <- function(b, s) { #' qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), -#' study = "mash") +#' studyName = "mash") #' } #' ssl <- list(strong = mk("strong.b", "strong.s"), #' random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R index 3934cebd..87bf9359 100644 --- a/R/overlapTopLoci.R +++ b/R/overlapTopLoci.R @@ -27,7 +27,7 @@ keyCols ) # A collection with no signal above the cutoff yields an identity-only - # getTopLoci frame (study/context/trait/method) that carries no + # topLoci 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. inner_join( @@ -47,10 +47,15 @@ mutate(tl, variant_id = character(0)) } -# Convert the merged frame to the requested output type. + + +# The per-variant top-loci columns of one side as a tibble -- topLoci() +# returns ranges, and mcols() is exactly the pre-conversion table. # @noRd -.overlapFinish <- function(df, type) { - if (type == "GRanges") .overlapToGRanges(df) else df +.overlapTopLociTable <- function(x, signalCutoff) { + as_tibble(as.data.frame( + S4Vectors::mcols(topLoci(x, signalCutoff = signalCutoff)) + )) } #' Overlap QTL and GWAS top loci by allele-aware variant matching @@ -69,15 +74,14 @@ #' #' @param qtl A \code{QtlFineMappingResult}. #' @param gwas A \code{GwasFineMappingResult}. -#' @param signalCutoff PIP cutoff forwarded to \code{\link{getTopLoci}} for both +#' @param signalCutoff PIP cutoff forwarded to \code{\link{topLoci}} for both #' inputs. Default 0.025. -#' @param type \code{"data.frame"} (default) or \code{"GRanges"}. #' @param ... Ignored. -#' @return A \code{tibble} (or \code{GRanges}) keyed on the QTL variant -#' (\code{variant_id, chrom, pos, A1, A2}) with all other columns prefixed -#' \code{qtl_} / \code{gwas_}. Zero rows when there is no allele-aware -#' overlap. -#' @seealso \code{\link{getTopLoci}}, \code{matchVariants} +#' @return A \code{GRanges} keyed on the QTL variant +#' (\code{variant_id, chrom, pos, A1, A2} in \code{mcols()}) with all other +#' columns prefixed \code{qtl_} / \code{gwas_}. Zero ranges when there is no +#' allele-aware overlap. Take a table with \code{as.data.frame()}. +#' @seealso \code{\link{topLoci}}, \code{matchVariants} #' @examples #' data(qtlFineMappingLbfExample) #' data(gwasFineMappingLbfExample) @@ -94,26 +98,24 @@ setGeneric("overlapTopLoci", function(qtl, gwas, ...) { setMethod( "overlapTopLoci", signature("QtlFineMappingResult", "GwasFineMappingResult"), - function( - qtl, - gwas, - signalCutoff = 0.025, - type = c("data.frame", "GRanges") - ) { - type <- arg_match(type) + function(qtl, gwas, signalCutoff = 0.025) { keyCols <- c("variant_id", "chrom", "pos", "A1", "A2") coordCols <- c("chrom", "pos", "A1", "A2") - qtlTl <- as_tibble(getTopLoci(qtl, signalCutoff = signalCutoff)) - gwasTl <- as_tibble(getTopLoci(gwas, signalCutoff = signalCutoff)) + # mcols() rather than as.data.frame() on the ranges: the join + # prefixes every non-key column, so the standard + # seqnames/start/end/width/strand columns a GRanges coercion adds + # would turn into qtl_seqnames / gwas_start noise. + qtlTl <- .overlapTopLociTable(qtl, signalCutoff) + gwasTl <- .overlapTopLociTable(gwas, signalCutoff) if (nrow(qtlTl) == 0L || nrow(gwasTl) == 0L) { - return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols, type)) + return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols)) } # Allele-aware correspondence between the unique QTL + GWAS variant # sets. target = GWAS, ref = QTL, so `sign` is the flip applied to the # GWAS side. vmap <- .overlapVariantMap(qtlTl, gwasTl) if (is.null(vmap)) { - return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols, type)) + return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols)) } # No zero-row check on `g`: every gwas_vid in `vmap` is drawn from # gwasTl$variant_id, so once vmap is non-NULL the inner join above @@ -130,16 +132,15 @@ setMethod( intersect(keyCols, names(merged)), setdiff(names(merged), keyCols) ) - .overlapFinish(select(merged, all_of(ordered)), type) + .overlapToGRanges(select(merged, all_of(ordered))) } ) -# Finish an empty-overlap result (an empty prefixed merge) in the chosen type. +# Finish an empty-overlap result (an empty prefixed merge). # @noRd -.overlapEmptyReturn <- function(qtlTl, gwasTl, coordCols, keyCols, type) { - .overlapFinish( - .overlapEmptyMerge(qtlTl, gwasTl, coordCols, keyCols), - type +.overlapEmptyReturn <- function(qtlTl, gwasTl, coordCols, keyCols) { + .overlapToGRanges( + .overlapEmptyMerge(qtlTl, gwasTl, coordCols, keyCols) ) } @@ -197,9 +198,18 @@ setMethod( # columns (qtl_* / gwas_*) as mcols. # @noRd .overlapToGRanges <- function(df) { - if (is.null(df) || nrow(df) == 0L) { + if (is.null(df)) { return(GenomicRanges::GRanges()) } + # An empty overlap keeps the prefixed column schema: a zero-row frame + # still names its columns, and callers inspect them. Returning a bare + # GRanges() here would drop that. + if (nrow(df) == 0L) { + return(S4Vectors::`mcols<-`( + GenomicRanges::GRanges(), + value = S4Vectors::DataFrame(df, check.names = FALSE) + )) + } p <- parseVariantId(df$variant_id) gr <- GenomicRanges::GRanges( seqnames = str_c("chr", p$chrom), diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index 2fa8abe2..33ff5470 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -9,7 +9,7 @@ # tss_distance / tes_distance / qvalue mcols. It returns the SAME object # enriched with the corrected-statistic columns. No file I/O, no globbing (that # stays in the wrapper); no method key and no new class (the result is enriched -# summary statistics). Significance is never stored -- see getSignificantQtls(). +# summary statistics). Significance is never stored -- see significantQtls(). # # ALL multiple-testing math uses established package functions: # Bonferroni -> stats::p.adjust(method="bonferroni", n = + cols <- .qssBaseCols(studyName, context, trait, varY) |> .qssAppendNSample(nSample, n) |> .appendTraitPosCol(traitPos, n) |> .qssAppendExtras(extraCols) @@ -236,9 +236,9 @@ QtlSumStats <- function( # trait position when supplied; the authoritative shape check is in # .appendTraitPosCol). # @noRd -.qssBaseCols <- function(study, context, trait, varY) { +.qssBaseCols <- function(studyName, context, trait, varY) { list( - study = as.character(study), + study = as.character(studyName), context = as.character(context), trait = as.character(trait), varY = as.numeric(varY) @@ -306,12 +306,12 @@ QtlSumStats <- function( # 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) { +.qtlSumStatsSelectRow <- function(x, studyName, context, trait) { if (nrow(x) == 0L) { abort("QtlSumStats has no rows.") } - anyUnset <- missing(study) || - is.null(study) || + anyUnset <- missing(studyName) || + is.null(studyName) || missing(context) || is.null(context) || missing(trait) || @@ -326,10 +326,10 @@ QtlSumStats <- function( ) abort(msg) } - assertVector(study, len = 1L) + assertVector(studyName, len = 1L) assertVector(context, len = 1L) assertVector(trait, len = 1L) - .qssMatchTuple(x, study, context, trait) + .qssMatchTuple(x, studyName, context, trait) } # TRUE when every element belongs to the same (study, context, trait) tuple, @@ -348,14 +348,14 @@ QtlSumStats <- function( # Resolve the element indices for a (study, context, trait) tuple. # @noRd -.qssMatchTuple <- function(x, study, context, trait) { +.qssMatchTuple <- function(x, studyName, context, trait) { idx <- .matchTupleRows( x, - list(study = study, context = context, trait = trait) + list(study = studyName, context = context, trait = trait) ) if (length(idx) == 0L) { msg <- glue( - "No entry for (study='{study}', context='{context}', ", + "No entry for (study='{studyName}', context='{context}', ", "trait='{trait}')." ) abort(msg) @@ -366,7 +366,7 @@ QtlSumStats <- function( idx } -#' @rdname getSumStats +#' @rdname sumStats #' @param annotateSignificance Optional correction-method name #' (\code{"permutation"} / \code{"bonferroni_original"} / #' \code{"bonferroni_filtered"} / \code{"qvalue"}). When set on a QtlSumStats @@ -374,21 +374,21 @@ QtlSumStats <- function( #' \code{significant} mcol for that method is added to the returned entry (the #' significance is derived on the fly, not stored). Flat export flattens this #' full entry GRanges (all mcols) directly; note -#' \code{\link{getSumStatsDf}} is a fixed GWAS-schema view and does not +#' \code{\link{as.data.frame}} is a fixed GWAS-schema view and does not #' carry the association columns. #' @export setMethod( - "getSumStats", + "sumStats", signature(x = "QtlSumStats"), function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) { - idx <- .qtlSumStatsSelectRow(x, study, context, trait) + idx <- .qtlSumStatsSelectRow(x, studyName, context, trait) stitched <- .ssStitchElements(x, idx, ranges) gr <- if (is.null(annotateSignificance)) { stitched @@ -415,32 +415,41 @@ setMethod( } ) -# getZ / getN / getMaf / nSnps are provided once by SumStatsBase (AllClasses.R); -# they only delegate to getSumStats(). +# z / nSamples / maf / nSnps are provided once by SumStatsBase (AllClasses.R); +# they only delegate to sumStats(). -#' @rdname getSumStatsDf +#' @rdname sumStatsDataFrame #' @export setMethod( - "getSumStatsDf", + "as.data.frame", "QtlSumStats", function( x, - study = NULL, + row.names = NULL, + optional = FALSE, + studyName = NULL, context = NULL, trait = NULL, require = character(0), derive = c("none", "zFromBetaSe"), - keepChrPrefix = TRUE + keepChrPrefix = TRUE, + ... ) { derive <- arg_match(derive) - gr <- getSumStats(x, study = study, context = context, trait = trait) + gr <- sumStats( + x, + studyName = studyName, + context = context, + trait = trait + ) .entryToSumstatDf( gr, require = require, derive = derive, keepChrPrefix = keepChrPrefix, label = glue( - "QtlSumStats[{if (is.null(study)) '' else study}/", + "QtlSumStats[", + "{if (is.null(studyName)) '' else studyName}/", "{if (is.null(context)) '' else context}/", "{if (is.null(trait)) '' else trait}]" ) @@ -449,35 +458,37 @@ setMethod( ) -#' @rdname getVarY +#' @rdname varY #' @export setMethod( - "getVarY", + "varY", "QtlSumStats", - function(x, study = NULL, context = NULL, trait = NULL) { - idx <- .qtlSumStatsSelectRow(x, study, context, trait) + function(x, studyName = NULL, context = NULL, trait = NULL) { + idx <- .qtlSumStatsSelectRow(x, studyName, context, trait) val <- x$varY[[idx]] if (is.na(val)) NULL else val } ) -#' @rdname getContexts +#' @rdname contexts #' @export -setMethod("getContexts", "QtlSumStats", function(x) { +setMethod("contexts", "QtlSumStats", function(x) { unique(as.character(x$context)) }) -#' @rdname getTraits +#' @rdname traitNames #' @export -setMethod("getTraits", "QtlSumStats", function(x) unique(as.character(x$trait))) +setMethod("traitNames", "QtlSumStats", function(x) { + unique(as.character(x$trait)) +}) # Trait position provenance. Optional for a QtlSumStats -- it cannot be inferred # from summary statistics, so it is only present when the caller supplied it. # Returns the traitPos GRanges (whole column, or the rows matching `traitId`), # or a scalar NA when no trait position was supplied. -#' @rdname getTraitPosition +#' @rdname traitPosition #' @export -setMethod("getTraitPosition", "QtlSumStats", function(x, traitId = NULL) { +setMethod("traitPosition", "QtlSumStats", function(x, traitId = NULL) { tp <- .getTraitPosColumn(x) if (!methods::is(tp, "GRanges") || is.null(traitId)) { return(tp) @@ -501,7 +512,7 @@ setMethod("getTraitPosition", "QtlSumStats", function(x, traitId = NULL) { setMethod("show", "QtlSumStats", function(object) { cat(glue( "QtlSumStats: {nrow(object)} entries, ", - "genome build {getGenome(object)}\n", + "genome build {GenomeInfoDb::genome(object)}\n", .trim = FALSE )) if (nrow(object) > 0L) { @@ -512,7 +523,7 @@ setMethod("show", "QtlSumStats", function(object) { .trim = FALSE )) } - ld <- getLdSketch(object) + ld <- ldSketch(object) ldSrc <- if (is.null(ld)) { "none (LD-free)" } else { diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index bcee90d4..6018c771 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -694,7 +694,7 @@ mrmashRssWeights <- function( } # mr.mash.rss expects either Z or (Bhat, Shat) but not both; prefer # Bhat/Shat. n must be a scalar (mr.mash.rss contract); use the median. - rssArgs <- c( + callArgs <- c( list( Bhat = ss$Bhat, Shat = ss$Shat, @@ -709,7 +709,7 @@ mrmashRssWeights <- function( # one opaque element instead of splicing its entries. as.list(dots) ) - exec(mr.mashr::mr.mash.rss, !!!rssArgs) + exec(mr.mashr::mr.mash.rss, !!!callArgs) } @@ -770,16 +770,19 @@ initPriorSd <- function(X, y, n = 30) { #' 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}}. +#' \code{GlmnetOptions}, \code{NcvregOptions} and \code{DprOptions} cannot +#' check for an UNKNOWN name: \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. Separately, and in all of them, a name pecotmr supplies +#' itself is refused --- \code{GlmnetOptions(alpha=)} and +#' \code{NcvregOptions(penalty=)} select the penalty family, which is the +#' calling wrapper's to set. 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) +#' QggOptions(updateB = TRUE) #' LassosumOptions(thr = 1e-4) #' @name twasEngineOptions NULL @@ -787,6 +790,20 @@ NULL #' @rdname twasEngineOptions #' @export GlmnetOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + x = "supplied from the data by the pipeline", + y = "supplied from the data by the pipeline", + # `alpha` selects the penalty family -- it is what distinguishes + # lasso from enet from ridge -- so it belongs to the calling + # wrapper. Refused here rather than in glmnetWeights() so the + # failure lands where the value was written. + alpha = "the calling wrapper (lassoWeights, enetWeights)" + ), + "GlmnetOptions" + ) .newMethodOptions( "glmnet::cv.glmnet", defaults = list(), @@ -799,6 +816,26 @@ GlmnetOptions <- function(...) { #' @rdname twasEngineOptions #' @export QggOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + y = "supplied from the data by the pipeline", + # qgg's spellings do not line up with the wrapper's: the + # genotype matrix is `W` here and `X` is the covariates (the + # wrapper's `Z`). Both are pecotmr's to supply, so both are + # refused -- matching only the names that happen to agree on + # both sides is how `W` was missed. + W = "supplied from the data by the pipeline", + X = "supplied from the data by the pipeline", + h2 = "the wrapper's `h2`", + method = "the wrapper's `method`", + nit = "the wrapper's `nit`", + nburn = "the wrapper's `nburn`", + nthin = "the wrapper's `nthin`" + ), + "QggOptions" + ) .newMethodOptions( "qgg::gbayes", defaults = list(), @@ -811,6 +848,18 @@ QggOptions <- function(...) { #' @rdname twasEngineOptions #' @export BglrOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + y = "supplied from the data by the pipeline", + ETA = "supplied from the data by the pipeline", + nIter = "the wrapper's `nIter`", + burnIn = "the wrapper's `burnIn`", + thin = "the wrapper's `thin`" + ), + "BglrOptions" + ) .newMethodOptions( "BGLR::BGLR", defaults = list(), @@ -823,6 +872,17 @@ BglrOptions <- function(...) { #' @rdname twasEngineOptions #' @export DprOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + y = "supplied from the data by the pipeline", + x = "supplied from the data by the pipeline", + w = "supplied from the data by the pipeline", + fitting_method = "the wrapper's `fittingMethod`" + ), + "DprOptions" + ) .newMethodOptions( "RcppDPR::fit_model", defaults = list(), @@ -835,6 +895,17 @@ DprOptions <- function(...) { #' @rdname twasEngineOptions #' @export NcvregOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + X = "supplied from the data by the pipeline", + y = "supplied from the data by the pipeline", + nfolds = "the wrapper's `nfolds`", + penalty = "the calling wrapper (scadWeights, mcpWeights)" + ), + "NcvregOptions" + ) .newMethodOptions( "ncvreg::cv.ncvreg", defaults = list(), @@ -847,6 +918,17 @@ NcvregOptions <- function(...) { #' @rdname twasEngineOptions #' @export L0learnOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + x = "supplied from the data by the pipeline", + y = "supplied from the data by the pipeline", + nFolds = "the wrapper's `nFolds`", + penalty = "the wrapper's `penalty`" + ), + "L0learnOptions" + ) .newMethodOptions( "L0Learn::L0Learn.cvfit", defaults = list(), @@ -859,6 +941,15 @@ L0learnOptions <- function(...) { #' @rdname twasEngineOptions #' @export MrashOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + X = "supplied from the data by the pipeline", + y = "supplied from the data by the pipeline" + ), + "MrashOptions" + ) .newMethodOptions( "susieR::mr.ash", defaults = list(), @@ -871,6 +962,25 @@ MrashOptions <- function(...) { #' @rdname twasEngineOptions #' @export MrashRssOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + bhat = "supplied from the data by the pipeline", + shat = "supplied from the data by the pipeline", + R = "supplied from the data by the pipeline", + n = "supplied from the data by the pipeline", + # The engine writes these five in snake_case while the wrapper + # spells them camelCase, so they read as unrelated names; every + # one is still fed straight from a formal. + z = "the wrapper's `z`", + var_y = "the wrapper's `varY`", + sigma2_e = "the wrapper's `sigma2E`", + s0 = "the wrapper's `s0`", + w0 = "the wrapper's `w0`" + ), + "MrashRssOptions" + ) # 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 @@ -888,6 +998,16 @@ MrashRssOptions <- function(...) { #' @rdname twasEngineOptions #' @export PrsCsOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + bhat = "supplied from the data by the pipeline", + R = "supplied from the data by the pipeline", + n = "supplied from the data by the pipeline" + ), + "PrsCsOptions" + ) .newMethodOptions( "pecotmr::prsCs", defaults = list(), @@ -900,6 +1020,16 @@ PrsCsOptions <- function(...) { #' @rdname twasEngineOptions #' @export LassosumOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + bhat = "supplied from the data by the pipeline", + R = "supplied from the data by the pipeline", + n = "supplied from the data by the pipeline" + ), + "LassosumOptions" + ) .newMethodOptions( "pecotmr::lassosumRss", defaults = list(), @@ -912,6 +1042,16 @@ LassosumOptions <- function(...) { #' @rdname twasEngineOptions #' @export PenalizedRssOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + bhat = "supplied from the data by the pipeline", + R = "supplied from the data by the pipeline", + n = "supplied from the data by the pipeline" + ), + "PenalizedRssOptions" + ) .newMethodOptions( "pecotmr::penalizedRss", defaults = list(), @@ -924,6 +1064,16 @@ PenalizedRssOptions <- function(...) { #' @rdname twasEngineOptions #' @export SdprOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + bhat = "supplied from the data by the pipeline", + R = "supplied from the data by the pipeline", + n = "supplied from the data by the pipeline" + ), + "SdprOptions" + ) .newMethodOptions( "pecotmr::sdpr", defaults = list(), @@ -936,6 +1086,20 @@ SdprOptions <- function(...) { #' @rdname twasEngineOptions #' @export MrmashOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + X = "supplied from the data by the pipeline", + Y = "supplied from the data by the pipeline", + S0 = "the pipeline's prior matrices", + mu1_init = "the wrapper's `bInit`", + standardize = "the wrapper's `standardize`", + update_V_method = "the wrapper's `updateVMethod`", + nthreads = "the wrapper's `numThreads`" + ), + "MrmashOptions" + ) .newMethodOptions( "mr.mashr::mr.mash", defaults = list(), @@ -956,6 +1120,21 @@ MrmashOptions <- function(...) { #' @rdname twasEngineOptions #' @export MrmashRssOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + Bhat = "supplied from the data by the pipeline", + Shat = "supplied from the data by the pipeline", + R = "supplied from the data by the pipeline", + n = "supplied from the data by the pipeline", + covY = "supplied from the data by the pipeline", + V = "supplied from the data by the pipeline", + S0 = "the pipeline's prior matrices", + w0 = "the pipeline's prior weights" + ), + "MrmashRssOptions" + ) # 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 @@ -1003,17 +1182,9 @@ glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "glmnetWeights") - # `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`." - )) - } + # `alpha` is the wrapper's own dial and is refused by GlmnetOptions() + # itself, so there is no second check here. Everything else pecotmr + # fixed below is a literal default and stays overridable. callArgs <- list_modify( list( x = X[, keep, drop = FALSE], @@ -1023,7 +1194,7 @@ glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { intercept = TRUE, standardize = FALSE ), - !!!userArgs + !!!methodArgs ) enet <- exec(glmnet::cv.glmnet, !!!callArgs) replace(eff.wgt, keep, coef(enet, s = "lambda.min")[2:(sum(keep) + 1)]) @@ -1221,6 +1392,12 @@ 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 h2 Numeric or \code{NULL}. Prior heritability; \code{NULL} +#' leaves the engine's own default. +#' @param nit Integer. Total MCMC iterations. Default \code{5000}. +#' @param nburn Integer. Burn-in iterations. Default \code{1000}. +#' @param nthin Integer. Thinning interval for retained MCMC samples. +#' Default \code{5}. #' @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 @@ -1233,9 +1410,28 @@ bayesAlphabetWeights <- function( #' y <- eqtlRegionExample$yRes #' bayesNWeights(X, y) #' @export -bayesNWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { +bayesNWeights <- function( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) { .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") - bayesAlphabetWeights(X, y, method = "bayesN", Z, methodArgs = methodArgs) + bayesAlphabetWeights( + X, + y, + method = "bayesN", + Z, + h2 = h2, + nit = nit, + nburn = nburn, + nthin = nthin, + methodArgs = methodArgs + ) } #' @title BayesL TWAS weights (Laplace prior, LASSO-equivalent) #' @description Use laplace/double exponential distribution as prior. This is @@ -1243,6 +1439,12 @@ bayesNWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { #' @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 h2 Numeric or \code{NULL}. Prior heritability; \code{NULL} +#' leaves the engine's own default. +#' @param nit Integer. Total MCMC iterations. Default \code{5000}. +#' @param nburn Integer. Burn-in iterations. Default \code{1000}. +#' @param nthin Integer. Thinning interval for retained MCMC samples. +#' Default \code{5}. #' @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 @@ -1255,15 +1457,40 @@ bayesNWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { #' y <- eqtlRegionExample$yRes #' bayesLWeights(X, y) #' @export -bayesLWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { +bayesLWeights <- function( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) { .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") - bayesAlphabetWeights(X, y, method = "bayesL", Z, methodArgs = methodArgs) + bayesAlphabetWeights( + X, + y, + method = "bayesL", + Z, + h2 = h2, + nit = nit, + nburn = nburn, + nthin = nthin, + 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 h2 Numeric or \code{NULL}. Prior heritability; \code{NULL} +#' leaves the engine's own default. +#' @param nit Integer. Total MCMC iterations. Default \code{5000}. +#' @param nburn Integer. Burn-in iterations. Default \code{1000}. +#' @param nthin Integer. Thinning interval for retained MCMC samples. +#' Default \code{5}. #' @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 @@ -1276,9 +1503,28 @@ bayesLWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { #' y <- eqtlRegionExample$yRes #' bayesAWeights(X, y) #' @export -bayesAWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { +bayesAWeights <- function( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) { .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") - bayesAlphabetWeights(X, y, method = "bayesA", Z, methodArgs = methodArgs) + bayesAlphabetWeights( + X, + y, + method = "bayesA", + Z, + h2 = h2, + nit = nit, + nburn = nburn, + nthin = nthin, + methodArgs = methodArgs + ) } #' @title BayesC TWAS weights (rounded-spike prior) #' @description Use a rounded spike prior (low-variance Gaussian). @@ -1287,6 +1533,12 @@ bayesAWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { #' @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 h2 Numeric or \code{NULL}. Prior heritability; \code{NULL} +#' leaves the engine's own default. +#' @param nit Integer. Total MCMC iterations. Default \code{5000}. +#' @param nburn Integer. Burn-in iterations. Default \code{1000}. +#' @param nthin Integer. Thinning interval for retained MCMC samples. +#' Default \code{5}. #' @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 @@ -1299,7 +1551,17 @@ bayesAWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { #' y <- eqtlRegionExample$yRes #' bayesCWeights(X, y) #' @export -bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) { +bayesCWeights <- function( + X, + y, + Z = NULL, + pi = 0.1, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + 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. @@ -1308,6 +1570,10 @@ bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) { y, method = "bayesC", Z, + h2 = h2, + nit = nit, + nburn = nburn, + nthin = nthin, methodArgs = .methodOptionsWith(methodArgs, "QggOptions", pi = pi) ) } @@ -1317,6 +1583,12 @@ bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) { #' @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 h2 Numeric or \code{NULL}. Prior heritability; \code{NULL} +#' leaves the engine's own default. +#' @param nit Integer. Total MCMC iterations. Default \code{5000}. +#' @param nburn Integer. Burn-in iterations. Default \code{1000}. +#' @param nthin Integer. Thinning interval for retained MCMC samples. +#' Default \code{5}. #' @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 @@ -1329,9 +1601,28 @@ bayesCWeights <- function(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) { #' y <- eqtlRegionExample$yRes #' bayesRWeights(X, y) #' @export -bayesRWeights <- function(X, y, Z = NULL, methodArgs = QggOptions()) { +bayesRWeights <- function( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) { .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") - bayesAlphabetWeights(X, y, method = "bayesR", Z, methodArgs = methodArgs) + bayesAlphabetWeights( + X, + y, + method = "bayesR", + Z, + h2 = h2, + nit = nit, + nburn = nburn, + nthin = nthin, + methodArgs = methodArgs + ) } diff --git a/R/relatednessQc.R b/R/relatednessQc.R index e6066457..8a398a22 100644 --- a/R/relatednessQc.R +++ b/R/relatednessQc.R @@ -121,6 +121,14 @@ PlinkQcOptions <- function( otherCriterionMeasure = NULL, ... ) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + relatedness = "the caller's relatedness table" + ), + "PlinkQcOptions" + ) .newMethodOptions( "plinkQC::relatednessFilter", defaults = list( diff --git a/R/sldscPostprocessingPipeline.R b/R/sldscPostprocessingPipeline.R index 1653147b..0e277c5f 100644 --- a/R/sldscPostprocessingPipeline.R +++ b/R/sldscPostprocessingPipeline.R @@ -36,8 +36,8 @@ #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7 * seq(0.9, 1.1, length.out = 10), 10, n, -#' dimnames = list(NULL, cats)), +#' annotationJackknifeCoefs = matrix(1e-7 * seq(0.9, 1.1, length.out = 10), +#' 10, n, dimnames = list(NULL, cats)), #' nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), @@ -50,7 +50,7 @@ #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sldscData <- SldscData(annot = annot, frq = frq, traits = traits) +#' sldscData <- SldscData(annotData = annot, frqData = frq, traits = traits) #' sldscPostprocessingPipeline(sldscData = sldscData) #' @export sldscPostprocessingPipeline <- function( @@ -109,7 +109,7 @@ sldscPostprocessingPipeline <- function( ) abort(msg) } - traitNames <- getTraits(sldscData) + traitNames <- traitNames(sldscData) if (length(traitNames) == 0L) { abort("sldscPostprocessingPipeline: SldscData has no traits.") } @@ -176,8 +176,8 @@ sldscPostprocessingPipeline <- function( # first single run. # @noRd .sldscPivotRun <- function(sldscData, trait1) { - pivotRun <- getTraitRun(sldscData, trait1, "joint") %||% - getTraitRun(sldscData, trait1, "single", 1L) + pivotRun <- sldscResults(sldscData, trait1, "joint") %||% + sldscResults(sldscData, trait1, "single", 1L) pivotRun } @@ -242,7 +242,7 @@ sldscPostprocessingPipeline <- function( # Baseline categories = the first trait's joint categories minus the targets. # @noRd .sldscBaselineCategories <- function(sldscData, traitNames, targetCategories) { - jointPivot <- getTraitRun(sldscData, traitNames[1], "joint") + jointPivot <- sldscResults(sldscData, traitNames[1], "joint") baselineCategories <- if (!is.null(jointPivot)) { setdiff(jointPivot$categories, targetCategories) } else { @@ -319,7 +319,7 @@ sldscPostprocessingPipeline <- function( # list(singleDf, blocksSingle, singleH2gs). # @noRd .sldscTraitSingle <- function(trait, ctx) { - singleRuns <- getTraitRun(ctx$sldscData, trait, "single") %||% list() + singleRuns <- sldscResults(ctx$sldscData, trait, "single") %||% list() nRun <- min(length(ctx$targetCategories), length(singleRuns)) stds <- compact(map( seq_len(nRun), @@ -395,7 +395,7 @@ sldscPostprocessingPipeline <- function( jointH2g = NA_real_, nBlocks = NA_integer_ ) - if (is.null(getTraitRun(ctx$sldscData, trait, "joint"))) { + if (is.null(sldscResults(ctx$sldscData, trait, "joint"))) { return(empty) } std <- try_fetch( diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index 13008005..61a0f5a3 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -75,7 +75,7 @@ readSldscTrait <- function(prefix) { propH2 = set_names(as.numeric(results[["Prop._h2"]]), cats), propSnps = set_names(as.numeric(results[["Prop._SNPs"]]), cats), h2g = h2g, - tauBlocks = deleteValues, + annotationJackknifeCoefs = deleteValues, nBlocks = nrow(deleteValues) ) } @@ -248,8 +248,8 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -261,14 +261,14 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) #' computeSldscAnnotSd(sldscData = sd) #' @importFrom purrr map map_dbl compact reduce #' @export computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { assertClass(sldscData, "SldscData") - annot <- getAnnotData(sldscData) - frq <- getFrqData(sldscData) + annot <- annotData(sldscData) + frq <- frqData(sldscData) if (mafCutoff > 0 && nrow(frq) == 0L) { msg <- glue( "computeSldscAnnotSd: mafCutoff = {mafCutoff} requires frq ", @@ -281,8 +281,8 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { contribs <- compact(map( unique(annot$CHR), .sldscChromVar, - annot = annot, - frq = frq, + annotData = annot, + frqData = frq, mafCutoff = mafCutoff, colsUse = colsUse )) @@ -304,9 +304,9 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { # @noRd .sldscColsUse <- function(sldscData, annotCols) { colsUse <- if (is.null(annotCols)) { - getAnnotCols(sldscData) + annotCols(sldscData) } else if (is.numeric(annotCols)) { - getAnnotCols(sldscData)[annotCols] + annotCols(sldscData)[annotCols] } else { annotCols } @@ -320,11 +320,11 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { # Returns list(num = named weighted-variance vector, den = n-1), or NULL when # the chromosome has <= 1 usable variant after MAF filtering. # @noRd -.sldscChromVar <- function(chrom, annot, frq, mafCutoff, colsUse) { - onChrom <- filter(annot, .data$CHR == chrom) +.sldscChromVar <- function(chrom, annotData, frqData, mafCutoff, colsUse) { + onChrom <- filter(annotData, .data$CHR == chrom) dat <- if (mafCutoff > 0) { onChrom |> - inner_join(select(frq, all_of(c("SNP", "MAF"))), by = "SNP") |> + inner_join(select(frqData, all_of(c("SNP", "MAF"))), by = "SNP") |> filter(!is.na(.data$MAF) & .data$MAF > mafCutoff) } else { onChrom @@ -373,8 +373,8 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -386,12 +386,12 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) #' computeSldscMRef(sldscData = sd) #' @export computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { assertClass(sldscData, "SldscData") - frq <- getFrqData(sldscData) + frq <- frqData(sldscData) if (nrow(frq) > 0L) { return(as.integer( if (mafCutoff > 0) { @@ -408,7 +408,7 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { ) abort(msg) } - as.integer(nrow(getAnnotData(sldscData))) + as.integer(nrow(annotData(sldscData))) } @@ -435,8 +435,8 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -448,27 +448,27 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) #' isBinarySldscAnnot(sd) #' @export isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { assertClass(sldscData, "SldscData") - annot <- getAnnotData(sldscData) + annot <- annotData(sldscData) colsUse <- if (is.null(annotCols)) { - getAnnotCols(sldscData) + annotCols(sldscData) } else if (is.numeric(annotCols)) { - getAnnotCols(sldscData)[annotCols] + annotCols(sldscData)[annotCols] } else { annotCols } - set_names(map_lgl(colsUse, .sldscColIsBinary, annot = annot), colsUse) + set_names(map_lgl(colsUse, .sldscColIsBinary, annotData = 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]]))) +.sldscColIsBinary <- function(col, annotData) { + vals <- unique(na.omit(as.numeric(annotData[[col]]))) all(is_in(vals, c(0, 1))) } @@ -483,7 +483,7 @@ isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { #' \Phi^{-1}(1 - p/2)}. #' #' @param sldscData An \code{\link{SldscData}} object (the run is pulled from it -#' via \code{getTraitRun}). +#' via \code{sldscResults}). #' @param trait Character. Trait name (a key of the SldscData traits list). #' @param mode Character: `"single"` or `"joint"`. #' @param idx Integer or NULL. For `mode = "single"`, which of the trait's @@ -508,8 +508,8 @@ isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -520,7 +520,7 @@ isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { #' mkRun(c("annot_B_0", "baselineLD_0"))), #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } -#' sd <- SldscData(annot = annot, frq = frq, +#' sd <- SldscData(annotData = annot, frqData = frq, #' traits = setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY"))) #' sdAnnot <- computeSldscAnnotSd(sd) #' MRef <- computeSldscMRef(sd) @@ -549,7 +549,10 @@ standardizeSldscTrait <- function( sdTarget <- .stdSdTarget(sdAnnot, targetCategories) tau <- as.numeric(traitData$tau[targetCategories]) tauSe <- as.numeric(traitData$tauSe[targetCategories]) - blocksTarget <- traitData$tauBlocks[, targetIdx, drop = FALSE] + blocksTarget <- traitData$annotationJackknifeCoefs[, + targetIdx, + drop = FALSE + ] ts <- standardizeTauStar(tau, blocksTarget, sdTarget, MRef, h2g) base <- .stdSummaryDf(targetCategories, tau, tauSe, ts) summaryDf <- if (mode != "single") { @@ -582,7 +585,7 @@ standardizeSldscTrait <- function( # Fetch the requested trait's single/joint run (error when absent). # @noRd .stdTraitRun <- function(sldscData, trait, mode, idx) { - traitData <- getTraitRun(sldscData, trait, mode, idx) + traitData <- sldscResults(sldscData, trait, mode, idx) if (is.null(traitData)) { idxNote <- if (!is.null(idx)) glue(" (idx={idx})") else "" msg <- glue( @@ -696,8 +699,8 @@ standardizeSldscTrait <- function( #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -709,7 +712,7 @@ standardizeSldscTrait <- function( #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) #' pp <- sldscPostprocessingPipeline(sd) #' metaSldscRandom(pp$per_trait, category = "annot_A_0", #' quantity = "enrichment") @@ -909,8 +912,8 @@ metaSldscRandom <- function( #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) +#' annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, +#' cats)), nBlocks = 10L) #' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -922,7 +925,7 @@ metaSldscRandom <- function( #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) +#' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) #' pp <- sldscPostprocessingPipeline(sd) #' sldscSubsetMeta(pp, subsetTraits = "traitX") #' @export diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 21ea8068..e0f5450c 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -2965,17 +2965,42 @@ effectiveN <- function(nCase, nControl) { } .entryDfAddStats <- function(df, mc) { - statMap <- c(z = "Z", beta = "BETA", se = "SE", N = "N", maf = "MAF") + statMap <- c( + z = "Z", + beta = "BETA", + se = "SE", + N = "N", + maf = "MAF", + af = "AF" + ) 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( + out <- mutate( df, !!!set_names( map(unname(present), .entryStatColumn, mc = mc), names(present) ) ) + .entryDfDeriveMaf(out) +} + +# AF is the DIRECTIONAL effect-allele frequency; MAF is its directionless +# form. A study that declared only `af:` therefore already carries the +# information, so derive the MAF rather than leaving the column absent -- +# absent, the MR Wald ratio falls back to the z scale (see +# .cipGwasHasScale) even though a real frequency was supplied. Same +# pmin(af, 1 - af) the QC frequency filter uses. +# +# A declared MAF wins: it is what the study actually asserted, and AF is +# only a route to the same quantity. +# @noRd +.entryDfDeriveMaf <- function(df) { + if (!is.null(df[["maf"]]) || is.null(df[["af"]])) { + return(df) + } + mutate(df, maf = pmin(.data$af, 1 - .data$af)) } .entryToSumstatDf <- function( @@ -4503,7 +4528,7 @@ effectiveN <- function(nCase, nControl) { # becoming two separate settings. cf <- .applyContentFilters( df, - mafCutoff = opts$panelFilterArgs$mafCutoff, + mafCutoff = opts$panelFilterParam$mafCutoff, infoCutoff = opts$sumstatsFilterArgs$infoCutoff, nCutoff = opts$sumstatsFilterArgs$nCutoff ) @@ -4971,9 +4996,9 @@ effectiveN <- function(nCase, nControl) { # 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(panelFilterArgs) { - bad <- names(panelFilterArgs)[ - !map_lgl(as.list(panelFilterArgs), .ssqcIsCutoff) +.ssqcCheckPanelCutoffs <- function(panelFilterParam) { + bad <- names(panelFilterParam)[ + !map_lgl(as.list(panelFilterParam), .ssqcIsCutoff) ] if (length(bad) > 0L) { msg <- glue( @@ -4988,7 +5013,7 @@ effectiveN <- function(nCase, nControl) { # Build the per-entry QC options list from the captured call parameters. .ssqcBuildOpts <- function( sumstatsFilterArgs, - panelFilterArgs, + panelFilterParam, skipRegion, ldMismatchQcMethod, alleleFlipKriging, @@ -5004,7 +5029,7 @@ effectiveN <- function(nCase, nControl) { # character vector: a renamed argument is now an error, not a NULL entry. opts <- list( sumstatsFilterArgs = sumstatsFilterArgs, - panelFilterArgs = panelFilterArgs, + panelFilterParam = panelFilterParam, skipRegion = skipRegion, ldMismatchQcMethod = ldMismatchQcMethod, alleleFlipKriging = alleleFlipKriging, @@ -5112,11 +5137,11 @@ effectiveN <- function(nCase, nControl) { # 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$panelFilterArgs), + ldSketch(sumstats), + .panelCutoffs(opts$panelFilterParam), "summaryStatsQc" ) - refGenome <- getGenome(sumstats) + refGenome <- unique(unname(GenomeInfoDb::genome(sumstats))) results <- map( seq_len(nrow(sumstats)), .ssqcRunEntry, @@ -5134,7 +5159,7 @@ effectiveN <- function(nCase, nControl) { # 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 +# like qcDiagnostics() index these four names, so the output shape is kept # even though the input is now one argument. # @noRd .ssqcScreenEcho <- function(signalScreenArgs, metric) { @@ -5145,7 +5170,7 @@ effectiveN <- function(nCase, nControl) { .ssqcBuildQcInfo <- function( entryAudits, sumstatsFilterArgs, - panelFilterArgs, + panelFilterParam, signalScreenArgs, ldMismatchQcMethod, alleleFlipKriging, @@ -5156,15 +5181,15 @@ effectiveN <- function(nCase, nControl) { list( timestamp = NA_character_, # Echoed FLAT, not nested: this record is part of the returned - # object's shape, which readers like getQcDiagnostics() index by + # object's shape, which readers like qcDiagnostics() 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, + mafCutoff = panelFilterParam$mafCutoff, + macCutoff = panelFilterParam$macCutoff, + imissCutoff = panelFilterParam$imissCutoff, infoCutoff = sumstatsFilterArgs$infoCutoff, nCutoff = sumstatsFilterArgs$nCutoff, pipCutoffToSkip = .ssqcScreenEcho(signalScreenArgs, "pip"), @@ -5197,9 +5222,9 @@ effectiveN <- function(nCase, nControl) { nSample <- if (has("nSample")) as.numeric(sumstats$nSample) else NULL if (methods::is(sumstats, "GwasSumStats")) { GwasSumStats( - study = as.character(sumstats$study), + studyName = as.character(sumstats$study), entry = newEntries, - genome = getGenome(sumstats), + genome = unique(unname(GenomeInfoDb::genome(sumstats))), ldSketch = newLdSketch, varY = as.numeric(sumstats$varY), nCase = if (has("nCase")) as.numeric(sumstats$nCase) else NULL, @@ -5221,11 +5246,11 @@ effectiveN <- function(nCase, nControl) { ) } else { QtlSumStats( - study = as.character(sumstats$study), + studyName = as.character(sumstats$study), context = as.character(sumstats$context), trait = as.character(sumstats$trait), entry = newEntries, - genome = getGenome(sumstats), + genome = unique(unname(GenomeInfoDb::genome(sumstats))), ldSketch = newLdSketch, varY = as.numeric(sumstats$varY), nSample = nSample, @@ -5250,7 +5275,7 @@ effectiveN <- function(nCase, nControl) { #' The returned collection has its \code{qcInfo} slot populated with a per-entry #' audit record (variant counts, drop counts at each step, which filters fired, #' etc.). Fine-mapping and TWAS-weights pipelines reject SumStats inputs where -#' \code{length(getQcInfo(x)) == 0L}. +#' \code{length(qcInfo(x)) == 0L}. #' #' Column-availability error contract: a non-zero \code{infoCutoff} requires #' every entry to carry an \code{INFO} column, and a non-zero \code{nCutoff} @@ -5287,7 +5312,7 @@ effectiveN <- function(nCase, nControl) { #' 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 +#' @param panelFilterParam 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 @@ -5383,7 +5408,7 @@ effectiveN <- function(nCase, nControl) { summaryStatsQc <- function( sumstats, sumstatsFilterArgs = SumstatsFilterParam(), - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), keepVariants = NULL, skipRegion = NULL, signalScreenArgs = SignalScreenParam(), @@ -5398,7 +5423,7 @@ summaryStatsQc <- function( r <- .ssqcResolveInputs( sumstats, sumstatsFilterArgs, - panelFilterArgs, + panelFilterParam, signalScreenArgs, sumstatsCleaningArgs, imputeArgs, @@ -5406,7 +5431,7 @@ summaryStatsQc <- function( ) opts <- .ssqcBuildOpts( sumstatsFilterArgs = sumstatsFilterArgs, - panelFilterArgs = panelFilterArgs, + panelFilterParam = panelFilterParam, skipRegion = skipRegion, ldMismatchQcMethod = r$ldMismatchQcMethod, alleleFlipKriging = alleleFlipKriging, @@ -5423,7 +5448,7 @@ summaryStatsQc <- function( sumstats, res, sumstatsFilterArgs = sumstatsFilterArgs, - panelFilterArgs = panelFilterArgs, + panelFilterParam = panelFilterParam, signalScreenArgs = signalScreenArgs, ldMismatchQcMethod = r$ldMismatchQcMethod, alleleFlipKriging = alleleFlipKriging, @@ -5441,7 +5466,7 @@ summaryStatsQc <- function( .ssqcResolveInputs <- function( sumstats, sumstatsFilterArgs, - panelFilterArgs, + panelFilterParam, signalScreenArgs, sumstatsCleaningArgs, imputeArgs, @@ -5452,11 +5477,11 @@ summaryStatsQc <- function( "SumstatsFilterParam", "sumstatsFilter" ) - .assertMethodParam(panelFilterArgs, "PanelFilterParam", "panelFilter") + .assertMethodParam(panelFilterParam, "PanelFilterParam", "panelFilter") .assertMethodParam(signalScreenArgs, "SignalScreenParam", "signalScreen") .assertMethodParam(imputeArgs, "RaissParam", "imputeArgs") .ssqcCheckEntries(sumstats, sumstatsFilterArgs$infoCutoff) - .ssqcCheckPanelCutoffs(panelFilterArgs) + .ssqcCheckPanelCutoffs(panelFilterParam) list( ldMismatchQcMethod = .resolveLdMismatchChoice(ldMismatchQcMethod), cleaning = .sumstatsCleaningResolve(sumstatsCleaningArgs), @@ -5470,7 +5495,7 @@ summaryStatsQc <- function( sumstats, res, sumstatsFilterArgs, - panelFilterArgs, + panelFilterParam, signalScreenArgs, ldMismatchQcMethod, alleleFlipKriging, @@ -5481,7 +5506,7 @@ summaryStatsQc <- function( qcInfo <- .ssqcBuildQcInfo( res$entryAudits, sumstatsFilterArgs = sumstatsFilterArgs, - panelFilterArgs = panelFilterArgs, + panelFilterParam = panelFilterParam, signalScreenArgs = signalScreenArgs, ldMismatchQcMethod = ldMismatchQcMethod, alleleFlipKriging = alleleFlipKriging, diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index bc74d5ed..fa9bae4a 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -127,7 +127,7 @@ #' @importFrom checkmate assertVector .tupleSelectRow <- function( x, - study, + studyName, context, trait, method, @@ -137,8 +137,8 @@ msg <- glue("{cls} has no rows.") abort(msg) } - anyUnset <- missing(study) || - is.null(study) || + anyUnset <- missing(studyName) || + is.null(studyName) || missing(context) || is.null(context) || missing(trait) || @@ -155,23 +155,28 @@ ) abort(msg) } - assertVector(study, len = 1L) + assertVector(studyName, len = 1L) assertVector(context, len = 1L) assertVector(trait, len = 1L) assertVector(method, len = 1L) - .tupleMatchQtl(x, study, context, trait, method) + .tupleMatchQtl(x, studyName, context, trait, method) } # Resolve a (study, context, trait, method) tuple to a single row index. # @noRd -.tupleMatchQtl <- function(x, study, context, trait, method) { +.tupleMatchQtl <- function(x, studyName, context, trait, method) { idx <- .matchTupleRows( x, - list(study = study, context = context, trait = trait, method = method) + list( + study = studyName, + context = context, + trait = trait, + method = method + ) ) if (length(idx) == 0L) { msg <- glue( - "No entry for (study='{study}', context='{context}', ", + "No entry for (study='{studyName}', context='{context}', ", "trait='{trait}', method='{method}')." ) abort(msg) @@ -184,12 +189,12 @@ # 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) { +.tupleSelectRowGwasFmr <- function(x, studyName, method, region = NULL) { if (nrow(x) == 0L) { abort("GwasFineMappingResult has no rows.") } - anyUnset <- missing(study) || - is.null(study) || + anyUnset <- missing(studyName) || + is.null(studyName) || missing(method) || is.null(method) if (anyUnset) { @@ -202,17 +207,17 @@ ) abort(msg) } - assertVector(study, len = 1L) + assertVector(studyName, len = 1L) assertVector(method, len = 1L) assertVector(region, len = 1L, null.ok = TRUE) - .tupleMatchGwas(x, study, method, region) + .tupleMatchGwas(x, studyName, method, region) } # Resolve a (study, method[, blockId]) tuple to a single row index. # @noRd -.tupleMatchGwas <- function(x, study, method, region) { +.tupleMatchGwas <- function(x, studyName, method, region) { keys <- c( - list(study = study, method = method), + list(study = studyName, method = method), compact(list(blockId = region)) ) idx <- .matchTupleRows(x, keys) @@ -223,26 +228,26 @@ glue(", region='{region}'") } msg <- glue( - "No entry for (study='{study}', method='{method}'{regionPart})." + "No entry for (study='{studyName}', method='{method}'{regionPart})." ) abort(msg) } if (length(idx) > 1L) { - .tupleGwasAmbiguous(x, study, method, idx) + .tupleGwasAmbiguous(x, studyName, method, idx) } idx[[1L]] } # Multiple (study, method) rows matched: report the disambiguating regions. # @noRd -.tupleGwasAmbiguous <- function(x, study, method, idx) { +.tupleGwasAmbiguous <- function(x, studyName, method, idx) { regions <- str_flatten( shQuote(as.character(x$blockId[idx])), ", " ) msg <- glue( "GwasFineMappingResult has {length(idx)} rows matching ", - "(study='{study}', method='{method}'); pass `region` to ", + "(study='{studyName}', method='{method}'); pass `region` to ", "disambiguate (available: {regions})." ) abort(msg) @@ -257,14 +262,14 @@ # ambiguity; it is the aggregate counterpart used by getTopLoci. .fmrRowsMatching <- function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, region = NULL ) { supplied <- compact(list( - study = study, + study = studyName, context = context, trait = trait, method = method, @@ -307,7 +312,7 @@ } # Internal: read the per-row `region` GRanges column of a collection, or an -# empty GRanges when the collection carries none. Shared by getRegion on +# empty GRanges when the collection carries none. Shared by genomicRegion on # TwasWeights and FineMappingResultBase (region is a uniform column across the # family; no derivation from topLoci / blockId). # The per-element span, DERIVED from the ranges rather than read from a stored @@ -361,7 +366,7 @@ # traitPos is optional provenance: always known for a QtlDataset, but only known # for a QtlSumStats when the caller supplied it (it cannot be inferred from # summary statistics). When the column is absent we return a scalar NA rather -# than an empty GRanges, so getTraitPosition() reports "no trait position" +# than an empty GRanges, so traitPosition() reports "no trait position" # honestly instead of a zero-length range. .getTraitPosColumn <- function(x) { if (is_in("traitPos", .tupleColumnNames(x))) { @@ -461,8 +466,9 @@ # Internal: aggregate a per-entry accessor across every row of a # FineMappingResultBase collection that matches the given selectors, prefixing # each entry's rows with the row identity (study/context/trait/blockId/method) -# so rows stay attributable to their source entry. Shared by getTopLoci / getCs -# / getMarginalEffects on FineMappingResultBase. +# so rows stay attributable to their source entry. Shared by topLoci / +# credibleSets +# / marginalEffects on FineMappingResultBase. # # When at least one selector is supplied AND resolves to exactly one entry, this # short-circuits to `onSingle(entry)` -- the bare per-entry view with no @@ -477,7 +483,7 @@ # entry (defaults to perEntry). .fmrAggregateView <- function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -488,7 +494,7 @@ ) { single <- .fmrTrySingle( x, - study, + studyName, context, trait, method, @@ -501,7 +507,7 @@ } idx <- .fmrRowsMatching( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -543,7 +549,7 @@ #' @importFrom rlang try_fetch .fmrTrySingle <- function( x, - study, + studyName, context, trait, method, @@ -551,7 +557,7 @@ onSingle, viewArgs ) { - anySelector <- !is.null(study) || + anySelector <- !is.null(studyName) || !is.null(context) || !is.null(trait) || !is.null(method) || @@ -562,7 +568,7 @@ sel <- try_fetch( .fmrSelectEntry( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -702,22 +708,22 @@ # @noRd .fmrPartsVariantIds <- function(parts) { - getVariantIds(.asFmRowPayload(parts)) + variantIds(.asFmRowPayload(parts)) } # @noRd .fmrPartsSusieFit <- function(parts) { - getSusieFit(.asFmRowPayload(parts)) + susieFit(.asFmRowPayload(parts)) } # @noRd .fmrPartsCvResult <- function(parts) { - getCvResult(.asFmRowPayload(parts)) + cvResult(.asFmRowPayload(parts)) } # @noRd .fmrPartsTopLoci <- function(parts) { - .fmeTopLociFromElement(rowVariants(.asFmRowPayload(parts))) + .fmeTopLociFromElement(variants(.asFmRowPayload(parts))) } # ---- per-row views ---------------------------------------------------------- @@ -728,7 +734,6 @@ # @noRd .fmrRowTopLoci <- function( parts, - type = c("data.frame", "GRanges"), signalCutoff = 0.025, minPurity = NULL, raw = FALSE @@ -739,12 +744,9 @@ if (isTRUE(raw)) { return(tl) } - type <- arg_match(type) - out <- .fmeFilterTopLoci(tl, signalCutoff, minPurity) - if (type == "data.frame") { - return(out) - } - .fmeTopLociGRanges(out) + # Always a table: .fmrAggregateView() stacks these, and topLoci() + # converts the stacked result to ranges once. + .fmeFilterTopLoci(tl, signalCutoff, minPurity) } # @noRd @@ -793,7 +795,7 @@ hasPurity <- is_in(purCol, names(tl)) if (!is.null(minPurity) && !hasPurity) { msg <- glue( - "getCs: no purity column '{purCol}' for coverage ", + "credibleSets: no purity column '{purCol}' for coverage ", "{coverage}; minPurity filter skipped." ) warn(msg) @@ -809,7 +811,7 @@ # @noRd .fmrRowLbf <- function(parts) { - lbf <- .asLbfMatrix(getSusieFit(parts)) + lbf <- .asLbfMatrix(susieFit(parts)) vids <- .fmrPartsVariantIds(parts) if (is.null(lbf) || ncol(lbf) != length(vids)) { return(tibble(variant_id = character(0))) @@ -821,18 +823,18 @@ # @noRd .fmrRowCredibleSetSummary <- function(parts, coverage = 0.95) { - .csSummaryFit(.fmrPartsTopLoci(parts), getSusieFit(parts), coverage) + .csSummaryFit(.fmrPartsTopLoci(parts), susieFit(parts), coverage) } # @noRd .fmrRowFsusieCredibleBand <- function(parts) { - .fsusieCredibleBandFit(getSusieFit(parts)) + .fsusieCredibleBandFit(susieFit(parts)) } # @noRd .fmrRowFsusieAffectedRegions <- function(parts) { .fsusieAffectedRegionsFit( - getSusieFit(parts), + susieFit(parts), topLoci = .fmrPartsTopLoci(parts) ) } @@ -870,16 +872,16 @@ "TwasWeightsRow", variants = gr, weights = mcols(gr, use.names = FALSE)$weight, - fits = md$fits[[first]], + methodFits = md$fits[[first]], cvResult = md$cvResult[[first]], - standardized = isTRUE(md$standardized[[first]]), - dataType = md$dataType[[first]] + weightStandardized = isTRUE(md$standardized[[first]]), + weightsDataType = md$dataType[[first]] ) } # @noRd .twrPartsVariantIds <- function(parts) { - getVariantIds(parts) + variantIds(parts) } # The weight vector aligned to the row's variant ids -- what resolveWeights @@ -888,7 +890,7 @@ .twrRowResolveWeights <- function(parts) { empty <- list(variantIds = character(0), weights = numeric(0)) vids <- .twrPartsVariantIds(parts) - raw <- getWeights(parts) + raw <- weights(parts) if (length(vids) == 0L || is.null(raw)) { return(empty) } @@ -930,10 +932,10 @@ # A fine-mapping row deliberately reports NULL: cTWAS would otherwise # renormalize alpha into an UNstandardized weight, which is inconsistent with # the standardized posterior effect the topLoci view already carries. Preserved -# verbatim from the FineMappingRow getFits method. +# verbatim from the FineMappingRow methodFits method. # @noRd .rowFits <- function(parts) { - if (methods::is(parts, "TwasWeightsRow")) getFits(parts) else NULL + if (methods::is(parts, "TwasWeightsRow")) methodFits(parts) else NULL } # Whether the row's weights are already on the standardized scale. @@ -944,7 +946,7 @@ # @noRd .rowStandardized <- function(parts) { if (methods::is(parts, "TwasWeightsRow")) { - return(getStandardized(parts)) + return(weightStandardized(parts)) } TRUE } @@ -961,7 +963,7 @@ # @noRd .asFmRowPayload <- function(e) { # A single-row collection is the other shape callers hand over -- it is - # what getFineMappingResult() returns, so anything accepting "one row's + # what fineMappingResult() returns, so anything accepting "one row's # worth of fine-mapping" has to take it too. if (methods::is(e, "FineMappingResultBase")) { if (length(e) == 0L) { @@ -1006,17 +1008,17 @@ # nothing produces entries. # @noRd .rowCvResult <- function(e) { - getCvResult(e) + cvResult(e) } # @noRd .rowWeights <- function(e) { - getWeights(e) + weights(e) } # @noRd .rowVariantIds <- function(e) { - getVariantIds(e) + variantIds(e) } # The non-variant half of each TWAS row payload, as outer mcols columns. @@ -1024,10 +1026,10 @@ # @noRd .twRowPayloadCols <- function(entry) { list( - fits = S4Vectors::SimpleList(map(entry, getFits)), - cvResult = S4Vectors::SimpleList(map(entry, getCvResult)), + fits = S4Vectors::SimpleList(map(entry, methodFits)), + cvResult = S4Vectors::SimpleList(map(entry, cvResult)), standardized = map_lgl(entry, .twPayloadStandardized), - dataType = S4Vectors::SimpleList(map(entry, getDataType)) + dataType = S4Vectors::SimpleList(map(entry, weightsDataType)) ) } @@ -1113,7 +1115,7 @@ } # The single build every part must agree on, or NULL for a family that does -# not carry one. Read through getGenome() so it works off seqinfo. +# not carry one. Read seqinfo directly via GenomeInfoDb::genome(). # @noRd .rtlCombineGenome <- function(parts, fn) { if (!methods::is(parts[[1L]], "SumStatsBase")) { @@ -1133,7 +1135,13 @@ # parts must agree. # @noRd .ssCombineGenome <- function(parts, fn) { - genomes <- unique(map_chr(parts, getGenome)) + # genome() is per-seqlevel, so flatten across parts before uniquing + # rather than map_chr (which would reject a multi-seqlevel part). + builds <- discard(list_c(map(parts, GenomeInfoDb::genome)), is.na) + genomes <- unique(unname(builds)) + if (length(genomes) == 0L) { + return(NA_character_) + } if (length(genomes) > 1L) { msg <- glue( "{fn}: every input must share one genome build (got ", @@ -1144,7 +1152,7 @@ genomes } -# qcInfo is collection-level EXCEPT `entryAudit`, which getQcDiagnostics() +# qcInfo is collection-level EXCEPT `entryAudit`, which qcDiagnostics() # addresses BY element index -- so the audit concatenates in element order # while the rest is carried from the first part. Concatenation pads a part # whose audit is absent or short, because an audit that slipped out of step @@ -1166,19 +1174,19 @@ } .ssCheckQcOptions(populated, fn) list_assign( - getQcInfo(populated[[1L]]), + qcInfo(populated[[1L]]), entryAudit = list_flatten(map(parts, .ssEntryAudit)) ) } # @noRd -.ssHasQcInfo <- function(x) length(getQcInfo(x)) > 0L +.ssHasQcInfo <- function(x) length(qcInfo(x)) > 0L # One part's per-element audit, padded to its element count so positions stay # aligned with the elements they describe. # @noRd .ssEntryAudit <- function(x) { - audit <- getQcInfo(x)$entryAudit %||% list() + audit <- qcInfo(x)$entryAudit %||% list() n <- nrow(x) if (length(audit) >= n) { return(as.list(audit)[seq_len(n)]) @@ -1191,7 +1199,7 @@ # and every downstream consumer reads that answer off one record. # @noRd .ssCheckQcOptions <- function(parts, fn) { - first <- getQcInfo(parts[[1L]])$options + first <- qcInfo(parts[[1L]])$options same <- map_lgl(parts, .ssSameQcOptions, first = first) if (all(same)) { return(invisible(NULL)) @@ -1206,7 +1214,7 @@ # @noRd .ssSameQcOptions <- function(x, first) { - identical(getQcInfo(x)$options, first) + identical(qcInfo(x)$options, first) } # The union of the parts' LD panels. All-NULL stays NULL (an individual-level @@ -1214,7 +1222,7 @@ # panels that exist would leave elements harmonized against nothing. # @noRd .combineLdSketch <- function(parts, fn) { - sketches <- map(parts, getLdSketch) + sketches <- map(parts, ldSketch) present <- !map_lgl(sketches, is.null) if (!any(present)) { return(NULL) @@ -1317,7 +1325,7 @@ # positionally and a tibble column is a one-column list there. # @noRd .ssUnionSnpInfo <- function(handles) { - first <- getSnpInfo(handles[[1L]]) + first <- snpInfo(handles[[1L]]) combined <- list_rbind(map(handles, .ssHandleSnpInfo)) keyed <- all(is_in(c("SNP", "CHR", "BP"), names(combined))) si <- if (nrow(combined) > 0L && keyed) { @@ -1334,4 +1342,4 @@ } # @noRd -.ssHandleSnpInfo <- function(h) as_tibble(getSnpInfo(h)) +.ssHandleSnpInfo <- function(h) as_tibble(snpInfo(h)) diff --git a/R/twasWeights.R b/R/twasWeights.R index 3c86820b..44df146a 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -153,7 +153,7 @@ setClass( #' @description Construct a \code{TwasWeights} DFrame-subclass collection from #' per-tuple vectors and a list of \code{TwasWeightsRow} payloads (one per #' tuple). -#' @param study Character vector of study identifiers. Use the sentinel +#' @param studyName Character vector of study identifiers. Use the sentinel #' \code{"joint"} for rows produced by a cross-study joint fit. #' @param context Character vector of context labels. Use \code{"joint"} for #' rows produced by a cross-context joint fit. @@ -177,15 +177,16 @@ setClass( #' @return A \code{TwasWeights} object. #' @examples #' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), -#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -#' tw <- TwasWeights(study = "s1", context = "brain", trait = "gene1", +#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), +#' weightStandardized = FALSE) +#' tw <- TwasWeights(studyName = "s1", context = "brain", trait = "gene1", #' method = "susie", entry = list(twe)) #' tw #' @importFrom checkmate assertCharacter assert checkList #' @importFrom checkmate checkClass #' @export TwasWeights <- function( - study, + studyName, context, trait, method, @@ -197,7 +198,7 @@ TwasWeights <- function( ldSketch = NULL ) { .twasAssertArgs( - study, + studyName, context, trait, method, @@ -206,11 +207,11 @@ TwasWeights <- function( jointContexts, jointTraits ) - n <- .twasCheckRowLengths(study, context, trait, method, entry) + n <- .twasCheckRowLengths(studyName, context, trait, method, entry) entry <- map(entry, .asTwRowPayload) .checkRowPayloads(entry, "TwasWeightsRow", "TWAS-weight") cols <- .twasMetadataCols( - study, + studyName, context, trait, method, @@ -235,7 +236,7 @@ TwasWeights <- function( # SimpleList is S4 and fails checkList, so that one is an or-combination. # @noRd .twasAssertArgs <- function( - study, + studyName, context, trait, method, @@ -244,7 +245,7 @@ TwasWeights <- function( jointContexts, jointTraits ) { - assertCharacter(study, any.missing = FALSE) + assertCharacter(studyName, any.missing = FALSE) assertCharacter(context, any.missing = FALSE) assertCharacter(trait, any.missing = FALSE) assertCharacter(method, any.missing = FALSE) @@ -262,7 +263,7 @@ TwasWeights <- function( # per-row payload columns, then the optional joint axes and trait position. # @noRd .twasMetadataCols <- function( - study, + studyName, context, trait, method, @@ -275,7 +276,7 @@ TwasWeights <- function( ) { baseCols <- c( list( - study = as.character(study), + study = as.character(studyName), context = as.character(context), trait = as.character(trait), method = as.character(method) @@ -302,7 +303,7 @@ TwasWeights <- function( # @noRd .twPayloadStandardized <- function(p) { - getStandardized(p) + weightStandardized(p) } # Every `entry` must be a TwasWeightsRow. Checked before the payload is @@ -312,8 +313,8 @@ TwasWeights <- function( # Require study/context/trait/method/entry to share one length; returns it. # @noRd -.twasCheckRowLengths <- function(study, context, trait, method, entry) { - n <- length(study) +.twasCheckRowLengths <- function(studyName, context, trait, method, entry) { + n <- length(studyName) if ( length(context) != n || length(trait) != n || @@ -357,49 +358,55 @@ TwasWeights <- function( abort(msg) } -#' @rdname getRegion +#' @rdname genomicRegion #' @export -setMethod("getRegion", "TwasWeights", function(x) .getRegionColumn(x)) +setMethod("genomicRegion", "TwasWeights", function(x) .getRegionColumn(x)) -#' @rdname getTraitPosition +#' @rdname traitPosition #' @export -setMethod("getTraitPosition", "TwasWeights", function(x) { +setMethod("traitPosition", "TwasWeights", function(x) { .getTraitPosColumn(x) }) +# Documented as `twasWeightsEntry`, not as `twasWeights`: man/ pages are +# files, and on a case-insensitive filesystem `twasWeights.Rd` and the +# constructor's `TwasWeights.Rd` are the same file, so whichever document() +# writes second silently destroys the other. Do not "simplify" this @rdname +# back to the generic's own name. #' @title Get a Single TWAS Weights Entry #' @description Return the \code{TwasWeightsRow} for one \code{(study, #' context, trait, method)} row of a \code{TwasWeights} collection. #' @param x A \code{TwasWeights} object. -#' @param study,context,trait,method Single character identifiers. All required -#' when the collection has more than one row; optional when the collection has -#' a single row. +#' @param studyName,context,trait,method Single character identifiers. All +#' required when the collection has more than one row; optional when the +#' collection has a single row. #' @return A \code{TwasWeightsRow} object. #' @examples #' twe <- twasWeightsRow( #' variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), -#' cvResult = list(rsq = 0.5), standardized = FALSE) -#' tw <- TwasWeights(study = "s1", context = "brain", trait = "g1", +#' cvResult = list(rsq = 0.5), weightStandardized = FALSE) +#' tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(twe)) -#' getTwasWeights(tw, study = "s1", context = "brain", trait = "g1", +#' twasWeights(tw, studyName = "s1", context = "brain", trait = "g1", #' method = "susie") +#' @rdname twasWeightsEntry #' @export setGeneric( - "getTwasWeights", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { - standardGeneric("getTwasWeights") + "twasWeights", + function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + standardGeneric("twasWeights") } ) -#' @rdname getTwasWeights +#' @rdname twasWeightsEntry #' @export setMethod( - "getTwasWeights", + "twasWeights", "TwasWeights", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { + function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { idx <- .tupleSelectRow( x, - study, + studyName, context, trait, method, @@ -421,19 +428,19 @@ setMethod( # element, the weights in that element's mcols, and the rest of the payload in # the collection's mcols. A tuple split across chromosomes owns several # elements, so they are stitched back into the single entry callers expect -- -# the same contract getSumStats() keeps. +# the same contract sumStats() keeps. # @noRd # The row payload a (study, context, trait, method) selector pins. # -# Read directly rather than via getTwasWeights(): that accessor returns a +# Read directly rather than via twasWeights(): that accessor returns a # single-row collection, so routing the per-field accessors through it would # dispatch straight back into them. # @noRd -.twrSelectRowParts <- function(x, study, context, trait, method) { +.twrSelectRowParts <- function(x, studyName, context, trait, method) { idx <- .tupleSelectRow( x, - study, + studyName, context, trait, method, @@ -449,75 +456,103 @@ setMethod( "TwasWeights", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL ) { .twrRowResolveWeights( - .twrSelectRowParts(x, study, context, trait, method) + .twrSelectRowParts(x, studyName, context, trait, method) ) } ) -#' @rdname getWeights +# Adopts BiocGenerics' `weights` generic instead of a pecotmr-owned one. Its +# first formal is `object`, not `x`, and the inherited default returned NULL +# for these classes, so overriding it loses nothing. Documented as +# `weights-methods` so no \alias{weights} competes with stats::weights. +#' @title Get TWAS Weights +#' @description Extract weights from a \code{TwasWeightsRow} or from one entry +#' of a \code{TwasWeights} collection. +#' @param object A \code{TwasWeightsRow} or \code{TwasWeights}. +#' @param ... Class-specific selection arguments. +#' @param studyName 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 method Character (length 1) or \code{NULL}. Restrict the selection to +#' this fine-mapping / weight method; \code{NULL} matches all methods. +#' @return A numeric vector or matrix of weights. +#' @examples +#' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), +#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), +#' weightStandardized = FALSE) +#' weights(twe) +#' @importFrom BiocGenerics weights +#' @rdname weights-methods +#' @aliases weights-methods #' @export setMethod( - "getWeights", + "weights", "TwasWeights", function( - x, - study = NULL, + object, + studyName = NULL, context = NULL, trait = NULL, - method = NULL + method = NULL, + ... ) { - getWeights(.twrSelectRowParts(x, study, context, trait, method)) + weights( + .twrSelectRowParts(object, studyName, context, trait, method) + ) } ) -#' @rdname getCvResult +#' @rdname cvResult #' @export setMethod( - "getCvResult", + "cvResult", "TwasWeights", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL ) { - getCvResult(.twrSelectRowParts(x, study, context, trait, method)) + cvResult(.twrSelectRowParts(x, studyName, context, trait, method)) } ) -#' @rdname getFits +#' @rdname methodFits #' @export setMethod( - "getFits", + "methodFits", "TwasWeights", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL ) { - getFits(.twrSelectRowParts(x, study, context, trait, method)) + methodFits(.twrSelectRowParts(x, studyName, context, trait, method)) } ) -#' @rdname getStandardized +#' @rdname weightStandardized #' @export setMethod( - "getStandardized", + "weightStandardized", "TwasWeights", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { + function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { isTRUE( - getStandardized(.twrSelectRowParts( + weightStandardized(.twrSelectRowParts( x, - study, + studyName, context, trait, method @@ -526,55 +561,63 @@ setMethod( } ) -#' @rdname getDataType +#' @rdname weightsDataType #' @export setMethod( - "getDataType", + "weightsDataType", "TwasWeights", - function(x, study = NULL, context = NULL, trait = NULL, method = NULL) { - getDataType(.twrSelectRowParts(x, study, context, trait, method)) + function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + weightsDataType(.twrSelectRowParts( + x, + studyName, + context, + trait, + method + )) } ) -#' @rdname getVariantIds +#' @rdname variantIds #' @export setMethod( - "getVariantIds", + "variantIds", "TwasWeights", function( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL ) { .twrPartsVariantIds( - .twrSelectRowParts(x, study, context, trait, method) + .twrSelectRowParts(x, studyName, context, trait, method) ) } ) -#' @rdname getStudy +#' @rdname studyName #' @export -setMethod("getStudy", "TwasWeights", function(x) unique(as.character(x$study))) +setMethod("studyName", "TwasWeights", function(x) unique(as.character(x$study))) -#' @rdname getLdSketch +#' @rdname ldSketch #' @export -setMethod("getLdSketch", "TwasWeights", function(x) x@ldSketch) +setMethod("ldSketch", "TwasWeights", function(x) x@ldSketch) -#' @rdname getContexts +#' @rdname contexts #' @export -setMethod("getContexts", "TwasWeights", function(x) { +setMethod("contexts", "TwasWeights", function(x) { unique(as.character(x$context)) }) -#' @rdname getTraits +#' @rdname traitNames #' @export -setMethod("getTraits", "TwasWeights", function(x) unique(as.character(x$trait))) +setMethod("traitNames", "TwasWeights", function(x) { + unique(as.character(x$trait)) +}) -#' @rdname getMethodNames +#' @rdname methodNames #' @export -setMethod("getMethodNames", "TwasWeights", function(x) { +setMethod("methodNames", "TwasWeights", function(x) { unique(as.character(x$method)) }) @@ -2175,10 +2218,10 @@ twasWeightsCv <- function( twasWeightsRow( variantIds = variantIds, weights = weights, - fits = fits, + methodFits = fits, cvResult = NULL, - standardized = ctx$standardized, - dataType = ctx$dataType + weightStandardized = ctx$standardized, + weightsDataType = ctx$dataType ) } @@ -2258,16 +2301,16 @@ twasWeightsCv <- function( #' @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 study Character. Study identity label recorded on the resulting +#' @param studyName Character. Study identity label recorded on the resulting #' weights. #' @param context Character. Context identity label recorded on the resulting #' weights. #' @param trait Character. Trait identity label recorded on the resulting #' weights. -#' @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 -#' weights (e.g. \code{"individual"}). +#' @param weightStandardized Logical. Whether the supplied \code{X} / \code{Y} +#' are already standardized. Default \code{FALSE}. +#' @param weightsDataType Character or \code{NULL}. Data-type label recorded on +#' the weights (e.g. \code{"individual"}). #' @param ldSketch A genotype panel (see \code{\link{readGenotypes}}) to #' record on the weights as their LD sketch, or \code{NULL}. #' @param seed Integer or \code{NULL}. When supplied, seeds the main-process @@ -2299,25 +2342,25 @@ learnTwasWeights <- function( X, Y, weightMethods, - study = "", + studyName = "", context = "", trait = "", numThreads = 1, fittedModels = NULL, fitRetention = c("none", "slim", "full"), - standardized = FALSE, - dataType = NULL, + weightStandardized = FALSE, + weightsDataType = NULL, ldSketch = NULL, verbose = 1, seed = NULL ) { - assertString(study) + assertString(studyName) assertString(context) assertString(trait) assertInt(numThreads) fitRetention <- arg_match(fitRetention) - assertFlag(standardized) - assertString(dataType, null.ok = TRUE) + assertFlag(weightStandardized) + assertString(weightsDataType, null.ok = TRUE) assertCount(verbose) assertInt(seed, null.ok = TRUE) # weightMethods is documented as a named list OR a character vector. @@ -2330,14 +2373,14 @@ learnTwasWeights <- function( X = X, Y = Y, weightMethods = weightMethods, - study = study, + studyName = studyName, context = context, trait = trait, numThreads = numThreads, fittedModels = fittedModels, fitRetention = fitRetention, - standardized = standardized, - dataType = dataType, + weightStandardized = weightStandardized, + weightsDataType = weightsDataType, ldSketch = ldSketch, verbose = verbose, seed = seed @@ -2444,14 +2487,14 @@ learnTwasWeights <- function( X, Y, weightMethods, - study, + studyName, context, trait, numThreads, fittedModels, fitRetention, - standardized, - dataType, + weightStandardized, + weightsDataType, ldSketch, verbose, seed @@ -2470,12 +2513,12 @@ learnTwasWeights <- function( Y = Y, Xfiltered = Xfiltered, validColumns = validColumns, - study = study, + study = studyName, context = context, trait = trait, fitRetention = fitRetention, - standardized = standardized, - dataType = dataType, + standardized = weightStandardized, + dataType = weightsDataType, verbose = verbose, rngSeed = seed ) @@ -2496,7 +2539,7 @@ learnTwasWeights <- function( # @noRd .twasLearnResult <- function(rows, ldSketch) { TwasWeights( - study = rows$study, + studyName = rows$study, context = rows$context, trait = rows$trait, method = rows$method, @@ -2541,8 +2584,9 @@ learnTwasWeights <- function( #' X <- multiTraitData$X[, 1:4] #' colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:4)) #' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), -#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -#' tw <- TwasWeights(study = "s1", context = "brain", trait = "g1", +#' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), +#' weightStandardized = FALSE) +#' tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(twe)) #' twasPredict(X, tw) #' @importFrom checkmate assert checkList checkClass @@ -2610,7 +2654,7 @@ estimateSparsity <- function(weightResults) { ) abort(msg) } - fit <- getFits(.twrRowParts(weightResults, idx[[1L]])) + fit <- methodFits(.twrRowParts(weightResults, idx[[1L]])) if (is.null(fit) || is.null(fit$pi)) { msg <- glue( "mr.ash fit object not found. Run learnTwasWeights() with ", diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index 8083d2d2..80a87bab 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -58,10 +58,10 @@ #' @examples #' twe <- twasWeightsRow( #' variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), -#' cvResult = list(rsq = 0.5), standardized = FALSE) -#' tw1 <- TwasWeights(study = "s1", context = "brain", trait = "g1", +#' cvResult = list(rsq = 0.5), weightStandardized = FALSE) +#' tw1 <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(twe)) -#' tw2 <- TwasWeights(study = "s2", context = "brain", trait = "g1", +#' tw2 <- TwasWeights(studyName = "s2", context = "brain", trait = "g1", #' method = "susie", entry = list(twe)) #' combineTwasWeights(tw1, tw2) #' @importFrom stringr str_starts @@ -126,19 +126,19 @@ combineTwasWeights <- function(..., ldSketch = NULL) { return(fitted[[1L]]) } payloads <- map(fitted, .asTwRowPayload) - wList <- map(payloads, getWeights) - weights <- if (is.matrix(wList[[1L]])) { + wList <- map(payloads, weights) + stacked <- if (is.matrix(wList[[1L]])) { exec(rbind, !!!wList) } else { unname(list_c(wList)) } twasWeightsRow( variantIds = unname(list_c(map(payloads, .twrPartsVariantIds))), - weights = weights, - fits = set_names(map(payloads, getFits), fittedLabels), + weights = stacked, + methodFits = set_names(map(payloads, methodFits), fittedLabels), cvResult = .twasRegionCvDf(payloads, fittedLabels), - standardized = getStandardized(payloads[[1L]]), - dataType = getDataType(payloads[[1L]]) + weightStandardized = weightStandardized(payloads[[1L]]), + weightsDataType = weightsDataType(payloads[[1L]]) ) } @@ -159,11 +159,11 @@ combineTwasWeights <- function(..., ldSketch = NULL) { )) } assertClass(mashPrior, "MashPrior") - cvFits <- getCvFits(mashPrior) + cvFits <- cvFits(mashPrior) perFold <- if (!is.null(cvFits)) cvFits$perFoldFits else NULL sp <- samplePartition %||% cvFits$samplePartition list( - fullPrior = getFullFit(mashPrior), + fullPrior = fullFit(mashPrior), dataDrivenPriorMatricesCv = perFold, samplePartition = sp ) @@ -672,7 +672,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # Whether row `i` of a FineMappingResult carries a cross-validation result. # @noRd .fmrRowHasCv <- function(i, fineMappingResult) { - !is.null(getCvResult(.fmrRowParts(fineMappingResult, i))) + !is.null(cvResult(.fmrRowParts(fineMappingResult, i))) } # Whether a FineMappingResult carries any cross-validation result at all. @@ -810,7 +810,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { if (length(mv) == 0L) { return(invisible(NULL)) } - components <- getQtlDatasets(data) + components <- qtlDatasets(data) if (length(components) == 0L) { return(invisible(NULL)) } @@ -835,10 +835,10 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # @noRd .twasComponentIsUnivariate <- function(key, components) { d <- components[[key]] - nTraits <- length(tryCatch(getTraits(d), error = function(cnd) { + nTraits <- length(tryCatch(traitNames(d), error = function(cnd) { character(0) })) - nCtx <- length(tryCatch(getContexts(d), error = function(cnd) character(0))) + nCtx <- length(tryCatch(contexts(d), error = function(cnd) character(0))) nTraits < 2L && nCtx < 2L } @@ -861,7 +861,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # Reject SumStats inputs that have not been QC'd via summaryStatsQc. # @noRd .twasAssertQcd <- function(sumstats) { - if (length(getQcInfo(sumstats)) == 0L) { + if (length(qcInfo(sumstats)) == 0L) { cls <- class(sumstats)[[1L]] msg <- glue( "twasWeightsPipeline: the supplied {cls} has no QC record ", @@ -878,7 +878,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # silently when twasWeights is NULL or not a TwasWeights collection. # Mirrors .fmCacheLookup (R/fineMappingPipeline.R). # @noRd -.twasCacheLookup <- function(twasWeights, study, context, trait, method) { +.twasCacheLookup <- function(twasWeights, studyName, context, trait, method) { if (is.null(twasWeights)) { return(NULL) } @@ -887,7 +887,12 @@ combineTwasWeights <- function(..., ldSketch = NULL) { } idx <- .matchTupleRows( twasWeights, - list(study = study, context = context, trait = trait, method = method) + list( + study = studyName, + context = context, + trait = trait, + method = method + ) ) if (length(idx) == 0L) { return(NULL) @@ -901,7 +906,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # entry. Returns a (possibly empty) list. # @noRd #' @importFrom checkmate assertClass -.twasFineMappingFits <- function(fineMappingResult, study, context, trait) { +.twasFineMappingFits <- function(fineMappingResult, studyName, context, trait) { if (is.null(fineMappingResult)) { return(list()) } @@ -912,7 +917,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { tokens, .twasFitForToken, fineMappingResult = fineMappingResult, - study = study, + study = studyName, context = context, trait = trait ), @@ -929,7 +934,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { .twasFitForToken <- function( canonical, fineMappingResult, - study, + studyName, context, trait ) { @@ -938,14 +943,14 @@ combineTwasWeights <- function(..., ldSketch = NULL) { str_to_lower(as.character(fineMappingResult$method)), .twasSpellingCandidates(canonical) ) & - as.character(fineMappingResult$study) == study & + as.character(fineMappingResult$study) == studyName & as.character(fineMappingResult$context) == context & as.character(fineMappingResult$trait) == trait ) if (length(idx) == 0L) { return(NULL) } - getSusieFit(.fmrRowParts(fineMappingResult, idx[[1L]])) + susieFit(.fmrRowParts(fineMappingResult, idx[[1L]])) } # Locate a fine-mapping fit for one (study, context, trait, token) tuple. @@ -955,7 +960,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # @noRd .twasFineMappingFitFor <- function( fineMappingResult, - study, + studyName, context, trait, token @@ -965,7 +970,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { } fits <- .twasFineMappingFits( fineMappingResult, - study = study, + studyName = studyName, context = context, trait = trait ) @@ -997,7 +1002,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # carries a partition stands for the row. # @noRd .twasRowCvResult <- function(i, fineMappingResult) { - cv <- getCvResult(.fmrRowParts(fineMappingResult, i)) + cv <- cvResult(.fmrRowParts(fineMappingResult, i)) if (is.null(cv)) { return(NULL) } @@ -1011,7 +1016,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { hit[[1L]] } -.twasCvResultFor <- function(fineMappingResult, study, context, trait) { +.twasCvResultFor <- function(fineMappingResult, studyName, context, trait) { if (is.null(fineMappingResult)) { return(NULL) } @@ -1019,7 +1024,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { return(NULL) } idx <- which( - as.character(fineMappingResult$study) == study & + as.character(fineMappingResult$study) == studyName & as.character(fineMappingResult$context) == context & as.character(fineMappingResult$trait) == trait ) @@ -1125,15 +1130,15 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' \code{summaryStatsQc(imputeArgs = ...)}, which only bounds which variants #' RAISS will impute. #' -#' @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 +#' @param genotypeFilterParam 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 panelFilterArgs For QtlSumStats: LD-reference-panel filters, +#' @param panelFilterParam For QtlSumStats: LD-reference-panel filters, #' built with #' \code{\link{PanelFilterParam}}. See \emph{Panel filters on the RSS path} #' above. @@ -1217,8 +1222,8 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' before BGLR / qgg spike-and-slab methods that consume it. #' @param residualizationArgs Covariate residualization settings, built with #' \code{\link{ResidualizationParam}} and forwarded to -#' \code{\link{getResidualizedPhenotypes}} / -#' \code{\link{getResidualizedGenotypes}}: \code{phenotypeCovariates} and +#' \code{\link{residualizedPhenotypes}} / +#' \code{\link{residualizedGenotypes}}: \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 @@ -1231,7 +1236,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' 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 +#' @param weightsDataType 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 #' messages). @@ -1373,7 +1378,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { )) } .twasQdsUnivariateEngine( - study = grid$study, + studyName = grid$study, useCtx = grid$useCtx, allTraits = grid$allTraits, marker = marker, @@ -1419,7 +1424,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { traitId = NULL, region = NULL, cisWindow = NULL, - genotypeFilterArgs = GenotypeFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), jointRegions = FALSE, jointSpecification = NULL, fineMappingResult = NULL, @@ -1433,7 +1438,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { nPCs = 10L, fitRetention = c("slim", "none", "full"), residualizationArgs = ResidualizationParam(), - dataType = NULL, + weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, seed = NULL @@ -1454,7 +1459,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { region = region, cisWindow = cisWindow, jointRegions = jointRegions, - genotypeFilterArgs = genotypeFilterArgs + genotypeFilterParam = genotypeFilterParam ) data <- resolved$data xRegions <- resolved$xRegions @@ -1465,7 +1470,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { contexts = contexts, traitId = traitId, cisWindow = cisWindow, - dataType = dataType, + dataType = weightsDataType, verbose = verbose, xRegions = xRegions, fitRetention = fitRetention, @@ -1499,7 +1504,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { ), ensembleArgs = .ensembleResolve(ensembleArgs), fitFullData = fitFullData, - dataType = dataType, + weightsDataType = weightsDataType, fitRetention = fitRetention, estimatePi = estimatePi, verbose = verbose, @@ -1622,11 +1627,11 @@ setMethod( region, cisWindow, jointRegions, - genotypeFilterArgs + genotypeFilterParam ) { .twasQdsCheckRegionCisWindow(region, cisWindow) list( - data = .qtlApplyFilterOverrides(data, genotypeFilterArgs), + data = .qtlApplyFilterOverrides(data, genotypeFilterParam), xRegions = .makeXRegions(region, jointRegions) ) } @@ -1736,12 +1741,12 @@ setMethod( region, tokens ) { - study <- getStudy(data) + studyName <- studyName(data) useCtx <- .twasQdsResolveContexts(data, contexts) allTraits <- .twasQdsResolveTraits(data, useCtx, traitId, region) .twasCheckMultivariateY(tokens, length(allTraits), length(useCtx)) list( - study = study, + study = studyName, useCtx = useCtx, allTraits = allTraits, multivariate = any(map_lgl(tokens, .twasIsMultivariateToken)) @@ -1751,7 +1756,7 @@ setMethod( # Selected contexts (all when NULL; else validated against the dataset). # @noRd .twasQdsResolveContexts <- function(data, contexts) { - allCtx <- getContexts(data) + allCtx <- contexts(data) if (is.null(contexts)) { return(allCtx) } @@ -1790,7 +1795,7 @@ setMethod( crossValidationArgs, ensembleArgs, fitFullData, - dataType, + weightsDataType, fitRetention, estimatePi, verbose, @@ -1805,7 +1810,7 @@ setMethod( crossValidationArgs = crossValidationArgs, ensembleArgs = ensembleArgs, fitFullData = fitFullData, - dataType = dataType, + dataType = weightsDataType, fitRetention = fitRetention, standardized = FALSE, estimatePi = estimatePi, @@ -1820,7 +1825,7 @@ setMethod( # adds top-PC rows ALONGSIDE the per-trait ones, matching # fineMappingPipeline's c(univRows, pcaRows). # @noRd -.twasQdsUnivPlan <- function(usePCA, study, useCtx, allTraits) { +.twasQdsUnivPlan <- function(usePCA, studyName, useCtx, allTraits) { univCell <- .lookupJointCell("univariate", "individual") list( cells = if (isTRUE(usePCA)) { @@ -1829,9 +1834,9 @@ setMethod( list(univCell) }, scope = list( - studies = study, - contexts = set_names(list(useCtx), study), - traits = set_names(list(allTraits), study) + studies = studyName, + contexts = set_names(list(useCtx), studyName), + traits = set_names(list(allTraits), studyName) ) ) } @@ -1841,7 +1846,7 @@ setMethod( # for >= 2 methods + resume cache) as the joint paths, merged across regions. # @noRd .twasQdsUnivariateEngine <- function( - study, + studyName, useCtx, allTraits, marker, @@ -1858,7 +1863,7 @@ setMethod( nPCs, verbose ) { - plan <- .twasQdsUnivPlan(usePCA, study, useCtx, allTraits) + plan <- .twasQdsUnivPlan(usePCA, studyName, useCtx, allTraits) cells <- plan$cells scope <- plan$scope labs <- map_chr(xRegions, .twasRegionLabel) @@ -1960,9 +1965,9 @@ setMethod( fineMappingResult = NULL, twasWeights = NULL, fitRetention = c("slim", "none", "full"), - dataType = NULL, + weightsDataType = NULL, verbose = 1L, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam() ) { fitRetention <- arg_match(fitRetention) @@ -1981,9 +1986,9 @@ setMethod( fineMappingResult = fineMappingResult, twasWeights = twasWeights, fitRetention = fitRetention, - dataType = dataType, + weightsDataType = weightsDataType, verbose = verbose, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam ) } ) @@ -2012,9 +2017,9 @@ setMethod( univariateTokens = part$univariateTokens, data = cfg$data, twasWeights = cfg$twasWeights, - dataType = cfg$dataType, + weightsDataType = cfg$dataType, fineMappingResult = cfg$fineMappingResult, - panelFilterArgs = cfg$panelFilterArgs + panelFilterParam = cfg$panelFilterParam ), # `twasWeights` is the resume cache. The univariate builder looks # up one (study, context, trait, method) row; the multivariate one @@ -2026,10 +2031,10 @@ setMethod( multivariateTokens = part$multivariateTokens, twasWeights = cfg$twasWeights, data = cfg$data, - dataType = cfg$dataType, + weightsDataType = cfg$dataType, fitRetention = cfg$fitRetention, fineMappingResult = cfg$fineMappingResult, - panelFilterArgs = cfg$panelFilterArgs + panelFilterParam = cfg$panelFilterParam ) ) } @@ -2043,9 +2048,9 @@ setMethod( fineMappingResult, twasWeights, fitRetention, - dataType, + weightsDataType, verbose, - panelFilterArgs + panelFilterParam ) { # summaryStatsQc() is mandatory before twasWeightsPipeline for SumStats # input; it also drops variants not present in the ldSketch, so every @@ -2057,10 +2062,10 @@ setMethod( data = data, contexts = contexts, traitId = traitId, - dataType = dataType, + dataType = weightsDataType, verbose = verbose, fitRetention = fitRetention, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam ) joint <- .twasQssResolveTokens( jointSpecification, @@ -2077,10 +2082,10 @@ setMethod( contexts = contexts, traitId = traitId, twasWeights = twasWeights, - dataType = dataType, + weightsDataType = weightsDataType, fineMappingResult = fineMappingResult, fitRetention = fitRetention, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam ) } @@ -2094,10 +2099,10 @@ setMethod( contexts, traitId, twasWeights, - dataType, + weightsDataType, fineMappingResult, fitRetention, - panelFilterArgs + panelFilterParam ) { part <- .twasQssSelectAndPartition( data, @@ -2111,10 +2116,10 @@ setMethod( list( data = data, twasWeights = twasWeights, - dataType = dataType, + dataType = weightsDataType, fineMappingResult = fineMappingResult, fitRetention = fitRetention, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam ) ) .twasQssAssemble(rows, joint$result, part$ldSketch) @@ -2179,7 +2184,7 @@ setMethod( cfg$dataType, cfg$verbose, fitRetention = cfg$fitRetention, - panelFilterArgs = cfg$panelFilterArgs %||% PanelFilterParam() + panelFilterParam = cfg$panelFilterParam %||% PanelFilterParam() ) } @@ -2265,7 +2270,7 @@ setMethod( selRows = selRows, multivariateTokens = multivariateTokens, univariateTokens = univariateTokens, - ldSketch = getLdSketch(data) + ldSketch = ldSketch(data) ) } @@ -2332,9 +2337,9 @@ setMethod( # A single TwasWeights row: (study, context, trait, method) + its entry. # @noRd -.twasRowRecord <- function(study, context, trait, method, entry) { +.twasRowRecord <- function(studyName, context, trait, method, entry) { list( - study = study, + study = studyName, context = context, trait = trait, method = method, @@ -2349,7 +2354,7 @@ setMethod( return(NULL) } TwasWeights( - study = map_chr(rows, "study"), + studyName = map_chr(rows, "study"), context = map_chr(rows, "context"), trait = map_chr(rows, "trait"), method = map_chr(rows, "method"), @@ -2425,10 +2430,10 @@ setMethod( data, ldSketch, twasWeights, - dataType, + weightsDataType, fineMappingResult, methodArgs, - panelFilterArgs + panelFilterParam ) { if (length(univariateTokens) == 0L) { return(list()) @@ -2443,10 +2448,10 @@ setMethod( data = data, ldSketch = ldSketch, twasWeights = twasWeights, - dataType = dataType, + weightsDataType = weightsDataType, fineMappingResult = fineMappingResult, methodArgs = methodArgs, - panelFilterArgs = panelFilterArgs + panelFilterParam = panelFilterParam )) } @@ -2485,10 +2490,10 @@ setMethod( data, ldSketch, twasWeights, - dataType, + weightsDataType, fineMappingResult, methodArgs, - panelFilterArgs + panelFilterParam ) { st <- studyCol[i] ctx <- contextCol[i] @@ -2505,7 +2510,7 @@ setMethod( ctx, tr, ldSketch, - cutoffs = .panelCutoffs(panelFilterArgs) + cutoffs = .panelCutoffs(panelFilterParam) ) fitted <- compact(map( toFit, @@ -2516,7 +2521,7 @@ setMethod( fitCtx = fitCtx, methodArgs = methodArgs, fineMappingResult = fineMappingResult, - dataType = dataType + weightsDataType = weightsDataType )) c(unname(cachedRows), fitted) } @@ -2584,9 +2589,9 @@ setMethod( ldSketch, cutoffs = NULL ) { - allDf <- getSumStatsDf( + allDf <- as.data.frame( data, - study = st, + studyName = st, context = ctx, trait = tr, require = c("Z", "N"), @@ -2605,7 +2610,7 @@ setMethod( drop = FALSE ] variantIds <- df$variant_id - varY <- getVarY(data, study = st, context = ctx, trait = tr) %||% 1 + varY <- varY(data, studyName = st, context = ctx, trait = tr) %||% 1 stat <- list( z = df$z, n = stats::median(df$N, na.rm = TRUE), @@ -2644,7 +2649,7 @@ setMethod( } fit <- .twasFineMappingFitFor( fineMappingResult, - study = st, + studyName = st, context = ctx, trait = tr, token = tk @@ -2664,7 +2669,7 @@ setMethod( fitCtx, methodArgs, fineMappingResult, - dataType + weightsDataType ) { spec <- .twasResolveWeightFn(tk) userArgs <- .twasQssUnivariateArgs( @@ -2691,13 +2696,21 @@ setMethod( if (is.null(weights)) { return(NULL) } - .twasQssRowFromWeights(weights, st, ctx, tr, tk, fitCtx, dataType) + .twasQssRowFromWeights(weights, st, ctx, tr, tk, fitCtx, weightsDataType) } # 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) { +.twasQssRowFromWeights <- function( + weights, + st, + ctx, + tr, + tk, + fitCtx, + weightsDataType +) { .twasRowRecord( st, ctx, @@ -2706,10 +2719,10 @@ setMethod( twasWeightsRow( variantIds = fitCtx$variantIds, weights = as.numeric(`attr<-`(weights, "fit", NULL)), - fits = attr(weights, "fit"), + methodFits = attr(weights, "fit"), cvResult = NULL, - standardized = TRUE, - dataType = dataType + weightStandardized = TRUE, + weightsDataType = weightsDataType ) ) } @@ -2747,8 +2760,8 @@ setMethod( methodArgs, fitRetention, fineMappingResult, - dataType, - panelFilterArgs, + weightsDataType, + panelFilterParam, twasWeights = NULL ) { if (length(multivariateTokens) == 0L) { @@ -2773,8 +2786,8 @@ setMethod( methodArgs = methodArgs, fitRetention = fitRetention, fineMappingResult = fineMappingResult, - dataType = dataType, - panelFilterArgs = panelFilterArgs + weightsDataType = weightsDataType, + panelFilterParam = panelFilterParam )) } @@ -2791,8 +2804,8 @@ setMethod( methodArgs, fitRetention, fineMappingResult, - dataType, - panelFilterArgs, + weightsDataType, + panelFilterParam, twasWeights = NULL ) { if (length(gIdx) < 2L) { @@ -2807,7 +2820,7 @@ setMethod( tr, ctxNames, ldSketch = ldSketch, - cutoffs = .panelCutoffs(panelFilterArgs) + cutoffs = .panelCutoffs(panelFilterParam) ) ldMat <- .ldFromSketch( ldSketch, @@ -2826,7 +2839,7 @@ setMethod( methodArgs = methodArgs, fitRetention = fitRetention, fineMappingResult = fineMappingResult, - dataType = dataType + weightsDataType = weightsDataType )) } @@ -2842,9 +2855,9 @@ setMethod( ldSketch = NULL, cutoffs = NULL ) { - allDf <- getSumStatsDf( + allDf <- as.data.frame( data, - study = st, + studyName = st, context = ctxNames[[1L]], trait = tr, require = c("Z", "N"), @@ -2879,9 +2892,9 @@ setMethod( # One context's z column and median N, checked against the shared SNP order. # @noRd .twasQssContextStats <- function(ctx, data, st, tr, variantIds) { - d <- getSumStatsDf( + d <- as.data.frame( data, - study = st, + studyName = st, context = ctx, trait = tr, require = c("Z", "N"), @@ -2975,7 +2988,7 @@ setMethod( methodArgs, fitRetention, fineMappingResult, - dataType, + weightsDataType, twasWeights = NULL ) { cached <- .twasMvCacheHits(twasWeights, st, tr, ctxNames, tk) @@ -3012,7 +3025,16 @@ setMethod( 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) + .twasMvContextRows( + bare, + fitAttr, + ctxNames, + mvStat, + st, + tr, + tk, + weightsDataType + ) } # Thread the precomputed fine-mapping fit into a multivariate method's args; @@ -3029,7 +3051,7 @@ setMethod( ) { fit <- .twasFineMappingFitFor( fineMappingResult, - study = st, + studyName = st, context = ctxNames[[1L]], trait = tr, token = tk @@ -3073,7 +3095,7 @@ setMethod( st, tr, tk, - dataType + weightsDataType ) { map( seq_along(ctxNames), @@ -3085,7 +3107,7 @@ setMethod( st = st, tr = tr, tk = tk, - dataType = dataType + weightsDataType = weightsDataType ) } @@ -3153,11 +3175,11 @@ setMethod( crossValidationArgs = cfg$crossValidationArgs, ensembleArgs = cfg$ensembleArgs, seed = cfg$seed, - genotypeFilterArgs = cfg$genotypeFilterArgs, + genotypeFilterParam = cfg$genotypeFilterParam, mashPrior = cfg$mashPrior, fitFullData = cfg$fitFullData, estimatePi = cfg$estimatePi, - dataType = cfg$dataType, + weightsDataType = cfg$dataType, residualizationArgs = cfg$residualizationArgs ) } @@ -3179,8 +3201,8 @@ setMethod( fineMappingResult = cfg$fineMappingResult, twasWeights = cfg$twasWeights, verbose = cfg$verbose, - panelFilterArgs = cfg$panelFilterArgs, - dataType = cfg$dataType + panelFilterParam = cfg$panelFilterParam, + weightsDataType = cfg$dataType ) } @@ -3316,8 +3338,8 @@ setMethod( traitId = NULL, region = NULL, cisWindow = NULL, - genotypeFilterArgs = GenotypeFilterParam(), - panelFilterArgs = PanelFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), + panelFilterParam = PanelFilterParam(), jointRegions = FALSE, jointSpecification = NULL, fineMappingResult = NULL, @@ -3326,7 +3348,7 @@ setMethod( fitFullData = TRUE, estimatePi = TRUE, fitRetention = c("slim", "none", "full"), - dataType = NULL, + weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, residualizationArgs = ResidualizationParam(), @@ -3373,13 +3395,13 @@ setMethod( crossValidationArgs = crossValidationArgs, ensembleArgs = ensembleArgs, seed = seed, - genotypeFilterArgs = genotypeFilterArgs, - panelFilterArgs = panelFilterArgs, + genotypeFilterParam = genotypeFilterParam, + panelFilterParam = panelFilterParam, mashPrior = mashPrior, fitFullData = fitFullData, estimatePi = estimatePi, fitRetention = fitRetention, - dataType = dataType, + weightsDataType = weightsDataType, residualizationArgs = residualizationArgs, joint$result, joint$methods @@ -3471,7 +3493,7 @@ setMethod( methods, "TwasWeightsMethodsParam", "twasWeightsPipeline", - !is.null(getSumStats(cfg$data)) + !is.null(sumStats(cfg$data)) ) .twasCheckFineMappingMethods( .twasMethodTokensFromArg(methods), @@ -3497,13 +3519,13 @@ setMethod( crossValidationArgs, ensembleArgs, seed, - genotypeFilterArgs, - panelFilterArgs, + genotypeFilterParam, + panelFilterParam, mashPrior, fitFullData, estimatePi, fitRetention, - dataType, + weightsDataType, residualizationArgs, jointResult, methods @@ -3522,13 +3544,13 @@ setMethod( crossValidationArgs = crossValidationArgs, ensembleArgs = ensembleArgs, seed = seed, - genotypeFilterArgs = genotypeFilterArgs, - panelFilterArgs = panelFilterArgs, + genotypeFilterParam = genotypeFilterParam, + panelFilterParam = panelFilterParam, mashPrior = mashPrior, fitFullData = fitFullData, estimatePi = estimatePi, fitRetention = fitRetention, - dataType = dataType, + dataType = weightsDataType, residualizationArgs = residualizationArgs ) .multiStudyPipelineDriver( @@ -4419,7 +4441,7 @@ ensembleWeights <- function( # every trait in the context. # @noRd .twasQdsCtxTraits <- function(ctx, data, traitId, region) { - se <- getPhenotypes(data, contexts = ctx) + se <- molecularTraits(data, contexts = ctx) ids <- rownames(se) if (!is.null(traitId)) { intersect(ids, traitId) @@ -4532,7 +4554,7 @@ ensembleWeights <- function( st, tr, tk, - dataType + weightsDataType ) { .twasRowRecord( st, @@ -4542,10 +4564,10 @@ ensembleWeights <- function( twasWeightsRow( variantIds = mvStat$variantIds, weights = as.numeric(weights[, kk]), - fits = if (kk == 1L) fitAttr else NULL, + methodFits = if (kk == 1L) fitAttr else NULL, cvResult = NULL, - standardized = TRUE, - dataType = dataType + weightStandardized = TRUE, + weightsDataType = weightsDataType ) ) } @@ -4606,7 +4628,7 @@ setClass("TwasWeightsMethodsParam", contains = "MethodsSelectionParam") #' TwasWeightsMethodsParam(methods = list(lasso = list(), susie = list())) #' TwasWeightsMethodsParam( #' methods = list(susie = list()), -#' qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), +#' qtlDatasetMethods = list(lasso = GlmnetOptions(nfold = 5)), #' qtlSumStatsMethods = list(lasso = LassosumOptions()) #' ) #' @export diff --git a/R/twasWeightsRow.R b/R/twasWeightsRow.R index eda27841..0c01ede2 100644 --- a/R/twasWeightsRow.R +++ b/R/twasWeightsRow.R @@ -15,10 +15,10 @@ NULL #' \code{\link{TwasWeights}}' \code{entry} argument. #' @slot variants A \code{GRanges} of the weighted variants. #' @slot weights Per-variant weights, aligned to \code{variants}. -#' @slot fits Per-method fit payload, or \code{NULL}. +#' @slot methodFits Per-method fit payload, or \code{NULL}. #' @slot cvResult Cross-validation payload, or \code{NULL}. -#' @slot standardized Whether the weights are on the standardized scale. -#' @slot dataType Optional data-type label. +#' @slot weightStandardized Whether the weights are on the standardized scale. +#' @slot weightsDataType Optional data-type label. #' @seealso \code{\link{twasWeightsRow}}, #' \code{\linkS4class{FineMappingRow}} #' @export @@ -27,17 +27,17 @@ setClass( representation( variants = "GRanges", weights = "ANY", - fits = "ANY", + methodFits = "ANY", cvResult = "ANY", - standardized = "logical", - dataType = "ANY" + weightStandardized = "logical", + weightsDataType = "ANY" ), prototype( weights = NULL, - fits = NULL, + methodFits = NULL, cvResult = NULL, - standardized = FALSE, - dataType = NULL + weightStandardized = FALSE, + weightsDataType = NULL ) ) @@ -58,7 +58,11 @@ methods::setValidity("TwasWeightsRow", function(object) { add = coll ) } - assertFlag(object@standardized, .var.name = "standardized", add = coll) + assertFlag( + object@weightStandardized, + .var.name = "weightStandardized", + add = coll + ) coll$getMessages() }) @@ -70,11 +74,11 @@ methods::setValidity("TwasWeightsRow", function(object) { #' coordinates (\code{chrom:pos:ref:alt}). #' @param weights Per-variant weights, aligned to \code{variantIds} (a vector, #' or a matrix with one column per condition). -#' @param fits Optional per-method fit payload. +#' @param methodFits Optional per-method fit payload. #' @param cvResult Optional cross-validation payload. -#' @param standardized Whether the weights are already on the standardized +#' @param weightStandardized Whether the weights are already on the standardized #' scale. -#' @param dataType Optional data-type label. +#' @param weightsDataType Optional data-type label. #' @return A \code{\linkS4class{TwasWeightsRow}}. #' @seealso \code{\link{fineMappingRow}} #' @examples @@ -83,17 +87,17 @@ methods::setValidity("TwasWeightsRow", function(object) { #' weights = c(0.4, -0.2) #' ) #' TwasWeights( -#' study = "s1", context = "brain", trait = "g1", method = "lasso", +#' studyName = "s1", context = "brain", trait = "g1", method = "lasso", #' entry = list(row) #' ) #' @export twasWeightsRow <- function( variantIds, weights, - fits = NULL, + methodFits = NULL, cvResult = NULL, - standardized = FALSE, - dataType = NULL + weightStandardized = FALSE, + weightsDataType = NULL ) { vids <- as.character(variantIds) gr <- .variantIdsToGRanges(vids, "variantIds") @@ -120,10 +124,10 @@ twasWeightsRow <- function( "TwasWeightsRow", variants = withWeight, weights = w, - fits = fits, + methodFits = methodFits, cvResult = cvResult, - standardized = isTRUE(standardized), - dataType = dataType + weightStandardized = isTRUE(weightStandardized), + weightsDataType = weightsDataType ) validObject(obj) obj @@ -132,43 +136,43 @@ twasWeightsRow <- function( # ---- field accessors -------------------------------------------------------- -#' @rdname getVariantIds +#' @rdname variantIds #' @export -setMethod("getVariantIds", "TwasWeightsRow", function(x) { +setMethod("variantIds", "TwasWeightsRow", function(x) { .grVariantIds(x@variants) }) -#' @rdname getWeights +#' @rdname weights-methods #' @export -setMethod("getWeights", "TwasWeightsRow", function(x) x@weights) +setMethod("weights", "TwasWeightsRow", function(object, ...) object@weights) -#' @rdname getFits +#' @rdname methodFits #' @export -setMethod("getFits", "TwasWeightsRow", function(x) x@fits) +setMethod("methodFits", "TwasWeightsRow", function(x) x@methodFits) -#' @rdname getCvResult +#' @rdname cvResult #' @export -setMethod("getCvResult", "TwasWeightsRow", function(x) x@cvResult) +setMethod("cvResult", "TwasWeightsRow", function(x) x@cvResult) -#' @rdname getStandardized +#' @rdname weightStandardized #' @export -setMethod("getStandardized", "TwasWeightsRow", function(x) { - isTRUE(x@standardized) +setMethod("weightStandardized", "TwasWeightsRow", function(x) { + isTRUE(x@weightStandardized) }) -#' @rdname getDataType +#' @rdname weightsDataType #' @export -setMethod("getDataType", "TwasWeightsRow", function(x) x@dataType) +setMethod("weightsDataType", "TwasWeightsRow", function(x) x@weightsDataType) # @noRd -setMethod("rowVariants", "TwasWeightsRow", function(x) x@variants) +setMethod("variants", "TwasWeightsRow", function(x) x@variants) #' @rdname show-methods #' @export setMethod("show", "TwasWeightsRow", function(object) { cat(glue( "TwasWeightsRow: {length(object@variants)} variants, ", - "standardized={object@standardized}\n", + "standardized={object@weightStandardized}\n", .trim = FALSE )) hasCv <- !is.null(object@cvResult) diff --git a/R/vcfWriter.R b/R/vcfWriter.R index 0db61260..7aecc39a 100644 --- a/R/vcfWriter.R +++ b/R/vcfWriter.R @@ -14,14 +14,14 @@ NULL setMethod( "writeSumStatsVcf", signature("GwasSumStats"), - function(x, outputPath, sampleName = NULL, study = NULL) { + function(x, outputPath, sampleName = NULL, studyName = NULL) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort( "Package 'VariantAnnotation' is required for writeSumStatsVcf" ) } - study <- .vcfResolveStudy(x, study) - ss <- getSumStats(x, study = study) + studyName <- .vcfResolveStudy(x, studyName) + ss <- sumStats(x, studyName = studyName) mc <- mcols(ss) .writeVcfImpl( chrom = as.character(seqnames(ss)), @@ -31,7 +31,7 @@ setMethod( snpIds = mc$SNP, geno = .vcfSumstatsGeno(mc, length(ss)), genoHeader = .vcfSumstatsGenoHeader(), - sampleName = sampleName %||% study, + sampleName = sampleName %||% studyName, outputPath = outputPath ) } @@ -40,9 +40,9 @@ setMethod( # Select which study to write (a GwasSumStats can hold many); a single-study # collection defaults to its one study. # @noRd -.vcfResolveStudy <- function(x, study) { - if (!is.null(study)) { - return(study) +.vcfResolveStudy <- function(x, studyName) { + if (!is.null(studyName)) { + return(studyName) } if (nrow(x) != 1L) { msg <- glue( @@ -90,7 +90,7 @@ setMethod( x, outputPath, sampleName = NULL, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -108,7 +108,7 @@ setMethod( # iterates over the unique values of the requested axis. rowSpecs <- .resolveFineMappingRows( x, - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -161,7 +161,7 @@ setMethod( # @noRd .resolveFineMappingRows <- function( x, - study, + studyName, context, trait, method, @@ -172,7 +172,7 @@ setMethod( hasContextSlot <- is_in("context", cols) hasTraitSlot <- is_in("trait", cols) selectors <- compact(list( - study = study, + study = studyName, context = if (hasContextSlot) context, trait = if (hasTraitSlot) trait, method = method @@ -335,20 +335,22 @@ setMethod( c(fixed, .vcfCsSpecs(base), .vcfFullFitSpecs(base)) } -# Resolve the per-variant body: the fine-mapping POSTERIOR (getTopLoci at +# Resolve the per-variant body: the fine-mapping POSTERIOR (topLoci at # signalCutoff 0 = every fitted variant, carrying pip / CS membership / # conditional effect) joined to the MARGINAL univariate sumstats -# (getMarginalEffects) where those exist. mvSuSiE / fSuSiE have no marginal +# (marginalEffects) where those exist. mvSuSiE / fSuSiE have no marginal # sumstats, so the posterior drives the variant set; univariate susie adds # marginal ES=beta / SE / LP / AF on top. Returns list(base, m, hasPost). # @noRd .vcfResolveBody <- function(entry, sn) { post <- try_fetch( - as_tibble(getTopLoci(entry, signalCutoff = 0)), + as_tibble(as.data.frame( + S4Vectors::mcols(topLoci(entry, signalCutoff = 0)) + )), error = function(cnd) NULL ) marg <- try_fetch( - as_tibble(getMarginalEffects(entry)), + as_tibble(marginalEffects(entry)), error = function(cnd) NULL ) hasPost <- !is.null(post) && nrow(post) > 0L @@ -411,7 +413,7 @@ setMethod( splitByContext, splitByTrait ) { - entry <- getFineMappingResult( + entry <- fineMappingResult( x, spec$study, spec$context, diff --git a/Rplots.pdf b/Rplots.pdf new file mode 100644 index 00000000..c11f7f2a Binary files /dev/null and b/Rplots.pdf differ diff --git a/_pkgdown.yml b/_pkgdown.yml index 10805b0e..319d0883 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -68,7 +68,7 @@ articles: - finemapping-postprocessing - title: "TWAS" desc: > - Training TWAS weights from QTL data (individual-level and + Training TWAS weights-methods from QTL data (individual-level and summary-statistics, single and multi-context), computing per-gene TWAS Z-scores from GWAS summary statistics, and fine-mapping genes jointly with SNPs so a gene's PIP is conditioned on the signal @@ -194,6 +194,14 @@ reference: - CovPcaOptions - CovUdrOptions - CtwasOptions + - CtwasBoundaryGenesOptions + - CtwasEstParamOptions + - CtwasExpandOptions + - CtwasFinemapOptions + - CtwasGeneZOptions + - CtwasMergeOptions + - CtwasRegionDataOptions + - CtwasScreenOptions - fineMappingMethodOptions - GbjOptions - GbjOmniOptions @@ -277,7 +285,7 @@ reference: # The virtual base of every tuple collection: container and metadata # methods, the region verb, and the plyranges bridge. The families # that inherit it -- fine-mapping results, colocalization results, - # summary statistics, TWAS weights -- follow. + # summary statistics, TWAS weights-methods -- follow. - flattenTupleRanges - nestTupleRanges - RangedTupleList-methods @@ -288,214 +296,209 @@ reference: - computeCsCorrelation - fsusieAffectedRegions - fsusieCredibleBand - - getCredibleSetSummary - - getCs - - getLbf - - getLdSketch - - getMarginalEffects - - getMethodNames - - getRegion - - getRetainedMass - - getStudy - - getSusieFit - - getTopLoci - - getTraitPosition - - getVariantIds + - credibleSetSummary + - credibleSets + - lbf + - ldSketch + - marginalEffects + - methodNames + - genomicRegion + - retainedMass + - studyName + - susieFit + - topLoci + - traitPosition + - variantIds - intersectVariants - resolveWeights - writeSumStatsVcf - subtitle: "QtlFineMappingResult" contents: - - getContexts - - getCvResult - - getFineMappingResult - - getPip - - getTraits + - contexts + - cvResult + - fineMappingResult + - pip + - traitNames - subtitle: "GwasFineMappingResult" contents: - - getContexts - - getFineMappingResult - - getPip - - getTraits + - contexts + - fineMappingResult + - pip + - traitNames - subtitle: "FineMappingRow" contents: - - getCvResult - - getSusieFit - - getVariantIds + - cvResult + - susieFit + - variantIds - subtitle: "ColocResultBase / ColocResult / ColocBoostResult" contents: - "as.data.frame,ColocBoostResult-method" - "as.data.frame,ColocResult-method" - colocViews - - getColocBoostOutcomes - - getComputingTime - - getLdSketch - - getRegionVcp + - colocBoostOutcomes + - computingTime + - ldSketch + - regionVcp - subtitle: "SumStatsBase" contents: - - getBeta - - getGenome - - getLdSketch - - getMaf - - getN - - getP - - getQcDiagnostics - - getQcInfo - - getSe - - getStudy - - getVariantIds - - getZ + - af + - coef + - ldSketch + - maf + - nSamples + - variantColumnReplace + - pval + - qcDiagnostics + - qcInfo + - se + - studyName + - variantIds + - z - nSnps - subsetChr - subtitle: "GwasSumStats" contents: - - as.data.frame.GwasSumStats - combineGwasSumStats - - getSumStatsDf - - "getSumStats,GwasSumStats-method" - - getVarY + - sumStatsDataFrame + - "sumStats,GwasSumStats-method" + - varY - writeSumStatsVcf - subtitle: "QtlSumStats" contents: - combineQtlSumStats - - getContexts - - getSignificantQtls - - getSumStatsDf - - getSumStats - - getTraitPosition - - getTraits - - getVarY + - contexts + - significantQtls + - sumStatsDataFrame + - sumStats + - traitPosition + - traitNames + - varY - qtlAssociationPostprocess - subtitle: "TwasWeights" contents: - - getContexts - - getCvResult - - getDataType - - getFits - - getLdSketch - - getMethodNames - - getRegion - - getStandardized - - getStudy - - getTraitPosition - - getTraits - - getTwasWeights - - getVariantIds - - getWeights + - contexts + - cvResult + - weightsDataType + - methodFits + - ldSketch + - methodNames + - genomicRegion + - weightStandardized + - studyName + - traitPosition + - traitNames + - twasWeights + - variantIds + - weights-methods - resolveWeights - subtitle: "TwasWeightsRow" contents: - - getCvResult - - getDataType - - getFits - - getStandardized - - getVariantIds - - getWeights + - cvResult + - weightsDataType + - methodFits + - weightStandardized + - variantIds + - weights-methods - subtitle: "AnnotationMatrix" contents: # Classes outside the RangedTupleList hierarchy follow, in # alphabetical order. - - getBaseline - - getCandidates - - getGenome + - baselineAnnotations + - testedAnnotations - subtitle: "CtwasResult / CtwasResultEntry" contents: - - getContexts - - getCtwasGroupPriors - - getFinemap - - getMethodNames - - getStudy - - getSusieAlpha + - contexts + - ctwasGroupPriors + - ctwasPosteriors + - methodNames + - studyName + - susieAlpha - subtitle: "H2Estimate" contents: - - getEnrichment - - getH2 - - getH2Se - - getIntercept - - getInterceptSe - - getLocal - - getMethodNames - - getNSnps - - getScoreStats - - getTauBlocks - - getTraitName + - stratifiedHeritabilityEnrichment + - heritabilityEstimate + - heritabilityEstimateSe + - heritabilityIntercept + - heritabilityInterceptSe + - localH2Blocks + - methodNames + - nSnps + - scoreStats + - annotationJackknifeCoefs + - traitNames - subtitle: "LdData" contents: - - getBlockMetadata - - getCorrelation - - getGenotypes - - getMixtureWeights - - getNRef - - getRefPanel - - getSnpIdx - - getVariantIds - - getVariantInfo + - blockMetadata + - ldMatrix + - genotypes + - mixtureWeights + - ldPanelNSamples + - refPanel + - snpIdx + - variantIds + - variantInfo - hasGenotypes - subtitle: "LdEigen" contents: - - getEigenList + - eigenList - subtitle: "LdScore" contents: - - getLdMatrixList - - getLdScores - - getLdScoreWeights + - ldMatrixList - subtitle: "LdStatistic" contents: - - getGenome - - getInSample - - getLdBlocks - - getNRef + - inSample + - ldBlocks + - ldPanelNSamples - subtitle: "MashPrior" contents: - - getCvFits - - getFullFit + - cvFits + - fullFit - subtitle: "MultiStudyQtlDataset" contents: - - getQtlDatasets - - getStudy - - getSumStats + - qtlDatasets + - studyName + - sumStats - subtitle: "QtlDataset" contents: - - getAf - - getContexts - - getGenotypeCovariates - - getGenotypes - - getMaf - - getPhenotypeCovariates - - getPhenotypes - - getResidualizedGenotypes - - getResidualizedPhenotypes - - getScaleResiduals - - getStudy - - getTraitPosition + - contexts + - genotypeCovariates + - genotypes + - maf + - phenotypeCovariates + - molecularTraits + - residualizedGenotypes + - residualizedPhenotypes + - scaleResiduals + - studyName + - traitPosition - qtlDatasetFilters - subtitle: "SldscData" contents: - - getAnnotCols - - getAnnotData - - getFrqData - - getTraitRun - - getTraitRuns + - annotCols + - annotData + - frqData + - sldscResults + - sldscResults - title: "Pipelines" desc: > @@ -570,7 +573,7 @@ reference: - readGenotypes - loadGenotypeRegion - readAfreq - - getRefVariantInfo + - refVariantInfo - invertMinmaxScaling - title: "Variant ID and region helpers" @@ -609,7 +612,7 @@ reference: - fitSusieInfThenSusieRss - fsusieGetCs - fsusieWrapper - - getSusieResult + - susieResult - computeCsTables - buildTopLoci - extractCsInfo @@ -683,7 +686,7 @@ reference: - subtitle: "Association testing and p-value combination" contents: - # twasZ() turns weights plus GWAS summary statistics into a per-tuple + # twasZ() turns weights-methods plus GWAS summary statistics into a per-tuple # Z and p-value, then delegates cross-tuple pooling to combinePValues(). - twasZ - combinePValues diff --git a/data/ctwasEstExample.rda b/data/ctwasEstExample.rda index 58021fa7..2ec972e8 100644 Binary files a/data/ctwasEstExample.rda and b/data/ctwasEstExample.rda differ diff --git a/data/ctwasFinemapExample.rda b/data/ctwasFinemapExample.rda index 24c5200c..dfe1d581 100644 Binary files a/data/ctwasFinemapExample.rda and b/data/ctwasFinemapExample.rda differ diff --git a/data/ctwasInputsExample.rda b/data/ctwasInputsExample.rda index 6369485d..47a5e067 100644 Binary files a/data/ctwasInputsExample.rda and b/data/ctwasInputsExample.rda differ diff --git a/data/ctwasWeightsExample.rda b/data/ctwasWeightsExample.rda index 363d2a9d..3af3a319 100644 Binary files a/data/ctwasWeightsExample.rda and b/data/ctwasWeightsExample.rda differ diff --git a/data/h2EstimateExample.rda b/data/h2EstimateExample.rda index a5221853..c96d5c5f 100644 Binary files a/data/h2EstimateExample.rda and b/data/h2EstimateExample.rda differ diff --git a/data/ldEigenExample.rda b/data/ldEigenExample.rda index 288269e7..50fc211b 100644 Binary files a/data/ldEigenExample.rda and b/data/ldEigenExample.rda differ diff --git a/data/ldScoreExample.rda b/data/ldScoreExample.rda index cb06d07a..69a4e63e 100644 Binary files a/data/ldScoreExample.rda and b/data/ldScoreExample.rda differ diff --git a/data/multiStudyQtlDatasetExample.rda b/data/multiStudyQtlDatasetExample.rda index 981d490a..ca813a21 100644 Binary files a/data/multiStudyQtlDatasetExample.rda and b/data/multiStudyQtlDatasetExample.rda differ diff --git a/data/qtlDatasetExample.rda b/data/qtlDatasetExample.rda index e8cd861a..b16523eb 100644 Binary files a/data/qtlDatasetExample.rda and b/data/qtlDatasetExample.rda differ diff --git a/inst/scripts/build_ctwas_examples.R b/inst/scripts/build_ctwas_examples.R index c0c11040..fe8a54f5 100644 --- a/inst/scripts/build_ctwas_examples.R +++ b/inst/scripts/build_ctwas_examples.R @@ -4,28 +4,46 @@ # ctwasInputsExample / ctwasEstExample / ctwasFinemapExample are the payloads # of the granular chain # -# assembleCtwasInputs -> estCtwasParam -> screenCtwasRegions +# assembleCtwasInputs -> estCtwasGroupPriors -> screenCtwasRegions # -> finemapCtwasRegions # # captured after each step, so a user can enter the chain anywhere without # re-running what came before. # -# The payloads carry an `LD_map$LD_file` token that ctwas asserts exists on -# disk and that pecotmr uses as the dispatch key into the cached per-region LD -# panels. Baking an absolute path into the .rda makes that token point at the -# machine that built it -- which is what left the previous objects unusable -# past `screenCtwasRegions` (finemapCtwasRegions failed on -# `all(file.exists(LD_matrix_files))`). Step 3 rewrites the token to the -# portable "pecotmr://extdata/" form the genotype handles already use; -# `.ctwasResolveLdPaths()` resolves it at extraction time on whatever machine -# the package is installed. +# The payloads carry one `LD_map$LD_file` token PER REGION, which ctwas +# asserts exists on disk and which pecotmr also uses as the dispatch key into +# the cached per-region LD panels. Those two duties are why the token cannot +# simply be the backing genotype file: every block on a chromosome shares that +# file, so each block was handed the FIRST block's LD panel. The tokens are +# per-region sentinels under the session tempdir instead, and are therefore +# gone when a saved object is read back -- `.ctwasResolveLdPaths()` re-mints +# one per region on the way in and re-keys the loader cache onto them, so no +# path from the building machine is ever baked into the .rda. # # Run from the package root: # Rscript inst/scripts/build_ctwas_examples.R # ============================================================================= devtools::load_all(".", quiet = TRUE) -library(purrr) + +# A bundled stem as the portable reference the serialized objects carry, so +# no .rda holds a path from the machine that built it. +asBundledResource <- function(stem) { + rel <- sub( + paste0("^.*", .Platform$file.sep, "extdata", .Platform$file.sep), + "", + stem + ) + paste0("pecotmr://extdata/", rel) +} + +# A GenotypeHandle for `stem`, carrying the portable reference rather than +# the concrete path it had to be read from. +.portableHandle <- function(stem) { + handle <- pecotmr:::.ldSketchHandle(readGenotypes(plink2Prefix = stem)) + handle@path <- asBundledResource(stem) + handle +} # ----------------------------------------------------------------------------- # 1. Inputs: the bundled chr22 LD panel, GWAS sumstats, and TWAS weights. @@ -55,10 +73,39 @@ gwasSumStats <- loadGwasSumStatsFromManifest( region = "chr22:10000000-19000000", ldBlocks = blocks ) -gwasByRegion <- summaryStatsQc(gwasSumStats, mafCutoff = 0.0025) +gwasByRegion <- summaryStatsQc( + gwasSumStats, + panelFilterArgs = PanelFilterParam(mafCutoff = 0.0025) +) data(ctwasWeightsExample) +# ----------------------------------------------------------------------------- +# 1b. Point the weight example's LD sketch at the bundled panel. +# ----------------------------------------------------------------------------- +# ctwasWeightsExample was originally built against a local xqtl-protocol +# checkout, so it carried that machine's absolute genotype path and a +# 1975-variant sketch read from the untrimmed source. All 168 of its weight +# variants lie inside the bundled 175-variant chr22 panel, and the two span +# exactly the same range, so the bundled copy is the right panel rather than +# a substitute for it. +# +# Construction needs a real path (it reads .pvar to populate snpInfo), so +# the handle is built from the concrete stem and its path rewritten to the +# portable "pecotmr://extdata/" form afterwards -- the same two-step +# every other bundled example uses. .resolveGenotypeResourcePath() turns it +# back into a real path at read time, on whatever machine has the package. +ctwasWeightsExample <- methods::initialize( + ctwasWeightsExample, + ldSketch = pecotmr:::.asLdSketch(.portableHandle(ldStem)) +) + +stopifnot( + path(pecotmr:::.ldSketchHandle( + ldSketch(ctwasWeightsExample) + )) == asBundledResource(ldStem) +) + # ----------------------------------------------------------------------------- # 2. Run the chain, capturing each payload. # ----------------------------------------------------------------------------- @@ -67,13 +114,15 @@ ctwasInputsExample <- assembleCtwasInputs( twasWeights = list(ctwasWeightsExample) ) -ctwasEstExample <- estCtwasParam( +ctwasEstExample <- estCtwasGroupPriors( ctwasInputsExample, - thin = 1, - niterPrefit = 3, - niter = 10, - fallbackToPrefit = TRUE, - methodArgs = ctwasArgs(min_group_size = 1, min_p_single_effect = 0) + ctwasPriorArgs = CtwasPriorParam( + thin = 1, + niterPrefit = 3, + niter = 10, + fallbackToPrefit = TRUE + ), + methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0) ) # The toy GWAS carries no genome-wide-significant signal, so the default @@ -81,70 +130,112 @@ ctwasEstExample <- estCtwasParam( # empty result. Keep every region so the finemap payload is populated. screened <- screenCtwasRegions( ctwasEstExample, - methodArgs = ctwasArgs(min_nonSNP_PIP = 0) + methodArgs = CtwasOptions(min_nonSNP_PIP = 0) ) ctwasFinemapExample <- finemapCtwasRegions(screened) # ----------------------------------------------------------------------------- -# 3. Make the LD token portable. +# 3. Materialize each region's LD and let its sketch go. # ----------------------------------------------------------------------------- -asResource <- function(p) { - rel <- sub( - paste0("^.*", .Platform$file.sep, "extdata", .Platform$file.sep), - "", - p +# The pipeline keeps a sketch per panel so a region's n x n correlation is +# built only if ctwas actually fine-maps that region. A bundled example has +# the opposite requirement: it has to work in an installation with no access +# to the machine that built it, and a serialized sketch carries that +# machine's genotype path. These panels are small, so materialize the +# correlation and drop the sketch -- .ctwasPanelLd() uses a panel's own R +# when it has one, which is the path every reader of these objects takes. +materializePanel <- function(p) { + list( + R = pecotmr:::.ctwasPanelLd(p), + snpInfo = p$snpInfo, + variance = p$variance ) - paste0("pecotmr://extdata/", rel) } -repointLd <- function(payload) { - if (is.null(payload$LD_map)) { +materializeLd <- function(payload) { + panels <- pecotmr:::.ctwasCachedPanels(payload) + if (is.null(panels)) { return(payload) } - stored <- as.character(payload$LD_map$LD_file) - portable <- map_chr(stored, asResource) - keyMap <- setNames(portable, stored) - payload$LD_map$LD_file <- portable - payload$LD_map$SNP_file <- portable - # The loader closures dispatch on the same token, so their cache has to be - # re-keyed in step with it or the resolved token finds no panel. - pecotmr:::.ctwasRekeyLdLoaders(payload, keyMap) + built <- lapply(panels, materializePanel) + names(built) <- names(panels) + # Both loaders dispatch on the LD_file token, so they are rebuilt over + # the materialized cache exactly as .ctwasAssembleResult() builds them. + payload$LD_loader_fun <- pecotmr:::.ctwasMultiBlockLdLoader(built) + payload$snpinfo_loader_fun <- + pecotmr:::.ctwasMultiBlockSnpInfoLoader(built) + payload } -ctwasInputsExample <- repointLd(ctwasInputsExample) -ctwasEstExample <- repointLd(ctwasEstExample) -ctwasFinemapExample <- repointLd(ctwasFinemapExample) +ctwasInputsExample <- materializeLd(ctwasInputsExample) +ctwasEstExample <- materializeLd(ctwasEstExample) +ctwasFinemapExample <- materializeLd(ctwasFinemapExample) stopifnot( - all(grepl("^pecotmr://", ctwasInputsExample$LD_map$LD_file)), - all(grepl("^pecotmr://", ctwasEstExample$LD_map$LD_file)), - all(grepl("^pecotmr://", ctwasFinemapExample$LD_map$LD_file)) + all(!vapply( + pecotmr:::.ctwasCachedPanels(ctwasInputsExample), + function(p) is.null(p$R) || !is.null(p$sketch), + logical(1) + )) ) # ----------------------------------------------------------------------------- -# 4. Verify each payload still drives the step that consumes it, from the +# 4. Check the token invariant. +# ----------------------------------------------------------------------------- +# Every region now carries its OWN LD_file token -- a sentinel under the +# session tempdir -- because ctwas asserts file.exists() on each token AND +# dispatches LD_loader_fun on that same string, so pointing them all at the +# one shared genotype file handed every block the FIRST block's LD. The +# sentinels are gone by the time a saved object is read back, which is +# precisely the case .ctwasResolveLdPaths() handles: it re-mints one per +# region and re-keys the loader cache onto the new tokens. So nothing is +# rewritten here. The old "pecotmr://extdata/" step only worked while +# the token was a real file under extdata and would mangle a sentinel path. +# +# What is worth asserting is the invariant the bug violated: one distinct +# token per region. +stopifnot( + anyDuplicated(ctwasInputsExample$LD_map$LD_file) == 0L, + anyDuplicated(ctwasEstExample$LD_map$LD_file) == 0L, + anyDuplicated(ctwasFinemapExample$LD_map$LD_file) == 0L +) + +# ----------------------------------------------------------------------------- +# 5. Verify each payload still drives the step that consumes it, from the # portable form -- the check the previous objects would have failed. # ----------------------------------------------------------------------------- -invisible(estCtwasParam( +# Drop the live sentinels first. Without this the verification below runs +# against tokens that still exist in this session and so would not exercise +# the re-mint path every reader of the saved object actually takes. +unlink(unique(c( + ctwasInputsExample$LD_map$LD_file, + ctwasEstExample$LD_map$LD_file, + ctwasFinemapExample$LD_map$LD_file +))) + +invisible(estCtwasGroupPriors( ctwasInputsExample, - thin = 1, - niterPrefit = 3, - niter = 10, - fallbackToPrefit = TRUE, - methodArgs = ctwasArgs(min_group_size = 1, min_p_single_effect = 0) + ctwasPriorArgs = CtwasPriorParam( + thin = 1, + niterPrefit = 3, + niter = 10, + fallbackToPrefit = TRUE + ), + methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0) )) invisible(finemapCtwasRegions( screenCtwasRegions( ctwasEstExample, - methodArgs = ctwasArgs(min_nonSNP_PIP = 0) + methodArgs = CtwasOptions(min_nonSNP_PIP = 0) ) )) invisible(asCtwasResult(ctwasFinemapExample)) invisible(mergeCtwasBoundaryRegions(ctwasFinemapExample)) # ----------------------------------------------------------------------------- -# 5. Save. +# 6. Save. # ----------------------------------------------------------------------------- +usethis::use_data(ctwasWeightsExample, overwrite = TRUE, compress = "xz") usethis::use_data(ctwasInputsExample, overwrite = TRUE, compress = "xz") usethis::use_data(ctwasEstExample, overwrite = TRUE, compress = "xz") usethis::use_data(ctwasFinemapExample, overwrite = TRUE, compress = "xz") diff --git a/inst/scripts/build_examples.R b/inst/scripts/build_examples.R index 4d686430..2ad31cf5 100644 --- a/inst/scripts/build_examples.R +++ b/inst/scripts/build_examples.R @@ -301,7 +301,7 @@ asResource <- function(p) paste0("pecotmr://extdata/", basename(p)) # assay's seed. Repointing only the slot would leave the assay reading the # build machine's absolute path, so both move together. repointHandle <- function(x) { - handle <- getGenotypeHandle(x) + handle <- genotypeHandle(x) handle@path <- asResource(handle@path) pecotmr:::.qtlWithGenotypeHandle(x, handle) } diff --git a/inst/scripts/build_h2_examples.R b/inst/scripts/build_h2_examples.R index 2c88e01c..ba9f278b 100644 --- a/inst/scripts/build_h2_examples.R +++ b/inst/scripts/build_h2_examples.R @@ -61,14 +61,14 @@ ldScoreExample <- buildLdScore(ldList, genome = "hg38") stopifnot( length(ldEigenExample) == length(ldScoreExample), - length(getEigenList(ldEigenExample)) == N_BLOCKS, - length(getLdMatrixList(ldScoreExample)) == N_BLOCKS, + length(eigenList(ldEigenExample)) == N_BLOCKS, + length(ldMatrixList(ldScoreExample)) == N_BLOCKS, identical(names(ldEigenExample), names(ldScoreExample)) ) # The two routes to an LD score must agree, or one of them has drifted. stopifnot(all.equal( - as.vector(getLdScores(ldScoreExample)[, 1]), + as.vector(mcols(ldScoreExample)$ldScores[, 1]), as.vector(computeLdScores(ldEigenExample)[, 1]) )) @@ -83,7 +83,7 @@ perSnpVar <- rep(h2True / M, M) simZ <- function() { z <- numeric(M) - for (block in getLdMatrixList(ldScoreExample)) { + for (block in ldMatrixList(ldScoreExample)) { idx <- block$snpIdx p <- length(idx) sigma <- N * (block$R %*% diag(perSnpVar[idx], p) %*% block$R) + block$R diff --git a/inst/scripts/build_sldsc_upstream_z.R b/inst/scripts/build_sldsc_upstream_z.R index 0d31f45b..334e0451 100644 --- a/inst/scripts/build_sldsc_upstream_z.R +++ b/inst/scripts/build_sldsc_upstream_z.R @@ -30,7 +30,7 @@ simZ <- function(ref, h2, n, seed) { perSnpVar <- rep(h2 / M, M) set.seed(seed) z <- numeric(M) - for (b in pecotmr:::getLdMatrixList(ref)) { + for (b in pecotmr:::ldMatrixList(ref)) { idx <- b$snpIdx p <- length(idx) sigma <- n * (b$R %*% diag(perSnpVar[idx], p) %*% b$R) + b$R diff --git a/inst/scripts/prepare_example_data.R b/inst/scripts/prepare_example_data.R index 800b5dd3..58ce2211 100644 --- a/inst/scripts/prepare_example_data.R +++ b/inst/scripts/prepare_example_data.R @@ -21,7 +21,7 @@ # entry point fineMappingPipeline() uses, rather than being assembled by hand. # Earlier versions of this script hand-built a `cs` column of bare integer # labels; that predates the cs_95 / cs_70 / cs_50 (+ _purity) schema, and a -# fixture carrying it makes getCs() and getCredibleSetSummary() silently return +# fixture carrying it makes credibleSets() and credibleSetSummary() silently return # nothing. Going through the real post-processor keeps the fixtures on whatever # schema the package currently emits. # @@ -49,10 +49,10 @@ posOffset <- 5000000L # The one credible set at this eQTL locus spans 42 variants with # min.abs.corr = 0.626, so the pipeline default (minAbsCorr = 0.8) would reject -# it and label every variant "susie_0" -- leaving getCs() on the package's +# it and label every variant "susie_0" -- leaving credibleSets() on the package's # headline QTL example with nothing to show. Building at 0.5 keeps the set # labelled while cs_95_purity still records the true 0.626, so a caller who -# asks for getCs(x, minPurity = 0.8) correctly gets nothing back. The GWAS fit +# asks for credibleSets(x, minPurity = 0.8) correctly gets nothing back. The GWAS fit # below needs no such allowance: its credible sets are all above 0.95. qtlMinAbsCorr <- 0.5 @@ -303,24 +303,24 @@ for (nm in c( cat("\n=== Verifying ===\n") for (nm in c("qtlFineMappingExample", "gwasFineMappingExample")) { obj <- get(nm) - cs <- getCs(obj) - summ <- getCredibleSetSummary(obj) + cs <- credibleSets(obj) + summ <- credibleSetSummary(obj) cat(sprintf( - " %-24s %d variants, getCs() %d rows, %d credible sets\n", + " %-24s %d variants, credibleSets() %d rows, %d credible sets\n", nm, sum(lengths(obj)), nrow(cs), nrow(summ) )) if (nrow(cs) == 0L) { - stop(nm, ": getCs() is empty, which is the defect this build fixes") + stop(nm, ": credibleSets() is empty, which is the defect this build fixes") } } # intersectVariants() returns the two collections restricted to their shared # variants (a list of x and y), not the variant vector itself. both <- intersectVariants(qtlFineMappingExample, gwasFineMappingExample) -nShared <- length(getVariantIds(both$x)) +nShared <- length(variantIds(both$x)) cat(sprintf(" intersectVariants() -> %d shared variants\n", nShared)) if (nShared != sum(lengths(qtlFineMappingExample))) { stop( diff --git a/inst/scripts/prepare_paired_finemapping_example.R b/inst/scripts/prepare_paired_finemapping_example.R index df74a526..fe77df8c 100644 --- a/inst/scripts/prepare_paired_finemapping_example.R +++ b/inst/scripts/prepare_paired_finemapping_example.R @@ -11,7 +11,7 @@ # any shipped LD source, so cross-object, LD-derived computations such as # `computeCsCorrelation()` cannot use them. This fixture closes that gap: it is # self-consistent with `qtlSumStatsExample`, so -# `computeCsCorrelation(getFineMappingResult(qtlFineMappingPairedExample), +# `computeCsCorrelation(fineMappingResult(qtlFineMappingPairedExample), # qtlSumStatsExample)` returns a real between-credible-set correlation matrix. # # A phenotype with two causal variants in low mutual LD is simulated so the fit @@ -27,7 +27,7 @@ library(susieR) data(qtlDatasetExample) # Genotypes for the 200 shipped variants (columns match the LD-source panels). -X <- getGenotypes(qtlDatasetExample) +X <- genotypes(qtlDatasetExample) variantIds <- colnames(X) # Two causal variants far apart and in low mutual LD -> two credible sets. @@ -57,7 +57,7 @@ if (length(fit$sets$cs) < 2L) { # Post-process through the same entry point fineMappingPipeline() uses, rather # than hand-assembling a topLoci table. A hand-built table carries only # variant_id and pip, with no cs_95 / cs_70 / cs_50 (+ _purity) columns, and a -# fixture like that makes getCs() and getCredibleSetSummary() return nothing +# fixture like that makes credibleSets() and credibleSetSummary() return nothing # even though the fit has credible sets. post <- postprocessFinemappingFits( fits = list(susie = fit), @@ -84,7 +84,7 @@ save( # Sanity check: the paired correlation resolves against qtlSumStatsExample. data(qtlSumStatsExample) cc <- computeCsCorrelation( - getFineMappingResult(qtlFineMappingPairedExample), + fineMappingResult(qtlFineMappingPairedExample), qtlSumStatsExample ) cat(sprintf( @@ -93,10 +93,10 @@ cat(sprintf( ncol(cc) )) -nCs <- nrow(getCredibleSetSummary(qtlFineMappingPairedExample)) +nCs <- nrow(credibleSetSummary(qtlFineMappingPairedExample)) cat(sprintf( - "getCs() -> %d rows across %d credible sets\n", - nrow(getCs(qtlFineMappingPairedExample)), + "credibleSets() -> %d rows across %d credible sets\n", + nrow(credibleSets(qtlFineMappingPairedExample)), nCs )) if (nCs < 2L) { diff --git a/man/AnnotationMatrix-class.Rd b/man/AnnotationMatrix-class.Rd index 7b6ab87a..4ee9cc25 100644 --- a/man/AnnotationMatrix-class.Rd +++ b/man/AnnotationMatrix-class.Rd @@ -14,6 +14,7 @@ Container for SNP-level annotations used in stratified \code{rowRanges}, the annotation matrix in the \code{annotations} assay, and the per-annotation table in \code{colData}. Subsetting works in both directions -- \code{x[i, j]} narrows SNPs and annotations - together -- and \code{\link{getBaseline}} / \code{\link{getCandidates}} + together -- and \code{\link{baselineAnnotations}} / + \code{\link{testedAnnotations}} are column subsets rather than reconstructions. } diff --git a/man/ColocBoostResult-class.Rd b/man/ColocBoostResult-class.Rd index 7cc8b218..263dc8b4 100644 --- a/man/ColocBoostResult-class.Rd +++ b/man/ColocBoostResult-class.Rd @@ -6,8 +6,8 @@ \title{ColocBoost Result} \description{ A collection of ColocBoost results, one element per confidence - set (CoS). Project it with \code{\link{getColocPairs}}, - \code{\link{getColocVariants}} or \code{\link{getColocBoostOutcomes}}. + set (CoS). Project it with \code{\link{colocPairs}}, + \code{\link{colocVariants}} or \code{\link{colocBoostOutcomes}}. } \section{Slots}{ diff --git a/man/ColocBoostResult.Rd b/man/ColocBoostResult.Rd index 004ae7c1..32f8cc16 100644 --- a/man/ColocBoostResult.Rd +++ b/man/ColocBoostResult.Rd @@ -55,7 +55,7 @@ colocboostResultExample # Its unit is a SET of colocalized outcomes rather than a pair, so one row # can carry any number of them. colocboostResultExample$outcomes -getColocPairs(colocboostResultExample)$nOutcomes +colocPairs(colocboostResultExample)$nOutcomes # A run that failed or was not requested arrives as NULL and is skipped, # giving an empty result rather than an error. nrow(ColocBoostResult(list(NULL), "xqtl_coloc")) diff --git a/man/ColocResult-class.Rd b/man/ColocResult-class.Rd index f477ba16..0a37190e 100644 --- a/man/ColocResult-class.Rd +++ b/man/ColocResult-class.Rd @@ -7,12 +7,12 @@ \description{ A collection of colocalization results, one element per tested (QTL credible set, GWAS credible set, block) pair. Build the four views - with \code{\link{getColocPairs}}, \code{\link{getColocVariants}}, - \code{\link{getColocCredibleSets}} and \code{\link{getColocGenes}}. + with \code{\link{colocPairs}}, \code{\link{colocVariants}}, + \code{\link{colocCredibleSets}} and \code{\link{colocGenes}}. } \details{ The inherited \code{ldSketch} is what - \code{getColocCredibleSets()} uses to compute credible-set purity. + \code{colocCredibleSets()} uses to compute credible-set purity. } \seealso{ \code{\link{colocPipeline}} diff --git a/man/ColocResult.Rd b/man/ColocResult.Rd index 11b78314..fe97f364 100644 --- a/man/ColocResult.Rd +++ b/man/ColocResult.Rd @@ -19,7 +19,7 @@ columns are \code{NA} for it.} frames with a \code{variant_id} column and a \code{SNP.PP.H4} column.} \item{ldSketch}{Optional genotype panel (see \code{\link{readGenotypes}}) -for the LD reference, used by \code{\link{getColocCredibleSets}} to +for the LD reference, used by \code{\link{colocCredibleSets}} to compute purity.} } \value{ diff --git a/man/ColocResultBase-class.Rd b/man/ColocResultBase-class.Rd index 9057f3d2..3acd7a4a 100644 --- a/man/ColocResultBase-class.Rd +++ b/man/ColocResultBase-class.Rd @@ -14,8 +14,8 @@ Virtual base shared by \code{\linkS4class{ColocResult}} (from normalized posterior over an arbitrary-sized set of outcomes -- so neither can be expressed in the other's schema. What they share is the shape (one element per colocalization unit, its variants inside) and therefore the - projection surface: both answer \code{\link{getColocPairs}} and - \code{\link{getColocVariants}}, so code that only needs "which variants + projection surface: both answer \code{\link{colocPairs}} and + \code{\link{colocVariants}}, so code that only needs "which variants colocalized, and how strongly" works against either. } \section{Slots}{ diff --git a/man/CovMcdOptions.Rd b/man/CovMcdOptions.Rd index 17328914..061f1b04 100644 --- a/man/CovMcdOptions.Rd +++ b/man/CovMcdOptions.Rd @@ -23,13 +23,13 @@ A \code{MethodOptions} record for the \code{outlierArgs} argument. 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}}. + \code{\link{molecularTraits}} and + \code{\link{residualizedPhenotypes}}. } \examples{ CovMcdOptions(alpha = 0.75) } \seealso{ -\code{\link{getPhenotypes}}, - \code{\link{getResidualizedPhenotypes}} +\code{\link{molecularTraits}}, + \code{\link{residualizedPhenotypes}} } diff --git a/man/CredibleSetParam.Rd b/man/CredibleSetParam.Rd index 17890b59..d26a8ab9 100644 --- a/man/CredibleSetParam.Rd +++ b/man/CredibleSetParam.Rd @@ -1,106 +1,106 @@ % 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} +\name{csCoverage} +\alias{csCoverage} +\alias{csCoverage<-} +\alias{secondaryCoverage} +\alias{secondaryCoverage<-} +\alias{signalCutoff} +\alias{signalCutoff<-} +\alias{minAbsCorr} +\alias{minAbsCorr<-} +\alias{medianAbsCorr} +\alias{medianAbsCorr<-} +\alias{includeAllCs} +\alias{includeAllCs<-} +\alias{perCsColumns} +\alias{perCsColumns<-} +\alias{maxNumSingleEffects} +\alias{maxNumSingleEffectsGreedy} +\alias{csCoverage,CredibleSetParam-method} +\alias{csCoverage<-,CredibleSetParam-method} +\alias{secondaryCoverage,CredibleSetParam-method} +\alias{secondaryCoverage<-,CredibleSetParam-method} +\alias{signalCutoff,CredibleSetParam-method} +\alias{signalCutoff<-,CredibleSetParam-method} +\alias{minAbsCorr,CredibleSetParam-method} +\alias{minAbsCorr<-,CredibleSetParam-method} +\alias{medianAbsCorr,CredibleSetParam-method} +\alias{medianAbsCorr<-,CredibleSetParam-method} +\alias{includeAllCs,CredibleSetParam-method} +\alias{includeAllCs<-,CredibleSetParam-method} +\alias{perCsColumns,CredibleSetParam-method} +\alias{perCsColumns<-,CredibleSetParam-method} +\alias{maxNumSingleEffects,CredibleSetParam-method} +\alias{maxNumSingleEffectsGreedy,CredibleSetParam-method} \alias{CredibleSetParam-class} \alias{CredibleSetParam} \title{Credible-Set Construction And Reporting} \usage{ -getCoverage(x, ...) +csCoverage(x, ...) -setCoverage(x, value, ...) +csCoverage(x, ...) <- value -getSecondaryCoverage(x, ...) +secondaryCoverage(x, ...) -setSecondaryCoverage(x, value, ...) +secondaryCoverage(x, ...) <- value -getSignalCutoff(x, ...) +signalCutoff(x, ...) -setSignalCutoff(x, value, ...) +signalCutoff(x, ...) <- value -getMinAbsCorr(x, ...) +minAbsCorr(x, ...) -setMinAbsCorr(x, value, ...) +minAbsCorr(x, ...) <- value -getMedianAbsCorr(x, ...) +medianAbsCorr(x, ...) -setMedianAbsCorr(x, value, ...) +medianAbsCorr(x, ...) <- value -getIncludeAllCs(x, ...) +includeAllCs(x, ...) -setIncludeAllCs(x, value, ...) +includeAllCs(x, ...) <- value -getPerCsColumns(x, ...) +perCsColumns(x, ...) -setPerCsColumns(x, value, ...) +perCsColumns(x, ...) <- value -getL(x, ...) +maxNumSingleEffects(x, ...) -getLgreedy(x, ...) +maxNumSingleEffectsGreedy(x, ...) -\S4method{getCoverage}{CredibleSetParam}(x) +\S4method{csCoverage}{CredibleSetParam}(x) -\S4method{setCoverage}{CredibleSetParam}(x, value) +\S4method{csCoverage}{CredibleSetParam}(x) <- value -\S4method{getSecondaryCoverage}{CredibleSetParam}(x) +\S4method{secondaryCoverage}{CredibleSetParam}(x) -\S4method{setSecondaryCoverage}{CredibleSetParam}(x, value) +\S4method{secondaryCoverage}{CredibleSetParam}(x) <- value -\S4method{getSignalCutoff}{CredibleSetParam}(x) +\S4method{signalCutoff}{CredibleSetParam}(x) -\S4method{setSignalCutoff}{CredibleSetParam}(x, value) +\S4method{signalCutoff}{CredibleSetParam}(x) <- value -\S4method{getMinAbsCorr}{CredibleSetParam}(x) +\S4method{minAbsCorr}{CredibleSetParam}(x) -\S4method{setMinAbsCorr}{CredibleSetParam}(x, value) +\S4method{minAbsCorr}{CredibleSetParam}(x) <- value -\S4method{getMedianAbsCorr}{CredibleSetParam}(x) +\S4method{medianAbsCorr}{CredibleSetParam}(x) -\S4method{setMedianAbsCorr}{CredibleSetParam}(x, value) +\S4method{medianAbsCorr}{CredibleSetParam}(x) <- value -\S4method{getIncludeAllCs}{CredibleSetParam}(x) +\S4method{includeAllCs}{CredibleSetParam}(x) -\S4method{setIncludeAllCs}{CredibleSetParam}(x, value) +\S4method{includeAllCs}{CredibleSetParam}(x) <- value -\S4method{getPerCsColumns}{CredibleSetParam}(x) +\S4method{perCsColumns}{CredibleSetParam}(x) -\S4method{setPerCsColumns}{CredibleSetParam}(x, value) +\S4method{perCsColumns}{CredibleSetParam}(x) <- value -\S4method{getL}{CredibleSetParam}(x) +\S4method{maxNumSingleEffects}{CredibleSetParam}(x) -\S4method{getLgreedy}{CredibleSetParam}(x) +\S4method{maxNumSingleEffectsGreedy}{CredibleSetParam}(x) CredibleSetParam( coverage = 0.95, @@ -110,8 +110,8 @@ CredibleSetParam( medianAbsCorr = NULL, includeAllCs = FALSE, perCsColumns = c("none", "alpha", "full"), - L = 10L, - Lgreedy = NULL + maxNumSingleEffects = 10L, + maxNumSingleEffectsGreedy = NULL ) } \arguments{ @@ -147,21 +147,24 @@ 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 +\item{maxNumSingleEffects}{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. +\item{maxNumSingleEffectsGreedy}{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. + object, a \code{\link{MethodParam}}. Each accessor returns that + setting's value; each replacement form returns a modified copy. + \code{maxNumSingleEffects} and \code{maxNumSingleEffectsGreedy} have + no replacement form: 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 diff --git a/man/CtwasBoundaryGenesOptions.Rd b/man/CtwasBoundaryGenesOptions.Rd new file mode 100644 index 00000000..14e0a957 --- /dev/null +++ b/man/CtwasBoundaryGenesOptions.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasBoundaryGenesOptions} +\alias{CtwasBoundaryGenesOptions} +\title{Arguments For ctwas's Boundary-Gene Step} +\usage{ +CtwasBoundaryGenesOptions(...) +} +\arguments{ +\item{...}{Any \code{ctwas::get_boundary_genes()} argument, under ctwas's +own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{ctwas::get_boundary_genes()}, which + recovers the boundary genes \code{assemble_region_data()} computes but + does not return. +} +\examples{ +CtwasBoundaryGenesOptions(show_mapping = TRUE) +} diff --git a/man/CtwasEstParamOptions.Rd b/man/CtwasEstParamOptions.Rd new file mode 100644 index 00000000..55d0c7ff --- /dev/null +++ b/man/CtwasEstParamOptions.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasEstParamOptions} +\alias{CtwasEstParamOptions} +\title{Arguments For ctwas's Group-Prior EM} +\usage{ +CtwasEstParamOptions(...) +} +\arguments{ +\item{...}{Any argument of either EM entry point, under ctwas's own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for the EM that estimates ctwas's group priors. + Two callees, because the pipeline falls back from + \code{ctwas::est_param()} to ctwas's internal \code{fit_EM()} when the + accurate EM diverges; \code{fit_EM()} is not a subset of + \code{est_param()} (\code{groups}, \code{types}, \code{contexts}, + \code{warn_converge_fail} are its own), so the bundle is checked against + both and \code{.ctwasInvoke()} drops whichever the running step does not + take. +} +\examples{ +CtwasEstParamOptions(min_group_size = 1, EM_tol = 1e-4) +} diff --git a/man/CtwasExpandOptions.Rd b/man/CtwasExpandOptions.Rd new file mode 100644 index 00000000..9ac82eeb --- /dev/null +++ b/man/CtwasExpandOptions.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasExpandOptions} +\alias{CtwasExpandOptions} +\title{Arguments For ctwas's Region-Expansion Step} +\usage{ +CtwasExpandOptions(...) +} +\arguments{ +\item{...}{Any \code{ctwas::expand_region_data()} argument, under ctwas's +own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{ctwas::expand_region_data()}, run before + screening when the region data was assembled with \code{thin < 1}. +} +\examples{ +CtwasExpandOptions(maxSNP = 1000L) +} diff --git a/man/CtwasFinemapOptions.Rd b/man/CtwasFinemapOptions.Rd new file mode 100644 index 00000000..3975d971 --- /dev/null +++ b/man/CtwasFinemapOptions.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasFinemapOptions} +\alias{CtwasFinemapOptions} +\title{Arguments For ctwas's Fine-Mapping Step} +\usage{ +CtwasFinemapOptions(...) +} +\arguments{ +\item{...}{Any \code{ctwas::finemap_regions()} argument, under ctwas's own +names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{ctwas::finemap_regions()}. +} +\examples{ +CtwasFinemapOptions(min_abs_corr = 0.1, include_cs = TRUE) +} diff --git a/man/CtwasGeneZOptions.Rd b/man/CtwasGeneZOptions.Rd new file mode 100644 index 00000000..7465791d --- /dev/null +++ b/man/CtwasGeneZOptions.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasGeneZOptions} +\alias{CtwasGeneZOptions} +\title{Arguments For ctwas's Gene Z-Score Step} +\usage{ +CtwasGeneZOptions(...) +} +\arguments{ +\item{...}{Any \code{ctwas::compute_gene_z()} argument, under ctwas's own +names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{ctwas::compute_gene_z()}, which derives + gene-level z-scores from the SNP z-scores and the TWAS weights. +} +\examples{ +CtwasGeneZOptions(logfile = "gene-z.log") +} diff --git a/man/CtwasMergeOptions.Rd b/man/CtwasMergeOptions.Rd new file mode 100644 index 00000000..9a837804 --- /dev/null +++ b/man/CtwasMergeOptions.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasMergeOptions} +\alias{CtwasMergeOptions} +\title{Arguments For ctwas's Region-Merging Postprocess} +\usage{ +CtwasMergeOptions(...) +} +\arguments{ +\item{...}{Any argument of the merging postprocess, or of the fine-mapping +rerun it forwards to, under ctwas's own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{ctwas::postprocess_region_merging()} (or + its \code{_noLD} twin, whose formals are a strict subset). + + The accepted set is deliberately WIDER than those functions' own + formals: both of them forward \code{...} into a fine-mapping rerun for + the merged regions, so \code{ctwas::finemap_regions()}'s formals are + legitimate here too --- twelve names (\code{min_abs_corr}, + \code{include_cs}, \code{coverage}, ...) reach the rerun and nothing + else. That is why this step's call must NOT be filtered down to the + merge function's explicit formals. +} +\examples{ +CtwasMergeOptions(combine_PIPs = TRUE, min_abs_corr = 0.1) +} diff --git a/man/CtwasOptions.Rd b/man/CtwasOptions.Rd index 2488d130..d3becd86 100644 --- a/man/CtwasOptions.Rd +++ b/man/CtwasOptions.Rd @@ -4,29 +4,62 @@ \alias{CtwasOptions} \title{Arguments For The ctwas Fitting Steps} \usage{ -CtwasOptions(...) +CtwasOptions( + geneZ = CtwasGeneZOptions(), + regionData = CtwasRegionDataOptions(), + estParam = CtwasEstParamOptions(), + screen = CtwasScreenOptions(), + expand = CtwasExpandOptions(), + finemap = CtwasFinemapOptions(), + merge = CtwasMergeOptions(), + boundaryGenes = CtwasBoundaryGenesOptions() +) } \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.} +\item{geneZ}{Arguments for \code{ctwas::compute_gene_z()}, built with +\code{\link{CtwasGeneZOptions}}.} + +\item{regionData}{Arguments for \code{ctwas::assemble_region_data()}, +built with \code{\link{CtwasRegionDataOptions}}.} + +\item{estParam}{Arguments for the group-prior EM, built with +\code{\link{CtwasEstParamOptions}}.} + +\item{screen}{Arguments for \code{ctwas::screen_regions()}, built with +\code{\link{CtwasScreenOptions}}.} + +\item{expand}{Arguments for \code{ctwas::expand_region_data()}, built with +\code{\link{CtwasExpandOptions}}.} + +\item{finemap}{Arguments for \code{ctwas::finemap_regions()}, built with +\code{\link{CtwasFinemapOptions}}.} + +\item{merge}{Arguments for the region-merging postprocess, built with +\code{\link{CtwasMergeOptions}}.} + +\item{boundaryGenes}{Arguments for \code{ctwas::get_boundary_genes()}, +built with \code{\link{CtwasBoundaryGenesOptions}}.} } \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. +ctwas is not one function but nine, run in sequence, so each + step's arguments travel in their own bundle and are checked against that + step's own live formals --- the same shape as + \code{\link{CovUdrOptions}}. + + This replaces a single flat bundle that was checked against the + \emph{union} of every step's formals. That mirrored ctwas's own + \code{ctwas_sumstats}, which takes forty arguments in one signature, but + it could not tell which step a name was meant for: of the 55 names in + the union, 29 are accepted by exactly one step, so a name aimed at the + wrong step was accepted and then silently dropped. Per-step bundles make + that a construction-time error instead. } \examples{ -CtwasOptions(min_group_size = 1, min_gene = 1) +CtwasOptions( + estParam = CtwasEstParamOptions(min_group_size = 1), + screen = CtwasScreenOptions(min_gene = 1) +) } diff --git a/man/CtwasRegionDataOptions.Rd b/man/CtwasRegionDataOptions.Rd new file mode 100644 index 00000000..8563e93d --- /dev/null +++ b/man/CtwasRegionDataOptions.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasRegionDataOptions} +\alias{CtwasRegionDataOptions} +\title{Arguments For ctwas's Region-Assembly Step} +\usage{ +CtwasRegionDataOptions(...) +} +\arguments{ +\item{...}{Any \code{ctwas::assemble_region_data()} argument, under +ctwas's own names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{ctwas::assemble_region_data()}, which + builds the per-region list the EM and fine-mapping steps consume. + + This step was absent from the flat bundle's callee set, so four of its + real options --- \code{trim_by}, \code{thin_by}, + \code{adjust_boundary_genes}, \code{seed} --- were rejected as unknown + even though the pipeline does call it. +} +\examples{ +CtwasRegionDataOptions(trim_by = "z", seed = 1L) +} diff --git a/man/CtwasResult.Rd b/man/CtwasResult.Rd index 12596e06..aa22f6f2 100644 --- a/man/CtwasResult.Rd +++ b/man/CtwasResult.Rd @@ -6,7 +6,7 @@ \usage{ CtwasResult( gwasStudy, - study, + studyName, context, method, entry, @@ -17,7 +17,7 @@ CtwasResult( \arguments{ \item{gwasStudy}{Character vector of GWAS (disease) study identifiers.} -\item{study}{Character vector of QTL study identifiers.} +\item{studyName}{Character vector of QTL study identifiers.} \item{context}{Character vector of context labels (scalar per row).} @@ -44,9 +44,9 @@ Construct a \code{CtwasResult} DFrame-subclass collection of } \examples{ cre <- CtwasResultEntry( - finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), + posteriors = 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))) -cr <- CtwasResult(gwasStudy = "gwas1", study = "s1", context = "brain", +cr <- CtwasResult(gwasStudy = "gwas1", studyName = "s1", context = "brain", method = "susie", entry = list(cre)) cr } diff --git a/man/CtwasResultEntry-class.Rd b/man/CtwasResultEntry-class.Rd index 91f29e25..f6890474 100644 --- a/man/CtwasResultEntry-class.Rd +++ b/man/CtwasResultEntry-class.Rd @@ -13,7 +13,8 @@ Per-run cTWAS payload: the fine-mapping posterior table, the \section{Slots}{ \describe{ -\item{\code{finemap}}{The per-gene (and, when SNPs are retained, per-SNP) posterior +\item{\code{posteriors}}{The per-gene (and, when SNPs are retained, +per-SNP) posterior summary table (\code{ctwas::finemap_regions} \code{finemap_res} shape), or \code{NULL}.} diff --git a/man/CtwasResultEntry.Rd b/man/CtwasResultEntry.Rd index 25c807ce..68e34148 100644 --- a/man/CtwasResultEntry.Rd +++ b/man/CtwasResultEntry.Rd @@ -5,14 +5,15 @@ \title{Create a CtwasResultEntry} \usage{ CtwasResultEntry( - finemap = NULL, + posteriors = NULL, susieAlpha = NULL, groupPriors = NULL, regionInfo = NULL ) } \arguments{ -\item{finemap}{The per-gene (and, when SNPs are retained, per-SNP) posterior +\item{posteriors}{The per-gene (and, when SNPs are retained, +per-SNP) posterior summary table (\code{ctwas::finemap_regions} \code{finemap_res} shape), or \code{NULL}.} @@ -37,7 +38,7 @@ Per-run cTWAS payload wrapping the fine-mapping posterior table, } \examples{ cre <- CtwasResultEntry( - finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), + posteriors = 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))) cre } diff --git a/man/CtwasScreenOptions.Rd b/man/CtwasScreenOptions.Rd new file mode 100644 index 00000000..69d89db3 --- /dev/null +++ b/man/CtwasScreenOptions.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ctwasWrapper.R +\name{CtwasScreenOptions} +\alias{CtwasScreenOptions} +\title{Arguments For ctwas's Region-Screening Step} +\usage{ +CtwasScreenOptions(...) +} +\arguments{ +\item{...}{Any \code{ctwas::screen_regions()} argument, under ctwas's own +names.} +} +\value{ +A \code{\link{MethodOptions}} object. +} +\description{ +Arguments for \code{ctwas::screen_regions()}. +} +\examples{ +CtwasScreenOptions(min_nonSNP_PIP = 0, min_gene = 1) +} diff --git a/man/FineMappingMethodsParam.Rd b/man/FineMappingMethodsParam.Rd index 82dd7289..2f5cf35d 100644 --- a/man/FineMappingMethodsParam.Rd +++ b/man/FineMappingMethodsParam.Rd @@ -44,9 +44,11 @@ Selects the methods \code{\link{fineMappingPipeline}} runs and } \examples{ FineMappingMethodsParam(methods = "susie") -FineMappingMethodsParam(methods = list(susie = SusieOptions(L = 20))) FineMappingMethodsParam( - qtlDatasetMethods = list(susie = SusieOptions(L = 20)), - qtlSumStatsMethods = list(susie = SusieRssOptions(L = 20)) + methods = list(susie = SusieOptions(max_iter = 200)) +) +FineMappingMethodsParam( + qtlDatasetMethods = list(susie = SusieOptions(max_iter = 200)), + qtlSumStatsMethods = list(susie = SusieRssOptions(max_iter = 200)) ) } diff --git a/man/GwasFineMappingParam.Rd b/man/GwasFineMappingParam.Rd index f29fbef8..eafabfd9 100644 --- a/man/GwasFineMappingParam.Rd +++ b/man/GwasFineMappingParam.Rd @@ -1,91 +1,91 @@ % 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} +\name{fineMappingMethods} +\alias{fineMappingMethods} +\alias{fineMappingMethods<-} +\alias{credibleSetParam} +\alias{credibleSetParam<-} +\alias{susieRssParam} +\alias{susieRssParam<-} +\alias{panelFilterParam} +\alias{panelFilterParam<-} +\alias{initializeWithSusieInf} +\alias{initializeWithSusieInf<-} +\alias{fitRetention} +\alias{fitRetention<-} \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} +\alias{fineMappingMethods,GwasFineMappingParam-method} +\alias{fineMappingMethods<-,GwasFineMappingParam-method} +\alias{credibleSetParam,GwasFineMappingParam-method} +\alias{credibleSetParam<-,GwasFineMappingParam-method} +\alias{susieRssParam,GwasFineMappingParam-method} +\alias{susieRssParam<-,GwasFineMappingParam-method} +\alias{panelFilterParam,GwasFineMappingParam-method} +\alias{panelFilterParam<-,GwasFineMappingParam-method} +\alias{initializeWithSusieInf,GwasFineMappingParam-method} +\alias{initializeWithSusieInf<-,GwasFineMappingParam-method} +\alias{fitRetention,GwasFineMappingParam-method} +\alias{fitRetention<-,GwasFineMappingParam-method} \title{Inline GWAS Fine-Mapping Settings} \usage{ -getFineMappingMethods(x, ...) +fineMappingMethods(x, ...) -setFineMappingMethods(x, value, ...) +fineMappingMethods(x, ...) <- value -getCredibleSetArgs(x, ...) +credibleSetParam(x, ...) -setCredibleSetArgs(x, value, ...) +credibleSetParam(x, ...) <- value -getRssArgs(x, ...) +susieRssParam(x, ...) -setRssArgs(x, value, ...) +susieRssParam(x, ...) <- value -getPanelFilterArgs(x, ...) +panelFilterParam(x, ...) -setPanelFilterArgs(x, value, ...) +panelFilterParam(x, ...) <- value -getAddSusieInf(x, ...) +initializeWithSusieInf(x, ...) -setAddSusieInf(x, value, ...) +initializeWithSusieInf(x, ...) <- value -getFitRetention(x, ...) +fitRetention(x, ...) -setFitRetention(x, value, ...) +fitRetention(x, ...) <- value GwasFineMappingParam( methods = "susie", - credibleSetArgs = CredibleSetParam(), - rssArgs = SusieRssParam(), - panelFilterArgs = PanelFilterParam(), - addSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), + susieRssParam = SusieRssParam(), + panelFilterParam = PanelFilterParam(), + initializeWithSusieInf = TRUE, fitRetention = c("slim", "full") ) -\S4method{getFineMappingMethods}{GwasFineMappingParam}(x) +\S4method{fineMappingMethods}{GwasFineMappingParam}(x) -\S4method{setFineMappingMethods}{GwasFineMappingParam}(x, value) +\S4method{fineMappingMethods}{GwasFineMappingParam}(x) <- value -\S4method{getCredibleSetArgs}{GwasFineMappingParam}(x) +\S4method{credibleSetParam}{GwasFineMappingParam}(x) -\S4method{setCredibleSetArgs}{GwasFineMappingParam}(x, value) +\S4method{credibleSetParam}{GwasFineMappingParam}(x) <- value -\S4method{getRssArgs}{GwasFineMappingParam}(x) +\S4method{susieRssParam}{GwasFineMappingParam}(x) -\S4method{setRssArgs}{GwasFineMappingParam}(x, value) +\S4method{susieRssParam}{GwasFineMappingParam}(x) <- value -\S4method{getPanelFilterArgs}{GwasFineMappingParam}(x) +\S4method{panelFilterParam}{GwasFineMappingParam}(x) -\S4method{setPanelFilterArgs}{GwasFineMappingParam}(x, value) +\S4method{panelFilterParam}{GwasFineMappingParam}(x) <- value -\S4method{getAddSusieInf}{GwasFineMappingParam}(x) +\S4method{initializeWithSusieInf}{GwasFineMappingParam}(x) -\S4method{setAddSusieInf}{GwasFineMappingParam}(x, value) +\S4method{initializeWithSusieInf}{GwasFineMappingParam}(x) <- value -\S4method{getFitRetention}{GwasFineMappingParam}(x) +\S4method{fitRetention}{GwasFineMappingParam}(x) -\S4method{setFitRetention}{GwasFineMappingParam}(x, value) +\S4method{fitRetention}{GwasFineMappingParam}(x) <- value } \arguments{ \item{x}{A \code{GwasFineMappingParam}.} @@ -97,22 +97,23 @@ GwasFineMappingParam( \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 +\item{credibleSetParam}{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 +\item{susieRssParam}{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 +\item{panelFilterParam}{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{initializeWithSusieInf}{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 @@ -122,9 +123,9 @@ 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. + Each accessor returns that setting's value --- for the three nested + bundles, the \code{MethodParam} itself --- and each replacement form + returns a modified copy. } \description{ How \code{\link{colocPipeline}} fine-maps \code{gwasInput} @@ -140,5 +141,7 @@ How \code{\link{colocPipeline}} fine-maps \code{gwasInput} fine-mapping result, since no fit is run. } \examples{ -GwasFineMappingParam(credibleSet = CredibleSetParam(coverage = 0.9)) +GwasFineMappingParam( + credibleSetParam = CredibleSetParam(coverage = 0.9) +) } diff --git a/man/GwasFineMappingResult.Rd b/man/GwasFineMappingResult.Rd index 7d6bdcb3..99a3d45a 100644 --- a/man/GwasFineMappingResult.Rd +++ b/man/GwasFineMappingResult.Rd @@ -5,7 +5,7 @@ \title{Create a GwasFineMappingResult Collection} \usage{ GwasFineMappingResult( - study, + studyName, method, entry, blockId = NULL, @@ -14,7 +14,7 @@ GwasFineMappingResult( ) } \arguments{ -\item{study}{Character vector of study identifiers (per tuple).} +\item{studyName}{Character vector of study identifiers (per tuple).} \item{method}{Character vector of fine-mapping method names (per tuple).} @@ -53,5 +53,5 @@ tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) fe <- fineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl) -GwasFineMappingResult(study = "t1", method = "susie", entry = list(fe)) +GwasFineMappingResult(studyName = "t1", method = "susie", entry = list(fe)) } diff --git a/man/GwasSumStats.Rd b/man/GwasSumStats.Rd index 1eef6785..702189f0 100644 --- a/man/GwasSumStats.Rd +++ b/man/GwasSumStats.Rd @@ -5,7 +5,7 @@ \title{Create a GwasSumStats Collection Object} \usage{ GwasSumStats( - study, + studyName, entry, genome, ldSketch = NULL, @@ -20,7 +20,7 @@ GwasSumStats( ) } \arguments{ -\item{study}{Character vector of study identifiers (must be unique).} +\item{studyName}{Character vector of study identifiers (must be unique).} \item{entry}{A \code{SimpleList} or \code{list} of \code{GRanges}, one per study.} @@ -48,13 +48,13 @@ in a mixed collection). For case/control GWAS, downstream consumers (e.g. \code{NULL}). Attached only when supplied (length 1 or length(study)). Used as the study-level fallback for the per-variant \code{N} when a study has no per-variant \code{N} column and no case/control counts. Named -\code{nSample} to avoid clashing with \code{getNSamples()} (the LD-panel +\code{nSample} to avoid clashing with \code{nSamples()} (the LD-panel sample size).} \item{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 -\code{length(getQcInfo(x)) == 0}.} +\code{length(qcInfo(x)) == 0}.} \item{ldBlocks}{Optional LD-block specification: an \code{LdBlocks}, a \code{GRanges}, a data.frame with \code{chrom}/\code{start}/\code{end} @@ -99,6 +99,6 @@ panel <- readGenotypes( gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100 * 1:3, width = 1)) S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:3), A1 = "A", A2 = "G", Z = rnorm(3), N = 100L) -GwasSumStats(study = "t1", entry = list(gr), genome = "hg38", +GwasSumStats(studyName = "t1", entry = list(gr), genome = "hg38", ldSketch = panel) } diff --git a/man/H2Estimate-class.Rd b/man/H2Estimate-class.Rd index bb86a283..ab2dc58c 100644 --- a/man/H2Estimate-class.Rd +++ b/man/H2Estimate-class.Rd @@ -11,25 +11,36 @@ Container for univariate heritability estimation results. Holds \section{Slots}{ \describe{ -\item{\code{h2}}{Numeric, global SNP heritability estimate.} +\item{\code{estimate}}{Numeric, global SNP heritability estimate.} -\item{\code{h2Se}}{Numeric, standard error of global h2.} +\item{\code{estimateSe}}{Numeric, standard error of global h2.} \item{\code{intercept}}{Numeric, confounding intercept estimate (NA if method does not estimate one).} \item{\code{interceptSe}}{Numeric, SE of intercept.} -\item{\code{local}}{A \code{data.frame} with per-block local heritability estimates +\item{\code{localBlocks}}{A \code{data.frame} with per-block local +heritability estimates (columns: \code{blockId}, \code{h2Local}, \code{h2LocalSe}). NULL if \code{local = FALSE}.} -\item{\code{enrichment}}{A \code{data.frame} with baseline annotation enrichment -estimates (columns: \code{annotation}, \code{tau}, \code{tauSe}, -\code{enrichment}, \code{enrichmentSe}, \code{enrichmentP}, \code{propH2}, -\code{propSnps}). NULL if unstratified.} +\item{\code{enrichment}}{A \code{data.frame} of per-annotation enrichment results, +NULL if unstratified. Two shapes are possible, depending on which route +produced the estimate: +\describe{ + \item{partitioned}{tau-based enrichment of the baseline annotations + (\code{computeBaselineEnrichment}, \code{.gldscEnrichmentDf}), with + columns \code{annotation}, \code{tau}, \code{tauSe}, + \code{enrichment}, \code{enrichmentSe}, \code{enrichmentP}, + \code{propH2}, \code{propSnps}.} + \item{score test}{the score test over the tested (candidate) + annotations, with columns \code{annotation}, \code{scoreZ}, + \code{scoreP}.} +}} -\item{\code{tauBlocks}}{A numeric matrix (nBlocks x n_annotations) of per-block +\item{\code{annotationJackknifeCoefs}}{A numeric matrix +(nBlocks x n_annotations) of per-block jackknife tau values. Required for Gazal tauStar standardization downstream. NULL if not available (e.g., unstratified analysis).} diff --git a/man/LdData-class.Rd b/man/LdData-class.Rd index 7990cb4e..86f4e44a 100644 --- a/man/LdData-class.Rd +++ b/man/LdData-class.Rd @@ -65,13 +65,13 @@ 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.} +\item{\code{nSamples}}{Integer, reference panel sample size.} \item{\code{mixtureWeights}}{NULL when \code{genotypeHandle} is a single \code{GenotypeHandle}; a numeric vector of mixing proportions (one per panel, summing to 1) when \code{genotypeHandle} is a list of -\code{GenotypeHandle}s. Used by \code{getCorrelation()} to compute a +\code{GenotypeHandle}s. Used by \code{ldMatrix()} to compute a weighted-average mixture LD matrix; required whenever \code{genotypeHandle} -is a list and \code{getCorrelation()} will be called.} +is a list and \code{ldMatrix()} will be called.} }} diff --git a/man/LdData.Rd b/man/LdData.Rd index 81700665..a491ecdb 100644 --- a/man/LdData.Rd +++ b/man/LdData.Rd @@ -10,7 +10,7 @@ LdData( snpIdx = NULL, variants, blockMetadata, - nRef = 0L, + nSamples = 0L, mixtureWeights = NULL ) } @@ -33,12 +33,12 @@ single block is derived from \code{variants}, so a bare genomic span 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.} +\item{nSamples}{Integer, reference panel sample size.} \item{mixtureWeights}{Optional numeric vector of mixing proportions, one per panel in \code{genotypeHandle} when it is a list. Must be non-negative and sum to 1. Required whenever \code{genotypeHandle} is a list and downstream -code will call \code{getCorrelation()}.} +code will call \code{ldMatrix()}.} } \value{ An \code{LdData} object. diff --git a/man/LdEigen.Rd b/man/LdEigen.Rd index a91927f9..3b99a891 100644 --- a/man/LdEigen.Rd +++ b/man/LdEigen.Rd @@ -8,7 +8,7 @@ LdEigen( snpInfo, eigenList, ldBlocks, - nRef, + nSamples, inSample = FALSE, genome = NA_character_, eigenvalueTruncation = 1 @@ -22,7 +22,7 @@ LdEigen( \item{ldBlocks}{A \code{GRanges} of LD block intervals.} -\item{nRef}{Integer, sample size of the LD reference panel.} +\item{nSamples}{Integer, sample size of the LD reference panel.} \item{inSample}{Logical, whether the reference is the GWAS cohort.} @@ -47,7 +47,7 @@ mkBlock <- function(idx) list(values = rep(1, length(idx)), vectors = diag(length(idx)), snpIdx = idx) le <- LdEigen(snpInfo = snpInfo, eigenList = list(mkBlock(1:2), mkBlock(3:4)), - ldBlocks = blocks, nRef = 100L, genome = "hg19") + ldBlocks = blocks, nSamples = 100L, genome = "hg19") length(le) -length(getEigenList(le)) +length(eigenList(le)) } diff --git a/man/LdScore.Rd b/man/LdScore.Rd index 8c9e86bd..6b9f1a18 100644 --- a/man/LdScore.Rd +++ b/man/LdScore.Rd @@ -9,7 +9,7 @@ LdScore( ldScores, ldScoreWeights, ldBlocks, - nRef, + nSamples, inSample = FALSE, genome = NA_character_, ldMatrixList = list() @@ -27,7 +27,7 @@ annotation-stratified scores.} \item{ldBlocks}{A \code{GRanges} of LD block intervals.} -\item{nRef}{Integer, sample size of the LD reference panel.} +\item{nSamples}{Integer, sample size of the LD reference panel.} \item{inSample}{Logical, whether the reference is the GWAS cohort.} @@ -48,8 +48,8 @@ blocks <- GenomicRanges::GRanges("chr1", IRanges::IRanges(c(1L, 200L), c(199L, 400L))) ls <- LdScore(snpInfo = snpInfo, ldScores = matrix(runif(4), ncol = 1, dimnames = list(NULL, "base_l2")), - ldScoreWeights = rep(1, 4), ldBlocks = blocks, nRef = 100L, + ldScoreWeights = rep(1, 4), ldBlocks = blocks, nSamples = 100L, inSample = FALSE, genome = "hg19") length(ls) -head(getLdScores(ls)) +head(S4Vectors::mcols(ls)$ldScores) } diff --git a/man/LdStatistic-class.Rd b/man/LdStatistic-class.Rd index 22ffee77..723fbded 100644 --- a/man/LdStatistic-class.Rd +++ b/man/LdStatistic-class.Rd @@ -21,7 +21,7 @@ Abstract container for pre-computed LD statistics. Subclasses \describe{ \item{\code{ldBlocks}}{A \code{GRanges} of LD block intervals.} -\item{\code{nRef}}{Integer, sample size of the LD reference panel.} +\item{\code{nSamples}}{Integer, sample size of the LD reference panel.} \item{\code{inSample}}{Logical, whether the LD reference is from the same cohort as the GWAS (affects bias correction).} diff --git a/man/MultiStudyQtlDataset.Rd b/man/MultiStudyQtlDataset.Rd index 629c3637..e42218f5 100644 --- a/man/MultiStudyQtlDataset.Rd +++ b/man/MultiStudyQtlDataset.Rd @@ -40,10 +40,10 @@ se <- SummarizedExperiment::SummarizedExperiment( rowRanges = rng ) qd1 <- QtlDataset( - study = "s1", genotypes = panel, phenotypes = list(brain = se) + studyName = "s1", genotypes = panel, phenotypes = list(brain = se) ) qd2 <- QtlDataset( - study = "s2", genotypes = panel, phenotypes = list(brain = se) + studyName = "s2", genotypes = panel, phenotypes = list(brain = se) ) MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) } diff --git a/man/QtlDataset-class.Rd b/man/QtlDataset-class.Rd index d9d45717..bbe98236 100644 --- a/man/QtlDataset-class.Rd +++ b/man/QtlDataset-class.Rd @@ -87,7 +87,7 @@ than one of the things being chosen between, so it is always retained. \section{Slots}{ \describe{ -\item{\code{study}}{Character (length 1). Study identifier; used in collection +\item{\code{studyName}}{Character (length 1). Study identifier; used in collection classes to tag downstream \code{FineMappingResult} / \code{TwasWeights} entries. The \code{genotype} experiment's assay reads through this handle; the @@ -99,7 +99,7 @@ scale residuals to unit variance.} \item{\code{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 +\code{genotypes()} / \code{residualizedGenotypes()}. Default 0 (no filter).} \item{\code{macCutoff}}{Numeric (length 1). Minor allele count threshold; converted diff --git a/man/QtlDataset.Rd b/man/QtlDataset.Rd index ebbf3c88..3fa67fbd 100644 --- a/man/QtlDataset.Rd +++ b/man/QtlDataset.Rd @@ -5,16 +5,16 @@ \title{Create a QtlDataset Object} \usage{ QtlDataset( - study, + studyName, genotypes, phenotypes, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0), scaleResiduals = TRUE, - genotypeFilterArgs = GenotypeFilterParam() + genotypeFilterParam = GenotypeFilterParam() ) } \arguments{ -\item{study}{Character (length 1). Study identifier.} +\item{studyName}{Character (length 1). Study identifier.} \item{genotypes}{A genotype panel (see \code{\link{readGenotypes}}).} @@ -29,11 +29,11 @@ genotype experiment.} \item{scaleResiduals}{Logical (length 1). Default \code{TRUE}.} -\item{genotypeFilterArgs}{Which variants and samples to keep, built with +\item{genotypeFilterParam}{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()}: +lazily, at extraction time inside \code{genotypes()} / +\code{residualizedGenotypes()}: \itemize{ \item \code{mafCutoff} --- drop variants with \code{MAF < mafCutoff}. Unset means 0 (no filter). @@ -82,5 +82,7 @@ se <- SummarizedExperiment::SummarizedExperiment( )), rowRanges = rng ) -QtlDataset(study = "s1", genotypes = panel, phenotypes = list(brain = se)) +QtlDataset( + studyName = "s1", genotypes = panel, phenotypes = list(brain = se) +) } diff --git a/man/QtlFineMappingResult.Rd b/man/QtlFineMappingResult.Rd index 3018e191..8736c3dc 100644 --- a/man/QtlFineMappingResult.Rd +++ b/man/QtlFineMappingResult.Rd @@ -5,7 +5,7 @@ \title{Create a QtlFineMappingResult Collection} \usage{ QtlFineMappingResult( - study, + studyName, context, trait, method, @@ -18,7 +18,7 @@ QtlFineMappingResult( ) } \arguments{ -\item{study}{Character vector of study identifiers (per tuple). Use the +\item{studyName}{Character vector of study identifiers (per tuple). Use the sentinel \code{"joint"} for rows produced by a cross-study joint fit.} \item{context}{Character vector of context labels (per tuple). Use @@ -65,6 +65,6 @@ tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) fe <- fineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl) -QtlFineMappingResult(study = "s1", context = "brain", trait = "g1", +QtlFineMappingResult(studyName = "s1", context = "brain", trait = "g1", method = "susie", entry = list(fe)) } diff --git a/man/QtlSumStats.Rd b/man/QtlSumStats.Rd index d3fb4ea0..5408fde1 100644 --- a/man/QtlSumStats.Rd +++ b/man/QtlSumStats.Rd @@ -5,7 +5,7 @@ \title{Create a QtlSumStats Collection Object} \usage{ QtlSumStats( - study, + studyName, context, trait, entry, @@ -19,7 +19,7 @@ QtlSumStats( ) } \arguments{ -\item{study}{Character vector of study identifiers (per tuple).} +\item{studyName}{Character vector of study identifiers (per tuple).} \item{context}{Character vector of context labels (per tuple).} @@ -42,14 +42,14 @@ carrying the LD reference.} \code{NULL}). Attached only when supplied (length 1 or length(study)). Used as the study-level fallback for the per-variant \code{N} when a tuple has no per-variant \code{N} column. Named \code{nSample} to avoid clashing with -\code{getNSamples()} (the LD-panel sample size). Unlike GWAS, QTL +\code{nSamples()} (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.} \item{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 -\code{length(getQcInfo(x)) == 0}.} +\code{length(qcInfo(x)) == 0}.} \item{traitPos}{Optional per-row trait genomic anchor (a \code{GRanges} or \code{NULL}), carried forward as provenance; not part of the identity key. @@ -79,6 +79,6 @@ panel <- readGenotypes( gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100 * 1:3, width = 1)) S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:3), A1 = "A", A2 = "G", Z = rnorm(3), N = 100L) -QtlSumStats(study = "s1", context = "brain", trait = "g1", entry = list(gr), - genome = "hg38", ldSketch = panel) +QtlSumStats(studyName = "s1", context = "brain", trait = "g1", entry = + list(gr), genome = "hg38", ldSketch = panel) } diff --git a/man/SldscData-class.Rd b/man/SldscData-class.Rd index c814b811..4bab0365 100644 --- a/man/SldscData-class.Rd +++ b/man/SldscData-class.Rd @@ -15,11 +15,11 @@ An in-memory bundle of the loaded S-LDSC inputs, produced from \section{Slots}{ \describe{ -\item{\code{annot}}{A \code{data.frame} of target annotations with at least +\item{\code{annotData}}{A \code{data.frame} of target annotations with at least \code{CHR} and \code{SNP} columns plus one or more annotation columns (\code{BP}/\code{CM} optional).} -\item{\code{frq}}{A \code{data.frame} of reference-panel allele frequencies with +\item{\code{frqData}}{A \code{data.frame} of reference-panel allele frequencies with \code{SNP} and \code{MAF} columns (a 0-row frame when no \code{.frq} data was supplied).} diff --git a/man/SldscData.Rd b/man/SldscData.Rd index 6775f704..1488bb56 100644 --- a/man/SldscData.Rd +++ b/man/SldscData.Rd @@ -5,16 +5,17 @@ \alias{show,SldscData-method} \title{Construct an SldscData object} \usage{ -SldscData(annot, frq = NULL, traits = list()) +SldscData(annotData, frqData = NULL, traits = list()) \S4method{show}{SldscData}(object) } \arguments{ -\item{annot}{A target-annotation \code{data.frame} (e.g. from +\item{annotData}{A target-annotation \code{data.frame} (e.g. from \code{\link{readSldscAnnot}}): \code{CHR}, \code{SNP}, and one or more annotation columns.} -\item{frq}{Optional reference-panel allele-frequency \code{data.frame} (e.g. +\item{frqData}{Optional reference-panel allele-frequency +\code{data.frame} (e.g. from \code{\link{readSldscFrq}}): \code{SNP}, \code{MAF}. \code{NULL} (the default) stores an empty frame, which disables MAF-based filtering.} @@ -41,8 +42,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -54,7 +55,7 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) sd } \seealso{ diff --git a/man/SumStatsBase-class.Rd b/man/SumStatsBase-class.Rd index 1f3f2ea5..f433c152 100644 --- a/man/SumStatsBase-class.Rd +++ b/man/SumStatsBase-class.Rd @@ -28,7 +28,7 @@ validate its presence when they consume the collection.} on construction; populated by \code{summaryStatsQc()} with a per-step audit record (filter names, drop counts, liftover target, RAISS settings, etc.). Fine-mapping and TWAS-weights pipelines reject inputs where -\code{length(getQcInfo(x)) == 0L} -- the slot serves as both the gating +\code{length(qcInfo(x)) == 0L} -- the slot serves as both the gating flag and the audit trail.} }} diff --git a/man/TwasWeights.Rd b/man/TwasWeights.Rd index 9b69b689..338c0046 100644 --- a/man/TwasWeights.Rd +++ b/man/TwasWeights.Rd @@ -5,7 +5,7 @@ \title{Create a TwasWeights Collection Object} \usage{ TwasWeights( - study, + studyName, context, trait, method, @@ -18,7 +18,7 @@ TwasWeights( ) } \arguments{ -\item{study}{Character vector of study identifiers. Use the sentinel +\item{studyName}{Character vector of study identifiers. Use the sentinel \code{"joint"} for rows produced by a cross-study joint fit.} \item{context}{Character vector of context labels. Use \code{"joint"} for @@ -59,8 +59,9 @@ Construct a \code{TwasWeights} DFrame-subclass collection from } \examples{ twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), - weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -tw <- TwasWeights(study = "s1", context = "brain", trait = "gene1", + weights = rep(0.1, 4), cvResult = list(rsq = 0.5), + weightStandardized = FALSE) +tw <- TwasWeights(studyName = "s1", context = "brain", trait = "gene1", method = "susie", entry = list(twe)) tw } diff --git a/man/TwasWeightsMethodsParam.Rd b/man/TwasWeightsMethodsParam.Rd index 6834f8ce..c389395a 100644 --- a/man/TwasWeightsMethodsParam.Rd +++ b/man/TwasWeightsMethodsParam.Rd @@ -46,7 +46,7 @@ Selects the methods \code{\link{twasWeightsPipeline}} runs and TwasWeightsMethodsParam(methods = list(lasso = list(), susie = list())) TwasWeightsMethodsParam( methods = list(susie = list()), - qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), + qtlDatasetMethods = list(lasso = GlmnetOptions(nfold = 5)), qtlSumStatsMethods = list(lasso = LassosumOptions()) ) } diff --git a/man/TwasWeightsRow-class.Rd b/man/TwasWeightsRow-class.Rd index ed593a03..dd800cbc 100644 --- a/man/TwasWeightsRow-class.Rd +++ b/man/TwasWeightsRow-class.Rd @@ -16,13 +16,13 @@ One row's worth of TWAS weights. Build one with \item{\code{weights}}{Per-variant weights, aligned to \code{variants}.} -\item{\code{fits}}{Per-method fit payload, or \code{NULL}.} +\item{\code{methodFits}}{Per-method fit payload, or \code{NULL}.} \item{\code{cvResult}}{Cross-validation payload, or \code{NULL}.} -\item{\code{standardized}}{Whether the weights are on the standardized scale.} +\item{\code{weightStandardized}}{Whether the weights are on the standardized scale.} -\item{\code{dataType}}{Optional data-type label.} +\item{\code{weightsDataType}}{Optional data-type label.} }} \seealso{ diff --git a/man/UdFitOptions.Rd b/man/UdFitOptions.Rd index ea8a57e8..c16fad16 100644 --- a/man/UdFitOptions.Rd +++ b/man/UdFitOptions.Rd @@ -9,7 +9,9 @@ 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()}.} +the rest of \code{udr::ud_fit_control_default()}. The one exception is +\code{lambda}, which pecotmr derives from the number of conditions and +so refuses here.} } \value{ A \code{\link{MethodOptions}} object. diff --git a/man/af.Rd b/man/af.Rd new file mode 100644 index 00000000..8551debc --- /dev/null +++ b/man/af.Rd @@ -0,0 +1,77 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/QtlDataset.R +\name{af} +\alias{af} +\alias{af,SumStatsBase-method} +\alias{af,QtlDataset-method} +\title{Get Effect-Allele Frequencies} +\usage{ +af(x, ...) + +\S4method{af}{SumStatsBase}( + x, + studyName = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) + +\S4method{af}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) +} +\arguments{ +\item{x}{A \code{QtlDataset}, \code{GwasSumStats} or \code{QtlSumStats} +object.} + +\item{...}{Class-specific selection arguments (e.g., \code{traitId}, +\code{region}, \code{cisWindow}, \code{samples} for \code{QtlDataset}).} + +\item{studyName}{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{sumStats}} (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{traitId}{Character or \code{NULL}. Molecular trait / feature identifier +to select; \code{NULL} matches all traits in the dataset.} + +\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{cisWindow}{Integer or \code{NULL}. Half-width (bp) of the cis window +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.} +} +\value{ +Named numeric vector of effect-allele frequencies (names are variant + IDs), or an empty vector when no variants are selected. +} +\description{ +Extract the directional effect-allele (A1) frequency vector + for a \code{QtlDataset}, or for one entry of a \code{GwasSumStats} / + \code{QtlSumStats} collection. Unlike \code{\link{maf}}, the value is + \emph{not} folded to the minor allele: it is the frequency of the + dosage-counted allele (A1, the effect allele), matching the allele the + marginal effect sizes and the fine-mapping \code{af} column report. For + a summary-statistic collection this is \code{NULL} when the source + carried no frequency column -- see \code{\link{variantColumnReplace}} + for supplying one afterwards. +} +\examples{ +data(qtlDatasetExample) +af(qtlDatasetExample) +data(qtlSumStatsExample) +af(qtlSumStatsExample) +} diff --git a/man/getAnnotCols.Rd b/man/annotCols.Rd similarity index 80% rename from man/getAnnotCols.Rd rename to man/annotCols.Rd index a1d80957..7be38707 100644 --- a/man/getAnnotCols.Rd +++ b/man/annotCols.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/SldscData.R -\name{getAnnotCols} -\alias{getAnnotCols} -\alias{getAnnotCols,SldscData-method} +\name{annotCols} +\alias{annotCols} +\alias{annotCols,SldscData-method} \title{Get the annotation column names from an SldscData} \usage{ -getAnnotCols(x) +annotCols(x) -\S4method{getAnnotCols}{SldscData}(x) +\S4method{annotCols}{SldscData}(x) } \arguments{ \item{x}{An \code{\link{SldscData}} object.} @@ -28,8 +28,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -41,6 +41,6 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) -getAnnotCols(sd) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +annotCols(sd) } diff --git a/man/getAnnotData.Rd b/man/annotData.Rd similarity index 81% rename from man/getAnnotData.Rd rename to man/annotData.Rd index 26cb7105..26e13383 100644 --- a/man/getAnnotData.Rd +++ b/man/annotData.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/SldscData.R -\name{getAnnotData} -\alias{getAnnotData} -\alias{getAnnotData,SldscData-method} +\name{annotData} +\alias{annotData} +\alias{annotData,SldscData-method} \title{Get the annotation table from an SldscData} \usage{ -getAnnotData(x) +annotData(x) -\S4method{getAnnotData}{SldscData}(x) +\S4method{annotData}{SldscData}(x) } \arguments{ \item{x}{An \code{\link{SldscData}} object.} @@ -28,8 +28,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -41,6 +41,6 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) -getAnnotData(sd) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +annotData(sd) } diff --git a/man/getTauBlocks.Rd b/man/annotationJackknifeCoefs.Rd similarity index 60% rename from man/getTauBlocks.Rd rename to man/annotationJackknifeCoefs.Rd index cba1525e..a86303d1 100644 --- a/man/getTauBlocks.Rd +++ b/man/annotationJackknifeCoefs.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getTauBlocks} -\alias{getTauBlocks} -\alias{getTauBlocks,H2Estimate-method} +\name{annotationJackknifeCoefs} +\alias{annotationJackknifeCoefs} +\alias{annotationJackknifeCoefs,H2Estimate-method} \title{Get Per-Block tau Matrix} \usage{ -getTauBlocks(x) +annotationJackknifeCoefs(x) -\S4method{getTauBlocks}{H2Estimate}(x) +\S4method{annotationJackknifeCoefs}{H2Estimate}(x) } \arguments{ \item{x}{An \code{H2Estimate}.} @@ -21,5 +21,5 @@ Return the per-block jackknife tau matrix carried by an } \examples{ data(h2EstimateExample) -getTauBlocks(h2EstimateExample) +annotationJackknifeCoefs(h2EstimateExample) } diff --git a/man/as.data.frame-ColocBoostResult-method.Rd b/man/as.data.frame-ColocBoostResult-method.Rd index 384bd569..caef690b 100644 --- a/man/as.data.frame-ColocBoostResult-method.Rd +++ b/man/as.data.frame-ColocBoostResult-method.Rd @@ -19,7 +19,7 @@ A data frame with one row per confidence set. \description{ Returns the set-level view. New code should call the view it wants (\code{\link{colocViews}}, - \code{\link{getColocBoostOutcomes}}). + \code{\link{colocBoostOutcomes}}). } \examples{ methods::existsMethod("as.data.frame", "ColocBoostResult") diff --git a/man/as.data.frame.GwasSumStats.Rd b/man/as.data.frame.GwasSumStats.Rd deleted file mode 100644 index 123c0e5e..00000000 --- a/man/as.data.frame.GwasSumStats.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/gwasSumStats.R -\name{as.data.frame.GwasSumStats} -\alias{as.data.frame.GwasSumStats} -\title{Convert GwasSumStats to data.frame} -\usage{ -\method{as.data.frame}{GwasSumStats}(x, row.names = NULL, optional = FALSE, study = NULL, ...) -} -\arguments{ -\item{x}{A \code{GwasSumStats} object.} - -\item{row.names}{Ignored (present for S3 generic compatibility).} - -\item{optional}{Ignored.} - -\item{study}{Character (length 1) study identifier. Optional when the -collection has a single row.} - -\item{...}{Ignored.} -} -\value{ -A data.frame. -} -\description{ -Extracts the per-variant statistics for one study (selected by - \code{study}) into a plain data.frame with columns SNP, CHR, BP, A1, A2, Z, - N (and any optional columns such as MAF, BETA, SE, P). -} diff --git a/man/assembleCtwasInputs.Rd b/man/assembleCtwasInputs.Rd index 3889b679..608970bb 100644 --- a/man/assembleCtwasInputs.Rd +++ b/man/assembleCtwasInputs.Rd @@ -16,7 +16,7 @@ assembleCtwasInputs( \arguments{ \item{gwasSumStats}{A \code{\link{GwasSumStats}} whose elements are LD blocks (at least two), keyed by its \code{blockId} column, with -\code{getQcInfo()} non-empty. Build it with +\code{qcInfo()} non-empty. Build it with \code{loadGwasSumStatsFromManifest(..., ldBlocks = )} and pass it through \code{\link{summaryStatsQc}}.} @@ -94,7 +94,7 @@ blocks <- GenomicRanges::GRanges("chr22", gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) gwasByRegion <- summaryStatsQc(gss, - panelFilter = PanelFilterParam(mafCutoff = 0.0025)) + panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) assembleCtwasInputs(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample)) } diff --git a/man/getBaseline.Rd b/man/baselineAnnotations.Rd similarity index 65% rename from man/getBaseline.Rd rename to man/baselineAnnotations.Rd index 2ed8fcaf..67cd54b1 100644 --- a/man/getBaseline.Rd +++ b/man/baselineAnnotations.Rd @@ -1,13 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AnnotationMatrix.R -\name{getBaseline} -\alias{getBaseline} +% Please edit documentation in R/AllGenerics.R, R/AnnotationMatrix.R +\name{baselineAnnotations} +\alias{baselineAnnotations} +\alias{baselineAnnotations,AnnotationMatrix-method} \title{Get Baseline Annotations} \usage{ -getBaseline(annot) +baselineAnnotations(x) + +\S4method{baselineAnnotations}{AnnotationMatrix}(x) } \arguments{ -\item{annot}{An \code{AnnotationMatrix} object.} +\item{x}{An \code{AnnotationMatrix} object.} } \value{ An \code{AnnotationMatrix} with only baseline annotations. @@ -24,5 +27,5 @@ annotations <- matrix(rbinom(50, 1, 0.3), 10, 5, meta <- data.frame(name = paste0("annot", 1:5), tier = "baseline", type = "binary") am <- AnnotationMatrix(annotations, snpRanges, annotationMeta = meta) -getBaseline(am) +baselineAnnotations(am) } diff --git a/man/bayesAWeights.Rd b/man/bayesAWeights.Rd index ec52cd31..86b6ec5b 100644 --- a/man/bayesAWeights.Rd +++ b/man/bayesAWeights.Rd @@ -4,7 +4,16 @@ \alias{bayesAWeights} \title{BayesA TWAS weights (t-distribution prior)} \usage{ -bayesAWeights(X, y, Z = NULL, methodArgs = QggOptions()) +bayesAWeights( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,6 +22,16 @@ bayesAWeights(X, y, Z = NULL, methodArgs = QggOptions()) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} +leaves the engine's own default.} + +\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} + +\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} + +\item{nthin}{Integer. Thinning interval for retained MCMC samples. +Default \code{5}.} + \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 diff --git a/man/bayesCWeights.Rd b/man/bayesCWeights.Rd index 7150b95b..17b9dfad 100644 --- a/man/bayesCWeights.Rd +++ b/man/bayesCWeights.Rd @@ -4,7 +4,17 @@ \alias{bayesCWeights} \title{BayesC TWAS weights (rounded-spike prior)} \usage{ -bayesCWeights(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) +bayesCWeights( + X, + y, + Z = NULL, + pi = 0.1, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -16,6 +26,16 @@ bayesCWeights(X, y, Z = NULL, pi = 0.1, methodArgs = QggOptions()) \item{pi}{Numeric in (0, 1). Prior proportion of non-null effects for the BayesC mixture. Default \code{0.1}.} +\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} +leaves the engine's own default.} + +\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} + +\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} + +\item{nthin}{Integer. Thinning interval for retained MCMC samples. +Default \code{5}.} + \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 diff --git a/man/bayesLWeights.Rd b/man/bayesLWeights.Rd index b94e320f..c6e9340d 100644 --- a/man/bayesLWeights.Rd +++ b/man/bayesLWeights.Rd @@ -4,7 +4,16 @@ \alias{bayesLWeights} \title{BayesL TWAS weights (Laplace prior, LASSO-equivalent)} \usage{ -bayesLWeights(X, y, Z = NULL, methodArgs = QggOptions()) +bayesLWeights( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,6 +22,16 @@ bayesLWeights(X, y, Z = NULL, methodArgs = QggOptions()) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} +leaves the engine's own default.} + +\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} + +\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} + +\item{nthin}{Integer. Thinning interval for retained MCMC samples. +Default \code{5}.} + \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 diff --git a/man/bayesNWeights.Rd b/man/bayesNWeights.Rd index 1f5bd7a7..0afa6c03 100644 --- a/man/bayesNWeights.Rd +++ b/man/bayesNWeights.Rd @@ -4,7 +4,16 @@ \alias{bayesNWeights} \title{BayesN TWAS weights (Gaussian prior, ridge-equivalent)} \usage{ -bayesNWeights(X, y, Z = NULL, methodArgs = QggOptions()) +bayesNWeights( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,6 +22,16 @@ bayesNWeights(X, y, Z = NULL, methodArgs = QggOptions()) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} +leaves the engine's own default.} + +\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} + +\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} + +\item{nthin}{Integer. Thinning interval for retained MCMC samples. +Default \code{5}.} + \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 diff --git a/man/bayesRWeights.Rd b/man/bayesRWeights.Rd index 10ecaab6..e1d31bbe 100644 --- a/man/bayesRWeights.Rd +++ b/man/bayesRWeights.Rd @@ -4,7 +4,16 @@ \alias{bayesRWeights} \title{BayesR TWAS weights (hierarchical mixture prior)} \usage{ -bayesRWeights(X, y, Z = NULL, methodArgs = QggOptions()) +bayesRWeights( + X, + y, + Z = NULL, + h2 = NULL, + nit = 5000, + nburn = 1000, + nthin = 5, + methodArgs = QggOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -13,6 +22,16 @@ bayesRWeights(X, y, Z = NULL, methodArgs = QggOptions()) \item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} +leaves the engine's own default.} + +\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} + +\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} + +\item{nthin}{Integer. Thinning interval for retained MCMC samples. +Default \code{5}.} + \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 diff --git a/man/getBlockMetadata.Rd b/man/blockMetadata.Rd similarity index 79% rename from man/getBlockMetadata.Rd rename to man/blockMetadata.Rd index fef30635..a210d0a4 100644 --- a/man/getBlockMetadata.Rd +++ b/man/blockMetadata.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{getBlockMetadata} -\alias{getBlockMetadata} -\alias{getBlockMetadata,LdData-method} +\name{blockMetadata} +\alias{blockMetadata} +\alias{blockMetadata,LdData-method} \title{Get Block Metadata} \usage{ -getBlockMetadata(x) +blockMetadata(x) -\S4method{getBlockMetadata}{LdData}(x) +\S4method{blockMetadata}{LdData}(x) } \arguments{ \item{x}{An \code{LdData}.} @@ -27,5 +27,5 @@ gr <- GenomicRanges::GRanges("22", ld <- LdData(correlation = cor(X), variants = gr, blockMetadata = S4Vectors::DataFrame( chrom = "22", start = 1L, end = 1000L)) -getBlockMetadata(ld) +blockMetadata(ld) } diff --git a/man/buildLdEigen.Rd b/man/buildLdEigen.Rd index 1311d6e1..10a885e8 100644 --- a/man/buildLdEigen.Rd +++ b/man/buildLdEigen.Rd @@ -6,7 +6,7 @@ \usage{ buildLdEigen( ldBlockData, - nRef = NULL, + nSamples = NULL, inSample = FALSE, genome = NA_character_, eigenvalueTruncation = 1 @@ -24,7 +24,7 @@ buildLdEigen( least two blocks and wants many more. Loading a whole region as one dense matrix yields a single block.} -\item{nRef}{Integer, the LD reference panel sample size. Defaults to the +\item{nSamples}{Integer, the LD reference panel sample size. Defaults to the size recorded by the supplied \code{LdData}; required when they record none, and an error when they disagree.} @@ -60,7 +60,7 @@ meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") ldEigen <- buildLdEigen(ld, genome = "hg38") ldEigen -length(getEigenList(ldEigen)) +length(eigenList(ldEigen)) } \seealso{ \code{\link{buildLdScore}} for the g-LDSC input, diff --git a/man/buildLdScore.Rd b/man/buildLdScore.Rd index 29d5f3f9..42c49001 100644 --- a/man/buildLdScore.Rd +++ b/man/buildLdScore.Rd @@ -6,7 +6,7 @@ \usage{ buildLdScore( ldBlockData, - nRef = NULL, + nSamples = NULL, inSample = FALSE, genome = NA_character_, ldScoreWeights = NULL, @@ -25,7 +25,7 @@ buildLdScore( least two blocks and wants many more. Loading a whole region as one dense matrix yields a single block.} -\item{nRef}{Integer, the LD reference panel sample size. Defaults to the +\item{nSamples}{Integer, the LD reference panel sample size. Defaults to the size recorded by the supplied \code{LdData}; required when they record none, and an error when they disagree.} @@ -67,7 +67,7 @@ meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") ldScore <- buildLdScore(ld, genome = "hg38") ldScore -head(getLdScores(ldScore)) +head(S4Vectors::mcols(ldScore)$ldScores) } \seealso{ \code{\link{buildLdEigen}} for the LDER / HDL input, diff --git a/man/buildTopLoci.Rd b/man/buildTopLoci.Rd index 77f37ff3..dc14089b 100644 --- a/man/buildTopLoci.Rd +++ b/man/buildTopLoci.Rd @@ -17,7 +17,7 @@ buildTopLoci( otherQuantities = NULL, region = NULL, conditionIdx = NULL, - credibleSetArgs = CredibleSetParam(includeAllCs = FALSE) + credibleSetParam = CredibleSetParam(includeAllCs = FALSE) ) } \arguments{ @@ -61,7 +61,7 @@ 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{credibleSetArgs}{How credible sets are built and reported, built with +\item{credibleSetParam}{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.} diff --git a/man/causalInferencePipeline.Rd b/man/causalInferencePipeline.Rd index 0d629c37..491a7b67 100644 --- a/man/causalInferencePipeline.Rd +++ b/man/causalInferencePipeline.Rd @@ -16,7 +16,7 @@ causalInferencePipeline( } \arguments{ \item{gwasSumStats}{A \code{\link{GwasSumStats}} object. Must be QC'd -(\code{length(getQcInfo(x)) > 0L}).} +(\code{length(qcInfo(x)) > 0L}).} \item{twasWeights}{Optional \code{\link{TwasWeights}} carrying per-(study, context, trait, method) weights. When supplied, drives the TWAS-Z diff --git a/man/getChromPaths.Rd b/man/chromPaths.Rd similarity index 77% rename from man/getChromPaths.Rd rename to man/chromPaths.Rd index c3cff69d..5f1e495d 100644 --- a/man/getChromPaths.Rd +++ b/man/chromPaths.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R -\name{getChromPaths} -\alias{getChromPaths} -\alias{getChromPaths,GenotypeHandle-method} +\name{chromPaths} +\alias{chromPaths} +\alias{chromPaths,GenotypeHandle-method} \title{Get Per-Chromosome Payload Paths} \usage{ -getChromPaths(x, ...) +chromPaths(x, ...) -\S4method{getChromPaths}{GenotypeHandle}(x) +\S4method{chromPaths}{GenotypeHandle}(x) } \arguments{ \item{x}{A \code{GenotypeHandle}.} @@ -21,7 +21,7 @@ A named character vector mapping canonical chromosome to path or \description{ The chromosome-to-path map of a sharded \code{\link{GenotypeHandle}}. Empty (\code{character(0)}) for a - single-file handle, whose one path is \code{\link{getPath}} instead; a + single-file handle, whose one path is \code{\link{path}} instead; a non-empty map marks a one-file-per-chromosome handle whose extraction is routed by chromosome. } diff --git a/man/getBeta.Rd b/man/coef-methods.Rd similarity index 59% rename from man/getBeta.Rd rename to man/coef-methods.Rd index 6008fa99..c4f1b14d 100644 --- a/man/getBeta.Rd +++ b/man/coef-methods.Rd @@ -1,28 +1,29 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getBeta} -\alias{getBeta} -\alias{getBeta,SumStatsBase-method} +\name{coef} +\alias{coef} +\alias{coef,SumStatsBase-method} \title{Get Marginal Effect Sizes} \usage{ -getBeta(x, ...) +coef(object, ...) -\S4method{getBeta}{SumStatsBase}( - x, - study = NULL, +\S4method{coef}{SumStatsBase}( + object, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, - ranges = NULL + ranges = NULL, + ... ) } \arguments{ -\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} +\item{object}{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{studyName}{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.} @@ -31,7 +32,7 @@ this context; \code{NULL} matches all contexts.} 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.} +\code{\link{sumStats}} (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.} @@ -42,9 +43,12 @@ Numeric vector of effect sizes, or \code{NULL} if not available. \description{ Extract the marginal effect-size (beta) vector from a \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity - tuple. + tuple. A GWAS / QTL effect size is a regression coefficient, so this + adopts \code{stats::coef} rather than defining a pecotmr generic. + Promoting the existing function keeps it as the default method, so + \code{coef()} on a model fit is unaffected. } \examples{ data(qtlSumStatsExample) -getBeta(qtlSumStatsExample) +coef(qtlSumStatsExample) } diff --git a/man/getColocBoostOutcomes.Rd b/man/colocBoostOutcomes.Rd similarity index 76% rename from man/getColocBoostOutcomes.Rd rename to man/colocBoostOutcomes.Rd index 420ada9a..c7d857d0 100644 --- a/man/getColocBoostOutcomes.Rd +++ b/man/colocBoostOutcomes.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ColocBoostResult.R -\name{getColocBoostOutcomes} -\alias{getColocBoostOutcomes} -\alias{getColocBoostOutcomes,ColocBoostResult-method} +\name{colocBoostOutcomes} +\alias{colocBoostOutcomes} +\alias{colocBoostOutcomes,ColocBoostResult-method} \title{ColocBoost Outcome View} \usage{ -getColocBoostOutcomes(x, ...) +colocBoostOutcomes(x, ...) -\S4method{getColocBoostOutcomes}{ColocBoostResult}(x) +\S4method{colocBoostOutcomes}{ColocBoostResult}(x) } \arguments{ \item{x}{A \code{\linkS4class{ColocBoostResult}}.} @@ -28,5 +28,5 @@ One row per (confidence set, colocalized outcome), joined to } \examples{ # See colocboostPipeline(); a ColocBoostResult carries the mapping it needs. -methods::existsMethod("getColocBoostOutcomes", "ColocBoostResult") +methods::existsMethod("colocBoostOutcomes", "ColocBoostResult") } diff --git a/man/colocPipeline.Rd b/man/colocPipeline.Rd index ed095391..71191a05 100644 --- a/man/colocPipeline.Rd +++ b/man/colocPipeline.Rd @@ -47,10 +47,12 @@ 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 +\code{credibleSetParam}, \code{susieRssParam}, +\code{panelFilterParam}, \code{initializeWithSusieInf} and +\code{fitRetention}. Inert when \code{gwasInput} is already +fine-mapped. \code{credibleSetParam} is the one to check: its +\code{coverage} / \code{maxNumSingleEffects} decide the sets whose +LBFs are scored, so defaults here against a differently-built QTL side compare two different things.} @@ -117,10 +119,10 @@ A \code{\linkS4class{ColocResult}}: one element per tested \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 + Project it with \code{\link{colocPairs}} (the flat table this pipeline used to return, also available as \code{as.data.frame}), - \code{\link{getColocVariants}}, \code{\link{getColocCredibleSets}} or - \code{\link{getColocGenes}}. + \code{\link{colocVariants}}, \code{\link{colocCredibleSets}} or + \code{\link{colocGenes}}. } \description{ Per-region pipeline that pairs two fine-mapping result @@ -178,7 +180,7 @@ This pipeline preserves all three. \section{LD-sketch compatibility check}{ If - \code{getLdSketch(qtlFineMappingResult)} is non-\code{NULL}, it must come + \code{ldSketch(qtlFineMappingResult)} is non-\code{NULL}, it must come from the same reference panel as the LD sketch on \code{gwasInput}: the same samples, and the same allele orientation on the variants the two carry in common. The two need NOT carry the same variants --- running @@ -201,5 +203,5 @@ colocPipeline(qtlFineMappingLbfExample, # trait in gwasContext / gwasTrait. res <- colocPipeline(qtlFineMappingLbfExample, gwasInput = qtlFineMappingLbfExample) -unique(getColocPairs(res)[, c("context", "gwasContext")]) +unique(colocPairs(res)[, c("context", "gwasContext")]) } diff --git a/man/colocViews.Rd b/man/colocViews.Rd index 6bff247c..12cff8e4 100644 --- a/man/colocViews.Rd +++ b/man/colocViews.Rd @@ -3,33 +3,33 @@ % R/ColocBoostResult.R \name{colocViews} \alias{colocViews} -\alias{getColocPairs} -\alias{getColocVariants} -\alias{getColocCredibleSets} -\alias{getColocGenes} -\alias{getColocPairs,ColocResult-method} -\alias{getColocVariants,ColocResult-method} -\alias{getColocGenes,ColocResult-method} -\alias{getColocCredibleSets,ColocResult-method} -\alias{getColocPairs,ColocBoostResult-method} -\alias{getColocVariants,ColocBoostResult-method} +\alias{colocPairs} +\alias{colocVariants} +\alias{colocCredibleSets} +\alias{colocGenes} +\alias{colocPairs,ColocResult-method} +\alias{colocVariants,ColocResult-method} +\alias{colocGenes,ColocResult-method} +\alias{colocCredibleSets,ColocResult-method} +\alias{colocPairs,ColocBoostResult-method} +\alias{colocVariants,ColocBoostResult-method} \title{Colocalization Views} \usage{ -getColocPairs(x, ...) +colocPairs(x, ...) -getColocVariants(x, pooled = FALSE, ...) +colocVariants(x, pooled = FALSE, ...) -getColocCredibleSets(x, coverage = 0.95, minPp4 = NULL, minAbsCorr = 0.8, ...) +colocCredibleSets(x, coverage = 0.95, minPp4 = NULL, minAbsCorr = 0.8, ...) -getColocGenes(x, ...) +colocGenes(x, ...) -\S4method{getColocPairs}{ColocResult}(x) +\S4method{colocPairs}{ColocResult}(x) -\S4method{getColocVariants}{ColocResult}(x, pooled = FALSE) +\S4method{colocVariants}{ColocResult}(x, pooled = FALSE) -\S4method{getColocGenes}{ColocResult}(x) +\S4method{colocGenes}{ColocResult}(x) -\S4method{getColocCredibleSets}{ColocResult}( +\S4method{colocCredibleSets}{ColocResult}( x, coverage = 0.95, minPp4 = NULL, @@ -37,16 +37,16 @@ getColocGenes(x, ...) requireMaxH4 = FALSE ) -\S4method{getColocPairs}{ColocBoostResult}(x) +\S4method{colocPairs}{ColocBoostResult}(x) -\S4method{getColocVariants}{ColocBoostResult}(x, pooled = FALSE) +\S4method{colocVariants}{ColocBoostResult}(x, pooled = FALSE) } \arguments{ \item{x}{A \code{ColocResult}.} \item{...}{Additional arguments passed on to methods.} -\item{pooled}{Logical. \code{getColocVariants()} only: pool to one row per +\item{pooled}{Logical. \code{colocVariants()} only: pool to one row per (gene, variant) instead of per (pair, variant).} \item{coverage}{Cumulative \code{SNP.PP.H4} the credible set must reach.} @@ -73,20 +73,20 @@ The four views over a \code{\linkS4class{ColocResult}}. The analysis needs, rather than any one of them being the stored shape. \describe{ - \item{\code{getColocPairs()}}{One row per tested pair -- coloc's native + \item{\code{colocPairs()}}{One row per tested pair -- coloc's native \code{$summary} granularity. Every testable pair is reported verbatim, including both halves of a credible set that straddles a block boundary; interpreting them is the caller's decision.} - \item{\code{getColocVariants()}}{One row per (pair, variant), carrying + \item{\code{colocVariants()}}{One row per (pair, variant), carrying \code{colocPp = PP.H4.abf * SNP.PP.H4} -- the posterior that this variant is the shared causal one. With \code{pooled = TRUE}, one row per (gene, variant) pooled by the rule below.} - \item{\code{getColocCredibleSets()}}{One row per coloc credible set: the + \item{\code{colocCredibleSets()}}{One row per coloc credible set: the smallest set of variants whose cumulative \code{SNP.PP.H4} reaches \code{coverage}. This is a THIRD variant set, not guaranteed to be a subset of either input credible set, so its purity is recomputed from LD rather than inherited.} - \item{\code{getColocGenes()}}{One row per gene, pooled across pairs.} + \item{\code{colocGenes()}}{One row per gene, pooled across pairs.} } } \section{Pooling}{ @@ -106,8 +106,8 @@ res <- colocPipeline( qtlFineMappingResult = qtlFineMappingLbfExample, gwasInput = gwasFineMappingLbfExample ) -head(getColocPairs(res)) -head(getColocVariants(res)) -getColocGenes(res) -head(getColocCredibleSets(res, minPp4 = 0.001)) +head(colocPairs(res)) +head(colocVariants(res)) +colocGenes(res) +head(colocCredibleSets(res, minPp4 = 0.001)) } diff --git a/man/colocboostPipeline.Rd b/man/colocboostPipeline.Rd index f57f0165..d054c457 100644 --- a/man/colocboostPipeline.Rd +++ b/man/colocboostPipeline.Rd @@ -21,7 +21,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, methodArgs = ColocboostOptions() @@ -37,7 +37,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) jointGwas = FALSE, separateGwas = FALSE, alleleFlip = TRUE, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), methodArgs = ColocboostOptions() ) @@ -53,7 +53,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) jointGwas = FALSE, separateGwas = FALSE, samples = NULL, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, methodArgs = ColocboostOptions() @@ -75,7 +75,7 @@ every context present is used.} \item{traitId}{Optional character vector of trait identifiers to restrict the analysis to. When supplied with an individual-level \code{QtlDataset} input, \code{cisWindow} is required (passed to -\code{getResidualizedGenotypes} / \code{getPhenotypes} for the +\code{residualizedGenotypes} / \code{molecularTraits} for the variant-window selection).} \item{region}{Optional single-range \code{GRanges} describing the analysis @@ -101,8 +101,8 @@ colocboost variants to run.} \item{samples}{Optional character vector of sample IDs to restrict the analysis to; \code{NULL} (default) uses all samples.} -\item{panelFilterArgs}{Analysis-time filters applied to the summary-statistic -sides against the LD reference panel, built with +\item{panelFilterParam}{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 @@ -151,11 +151,11 @@ A \code{\linkS4class{ColocBoostResult}}: one element per \code{separate_gwas} runs. Outcome-specific (uncolocalized) sets are included with \code{isColocalized = FALSE}. - Project it with \code{\link{getColocPairs}} (also available as - \code{as.data.frame}), \code{\link{getColocVariants}} or - \code{\link{getColocBoostOutcomes}}; timings are on - \code{\link{getComputingTime}} and the region-wide marginal - probabilities on \code{\link{getRegionVcp}}. + Project it with \code{\link{colocPairs}} (also available as + \code{as.data.frame}), \code{\link{colocVariants}} or + \code{\link{colocBoostOutcomes}}; timings are on + \code{\link{computingTime}} and the region-wide marginal + probabilities on \code{\link{regionVcp}}. } \description{ Protocol-level multi-trait colocalization analysis using @@ -168,7 +168,7 @@ Protocol-level multi-trait colocalization analysis using \item \code{QtlSumStats} -- summary-statistic-only QTL data with a shared LD reference (\code{ldSketch}). Must already have been passed through \code{\link{summaryStatsQc}} (the - pipeline rejects inputs whose \code{getQcInfo()} is empty). + pipeline rejects inputs whose \code{qcInfo()} is empty). Every analysis variant is available on this input, including \code{xqtlColoc}, which colocalizes the QTL studies against each other with no GWAS involved. @@ -188,7 +188,7 @@ for either side; colocboost has its own variable-selection algorithm. \item Individual-level QC (MAF / MAC / X-variance / per-sample missingness, sample / variant restrictions) lives on the \code{QtlDataset} constructor and is applied lazily inside - \code{getGenotypes()} / \code{getResidualizedGenotypes()}. + \code{genotypes()} / \code{residualizedGenotypes()}. The pipeline does \emph{not} run a separate individual-level QC pass. \item \code{panelFilter} acts at ANALYSIS time on the sumstat @@ -205,7 +205,7 @@ for either side; colocboost has its own variable-selection algorithm. imputation, etc.) lives in \code{\link{summaryStatsQc}}. The pipeline rejects any \code{QtlSumStats} or \code{GwasSumStats} where - \code{length(getQcInfo(x)) == 0L}. + \code{length(qcInfo(x)) == 0L}. } } diff --git a/man/combineGwasSumStats.Rd b/man/combineGwasSumStats.Rd index df3fe5df..7896fc37 100644 --- a/man/combineGwasSumStats.Rd +++ b/man/combineGwasSumStats.Rd @@ -29,7 +29,7 @@ The three collection-level slots are merged rather than taken from the first input: \code{genome} and the \code{\link{summaryStatsQc}} options must agree across the inputs (a mismatch is an error, not a silent first-wins), the per-element \code{qcInfo$entryAudit} concatenates in element order so -\code{\link{getQcDiagnostics}} keeps addressing the right element, and the +\code{\link{qcDiagnostics}} keeps addressing the right element, and the LD sketches union into one panel over the shared genotype handle. That last one matters: block-parallel pipelines narrow each piece's panel to its own block, so keeping only the first would leave a multi-block collection whose diff --git a/man/combineTwasWeights.Rd b/man/combineTwasWeights.Rd index 3fdee699..78b3adf2 100644 --- a/man/combineTwasWeights.Rd +++ b/man/combineTwasWeights.Rd @@ -26,10 +26,10 @@ cTWAS. Joint-specification metadata columns are carried through. \examples{ twe <- twasWeightsRow( variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), - cvResult = list(rsq = 0.5), standardized = FALSE) -tw1 <- TwasWeights(study = "s1", context = "brain", trait = "g1", + cvResult = list(rsq = 0.5), weightStandardized = FALSE) +tw1 <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", method = "susie", entry = list(twe)) -tw2 <- TwasWeights(study = "s2", context = "brain", trait = "g1", +tw2 <- TwasWeights(studyName = "s2", context = "brain", trait = "g1", method = "susie", entry = list(twe)) combineTwasWeights(tw1, tw2) } diff --git a/man/computeBaselineEnrichment.Rd b/man/computeBaselineEnrichment.Rd index a1b2cb4f..6b880b5a 100644 --- a/man/computeBaselineEnrichment.Rd +++ b/man/computeBaselineEnrichment.Rd @@ -4,15 +4,22 @@ \alias{computeBaselineEnrichment} \title{Compute Baseline Annotation Enrichment Quantities} \usage{ -computeBaselineEnrichment(tau, tauSe, tauBlocks, baselineMat, annotNames, h2) +computeBaselineEnrichment( + tau, + tauSe, + annotationJackknifeCoefs, + baselineMat, + annotNames, + h2 +) } \arguments{ \item{tau}{Numeric vector of per-annotation regression coefficients.} \item{tauSe}{Numeric vector of SE for tau.} -\item{tauBlocks}{Numeric matrix (nBlocks x nAnnotations) of jackknife -block-level tau values, or NULL.} +\item{annotationJackknifeCoefs}{Numeric matrix (nBlocks x nAnnotations) of +jackknife block-level tau values, or NULL.} \item{baselineMat}{Numeric matrix (nSnps x nAnnotations).} diff --git a/man/computeCsCorrelation.Rd b/man/computeCsCorrelation.Rd index 1fcb5893..b18b04b3 100644 --- a/man/computeCsCorrelation.Rd +++ b/man/computeCsCorrelation.Rd @@ -17,9 +17,9 @@ computeCsCorrelation(x, ldSource, ...) membership and PIP) and its variant ids.} \item{ldSource}{The object supplying the LD: a \code{QtlDataset} -(individual-level; genotypes via \code{\link{getGenotypes}}) or a +(individual-level; genotypes via \code{\link{genotypes}}) or a \code{QtlSumStats} / \code{GwasSumStats} (summary statistics; LD via -\code{\link{getLdSketch}}). Any other type is an error.} +\code{\link{ldSketch}}). Any other type is an error.} \item{...}{Passed to methods.} } @@ -39,6 +39,6 @@ Compute the between-credible-set correlation matrix for a \examples{ data(qtlFineMappingPairedExample) data(qtlSumStatsExample) -fe <- getFineMappingResult(qtlFineMappingPairedExample) +fe <- fineMappingResult(qtlFineMappingPairedExample) computeCsCorrelation(fe, qtlSumStatsExample) } diff --git a/man/computeLd.Rd b/man/computeLd.Rd index 304715cb..d5ae36c4 100644 --- a/man/computeLd.Rd +++ b/man/computeLd.Rd @@ -64,7 +64,7 @@ Correlation between variants, from either a dosage matrix } \examples{ data(qtlSumStatsExample) -panel <- getLdSketch(qtlSumStatsExample) +panel <- ldSketch(qtlSumStatsExample) R <- computeLd(panel, snpIdx = 1:5) dim(R) # A dosage matrix already in memory is correlated directly. diff --git a/man/computeSldscAnnotSd.Rd b/man/computeSldscAnnotSd.Rd index 55b3f6cc..d596c625 100644 --- a/man/computeSldscAnnotSd.Rd +++ b/man/computeSldscAnnotSd.Rd @@ -34,8 +34,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -47,6 +47,6 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) computeSldscAnnotSd(sldscData = sd) } diff --git a/man/computeSldscMRef.Rd b/man/computeSldscMRef.Rd index 07f2b71e..d340b4cc 100644 --- a/man/computeSldscMRef.Rd +++ b/man/computeSldscMRef.Rd @@ -41,8 +41,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -54,6 +54,6 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) computeSldscMRef(sldscData = sd) } diff --git a/man/getComputingTime.Rd b/man/computingTime.Rd similarity index 62% rename from man/getComputingTime.Rd rename to man/computingTime.Rd index 3f8a3f64..934c0460 100644 --- a/man/getComputingTime.Rd +++ b/man/computingTime.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ColocBoostResult.R -\name{getComputingTime} -\alias{getComputingTime} -\alias{getComputingTime,ColocBoostResult-method} +\name{computingTime} +\alias{computingTime} +\alias{computingTime,ColocBoostResult-method} \title{Per-Analysis Timings} \usage{ -getComputingTime(x, ...) +computingTime(x, ...) -\S4method{getComputingTime}{ColocBoostResult}(x) +\S4method{computingTime}{ColocBoostResult}(x) } \arguments{ \item{x}{A \code{\linkS4class{ColocBoostResult}}.} @@ -22,5 +22,5 @@ The wall-clock timings colocboostPipeline recorded for each analysis it ran. } \examples{ -methods::existsMethod("getComputingTime", "ColocBoostResult") +methods::existsMethod("computingTime", "ColocBoostResult") } diff --git a/man/contexts.Rd b/man/contexts.Rd new file mode 100644 index 00000000..6a1e2006 --- /dev/null +++ b/man/contexts.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/CtwasResult.R, +% R/GwasFineMappingResult.R, R/QtlDataset.R, R/QtlFineMappingResult.R, +% R/qtlSumStats.R, R/twasWeights.R +\name{contexts} +\alias{contexts} +\alias{contexts,CtwasResult-method} +\alias{contexts,GwasFineMappingResult-method} +\alias{contexts,QtlDataset-method} +\alias{contexts,QtlFineMappingResult-method} +\alias{contexts,QtlSumStats-method} +\alias{contexts,TwasWeights-method} +\title{Get Context Names} +\usage{ +contexts(x) + +\S4method{contexts}{CtwasResult}(x) + +\S4method{contexts}{GwasFineMappingResult}(x) + +\S4method{contexts}{QtlDataset}(x) + +\S4method{contexts}{QtlFineMappingResult}(x) + +\S4method{contexts}{QtlSumStats}(x) + +\S4method{contexts}{TwasWeights}(x) +} +\arguments{ +\item{x}{The object.} +} +\value{ +Character vector of context names. +} +\description{ +Return the names of all contexts carried by an object (e.g., the + keys of the \code{phenotypes} list on a \code{QtlDataset}, or the unique + \code{context} values of a \code{QtlSumStats}). +} +\examples{ +data(qtlDatasetExample) +contexts(qtlDatasetExample) +} diff --git a/man/getCredibleSetSummary.Rd b/man/credibleSetSummary.Rd similarity index 71% rename from man/getCredibleSetSummary.Rd rename to man/credibleSetSummary.Rd index b09d1589..798f7379 100644 --- a/man/getCredibleSetSummary.Rd +++ b/man/credibleSetSummary.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getCredibleSetSummary} -\alias{getCredibleSetSummary} -\alias{getCredibleSetSummary,FineMappingResultBase-method} +\name{credibleSetSummary} +\alias{credibleSetSummary} +\alias{credibleSetSummary,FineMappingResultBase-method} \title{Per-credible-set summary of a fine-mapping result} \usage{ -getCredibleSetSummary(x, ...) +credibleSetSummary(x, ...) -\S4method{getCredibleSetSummary}{FineMappingResultBase}(x, coverage = 0.95) +\S4method{credibleSetSummary}{FineMappingResultBase}(x, coverage = 0.95) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} @@ -28,12 +28,13 @@ A \code{tibble}: \code{cs, effect_id, coverage, n_variants, \description{ One row per credible set (at a given coverage) with its size, purity, prior variance, log Bayes factor, and lead variant -- the per-CS complement to the -per-variant \code{\link{getCs}}. Replaces the legacy per-effect `effect.tsv`. +per-variant \code{\link{credibleSets}}. Replaces the legacy +per-effect `effect.tsv`. } \examples{ data(qtlFineMappingExample) -getCredibleSetSummary(qtlFineMappingExample) +credibleSetSummary(qtlFineMappingExample) } \seealso{ -\code{\link{getCs}}, \code{\link{getTopLoci}} +\code{\link{credibleSets}}, \code{\link{topLoci}} } diff --git a/man/getCs.Rd b/man/credibleSets.Rd similarity index 79% rename from man/getCs.Rd rename to man/credibleSets.Rd index 7b9905ef..cd6f7775 100644 --- a/man/getCs.Rd +++ b/man/credibleSets.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getCs} -\alias{getCs} -\alias{getCs,FineMappingResultBase-method} +\name{credibleSets} +\alias{credibleSets} +\alias{credibleSets,FineMappingResultBase-method} \title{Get Credible Sets} \usage{ -getCs(x, ...) +credibleSets(x, ...) -\S4method{getCs}{FineMappingResultBase}( +\S4method{credibleSets}{FineMappingResultBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -23,8 +23,8 @@ getCs(x, ...) \item{...}{Class-specific selection arguments plus \code{coverage}.} -\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to -this study; \code{NULL} matches all studies.} +\item{studyName}{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.} @@ -53,5 +53,5 @@ Extract credible set assignments at the requested coverage. } \examples{ data(qtlFineMappingExample) -getCs(qtlFineMappingExample) +credibleSets(qtlFineMappingExample) } diff --git a/man/getCtwasGroupPriors.Rd b/man/ctwasGroupPriors.Rd similarity index 66% rename from man/getCtwasGroupPriors.Rd rename to man/ctwasGroupPriors.Rd index dfc6a250..54b26c14 100644 --- a/man/getCtwasGroupPriors.Rd +++ b/man/ctwasGroupPriors.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/CtwasResultEntry.R -\name{getCtwasGroupPriors} -\alias{getCtwasGroupPriors} -\alias{getCtwasGroupPriors,CtwasResultEntry-method} +\name{ctwasGroupPriors} +\alias{ctwasGroupPriors} +\alias{ctwasGroupPriors,CtwasResultEntry-method} \title{Get cTWAS Group Prior Parameters} \usage{ -getCtwasGroupPriors(x, ...) +ctwasGroupPriors(x, ...) -\S4method{getCtwasGroupPriors}{CtwasResultEntry}(x) +\S4method{ctwasGroupPriors}{CtwasResultEntry}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry}.} @@ -23,7 +23,7 @@ Return the estimated \code{group_prior} / \code{group_prior_var} } \examples{ cre <- CtwasResultEntry( - finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), + posteriors = 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))) -getCtwasGroupPriors(cre) +ctwasGroupPriors(cre) } diff --git a/man/ctwasPipeline.Rd b/man/ctwasPipeline.Rd index 2788dc24..30028ddf 100644 --- a/man/ctwasPipeline.Rd +++ b/man/ctwasPipeline.Rd @@ -10,7 +10,7 @@ ctwasPipeline( twasZ = NULL, fineMappingResult = NULL, method = NULL, - L = 5L, + maxNumSingleEffects = 5L, numThreads = 1L, ctwasPriorArgs = CtwasPriorParam(), variantPruningArgs = VariantPruningParam(), @@ -22,7 +22,7 @@ ctwasPipeline( \arguments{ \item{gwasSumStats}{A \code{\link{GwasSumStats}} whose elements are LD blocks (at least two), keyed by its \code{blockId} column, with -\code{getQcInfo()} non-empty. Build it with +\code{qcInfo()} non-empty. Build it with \code{loadGwasSumStatsFromManifest(..., ldBlocks = )} and pass it through \code{\link{summaryStatsQc}}.} @@ -59,8 +59,9 @@ 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{L}{Integer. Max number of single effects in cTWAS fine-mapping. -Default \code{5}. Pass-through to \code{ctwas::ctwas_sumstats}.} +\item{maxNumSingleEffects}{Integer. Max number of single effects in cTWAS +fine-mapping. Default \code{5}. Pass-through to +\code{ctwas::ctwas_sumstats}.} \item{numThreads}{Number of cores. Default \code{1}.} @@ -86,7 +87,7 @@ boundary has its regions merged and re-fine-mapped, built with context-agnostic SNP background of each run as one extra \code{CtwasResult} row (\code{study = context = "SNP"}, mirroring cTWAS's own \code{"SNP"} group) so the full ctwas output is reconstructable from -\code{\link{getFinemap}} / \code{getSusieAlpha}. Default \code{FALSE} -- +\code{\link{ctwasPosteriors}} / \code{susieAlpha}. Default \code{FALSE} -- the SNP rows are the null background and are dropped from the structured gene-level result.} @@ -131,8 +132,8 @@ Pipeline that hands a per-block set of \section{LD-sketch compatibility check}{ Per block: - \code{getLdSketch(twasWeights)} (when non-NULL) must come from the same - reference panel as \code{getLdSketch(gwasSumStats)} --- same samples, same + \code{ldSketch(twasWeights)} (when non-NULL) must come from the same + reference panel as \code{ldSketch(gwasSumStats)} --- same samples, same allele orientation on the shared variants. The two need NOT carry the same variants; a partial overlap, which is what QC-ing the two sides separately produces, only warns. A different sample set, a swapped A1/A2 on a shared @@ -153,10 +154,15 @@ blocks <- GenomicRanges::GRanges("chr22", gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) gwasByRegion <- summaryStatsQc(gss, - panelFilter = PanelFilterParam(mafCutoff = 0.0025)) + panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) ctwasPipeline(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE), - methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) + methodArgs = CtwasOptions( + regionData = CtwasRegionDataOptions(min_group_size = 1), + estParam = CtwasEstParamOptions( + min_group_size = 1, min_p_single_effect = 0 + ) + )) } diff --git a/man/getFinemap.Rd b/man/ctwasPosteriors.Rd similarity index 67% rename from man/getFinemap.Rd rename to man/ctwasPosteriors.Rd index 792a3e54..f38d1d7b 100644 --- a/man/getFinemap.Rd +++ b/man/ctwasPosteriors.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/CtwasResult.R, % R/CtwasResultEntry.R -\name{getFinemap} -\alias{getFinemap} -\alias{getFinemap,CtwasResult-method} -\alias{getFinemap,CtwasResultEntry-method} +\name{ctwasPosteriors} +\alias{ctwasPosteriors} +\alias{ctwasPosteriors,CtwasResult-method} +\alias{ctwasPosteriors,CtwasResultEntry-method} \title{Get cTWAS Fine-mapping Posteriors} \usage{ -getFinemap(x, ...) +ctwasPosteriors(x, ...) -\S4method{getFinemap}{CtwasResult}(x) +\S4method{ctwasPosteriors}{CtwasResult}(x) -\S4method{getFinemap}{CtwasResultEntry}(x) +\S4method{ctwasPosteriors}{CtwasResultEntry}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry} or \code{CtwasResult}.} @@ -28,7 +28,7 @@ Return the per-gene (and per-SNP) fine-mapping posterior table } \examples{ cre <- CtwasResultEntry( - finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), + posteriors = 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))) -getFinemap(cre) +ctwasPosteriors(cre) } diff --git a/man/getCvFits.Rd b/man/cvFits.Rd similarity index 79% rename from man/getCvFits.Rd rename to man/cvFits.Rd index fe287c74..f2293af0 100644 --- a/man/getCvFits.Rd +++ b/man/cvFits.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/MashPrior.R -\name{getCvFits} -\alias{getCvFits} -\alias{getCvFits,MashPrior-method} +\name{cvFits} +\alias{cvFits} +\alias{cvFits,MashPrior-method} \title{Get the Per-Fold Priors from a MashPrior} \usage{ -getCvFits(x, ...) +cvFits(x, ...) -\S4method{getCvFits}{MashPrior}(x) +\S4method{cvFits}{MashPrior}(x) } \arguments{ \item{x}{A \code{MashPrior} object.} @@ -24,5 +24,5 @@ Accessor for the \code{cvFits} slot (per-fold priors + \examples{ 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))) -getCvFits(mp) +cvFits(mp) } diff --git a/man/getCvResult.Rd b/man/cvResult.Rd similarity index 66% rename from man/getCvResult.Rd rename to man/cvResult.Rd index c30f943c..56160fd6 100644 --- a/man/getCvResult.Rd +++ b/man/cvResult.Rd @@ -1,31 +1,31 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/QtlFineMappingResult.R, % R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R -\name{getCvResult} -\alias{getCvResult} -\alias{getCvResult,QtlFineMappingResult-method} -\alias{getCvResult,FineMappingRow-method} -\alias{getCvResult,TwasWeights-method} -\alias{getCvResult,TwasWeightsRow-method} +\name{cvResult} +\alias{cvResult} +\alias{cvResult,QtlFineMappingResult-method} +\alias{cvResult,FineMappingRow-method} +\alias{cvResult,TwasWeights-method} +\alias{cvResult,TwasWeightsRow-method} \title{Get Cross-Validation Result} \usage{ -getCvResult(x, ...) +cvResult(x, ...) -\S4method{getCvResult}{QtlFineMappingResult}(x, study = NULL, context = NULL, trait = NULL, method = NULL) +\S4method{cvResult}{QtlFineMappingResult}(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getCvResult}{FineMappingRow}(x) +\S4method{cvResult}{FineMappingRow}(x) -\S4method{getCvResult}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) +\S4method{cvResult}{TwasWeights}(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getCvResult}{TwasWeightsRow}(x) +\S4method{cvResult}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} \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{studyName}{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.} @@ -51,5 +51,5 @@ Extract the cross-validation payload stored on a } \examples{ data(qtlFineMappingExample) -getCvResult(qtlFineMappingExample) +cvResult(qtlFineMappingExample) } diff --git a/man/getEigenList.Rd b/man/eigenList.Rd similarity index 70% rename from man/getEigenList.Rd rename to man/eigenList.Rd index 3088aef0..26191ca8 100644 --- a/man/getEigenList.Rd +++ b/man/eigenList.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdEigen.R -\name{getEigenList} -\alias{getEigenList} -\alias{getEigenList,LdEigen-method} +\name{eigenList} +\alias{eigenList} +\alias{eigenList,LdEigen-method} \title{Get Per-Block Eigendecompositions} \usage{ -getEigenList(x) +eigenList(x) -\S4method{getEigenList}{LdEigen}(x) +\S4method{eigenList}{LdEigen}(x) } \arguments{ \item{x}{An \code{LdEigen}.} @@ -21,5 +21,5 @@ Return the per-block eigendecomposition list carried by an } \examples{ data(ldEigenExample) -getEigenList(ldEigenExample) +eigenList(ldEigenExample) } diff --git a/man/estCtwasGroupPriors.Rd b/man/estCtwasGroupPriors.Rd index 01b6876a..afa2c4ef 100644 --- a/man/estCtwasGroupPriors.Rd +++ b/man/estCtwasGroupPriors.Rd @@ -44,5 +44,10 @@ 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)) + methodArgs = CtwasOptions( + regionData = CtwasRegionDataOptions(min_group_size = 1), + estParam = CtwasEstParamOptions( + min_group_size = 1, min_p_single_effect = 0 + ) + )) } diff --git a/man/estimateH2.Rd b/man/estimateH2.Rd index da43e592..21376b5f 100644 --- a/man/estimateH2.Rd +++ b/man/estimateH2.Rd @@ -20,7 +20,7 @@ estimateH2( method = "lder", annotations = NULL, local = FALSE, - study = NULL, + studyName = NULL, estimatorArgs = list() ) } @@ -56,8 +56,8 @@ unstratified estimation.} \item{...}{Additional method-specific arguments.} -\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to -this study; \code{NULL} matches all studies.} +\item{studyName}{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).} @@ -85,7 +85,8 @@ S4Vectors::mcols(gr) <- S4Vectors::DataFrame( panel <- readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) -ss <- GwasSumStats(study = "trait1", entry = list(gr), - genome = getGenome(ldScoreExample), ldSketch = panel) +ss <- GwasSumStats(studyName = "trait1", entry = list(gr), + genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), + ldSketch = panel) estimateH2(ss, ldScoreExample, method = "sldsc") } diff --git a/man/extractCsInfo.Rd b/man/extractCsInfo.Rd index e7fb0fdb..c2ee5778 100644 --- a/man/extractCsInfo.Rd +++ b/man/extractCsInfo.Rd @@ -9,14 +9,14 @@ extractCsInfo(fmRow, csNames, topLociTable, ldSource) \arguments{ \item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row fine-mapping collection as returned by -\code{\link{getFineMappingResult}}, carrying the SuSiE fit and +\code{\link{fineMappingResult}}, carrying the SuSiE fit and variant ids.} \item{csNames}{Character vector. Names of the Credible Sets, usually in the format "L_".} \item{topLociTable}{Data frame. The top-loci table (e.g. from -\code{\link{getTopLoci}}) carrying \code{variant_id}, \code{pip}, and +\code{\link{topLoci}}) carrying \code{variant_id}, \code{pip}, and \code{z} columns.} \item{ldSource}{The LD source from which the between-credible-set correlation diff --git a/man/extractTopPipInfo.Rd b/man/extractTopPipInfo.Rd index 8358ae3a..09652da6 100644 --- a/man/extractTopPipInfo.Rd +++ b/man/extractTopPipInfo.Rd @@ -9,7 +9,7 @@ extractTopPipInfo(fmRow, sumstats) \arguments{ \item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row fine-mapping collection as returned by -\code{\link{getFineMappingResult}}, carrying the SuSiE fit and +\code{\link{fineMappingResult}}, carrying the SuSiE fit and variant ids.} \item{sumstats}{A list or data frame carrying a \code{z} element aligned to diff --git a/man/fineMappingMethodOptions.Rd b/man/fineMappingMethodOptions.Rd index d81c6b9a..e33f5ccb 100644 --- a/man/fineMappingMethodOptions.Rd +++ b/man/fineMappingMethodOptions.Rd @@ -66,7 +66,7 @@ Options forwarded to one fine-mapping engine, checked input class is known. } \examples{ -SusieOptions(L = 5) +SusieOptions(max_iter = 200) SusieRssOptions(maf_thresh = 0.01) MvsusieOptions(prior_tol = 1e-9) } diff --git a/man/fineMappingPipeline.Rd b/man/fineMappingPipeline.Rd index 3c92657f..aad0192a 100644 --- a/man/fineMappingPipeline.Rd +++ b/man/fineMappingPipeline.Rd @@ -17,11 +17,11 @@ fineMappingPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, - genotypeFilterArgs = GenotypeFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), jointRegions = FALSE, jointSpecification = NULL, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam(), @@ -43,19 +43,19 @@ fineMappingPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, - genotypeFilterArgs = GenotypeFilterParam(), - panelFilterArgs = PanelFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), + panelFilterParam = PanelFilterParam(), jointRegions = FALSE, jointSpecification = NULL, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam(), signalScreenArgs = SignalScreenParam(), - rssArgs = SusieRssParam(), + susieRssParam = SusieRssParam(), usePCA = FALSE, nPCs = 10L, seed = NULL, @@ -70,15 +70,15 @@ fineMappingPipeline(data, ...) contexts = NULL, traitId = NULL, jointSpecification = NULL, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, verbose = 1, fitRetention = c("slim", "full"), - rssArgs = SusieRssParam(), - panelFilterArgs = PanelFilterParam(), + susieRssParam = SusieRssParam(), + panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam() ) @@ -86,13 +86,13 @@ fineMappingPipeline(data, ...) \S4method{fineMappingPipeline}{GwasSumStats}( data, methods, - addSusieInf = TRUE, - credibleSetArgs = CredibleSetParam(), + initializeWithSusieInf = TRUE, + credibleSetParam = CredibleSetParam(), fineMappingResult = NULL, verbose = 1, fitRetention = c("slim", "full"), - rssArgs = SusieRssParam(), - panelFilterArgs = PanelFilterParam(), + susieRssParam = SusieRssParam(), + panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), residualizationArgs = ResidualizationParam() ) @@ -137,7 +137,7 @@ 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{genotypeFilterArgs}{Per-call overrides of the \code{QtlDataset}'s own +\item{genotypeFilterParam}{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 @@ -162,26 +162,28 @@ implementation is in progress and a non-NULL value currently errors with an 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}, 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{initializeWithSusieInf}{Logical. When \code{susieInf} is in +\code{methods} 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 +\item{credibleSetParam}{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. + variant-level columns to \code{topLoci}. + \code{maxNumSingleEffects} bounds how many credible sets can exist + (default \code{10}) and \code{maxNumSingleEffectsGreedy} the greedy + 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 + refitting. \code{maxNumSingleEffects} / + \code{maxNumSingleEffectsGreedy} are the exception: they are seeded onto each SuSiE-family token's own arguments, so changing them needs a refit.} @@ -276,19 +278,20 @@ phenotype/genotype data.} \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 +\code{susie()} return, so \code{susieFit()} and +non-default-coverage \code{credibleSets()} 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 +\item{panelFilterParam}{LD-reference-panel filters for the summary-statistics and GWAS methods, built with \code{\link{PanelFilterParam}}. See \emph{Panel filters on the RSS path} above.} -\item{rssArgs}{Summary-statistics solver settings for \code{QtlSumStats} / -\code{GwasSumStats} input, built with \code{\link{SusieRssParam}}: -\itemize{ +\item{susieRssParam}{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 @@ -299,13 +302,13 @@ and GWAS methods, built with \code{\link{PanelFilterParam}}. See 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{susieFit(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)}. + \code{nSamples(ldSketch)}. \item \code{rMismatch} (default \code{"none"}) --- LD-mismatch correction forwarded as \code{R_mismatch}: also \code{"eb"} or \code{"eb_mix"}. @@ -378,7 +381,8 @@ 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} (the default), the SuSiE-inf fit is computed + \code{initializeWithSusieInf = 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 @@ -389,7 +393,7 @@ S4-dispatched per-region fine-mapping entry point that \section{QC contract}{ All \code{QtlSumStats} and \code{GwasSumStats} inputs must have been QC'd via \code{\link{summaryStatsQc}}; the pipeline errors - on inputs where \code{length(getQcInfo(x)) == 0L}. \code{summaryStatsQc} + on inputs where \code{length(qcInfo(x)) == 0L}. \code{summaryStatsQc} also drops variants absent from the \code{ldSketch}, so by the time per-entry processing runs every variant is guaranteed to be present in the LD panel and a local LD matrix can be built with diff --git a/man/getFineMappingResult.Rd b/man/fineMappingResult.Rd similarity index 55% rename from man/getFineMappingResult.Rd rename to man/fineMappingResult.Rd index 2907874f..afd7d1e9 100644 --- a/man/getFineMappingResult.Rd +++ b/man/fineMappingResult.Rd @@ -1,31 +1,31 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GwasFineMappingResult.R, % R/QtlFineMappingResult.R -\name{getFineMappingResult} -\alias{getFineMappingResult} -\alias{getFineMappingResult,GwasFineMappingResult-method} -\alias{getFineMappingResult,QtlFineMappingResult-method} +\name{fineMappingResult} +\alias{fineMappingResult} +\alias{fineMappingResult,GwasFineMappingResult-method} +\alias{fineMappingResult,QtlFineMappingResult-method} \title{Get a Single Fine-Mapping Entry} \usage{ -getFineMappingResult( +fineMappingResult( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL ) -\S4method{getFineMappingResult}{GwasFineMappingResult}( +\S4method{fineMappingResult}{GwasFineMappingResult}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL ) -\S4method{getFineMappingResult}{QtlFineMappingResult}( +\S4method{fineMappingResult}{QtlFineMappingResult}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL @@ -34,9 +34,9 @@ getFineMappingResult( \arguments{ \item{x}{A \code{FineMappingResult} object.} -\item{study, context, trait, method}{Single character identifiers. All required -when the collection has more than one row; optional when the collection has -a single row.} +\item{studyName, context, trait, method}{Single character identifiers. All +required when the collection has more than one row; optional when the +collection has a single row.} } \value{ A \code{FineMappingRow} object. @@ -47,6 +47,6 @@ Return the \code{FineMappingRow} for one \code{(study, } \examples{ data(qtlFineMappingExample) -getFineMappingResult(qtlFineMappingExample, study = "study_1", +fineMappingResult(qtlFineMappingExample, studyName = "study_1", context = "context_1", trait = "gene_1", method = "susie") } diff --git a/man/fineMappingRow.Rd b/man/fineMappingRow.Rd index 16d945e2..070b7913 100644 --- a/man/fineMappingRow.Rd +++ b/man/fineMappingRow.Rd @@ -40,7 +40,7 @@ tl <- data.frame( ) row <- fineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) QtlFineMappingResult( - study = "s1", context = "c1", trait = "g1", method = "susie", + studyName = "s1", context = "c1", trait = "g1", method = "susie", entry = list(row) ) } diff --git a/man/finemapCtwasRegions.Rd b/man/finemapCtwasRegions.Rd index e42528c8..1dcefd70 100644 --- a/man/finemapCtwasRegions.Rd +++ b/man/finemapCtwasRegions.Rd @@ -6,7 +6,7 @@ \usage{ finemapCtwasRegions( screenResult, - L = 5L, + maxNumSingleEffects = 5L, numThreads = 1L, methodArgs = CtwasOptions() ) @@ -14,7 +14,7 @@ finemapCtwasRegions( \arguments{ \item{screenResult}{A list returned by \code{\link{screenCtwasRegions}}.} -\item{L}{Pass-through.} +\item{maxNumSingleEffects}{Pass-through.} \item{numThreads}{Number of cores.} @@ -49,13 +49,18 @@ blocks <- GenomicRanges::GRanges("chr22", gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", ldSketch = ldStem, region = "chr22:10000000-19000000", ldBlocks = blocks) gwasByRegion <- summaryStatsQc(gss, - panelFilter = PanelFilterParam(mafCutoff = 0.0025)) + panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample)) est <- estCtwasGroupPriors(inp, ctwasPrior = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE), - methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0)) + methodArgs = CtwasOptions( + regionData = CtwasRegionDataOptions(min_group_size = 1), + estParam = CtwasEstParamOptions( + min_group_size = 1, min_p_single_effect = 0 + ) + )) screened <- screenCtwasRegions(est) -finemapCtwasRegions(screened, L = 5L) +finemapCtwasRegions(screened, maxNumSingleEffects = 5L) } diff --git a/man/fitFsusie.Rd b/man/fitFsusie.Rd index 057185d8..7f6f0d75 100644 --- a/man/fitFsusie.Rd +++ b/man/fitFsusie.Rd @@ -32,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, methodArgs = FsusieOptions(L = 2)) +fitFsusie(X, Y, pos = pos, methodArgs = FsusieOptions(maxit = 5)) } diff --git a/man/flattenTupleRanges.Rd b/man/flattenTupleRanges.Rd index f2c1f81c..c933b7ba 100644 --- a/man/flattenTupleRanges.Rd +++ b/man/flattenTupleRanges.Rd @@ -33,7 +33,7 @@ between objects. Non-atomic \code{mcols} columns -- the per-element \code{susieFit} / \code{cvResult} payloads -- are dropped. They describe an element, not a range, so there is no row to broadcast them onto. Use the accessors -(\code{\link{getSusieFit}}, \code{\link{getCvResult}}) for those. +(\code{\link{susieFit}}, \code{\link{cvResult}}) for those. } \examples{ data(qtlFineMappingExample) diff --git a/man/getFrqData.Rd b/man/frqData.Rd similarity index 81% rename from man/getFrqData.Rd rename to man/frqData.Rd index beafc363..b13f6806 100644 --- a/man/getFrqData.Rd +++ b/man/frqData.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/SldscData.R -\name{getFrqData} -\alias{getFrqData} -\alias{getFrqData,SldscData-method} +\name{frqData} +\alias{frqData} +\alias{frqData,SldscData-method} \title{Get the allele-frequency table from an SldscData} \usage{ -getFrqData(x) +frqData(x) -\S4method{getFrqData}{SldscData}(x) +\S4method{frqData}{SldscData}(x) } \arguments{ \item{x}{An \code{\link{SldscData}} object.} @@ -28,8 +28,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -41,6 +41,6 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) -getFrqData(sd) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +frqData(sd) } diff --git a/man/fsusieGetCs.Rd b/man/fsusieGetCs.Rd index 8666cc14..cbcdc588 100644 --- a/man/fsusieGetCs.Rd +++ b/man/fsusieGetCs.Rd @@ -32,6 +32,6 @@ This function constructs a list that mimics the structure of } \examples{ data(fsusieFineMappingExample) -fit <- getSusieFit(fsusieFineMappingExample) +fit <- susieFit(fsusieFineMappingExample) fsusieGetCs(fit) } diff --git a/man/fsusieWeights.Rd b/man/fsusieWeights.Rd index 67e27404..f483508f 100644 --- a/man/fsusieWeights.Rd +++ b/man/fsusieWeights.Rd @@ -73,7 +73,7 @@ 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) -fit <- fsusieWrapper(X, Y, pos = pos, L = 2, +fit <- fsusieWrapper(X, Y, pos = pos, maxNumSingleEffects = 2, prior = "mixture_normal_per_scale", maxSnpEm = 10, covLev = 0.95, minPurity = 0.5, maxScale = 6) fsusieWeights(fsusieFit = fit, X = X, Y = Y, diff --git a/man/fsusieWrapper.Rd b/man/fsusieWrapper.Rd index 420e1632..fb7c13bd 100644 --- a/man/fsusieWrapper.Rd +++ b/man/fsusieWrapper.Rd @@ -8,7 +8,7 @@ fsusieWrapper( X, Y, pos, - L, + maxNumSingleEffects, prior, maxSnpEm, covLev, @@ -25,7 +25,7 @@ fsusieWrapper( \item{pos}{Genomics position of phenotypes, used for specifying the wavelet model.} -\item{L}{The maximum number of the credible set.} +\item{maxNumSingleEffects}{The maximum number of the credible set.} \item{prior}{method to generate the prior.} @@ -63,7 +63,7 @@ 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) -fsusieWrapper(X, Y, pos = pos, L = 2, +fsusieWrapper(X, Y, pos = pos, maxNumSingleEffects = 2, prior = "mixture_normal_per_scale", maxSnpEm = 10, covLev = 0.95, minPurity = 0.5, maxScale = 6) } diff --git a/man/getFullFit.Rd b/man/fullFit.Rd similarity index 78% rename from man/getFullFit.Rd rename to man/fullFit.Rd index 6c866e65..dfbc96a8 100644 --- a/man/getFullFit.Rd +++ b/man/fullFit.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/MashPrior.R -\name{getFullFit} -\alias{getFullFit} -\alias{getFullFit,MashPrior-method} +\name{fullFit} +\alias{fullFit} +\alias{fullFit,MashPrior-method} \title{Get the Full-Data Prior from a MashPrior} \usage{ -getFullFit(x, ...) +fullFit(x, ...) -\S4method{getFullFit}{MashPrior}(x) +\S4method{fullFit}{MashPrior}(x) } \arguments{ \item{x}{A \code{MashPrior} object.} @@ -24,5 +24,5 @@ Accessor for the \code{fullFit} slot (the full-data data-driven \examples{ 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))) -getFullFit(mp) +fullFit(mp) } diff --git a/man/getRegion.Rd b/man/genomicRegion.Rd similarity index 72% rename from man/getRegion.Rd rename to man/genomicRegion.Rd index b094ad79..e8f89e0f 100644 --- a/man/getRegion.Rd +++ b/man/genomicRegion.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/twasWeights.R -\name{getRegion} -\alias{getRegion} -\alias{getRegion,FineMappingResultBase-method} -\alias{getRegion,TwasWeights-method} +\name{genomicRegion} +\alias{genomicRegion} +\alias{genomicRegion,FineMappingResultBase-method} +\alias{genomicRegion,TwasWeights-method} \title{Get Per-Row Genomic Regions} \usage{ -getRegion(x, ...) +genomicRegion(x, ...) -\S4method{getRegion}{FineMappingResultBase}(x) +\S4method{genomicRegion}{FineMappingResultBase}(x) -\S4method{getRegion}{TwasWeights}(x) +\S4method{genomicRegion}{TwasWeights}(x) } \arguments{ \item{x}{The object.} @@ -30,5 +30,5 @@ Return the genomic anchor of each row of a per-tuple collection } \examples{ data(qtlFineMappingExample) -getRegion(qtlFineMappingExample) +genomicRegion(qtlFineMappingExample) } diff --git a/man/getGenotypeCovariates.Rd b/man/genotypeCovariates.Rd similarity index 65% rename from man/getGenotypeCovariates.Rd rename to man/genotypeCovariates.Rd index 6c4e6c7d..de35385a 100644 --- a/man/getGenotypeCovariates.Rd +++ b/man/genotypeCovariates.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{getGenotypeCovariates} -\alias{getGenotypeCovariates} -\alias{getGenotypeCovariates,QtlDataset-method} +\name{genotypeCovariates} +\alias{genotypeCovariates} +\alias{genotypeCovariates,QtlDataset-method} \title{Get Genotype Covariates} \usage{ -getGenotypeCovariates(x) +genotypeCovariates(x) -\S4method{getGenotypeCovariates}{QtlDataset}(x) +\S4method{genotypeCovariates}{QtlDataset}(x) } \arguments{ \item{x}{A \code{QtlDataset} object.} @@ -21,5 +21,5 @@ Return the single genotype-derived covariate matrix carried by a } \examples{ data(qtlDatasetExample) -getGenotypeCovariates(qtlDatasetExample) +genotypeCovariates(qtlDatasetExample) } diff --git a/man/genotypeDelayedArray.Rd b/man/genotypeDelayedArray.Rd index 3d855769..364336c4 100644 --- a/man/genotypeDelayedArray.Rd +++ b/man/genotypeDelayedArray.Rd @@ -21,7 +21,7 @@ an operation actually touches are fetched. } \details{ The result is \strong{variants x samples}, the Bioconductor assay -orientation, which is the transpose of what \code{\link{getGenotypes}} +orientation, which is the transpose of what \code{\link{genotypes}} returns. } \keyword{internal} diff --git a/man/getFormat.Rd b/man/genotypeFormat.Rd similarity index 77% rename from man/getFormat.Rd rename to man/genotypeFormat.Rd index 7e3a1e20..30fee7aa 100644 --- a/man/getFormat.Rd +++ b/man/genotypeFormat.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R -\name{getFormat} -\alias{getFormat} -\alias{getFormat,GenotypeHandle-method} +\name{genotypeFormat} +\alias{genotypeFormat} +\alias{genotypeFormat,GenotypeHandle-method} \title{Get Genotype Storage Format} \usage{ -getFormat(x) +genotypeFormat(x) -\S4method{getFormat}{GenotypeHandle}(x) +\S4method{genotypeFormat}{GenotypeHandle}(x) } \arguments{ \item{x}{A \code{GenotypeHandle}.} diff --git a/man/getGenotypeHandle.Rd b/man/genotypeHandle.Rd similarity index 67% rename from man/getGenotypeHandle.Rd rename to man/genotypeHandle.Rd index de9f19c7..8b1ea8b1 100644 --- a/man/getGenotypeHandle.Rd +++ b/man/genotypeHandle.Rd @@ -1,23 +1,23 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R, R/QtlDataset.R -\name{getGenotypeHandle} -\alias{getGenotypeHandle} -\alias{getGenotypeHandle,LdData-method} -\alias{getGenotypeHandle,QtlDataset-method} +\name{genotypeHandle} +\alias{genotypeHandle} +\alias{genotypeHandle,LdData-method} +\alias{genotypeHandle,QtlDataset-method} \title{Get GenotypeHandle from LdData} \usage{ -getGenotypeHandle(x) +genotypeHandle(x) -\S4method{getGenotypeHandle}{LdData}(x) +\S4method{genotypeHandle}{LdData}(x) -\S4method{getGenotypeHandle}{QtlDataset}(x) +\S4method{genotypeHandle}{QtlDataset}(x) } \arguments{ \item{x}{An \code{LdData}.} } \value{ A \code{GenotypeHandle}, a list of them, or NULL. For a - \code{QtlDataset} this is the handle itself; \code{getGenotypes()} + \code{QtlDataset} this is the handle itself; \code{genotypes()} extracts a dosage block from it instead. } \description{ diff --git a/man/getGenotypes.Rd b/man/genotypes.Rd similarity index 80% rename from man/getGenotypes.Rd rename to man/genotypes.Rd index a8b75c0e..0d7b3787 100644 --- a/man/getGenotypes.Rd +++ b/man/genotypes.Rd @@ -1,22 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R, R/QtlDataset.R -\name{getGenotypes} -\alias{getGenotypes} -\alias{getGenotypes,LdData-method} -\alias{getGenotypes,QtlDataset-method} +\name{genotypes} +\alias{genotypes} +\alias{genotypes,LdData-method} +\alias{genotypes,QtlDataset-method} \title{Get Genotype Matrix} \usage{ -getGenotypes(x, ...) +genotypes(x, ...) -\S4method{getGenotypes}{LdData}(x) +\S4method{genotypes}{LdData}(x) -\S4method{getGenotypes}{QtlDataset}( - x, - traitId = NULL, - region = NULL, - cisWindow = NULL, - samples = NULL -) +\S4method{genotypes}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) } \arguments{ \item{x}{The object to extract from.} @@ -49,5 +43,5 @@ Extract a genotype matrix from an object that carries genotype } \examples{ data(qtlDatasetExample) -getGenotypes(qtlDatasetExample) +genotypes(qtlDatasetExample) } diff --git a/man/getAf.Rd b/man/getAf.Rd deleted file mode 100644 index ee757e10..00000000 --- a/man/getAf.Rd +++ /dev/null @@ -1,45 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{getAf} -\alias{getAf} -\alias{getAf,QtlDataset-method} -\title{Get Effect-Allele Frequencies} -\usage{ -getAf(x, ...) - -\S4method{getAf}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) -} -\arguments{ -\item{x}{A \code{QtlDataset} object.} - -\item{...}{Class-specific selection arguments (e.g., \code{traitId}, -\code{region}, \code{cisWindow}, \code{samples} for \code{QtlDataset}).} - -\item{traitId}{Character or \code{NULL}. Molecular trait / feature identifier -to select; \code{NULL} matches all traits in the dataset.} - -\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{cisWindow}{Integer or \code{NULL}. Half-width (bp) of the cis window -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.} -} -\value{ -Named numeric vector of effect-allele frequencies (names are variant - IDs), or an empty vector when no variants are selected. -} -\description{ -Extract the directional effect-allele (A1) frequency vector for - a \code{QtlDataset}. Unlike \code{\link{getMaf}}, the value is \emph{not} - folded to the minor allele: it is the frequency of the dosage-counted - allele (A1, the effect allele), matching the allele the marginal effect - sizes and the fine-mapping \code{af} column report. -} -\examples{ -data(qtlDatasetExample) -getAf(qtlDatasetExample) -} diff --git a/man/getContexts.Rd b/man/getContexts.Rd deleted file mode 100644 index a77b45f2..00000000 --- a/man/getContexts.Rd +++ /dev/null @@ -1,43 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/CtwasResult.R, -% R/GwasFineMappingResult.R, R/QtlDataset.R, R/QtlFineMappingResult.R, -% R/qtlSumStats.R, R/twasWeights.R -\name{getContexts} -\alias{getContexts} -\alias{getContexts,CtwasResult-method} -\alias{getContexts,GwasFineMappingResult-method} -\alias{getContexts,QtlDataset-method} -\alias{getContexts,QtlFineMappingResult-method} -\alias{getContexts,QtlSumStats-method} -\alias{getContexts,TwasWeights-method} -\title{Get Context Names} -\usage{ -getContexts(x) - -\S4method{getContexts}{CtwasResult}(x) - -\S4method{getContexts}{GwasFineMappingResult}(x) - -\S4method{getContexts}{QtlDataset}(x) - -\S4method{getContexts}{QtlFineMappingResult}(x) - -\S4method{getContexts}{QtlSumStats}(x) - -\S4method{getContexts}{TwasWeights}(x) -} -\arguments{ -\item{x}{The object.} -} -\value{ -Character vector of context names. -} -\description{ -Return the names of all contexts carried by an object (e.g., the - keys of the \code{phenotypes} list on a \code{QtlDataset}, or the unique - \code{context} values of a \code{QtlSumStats}). -} -\examples{ -data(qtlDatasetExample) -getContexts(qtlDatasetExample) -} diff --git a/man/getGenome.Rd b/man/getGenome.Rd deleted file mode 100644 index 962f5c72..00000000 --- a/man/getGenome.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, -% R/AnnotationMatrix.R, R/LdStatistic.R -\name{getGenome} -\alias{getGenome} -\alias{getGenome,SumStatsBase-method} -\alias{getGenome,AnnotationMatrix-method} -\alias{getGenome,LdStatistic-method} -\title{Get the Genome Build} -\usage{ -getGenome(x, ...) - -\S4method{getGenome}{SumStatsBase}(x) - -\S4method{getGenome}{AnnotationMatrix}(x) - -\S4method{getGenome}{LdStatistic}(x) -} -\arguments{ -\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} - -\item{...}{Unused (present for method-signature compatibility).} -} -\value{ -Character (length 1). -} -\description{ -Return the genome build that the collection's LD sketch and - every entry are aligned to. Because all entries in a \code{GwasSumStats} or - \code{QtlSumStats} share the LD sketch, the genome build is a single value - at the collection level. -} -\examples{ -data(qtlSumStatsExample) -getGenome(qtlSumStatsExample) -} diff --git a/man/getLdScoreWeights.Rd b/man/getLdScoreWeights.Rd deleted file mode 100644 index 9d35a964..00000000 --- a/man/getLdScoreWeights.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdScore.R -\name{getLdScoreWeights} -\alias{getLdScoreWeights} -\alias{getLdScoreWeights,LdScore-method} -\title{Get LD-Score Regression Weights} -\usage{ -getLdScoreWeights(x) - -\S4method{getLdScoreWeights}{LdScore}(x) -} -\arguments{ -\item{x}{An \code{LdScore}.} -} -\value{ -Numeric vector. -} -\description{ -Return the per-SNP regression weights vector carried by an - \code{LdScore} object. -} -\examples{ -data(ldScoreExample) -getLdScoreWeights(ldScoreExample) -} diff --git a/man/getLdScores.Rd b/man/getLdScores.Rd deleted file mode 100644 index 4c2263d2..00000000 --- a/man/getLdScores.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/LdScore.R -\name{getLdScores} -\alias{getLdScores} -\alias{getLdScores,LdScore-method} -\title{Get LD Scores} -\usage{ -getLdScores(x) - -\S4method{getLdScores}{LdScore}(x) -} -\arguments{ -\item{x}{An \code{LdScore}.} -} -\value{ -Numeric matrix (SNPs x annotations+1). -} -\description{ -Return the per-SNP LD score matrix carried by an \code{LdScore} - object. -} -\examples{ -data(ldScoreExample) -getLdScores(ldScoreExample) -} diff --git a/man/getN.Rd b/man/getN.Rd deleted file mode 100644 index 1f8af3da..00000000 --- a/man/getN.Rd +++ /dev/null @@ -1,49 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getN} -\alias{getN} -\alias{getN,SumStatsBase-method} -\title{Get Sample Sizes} -\usage{ -getN(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. -} -\description{ -Extract sample size vector from a \code{GwasSumStats} or - \code{QtlSumStats} entry, selected by its identity tuple. -} -\examples{ -data(qtlSumStatsExample) -getN(qtlSumStatsExample) -} diff --git a/man/getNSamples.Rd b/man/getNSamples.Rd deleted file mode 100644 index 319e2231..00000000 --- a/man/getNSamples.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R -\name{getNSamples} -\alias{getNSamples} -\alias{getNSamples,GenotypeHandle-method} -\title{Get Sample Count} -\usage{ -getNSamples(x) - -\S4method{getNSamples}{GenotypeHandle}(x) -} -\arguments{ -\item{x}{A \code{GenotypeHandle}.} -} -\value{ -Integer (length 1). -} -\description{ -Return the number of samples carried by a \code{GenotypeHandle}. -} -\details{ -The genotype handle is the seed layer behind a panel and - is not part of the public interface; obtain a panel from - \code{readGenotypes()} and ask it directly. -} -\keyword{internal} diff --git a/man/getNSnps.Rd b/man/getNSnps.Rd deleted file mode 100644 index 9f8d948f..00000000 --- a/man/getNSnps.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getNSnps} -\alias{getNSnps} -\alias{getNSnps,H2Estimate-method} -\title{Get Variant Count} -\usage{ -getNSnps(x) - -\S4method{getNSnps}{H2Estimate}(x) -} -\arguments{ -\item{x}{An \code{H2Estimate}.} -} -\value{ -Integer (length 1). -} -\description{ -Return the number of variants the heritability estimate was - computed over. -} -\examples{ -data(h2EstimateExample) -getNSnps(h2EstimateExample) -} diff --git a/man/getPath.Rd b/man/getPath.Rd deleted file mode 100644 index f4be1da0..00000000 --- a/man/getPath.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R -\name{getPath} -\alias{getPath} -\alias{getPath,GenotypeHandle-method} -\title{Get File Path} -\usage{ -getPath(x) - -\S4method{getPath}{GenotypeHandle}(x) -} -\arguments{ -\item{x}{A \code{GenotypeHandle}.} -} -\value{ -Character (length 1). -} -\description{ -Return the underlying genotype file path or stem. -} -\details{ -The genotype handle is the seed layer behind a panel and - is not part of the public interface; obtain a panel from - \code{readGenotypes()} and ask it directly. -} -\keyword{internal} diff --git a/man/getStudy.Rd b/man/getStudy.Rd deleted file mode 100644 index 4a735887..00000000 --- a/man/getStudy.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, -% R/CtwasResult.R, R/QtlDataset.R, R/MultiStudyQtlDataset.R, R/twasWeights.R -\name{getStudy} -\alias{getStudy} -\alias{getStudy,SumStatsBase-method} -\alias{getStudy,FineMappingResultBase-method} -\alias{getStudy,CtwasResult-method} -\alias{getStudy,QtlDataset-method} -\alias{getStudy,MultiStudyQtlDataset-method} -\alias{getStudy,TwasWeights-method} -\title{Get Study Identifier} -\usage{ -getStudy(x) - -\S4method{getStudy}{SumStatsBase}(x) - -\S4method{getStudy}{FineMappingResultBase}(x) - -\S4method{getStudy}{CtwasResult}(x) - -\S4method{getStudy}{QtlDataset}(x) - -\S4method{getStudy}{MultiStudyQtlDataset}(x) - -\S4method{getStudy}{TwasWeights}(x) -} -\arguments{ -\item{x}{A \code{QtlDataset} object.} -} -\value{ -Character (length 1). -} -\description{ -Return the study identifier carried by a \code{QtlDataset}. -} -\examples{ -data(qtlDatasetExample) -getStudy(qtlDatasetExample) -} diff --git a/man/getSumStatsDf.Rd b/man/getSumStatsDf.Rd deleted file mode 100644 index ec3c51ea..00000000 --- a/man/getSumStatsDf.Rd +++ /dev/null @@ -1,70 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R -\name{getSumStatsDf} -\alias{getSumStatsDf} -\alias{getSumStatsDf,GwasSumStats-method} -\alias{getSumStatsDf,QtlSumStats-method} -\title{Get Standardized Sumstat Data Frame for One Tuple} -\usage{ -getSumStatsDf(x, ...) - -\S4method{getSumStatsDf}{GwasSumStats}( - x, - study = NULL, - require = character(0), - derive = c("none", "zFromBetaSe"), - keepChrPrefix = TRUE -) - -\S4method{getSumStatsDf}{QtlSumStats}( - x, - study = NULL, - context = NULL, - trait = NULL, - require = character(0), - derive = c("none", "zFromBetaSe"), - keepChrPrefix = TRUE -) -} -\arguments{ -\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} - -\item{...}{Class-specific selectors (\code{study} for \code{GwasSumStats}; -\code{study}, \code{context}, \code{trait} for \code{QtlSumStats}) plus -pass-throughs \code{require}, \code{derive}, \code{keepChrPrefix} forwarded -to the underlying unpacker.} - -\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to -this study; \code{NULL} matches all studies.} - -\item{require}{Character vector. Columns that must be present (derived if -necessary) in the returned summary-statistics data frame.} - -\item{derive}{Logical. Whether to derive missing standard columns (e.g. Z, -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}. -} -\description{ -Return a per-tuple summary-statistics \code{data.frame} in the - standardized layout \code{variant_id, chrom, pos, A1, A2, z, beta, se, N, - maf} (optional columns omitted when absent on the entry). Combines - tuple-keyed row selection (\code{getSumStats}) with mcols unpacking; - replaces the pre-S4 idiom of pulling \code{S4Vectors::mcols(entry)$} - directly inside pipelines. -} -\examples{ -data(qtlSumStatsExample) -getSumStatsDf(qtlSumStatsExample) -} diff --git a/man/getTraitName.Rd b/man/getTraitName.Rd deleted file mode 100644 index f6607d2c..00000000 --- a/man/getTraitName.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getTraitName} -\alias{getTraitName} -\alias{getTraitName,H2Estimate-method} -\title{Get Trait Name} -\usage{ -getTraitName(x) - -\S4method{getTraitName}{H2Estimate}(x) -} -\arguments{ -\item{x}{An \code{H2Estimate}.} -} -\value{ -Character (length 1). -} -\description{ -Return the trait label carried by an \code{H2Estimate}. -} -\examples{ -data(h2EstimateExample) -getTraitName(h2EstimateExample) -} diff --git a/man/getTraitRuns.Rd b/man/getTraitRuns.Rd deleted file mode 100644 index 9b5bd0dd..00000000 --- a/man/getTraitRuns.Rd +++ /dev/null @@ -1,46 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/SldscData.R -\name{getTraitRuns} -\alias{getTraitRuns} -\alias{getTraitRuns,SldscData-method} -\title{Get the per-trait runs list from an SldscData} -\usage{ -getTraitRuns(x) - -\S4method{getTraitRuns}{SldscData}(x) -} -\arguments{ -\item{x}{An \code{\link{SldscData}} object.} -} -\value{ -The named list of per-trait \code{single}/\code{joint} runs. -} -\description{ -Get the per-trait runs list from an SldscData -} -\examples{ -mkRun <- function(cats) { - n <- length(cats) - list(categories = cats, tau = setNames(rep(1e-7, n), cats), - tauSe = setNames(rep(3e-8, n), cats), - enrichment = setNames(rep(2, n), cats), - enrichmentSe = setNames(rep(0.4, n), cats), - enrichmentP = setNames(rep(0.01, n), cats), - propH2 = setNames(rep(0.2, n), cats), - propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) -} -annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), - annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) -frq <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), - MAF = rep(0.2, 6)) -mkTrait <- function() { - list(single = list(mkRun(c("annot_A_0", "baselineLD_0")), - mkRun(c("annot_B_0", "baselineLD_0"))), - joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) -} -traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) -getTraitRuns(sd) -} diff --git a/man/getTraits.Rd b/man/getTraits.Rd deleted file mode 100644 index 5bf93a31..00000000 --- a/man/getTraits.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/GwasFineMappingResult.R, -% R/QtlFineMappingResult.R, R/SldscData.R, R/qtlSumStats.R, R/twasWeights.R -\name{getTraits} -\alias{getTraits} -\alias{getTraits,GwasFineMappingResult-method} -\alias{getTraits,QtlFineMappingResult-method} -\alias{getTraits,SldscData-method} -\alias{getTraits,QtlSumStats-method} -\alias{getTraits,TwasWeights-method} -\title{Get Unique Trait Names} -\usage{ -getTraits(x) - -\S4method{getTraits}{GwasFineMappingResult}(x) - -\S4method{getTraits}{QtlFineMappingResult}(x) - -\S4method{getTraits}{SldscData}(x) - -\S4method{getTraits}{QtlSumStats}(x) - -\S4method{getTraits}{TwasWeights}(x) -} -\arguments{ -\item{x}{The object.} -} -\value{ -Character vector of unique trait names. -} -\description{ -Return the unique trait identifiers carried by a collection - class (e.g., \code{QtlSumStats}), or the trait names of an - \code{\link{SldscData}}. -} -\examples{ -data(qtlSumStatsExample) -getTraits(qtlSumStatsExample) -} diff --git a/man/getTwasWeights.Rd b/man/getTwasWeights.Rd deleted file mode 100644 index 9223788f..00000000 --- a/man/getTwasWeights.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/twasWeights.R -\name{getTwasWeights} -\alias{getTwasWeights} -\alias{getTwasWeights,TwasWeights-method} -\title{Get a Single TWAS Weights Entry} -\usage{ -getTwasWeights(x, study = NULL, context = NULL, trait = NULL, method = NULL) - -\S4method{getTwasWeights}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) -} -\arguments{ -\item{x}{A \code{TwasWeights} object.} - -\item{study, context, trait, method}{Single character identifiers. All required -when the collection has more than one row; optional when the collection has -a single row.} -} -\value{ -A \code{TwasWeightsRow} object. -} -\description{ -Return the \code{TwasWeightsRow} for one \code{(study, - context, trait, method)} row of a \code{TwasWeights} collection. -} -\examples{ -twe <- twasWeightsRow( - variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), - cvResult = list(rsq = 0.5), standardized = FALSE) -tw <- TwasWeights(study = "s1", context = "brain", trait = "g1", - method = "susie", entry = list(twe)) -getTwasWeights(tw, study = "s1", context = "brain", trait = "g1", - method = "susie") -} diff --git a/man/gwasFineMappingExample.Rd b/man/gwasFineMappingExample.Rd index b4bdd777..239eed4b 100644 --- a/man/gwasFineMappingExample.Rd +++ b/man/gwasFineMappingExample.Rd @@ -28,7 +28,7 @@ identifiers are synthetic. Built by \examples{ data(gwasFineMappingExample) gwasFineMappingExample -head(getTopLoci(gwasFineMappingExample)) +head(topLoci(gwasFineMappingExample)) } \keyword{data} diff --git a/man/h2EstimateExample.Rd b/man/h2EstimateExample.Rd index 5080a744..db75d77e 100644 --- a/man/h2EstimateExample.Rd +++ b/man/h2EstimateExample.Rd @@ -6,7 +6,8 @@ \title{Example Heritability Estimate} \format{ An \code{H2Estimate} object with \code{h2}, \code{h2Se}, - \code{intercept}, an \code{enrichment} data frame, and \code{tauBlocks}. + \code{intercept}, an \code{enrichment} data frame, and + \code{annotationJackknifeCoefs}. } \description{ A small synthetic \code{H2Estimate} (the output of diff --git a/man/h2EstimateToSldscTrait.Rd b/man/h2EstimateToSldscTrait.Rd index 9165e935..ec0037ad 100644 --- a/man/h2EstimateToSldscTrait.Rd +++ b/man/h2EstimateToSldscTrait.Rd @@ -7,7 +7,8 @@ h2EstimateToSldscTrait(h2Est) } \arguments{ -\item{h2Est}{An \code{H2Estimate} object with enrichment and tauBlocks.} +\item{h2Est}{An \code{H2Estimate} object with enrichment and +\code{annotationJackknifeCoefs}.} } \value{ A named list matching the format of \code{\link{readSldscTrait}}: @@ -21,8 +22,8 @@ A named list matching the format of \code{\link{readSldscTrait}}: \item{propH2}{Named numeric vector of proportion of h2} \item{propSnps}{Named numeric vector of proportion of SNPs} \item{h2g}{Numeric scalar, global h2 estimate} - \item{tauBlocks}{Matrix (nBlocks x nCategories) for jackknife} - \item{nBlocks}{Integer, number of jackknife blocks} + \item{annotationJackknifeCoefs}{Matrix (nBlocks x nCategories) for + jackknife} \item{nBlocks}{Integer, number of jackknife blocks} } } \description{ diff --git a/man/getH2.Rd b/man/heritabilityEstimate.Rd similarity index 62% rename from man/getH2.Rd rename to man/heritabilityEstimate.Rd index 7f3ad0b7..4a76d645 100644 --- a/man/getH2.Rd +++ b/man/heritabilityEstimate.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getH2} -\alias{getH2} -\alias{getH2,H2Estimate-method} +\name{heritabilityEstimate} +\alias{heritabilityEstimate} +\alias{heritabilityEstimate,H2Estimate-method} \title{Get Global SNP Heritability} \usage{ -getH2(x) +heritabilityEstimate(x) -\S4method{getH2}{H2Estimate}(x) +\S4method{heritabilityEstimate}{H2Estimate}(x) } \arguments{ \item{x}{An \code{H2Estimate}.} @@ -21,5 +21,5 @@ Return the global SNP heritability estimate carried by an } \examples{ data(h2EstimateExample) -getH2(h2EstimateExample) +heritabilityEstimate(h2EstimateExample) } diff --git a/man/getH2Se.Rd b/man/heritabilityEstimateSe.Rd similarity index 63% rename from man/getH2Se.Rd rename to man/heritabilityEstimateSe.Rd index 9cd9d1c4..08e742b3 100644 --- a/man/getH2Se.Rd +++ b/man/heritabilityEstimateSe.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getH2Se} -\alias{getH2Se} -\alias{getH2Se,H2Estimate-method} +\name{heritabilityEstimateSe} +\alias{heritabilityEstimateSe} +\alias{heritabilityEstimateSe,H2Estimate-method} \title{Get Heritability Standard Error} \usage{ -getH2Se(x) +heritabilityEstimateSe(x) -\S4method{getH2Se}{H2Estimate}(x) +\S4method{heritabilityEstimateSe}{H2Estimate}(x) } \arguments{ \item{x}{An \code{H2Estimate}.} @@ -21,5 +21,5 @@ Return the standard error of the global SNP heritability } \examples{ data(h2EstimateExample) -getH2Se(h2EstimateExample) +heritabilityEstimateSe(h2EstimateExample) } diff --git a/man/getIntercept.Rd b/man/heritabilityIntercept.Rd similarity index 66% rename from man/getIntercept.Rd rename to man/heritabilityIntercept.Rd index e037f2ff..7151b88f 100644 --- a/man/getIntercept.Rd +++ b/man/heritabilityIntercept.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getIntercept} -\alias{getIntercept} -\alias{getIntercept,H2Estimate-method} +\name{heritabilityIntercept} +\alias{heritabilityIntercept} +\alias{heritabilityIntercept,H2Estimate-method} \title{Get LD-Score Regression Intercept} \usage{ -getIntercept(x) +heritabilityIntercept(x) -\S4method{getIntercept}{H2Estimate}(x) +\S4method{heritabilityIntercept}{H2Estimate}(x) } \arguments{ \item{x}{An \code{H2Estimate}.} @@ -22,5 +22,5 @@ Return the regression intercept carried by an } \examples{ data(h2EstimateExample) -getIntercept(h2EstimateExample) +heritabilityIntercept(h2EstimateExample) } diff --git a/man/getInterceptSe.Rd b/man/heritabilityInterceptSe.Rd similarity index 61% rename from man/getInterceptSe.Rd rename to man/heritabilityInterceptSe.Rd index 0a84b72c..026a4497 100644 --- a/man/getInterceptSe.Rd +++ b/man/heritabilityInterceptSe.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getInterceptSe} -\alias{getInterceptSe} -\alias{getInterceptSe,H2Estimate-method} +\name{heritabilityInterceptSe} +\alias{heritabilityInterceptSe} +\alias{heritabilityInterceptSe,H2Estimate-method} \title{Get Intercept Standard Error} \usage{ -getInterceptSe(x) +heritabilityInterceptSe(x) -\S4method{getInterceptSe}{H2Estimate}(x) +\S4method{heritabilityInterceptSe}{H2Estimate}(x) } \arguments{ \item{x}{An \code{H2Estimate}.} @@ -21,5 +21,5 @@ Return the standard error of the regression intercept carried } \examples{ data(h2EstimateExample) -getInterceptSe(h2EstimateExample) +heritabilityInterceptSe(h2EstimateExample) } diff --git a/man/getInSample.Rd b/man/inSample.Rd similarity index 69% rename from man/getInSample.Rd rename to man/inSample.Rd index 64a530a4..982d7d10 100644 --- a/man/getInSample.Rd +++ b/man/inSample.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdStatistic.R -\name{getInSample} -\alias{getInSample} -\alias{getInSample,LdStatistic-method} +\name{inSample} +\alias{inSample} +\alias{inSample,LdStatistic-method} \title{Get In-Sample Flag} \usage{ -getInSample(x) +inSample(x) -\S4method{getInSample}{LdStatistic}(x) +\S4method{inSample}{LdStatistic}(x) } \arguments{ \item{x}{An \code{LdStatistic}.} @@ -21,5 +21,5 @@ Whether the LD reference panel is from the same cohort as the } \examples{ data(ldEigenExample) -getInSample(ldEigenExample) +inSample(ldEigenExample) } diff --git a/man/intersectVariants.Rd b/man/intersectVariants.Rd index 3e6a18f8..4a23b7de 100644 --- a/man/intersectVariants.Rd +++ b/man/intersectVariants.Rd @@ -47,7 +47,7 @@ Restrict two fine-mapping collections to the variants they have same variants. What it cannot recover is the information the dropped variants carried: coverage falls as overlap shrinks, equally for both, and that degradation is irreducible rather than an artifact of the method. - \code{getRetainedMass()} is what makes it visible. + \code{retainedMass()} is what makes it visible. } \examples{ data(qtlFineMappingExample) diff --git a/man/isBinarySldscAnnot.Rd b/man/isBinarySldscAnnot.Rd index b9beb642..186d14e7 100644 --- a/man/isBinarySldscAnnot.Rd +++ b/man/isBinarySldscAnnot.Rd @@ -28,8 +28,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -41,6 +41,6 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) isBinarySldscAnnot(sd) } diff --git a/man/getLbf.Rd b/man/lbf.Rd similarity index 74% rename from man/getLbf.Rd rename to man/lbf.Rd index 94d752b9..c68ee2c5 100644 --- a/man/getLbf.Rd +++ b/man/lbf.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getLbf} -\alias{getLbf} -\alias{getLbf,FineMappingResultBase-method} +\name{lbf} +\alias{lbf} +\alias{lbf,FineMappingResultBase-method} \title{Per-variant per-effect log Bayes factors (wide)} \usage{ -getLbf(x, ...) +lbf(x, ...) -\S4method{getLbf}{FineMappingResultBase}(x) +\S4method{lbf}{FineMappingResultBase}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} @@ -23,14 +23,14 @@ The variant x effect matrix of single-effect log Bayes factors (\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one row per variant, one \code{lbf_L} column per effect. The per-variant scalar summary (max across effects) is the \code{logBF} column of -\code{\link{getTopLoci}}; this accessor keeps the full per-effect breakdown. +\code{\link{topLoci}}; this accessor keeps the full per-effect breakdown. Across entries with different effect counts the collection method NA-fills the ragged columns. } \examples{ data(qtlFineMappingExample) -getLbf(qtlFineMappingExample) +lbf(qtlFineMappingExample) } \seealso{ -\code{\link{getTopLoci}} (the scalar \code{logBF} column) +\code{\link{topLoci}} (the scalar \code{logBF} column) } diff --git a/man/getLdBlocks.Rd b/man/ldBlocks.Rd similarity index 69% rename from man/getLdBlocks.Rd rename to man/ldBlocks.Rd index 23bb3a34..556d1858 100644 --- a/man/getLdBlocks.Rd +++ b/man/ldBlocks.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdStatistic.R -\name{getLdBlocks} -\alias{getLdBlocks} -\alias{getLdBlocks,LdStatistic-method} +\name{ldBlocks} +\alias{ldBlocks} +\alias{ldBlocks,LdStatistic-method} \title{Get LD Block Container} \usage{ -getLdBlocks(x) +ldBlocks(x) -\S4method{getLdBlocks}{LdStatistic}(x) +\S4method{ldBlocks}{LdStatistic}(x) } \arguments{ \item{x}{An \code{LdStatistic}.} @@ -21,5 +21,5 @@ Return the \code{GRanges} of LD blocks carried by an } \examples{ data(ldEigenExample) -getLdBlocks(ldEigenExample) +ldBlocks(ldEigenExample) } diff --git a/man/ldEigenExample.Rd b/man/ldEigenExample.Rd index 3c673407..55316c3a 100644 --- a/man/ldEigenExample.Rd +++ b/man/ldEigenExample.Rd @@ -19,7 +19,7 @@ reference panel, so the LD is real rather than simulated. Describes the same variants as \code{\link{ldScoreExample}}, so the four estimators can be compared on one reference. -The panel behind it has \code{nRef = 1000}. That is small enough that +The panel behind it has \code{nSamples = 1000}. That is small enough that \code{method = "hdl"}, which models reference-panel noise explicitly, shrinks its estimate hard -- correct behaviour for a panel this size rather than a fault. diff --git a/man/getCorrelation.Rd b/man/ldMatrix.Rd similarity index 82% rename from man/getCorrelation.Rd rename to man/ldMatrix.Rd index b4fe5e6f..de53c6ee 100644 --- a/man/getCorrelation.Rd +++ b/man/ldMatrix.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{getCorrelation} -\alias{getCorrelation} -\alias{getCorrelation,LdData-method} +\name{ldMatrix} +\alias{ldMatrix} +\alias{ldMatrix,LdData-method} \title{Get LD Correlation Matrix} \usage{ -getCorrelation(x) +ldMatrix(x) -\S4method{getCorrelation}{LdData}(x) +\S4method{ldMatrix}{LdData}(x) } \arguments{ \item{x}{An \code{LdData} object.} @@ -28,5 +28,5 @@ gr <- GenomicRanges::GRanges("22", ld <- LdData(correlation = cor(X), variants = gr, blockMetadata = S4Vectors::DataFrame( chrom = "22", start = 1L, end = 1000L)) -getCorrelation(ld) +ldMatrix(ld) } diff --git a/man/getLdMatrixList.Rd b/man/ldMatrixList.Rd similarity index 69% rename from man/getLdMatrixList.Rd rename to man/ldMatrixList.Rd index 4072594c..4a6ed950 100644 --- a/man/getLdMatrixList.Rd +++ b/man/ldMatrixList.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdScore.R -\name{getLdMatrixList} -\alias{getLdMatrixList} -\alias{getLdMatrixList,LdScore-method} +\name{ldMatrixList} +\alias{ldMatrixList} +\alias{ldMatrixList,LdScore-method} \title{Get Per-Block LD Matrix List} \usage{ -getLdMatrixList(x) +ldMatrixList(x) -\S4method{getLdMatrixList}{LdScore}(x) +\S4method{ldMatrixList}{LdScore}(x) } \arguments{ \item{x}{An \code{LdScore}.} @@ -21,5 +21,5 @@ Return the list of per-block LD (R^2) matrices used for the FGLS } \examples{ data(ldScoreExample) -getLdMatrixList(ldScoreExample) +ldMatrixList(ldScoreExample) } diff --git a/man/getNRef.Rd b/man/ldPanelNSamples.Rd similarity index 73% rename from man/getNRef.Rd rename to man/ldPanelNSamples.Rd index cd52a10c..2f64acf5 100644 --- a/man/getNRef.Rd +++ b/man/ldPanelNSamples.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R, R/LdStatistic.R -\name{getNRef} -\alias{getNRef} -\alias{getNRef,LdData-method} -\alias{getNRef,LdStatistic-method} +\name{ldPanelNSamples} +\alias{ldPanelNSamples} +\alias{ldPanelNSamples,LdData-method} +\alias{ldPanelNSamples,LdStatistic-method} \title{Get LD Reference Panel Size} \usage{ -getNRef(x) +ldPanelNSamples(x) -\S4method{getNRef}{LdData}(x) +\S4method{ldPanelNSamples}{LdData}(x) -\S4method{getNRef}{LdStatistic}(x) +\S4method{ldPanelNSamples}{LdStatistic}(x) } \arguments{ \item{x}{An \code{LdStatistic} or \code{LdData}.} @@ -30,5 +30,5 @@ gr <- GenomicRanges::GRanges("22", ld <- LdData(correlation = cor(X), variants = gr, blockMetadata = S4Vectors::DataFrame( chrom = "22", start = 1L, end = 1000L)) -getNRef(ld) +ldPanelNSamples(ld) } diff --git a/man/getLdSketch.Rd b/man/ldSketch.Rd similarity index 63% rename from man/getLdSketch.Rd rename to man/ldSketch.Rd index 7dbecf62..2a8cbcea 100644 --- a/man/getLdSketch.Rd +++ b/man/ldSketch.Rd @@ -1,23 +1,23 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, % R/ColocResult.R, R/twasWeights.R -\name{getLdSketch} -\alias{getLdSketch} -\alias{getLdSketch,SumStatsBase-method} -\alias{getLdSketch,FineMappingResultBase-method} -\alias{getLdSketch,ColocResultBase-method} -\alias{getLdSketch,TwasWeights-method} +\name{ldSketch} +\alias{ldSketch} +\alias{ldSketch,SumStatsBase-method} +\alias{ldSketch,FineMappingResultBase-method} +\alias{ldSketch,ColocResultBase-method} +\alias{ldSketch,TwasWeights-method} \title{Get LD Sketch} \usage{ -getLdSketch(x, ...) +ldSketch(x, ...) -\S4method{getLdSketch}{SumStatsBase}(x) +\S4method{ldSketch}{SumStatsBase}(x) -\S4method{getLdSketch}{FineMappingResultBase}(x) +\S4method{ldSketch}{FineMappingResultBase}(x) -\S4method{getLdSketch}{ColocResultBase}(x) +\S4method{ldSketch}{ColocResultBase}(x) -\S4method{getLdSketch}{TwasWeights}(x) +\S4method{ldSketch}{TwasWeights}(x) } \arguments{ \item{x}{An S4 object that carries an \code{ldSketch} slot.} @@ -37,5 +37,5 @@ Return the genotype panel carrying the LD reference for } \examples{ data(qtlSumStatsExample) -getLdSketch(qtlSumStatsExample) +ldSketch(qtlSumStatsExample) } diff --git a/man/learnTwasWeights.Rd b/man/learnTwasWeights.Rd index 6194d57f..a6620aff 100644 --- a/man/learnTwasWeights.Rd +++ b/man/learnTwasWeights.Rd @@ -8,14 +8,14 @@ learnTwasWeights( X, Y, weightMethods, - study = "", + studyName = "", context = "", trait = "", numThreads = 1, fittedModels = NULL, fitRetention = c("none", "slim", "full"), - standardized = FALSE, - dataType = NULL, + weightStandardized = FALSE, + weightsDataType = NULL, ldSketch = NULL, verbose = 1, seed = NULL @@ -35,7 +35,7 @@ alternatively a character vector of method names (eg, c("susie_weights", methods. methods in the list can be either univariate (applied to each column of Y) or multivariate (applied to the entire Y matrix).} -\item{study}{Character. Study identity label recorded on the resulting +\item{studyName}{Character. Study identity label recorded on the resulting weights.} \item{context}{Character. Context identity label recorded on the resulting @@ -62,11 +62,11 @@ 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}.} +\item{weightStandardized}{Logical. Whether the supplied \code{X} / \code{Y} +are already standardized. Default \code{FALSE}.} -\item{dataType}{Character or \code{NULL}. Data-type label recorded on the -weights (e.g. \code{"individual"}).} +\item{weightsDataType}{Character or \code{NULL}. Data-type label recorded on +the weights (e.g. \code{"individual"}).} \item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) to record on the weights as their LD sketch, or \code{NULL}.} diff --git a/man/loadMultiStudyQtlDatasetFromManifest.Rd b/man/loadMultiStudyQtlDatasetFromManifest.Rd index 5cd0a0b2..33abb230 100644 --- a/man/loadMultiStudyQtlDatasetFromManifest.Rd +++ b/man/loadMultiStudyQtlDatasetFromManifest.Rd @@ -16,7 +16,7 @@ loadMultiStudyQtlDatasetFromManifest( formatMapping = NULL, transposeCovariates = FALSE, scaleResiduals = TRUE, - genotypeFilterArgs = GenotypeFilterParam() + genotypeFilterParam = GenotypeFilterParam() ) } \arguments{ @@ -38,7 +38,7 @@ loader for \code{sumStatsManifest}.} \item{scaleResiduals}{Pass-through \code{\link{QtlDataset}} argument, applied to every study.} -\item{genotypeFilterArgs}{Pass-through \code{\link{QtlDataset}} filtering +\item{genotypeFilterParam}{Pass-through \code{\link{QtlDataset}} filtering options, built with \code{\link{GenotypeFilterParam}} and applied to every study.} } diff --git a/man/loadQtlDatasetFromManifest.Rd b/man/loadQtlDatasetFromManifest.Rd index 731319b5..0283d9bb 100644 --- a/man/loadQtlDatasetFromManifest.Rd +++ b/man/loadQtlDatasetFromManifest.Rd @@ -6,11 +6,11 @@ \usage{ loadQtlDatasetFromManifest( manifest, - study = NULL, + studyName = NULL, genotypes = NULL, genotypeCovariates = NULL, scaleResiduals = TRUE, - genotypeFilterArgs = GenotypeFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), transposeCovariates = FALSE ) } @@ -22,7 +22,7 @@ loadQtlDatasetFromManifest( single-valued \code{study} / \code{genotypePath} / \code{genotypeCovariatePath}.} -\item{study}{Study identifier; reconciled with a \code{study} column.} +\item{studyName}{Study identifier; reconciled with a \code{study} column.} \item{genotypes}{A genotype panel (see \code{\link{readGenotypes}}) or a genotype path/prefix; reconciled with a \code{genotypePath} column.} @@ -32,7 +32,7 @@ to a covariate TSV; reconciled with a \code{genotypeCovariatePath} column.} \item{scaleResiduals}{Pass-through \code{\link{QtlDataset}} argument.} -\item{genotypeFilterArgs}{Pass-through \code{\link{QtlDataset}} filtering +\item{genotypeFilterParam}{Pass-through \code{\link{QtlDataset}} filtering options, built with \code{\link{GenotypeFilterParam}} and stored as lazy QC slots.} @@ -53,5 +53,5 @@ d <- system.file("extdata", "qtl_mini", package = "pecotmr") manifest <- data.frame(context = "brain", phenotypePath = file.path(d, "example_geneexpr.bed.gz"), study = "s1", genotypePath = file.path(d, "example.chr22")) -loadQtlDatasetFromManifest(manifest = manifest, study = "s1") +loadQtlDatasetFromManifest(manifest = manifest, studyName = "s1") } diff --git a/man/getLocal.Rd b/man/localH2Blocks.Rd similarity index 67% rename from man/getLocal.Rd rename to man/localH2Blocks.Rd index 8cb91889..76a5c382 100644 --- a/man/getLocal.Rd +++ b/man/localH2Blocks.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getLocal} -\alias{getLocal} -\alias{getLocal,H2Estimate-method} +\name{localH2Blocks} +\alias{localH2Blocks} +\alias{localH2Blocks,H2Estimate-method} \title{Get Local Estimates} \usage{ -getLocal(object) +localH2Blocks(object) -\S4method{getLocal}{H2Estimate}(object) +\S4method{localH2Blocks}{H2Estimate}(object) } \arguments{ \item{object}{An \code{H2Estimate} object.} @@ -20,5 +20,5 @@ Extract per-block local estimates from a result object. } \examples{ data(h2EstimateExample) -getLocal(h2EstimateExample) +localH2Blocks(h2EstimateExample) } diff --git a/man/getMaf.Rd b/man/maf.Rd similarity index 76% rename from man/getMaf.Rd rename to man/maf.Rd index 5899410e..2289830d 100644 --- a/man/getMaf.Rd +++ b/man/maf.Rd @@ -1,23 +1,23 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/QtlDataset.R -\name{getMaf} -\alias{getMaf} -\alias{getMaf,SumStatsBase-method} -\alias{getMaf,QtlDataset-method} +\name{maf} +\alias{maf} +\alias{maf,SumStatsBase-method} +\alias{maf,QtlDataset-method} \title{Get Minor Allele Frequencies} \usage{ -getMaf(x, ...) +maf(x, ...) -\S4method{getMaf}{SumStatsBase}( +\S4method{maf}{SumStatsBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) -\S4method{getMaf}{QtlDataset}(x, region = NULL, cisWindow = NULL, samples = NULL) +\S4method{maf}{QtlDataset}(x, region = NULL, cisWindow = NULL, samples = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlDataset} object.} @@ -25,8 +25,8 @@ 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{studyName}{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.} @@ -35,7 +35,7 @@ this context; \code{NULL} matches all contexts.} 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.} +\code{\link{sumStats}} (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.} @@ -58,5 +58,5 @@ Extract MAF vector from a GwasSumStats object. } \examples{ data(qtlDatasetExample) -getMaf(qtlDatasetExample) +maf(qtlDatasetExample) } diff --git a/man/getMarginalEffects.Rd b/man/marginalEffects.Rd similarity index 79% rename from man/getMarginalEffects.Rd rename to man/marginalEffects.Rd index b1539b3a..4a08c449 100644 --- a/man/getMarginalEffects.Rd +++ b/man/marginalEffects.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getMarginalEffects} -\alias{getMarginalEffects} -\alias{getMarginalEffects,FineMappingResultBase-method} +\name{marginalEffects} +\alias{marginalEffects} +\alias{marginalEffects,FineMappingResultBase-method} \title{Get Marginal Effects} \usage{ -getMarginalEffects(x, maxPval = NULL, ...) +marginalEffects(x, maxPval = NULL, ...) -\S4method{getMarginalEffects}{FineMappingResultBase}( +\S4method{marginalEffects}{FineMappingResultBase}( x, maxPval = NULL, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -25,8 +25,8 @@ where \code{p > maxPval}. Default \code{NULL} (no filter).} \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{studyName}{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.} @@ -53,5 +53,5 @@ Extract per-variant marginal univariate effects from a } \examples{ data(qtlFineMappingExample) -getMarginalEffects(qtlFineMappingExample) +marginalEffects(qtlFineMappingExample) } diff --git a/man/mashModelFit.Rd b/man/mashModelFit.Rd index 8894d053..e4be56f4 100644 --- a/man/mashModelFit.Rd +++ b/man/mashModelFit.Rd @@ -72,7 +72,7 @@ data(mashInputExample) mi <- mashInputExample mk <- function(b, s) { qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), - study = "mash") + studyName = "mash") } ssl <- list(strong = mk("strong.b", "strong.s"), random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) diff --git a/man/mashPosterior.Rd b/man/mashPosterior.Rd index f9d58056..e43b126c 100644 --- a/man/mashPosterior.Rd +++ b/man/mashPosterior.Rd @@ -70,7 +70,7 @@ data(mashInputExample) mi <- mashInputExample mk <- function(b, s) { qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), - study = "mash") + studyName = "mash") } ssl <- list(strong = mk("strong.b", "strong.s"), random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) diff --git a/man/mergeCtwasBoundaryRegions.Rd b/man/mergeCtwasBoundaryRegions.Rd index 336b2b2f..ef516588 100644 --- a/man/mergeCtwasBoundaryRegions.Rd +++ b/man/mergeCtwasBoundaryRegions.Rd @@ -9,7 +9,7 @@ mergeCtwasBoundaryRegions( pipThresh = 0.5, filterCs = FALSE, maxSNP = Inf, - L = 5L, + maxNumSingleEffects = 5L, numThreads = 1L, methodArgs = CtwasOptions() ) @@ -33,8 +33,8 @@ to be selected (\code{select_boundary_genes} \code{filter_cs}). Default \item{maxSNP}{Numeric (length 1). Per-merged-region SNP cap. Default \code{Inf}.} -\item{L}{Integer. Max number of single effects for the merged-region -re-fine-mapping (LD path only). Default \code{5}.} +\item{maxNumSingleEffects}{Integer. Max number of single effects for the +merged-region re-fine-mapping (LD path only). Default \code{5}.} \item{numThreads}{Number of cores. Default \code{1}.} diff --git a/man/metaSldscRandom.Rd b/man/metaSldscRandom.Rd index 05a9f38c..ab98d253 100644 --- a/man/metaSldscRandom.Rd +++ b/man/metaSldscRandom.Rd @@ -47,8 +47,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -60,7 +60,7 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) pp <- sldscPostprocessingPipeline(sd) metaSldscRandom(pp$per_trait, category = "annot_A_0", quantity = "enrichment") diff --git a/man/getFits.Rd b/man/methodFits.Rd similarity index 66% rename from man/getFits.Rd rename to man/methodFits.Rd index 7174016b..4af54c73 100644 --- a/man/getFits.Rd +++ b/man/methodFits.Rd @@ -1,25 +1,25 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/twasWeights.R, % R/twasWeightsRow.R -\name{getFits} -\alias{getFits} -\alias{getFits,TwasWeights-method} -\alias{getFits,TwasWeightsRow-method} +\name{methodFits} +\alias{methodFits} +\alias{methodFits,TwasWeights-method} +\alias{methodFits,TwasWeightsRow-method} \title{Get Model Fits} \usage{ -getFits(x, ...) +methodFits(x, ...) -\S4method{getFits}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) +\S4method{methodFits}{TwasWeights}(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getFits}{TwasWeightsRow}(x) +\S4method{methodFits}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} \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{studyName}{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.} @@ -39,5 +39,5 @@ Extract fitted model objects. \examples{ data(ctwasWeightsExample) # NULL unless the pipeline kept fits (fitRetention != "none") -getFits(ctwasWeightsExample) +methodFits(ctwasWeightsExample) } diff --git a/man/getMethodNames.Rd b/man/methodNames.Rd similarity index 53% rename from man/getMethodNames.Rd rename to man/methodNames.Rd index 3cf5f3a5..452eaab8 100644 --- a/man/getMethodNames.Rd +++ b/man/methodNames.Rd @@ -1,23 +1,23 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, % R/CtwasResult.R, R/H2Estimate.R, R/twasWeights.R -\name{getMethodNames} -\alias{getMethodNames} -\alias{getMethodNames,FineMappingResultBase-method} -\alias{getMethodNames,CtwasResult-method} -\alias{getMethodNames,H2Estimate-method} -\alias{getMethodNames,TwasWeights-method} +\name{methodNames} +\alias{methodNames} +\alias{methodNames,FineMappingResultBase-method} +\alias{methodNames,CtwasResult-method} +\alias{methodNames,H2Estimate-method} +\alias{methodNames,TwasWeights-method} \title{Get Method Names} \usage{ -getMethodNames(x) +methodNames(x) -\S4method{getMethodNames}{FineMappingResultBase}(x) +\S4method{methodNames}{FineMappingResultBase}(x) -\S4method{getMethodNames}{CtwasResult}(x) +\S4method{methodNames}{CtwasResult}(x) -\S4method{getMethodNames}{H2Estimate}(x) +\S4method{methodNames}{H2Estimate}(x) -\S4method{getMethodNames}{TwasWeights}(x) +\S4method{methodNames}{TwasWeights}(x) } \arguments{ \item{x}{A \code{FineMappingResult}, \code{TwasWeights}, @@ -32,7 +32,7 @@ Extract the method name(s) an object was produced with: one } \examples{ data(h2EstimateExample) -getMethodNames(h2EstimateExample) +methodNames(h2EstimateExample) data(qtlFineMappingExample) -getMethodNames(qtlFineMappingExample) +methodNames(qtlFineMappingExample) } diff --git a/man/getMixtureWeights.Rd b/man/mixtureWeights.Rd similarity index 80% rename from man/getMixtureWeights.Rd rename to man/mixtureWeights.Rd index b95f039a..105f2d4e 100644 --- a/man/getMixtureWeights.Rd +++ b/man/mixtureWeights.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{getMixtureWeights} -\alias{getMixtureWeights} -\alias{getMixtureWeights,LdData-method} +\name{mixtureWeights} +\alias{mixtureWeights} +\alias{mixtureWeights,LdData-method} \title{Get Mixture Weights} \usage{ -getMixtureWeights(x) +mixtureWeights(x) -\S4method{getMixtureWeights}{LdData}(x) +\S4method{mixtureWeights}{LdData}(x) } \arguments{ \item{x}{An \code{LdData}.} @@ -28,5 +28,5 @@ gr <- GenomicRanges::GRanges("22", ld <- LdData(correlation = cor(X), variants = gr, blockMetadata = S4Vectors::DataFrame( chrom = "22", start = 1L, end = 1000L)) -getMixtureWeights(ld) +mixtureWeights(ld) } diff --git a/man/getPhenotypes.Rd b/man/molecularTraits.Rd similarity index 70% rename from man/getPhenotypes.Rd rename to man/molecularTraits.Rd index ffb3e76a..7cd247dc 100644 --- a/man/getPhenotypes.Rd +++ b/man/molecularTraits.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{getPhenotypes} -\alias{getPhenotypes} -\alias{getPhenotypes,QtlDataset-method} -\title{Get Phenotype List} +\name{molecularTraits} +\alias{molecularTraits} +\alias{molecularTraits,QtlDataset-method} +\title{Get Molecular Traits} \usage{ -getPhenotypes(x, ...) +molecularTraits(x, ...) -\S4method{getPhenotypes}{QtlDataset}( +\S4method{molecularTraits}{QtlDataset}( x, contexts, traitId = NULL, @@ -48,16 +48,20 @@ robust covariance estimator the outlier rule is built on, supplied with consulted when \code{outlierAction = "drop"}.} } \value{ -A named list of phenotype matrices or \code{SummarizedExperiment} - objects. +A \code{SummarizedExperiment} when one context is selected, or a + named list of them for several. A \code{QtlDataset} is a + \code{MultiAssayExperiment}, so these are its experiments; take the + measurement matrix itself with + \code{SummarizedExperiment::assay()} rather than asking this accessor + for one. } \description{ -Extract phenotype data from an object that carries it. For a - \code{QtlDataset}, the user can optionally select specific contexts, +Extract molecular-trait data from an object that carries it. + For a \code{QtlDataset}, the user can optionally select specific contexts, traits, or a region (see method documentation for the per-class selection arguments). } \examples{ data(qtlDatasetExample) -getPhenotypes(qtlDatasetExample, contexts = "brain") +molecularTraits(qtlDatasetExample, contexts = "brain") } diff --git a/man/mvsusieWeights.Rd b/man/mvsusieWeights.Rd index 39af00d9..0ac56e29 100644 --- a/man/mvsusieWeights.Rd +++ b/man/mvsusieWeights.Rd @@ -26,7 +26,7 @@ X <- multiTraitData$X[, 1:60] Y <- multiTraitData$Y fit <- fitMvsusie(X = X, Y = Y, prior_variance = mvsusieR::create_mixture_prior(R = ncol(Y)), - methodArgs = MvsusieOptions(L = 5)) + methodArgs = MvsusieOptions(max_iter = 50)) mvsusieWeights(mvsusieFit = fit) } } diff --git a/man/nSamples.Rd b/man/nSamples.Rd new file mode 100644 index 00000000..8bcdafaf --- /dev/null +++ b/man/nSamples.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R, +% R/AllClasses.R +\name{nSamples} +\alias{nSamples} +\alias{nSamples,GenotypeHandle-method} +\alias{nSamples,SumStatsBase-method} +\title{Get Sample Sizes} +\usage{ +nSamples(x, ...) + +\S4method{nSamples}{GenotypeHandle}(x) + +\S4method{nSamples}{SumStatsBase}( + x, + studyName = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ranges = NULL +) +} +\arguments{ +\item{x}{A \code{GwasSumStats}, \code{QtlSumStats} or +\code{GenotypeHandle} object.} + +\item{...}{Class-specific selection arguments.} + +\item{studyName}{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{sumStats}} (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 for a summary-statistic entry; + integer of length 1 for a \code{GenotypeHandle}. +} +\description{ +Extract sample sizes: the per-variant sample-size vector of a + \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity + tuple, or the number of samples carried by a \code{GenotypeHandle}. +} +\details{ +The genotype handle is the seed layer behind a panel and is not + part of the public interface; obtain a panel from + \code{readGenotypes()} and ask it directly. +} +\examples{ +data(qtlSumStatsExample) +nSamples(qtlSumStatsExample) +} diff --git a/man/nSnps.Rd b/man/nSnps.Rd index 3bac7b01..8eddf55f 100644 --- a/man/nSnps.Rd +++ b/man/nSnps.Rd @@ -1,28 +1,32 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/H2Estimate.R \name{nSnps} \alias{nSnps} \alias{nSnps,SumStatsBase-method} +\alias{nSnps,H2Estimate-method} \title{Get Number of SNPs} \usage{ nSnps(x, ...) \S4method{nSnps}{SumStatsBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) + +\S4method{nSnps}{H2Estimate}(x) } \arguments{ -\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} +\item{x}{A \code{GwasSumStats}, \code{QtlSumStats} or \code{H2Estimate} +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{studyName}{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.} @@ -31,7 +35,7 @@ this context; \code{NULL} matches all contexts.} 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.} +\code{\link{sumStats}} (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.} @@ -41,7 +45,8 @@ Integer. } \description{ Number of SNPs in a \code{GwasSumStats} or \code{QtlSumStats} - entry, selected by its identity tuple. + entry, selected by its identity tuple, or the number of variants an + \code{H2Estimate} was computed over. } \examples{ data(qtlSumStatsExample) diff --git a/man/overlapTopLoci.Rd b/man/overlapTopLoci.Rd index 50a0b85e..82182ef0 100644 --- a/man/overlapTopLoci.Rd +++ b/man/overlapTopLoci.Rd @@ -7,12 +7,7 @@ \usage{ overlapTopLoci(qtl, gwas, ...) -\S4method{overlapTopLoci}{QtlFineMappingResult,GwasFineMappingResult}( - qtl, - gwas, - signalCutoff = 0.025, - type = c("data.frame", "GRanges") -) +\S4method{overlapTopLoci}{QtlFineMappingResult,GwasFineMappingResult}(qtl, gwas, signalCutoff = 0.025) } \arguments{ \item{qtl}{A \code{QtlFineMappingResult}.} @@ -21,16 +16,14 @@ overlapTopLoci(qtl, gwas, ...) \item{...}{Ignored.} -\item{signalCutoff}{PIP cutoff forwarded to \code{\link{getTopLoci}} for both +\item{signalCutoff}{PIP cutoff forwarded to \code{\link{topLoci}} for both inputs. Default 0.025.} - -\item{type}{\code{"data.frame"} (default) or \code{"GRanges"}.} } \value{ -A \code{tibble} (or \code{GRanges}) keyed on the QTL variant - (\code{variant_id, chrom, pos, A1, A2}) with all other columns prefixed - \code{qtl_} / \code{gwas_}. Zero rows when there is no allele-aware - overlap. +A \code{GRanges} keyed on the QTL variant + (\code{variant_id, chrom, pos, A1, A2} in \code{mcols()}) with all other + columns prefixed \code{qtl_} / \code{gwas_}. Zero ranges when there is no + allele-aware overlap. Take a table with \code{as.data.frame()}. } \description{ Intersect the top-loci tables of a \code{QtlFineMappingResult} and a @@ -51,5 +44,5 @@ data(gwasFineMappingLbfExample) overlapTopLoci(qtlFineMappingLbfExample, gwasFineMappingLbfExample) } \seealso{ -\code{\link{getTopLoci}}, \code{matchVariants} +\code{\link{topLoci}}, \code{matchVariants} } diff --git a/man/pecotmr-h2-lder.Rd b/man/pecotmr-h2-lder.Rd index 1a984bca..955a6a70 100644 --- a/man/pecotmr-h2-lder.Rd +++ b/man/pecotmr-h2-lder.Rd @@ -17,7 +17,7 @@ Estimate SNP heritability by LD eigenvalue regression (Song et + (1 + N a)}, so \eqn{Cov(z) = (N h2/M) R^2 + (1 + N a) R}. The IRWLS weight uses an in-sample (\eqn{\min(1,\lambda)}) or out-of-sample (logistic) form - selected by \code{getInSample}, and a two-stage step estimates the + selected by \code{inSample}, and a two-stage step estimates the confounding inflation \eqn{a} on a \eqn{\chi^2}-filtered subset. The stratified extension regresses on \eqn{\lambda_i \ell_{ia}} (\eqn{\ell_{ia} = \sum_j A_{ja} V_{ji}^2}) and reduces to the univariate diff --git a/man/getPgenPtr.Rd b/man/pgenPtr.Rd similarity index 80% rename from man/getPgenPtr.Rd rename to man/pgenPtr.Rd index 0bbde99b..66fd0fae 100644 --- a/man/getPgenPtr.Rd +++ b/man/pgenPtr.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R -\name{getPgenPtr} -\alias{getPgenPtr} -\alias{getPgenPtr,GenotypeHandle-method} +\name{pgenPtr} +\alias{pgenPtr} +\alias{pgenPtr,GenotypeHandle-method} \title{Get plink2 pgen Pointer} \usage{ -getPgenPtr(x) +pgenPtr(x) -\S4method{getPgenPtr}{GenotypeHandle}(x) +\S4method{pgenPtr}{GenotypeHandle}(x) } \arguments{ \item{x}{A \code{GenotypeHandle}.} diff --git a/man/getPhenotypeCovariates.Rd b/man/phenotypeCovariates.Rd similarity index 62% rename from man/getPhenotypeCovariates.Rd rename to man/phenotypeCovariates.Rd index bbe71bc7..9b15eec0 100644 --- a/man/getPhenotypeCovariates.Rd +++ b/man/phenotypeCovariates.Rd @@ -1,19 +1,19 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{getPhenotypeCovariates} -\alias{getPhenotypeCovariates} -\alias{getPhenotypeCovariates,QtlDataset-method} +\name{phenotypeCovariates} +\alias{phenotypeCovariates} +\alias{phenotypeCovariates,QtlDataset-method} \title{Get Per-Context Phenotype Covariates} \usage{ -getPhenotypeCovariates(x, contexts) +phenotypeCovariates(x, contexts) -\S4method{getPhenotypeCovariates}{QtlDataset}(x, contexts) +\S4method{phenotypeCovariates}{QtlDataset}(x, contexts) } \arguments{ \item{x}{A \code{QtlDataset} object.} \item{contexts}{Character vector of context names (subset of -\code{names(getPhenotypes(x))}).} +\code{names(molecularTraits(x))}).} } \value{ A named list of matrices keyed by context. @@ -24,5 +24,5 @@ Return per-context phenotype covariate matrices, taken from the } \examples{ data(qtlDatasetExample) -getPhenotypeCovariates(qtlDatasetExample, contexts = "brain") +phenotypeCovariates(qtlDatasetExample, contexts = "brain") } diff --git a/man/getPip.Rd b/man/pip.Rd similarity index 78% rename from man/getPip.Rd rename to man/pip.Rd index 43eee303..2a527db6 100644 --- a/man/getPip.Rd +++ b/man/pip.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GwasFineMappingResult.R, % R/QtlFineMappingResult.R -\name{getPip} -\alias{getPip} -\alias{getPip,GwasFineMappingResult-method} -\alias{getPip,QtlFineMappingResult-method} +\name{pip} +\alias{pip} +\alias{pip,GwasFineMappingResult-method} +\alias{pip,QtlFineMappingResult-method} \title{Get PIP Values} \usage{ -getPip(x, ...) +pip(x, ...) -\S4method{getPip}{GwasFineMappingResult}( +\S4method{pip}{GwasFineMappingResult}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -19,9 +19,9 @@ getPip(x, ...) returnList = FALSE ) -\S4method{getPip}{QtlFineMappingResult}( +\S4method{pip}{QtlFineMappingResult}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -33,8 +33,8 @@ getPip(x, ...) \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{studyName}{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.} @@ -62,5 +62,5 @@ Extract posterior inclusion probabilities from a single } \examples{ data(qtlFineMappingExample) -getPip(qtlFineMappingExample) +pip(qtlFineMappingExample) } diff --git a/man/postprocessFinemappingFits.Rd b/man/postprocessFinemappingFits.Rd index a66a1fbb..04466a70 100644 --- a/man/postprocessFinemappingFits.Rd +++ b/man/postprocessFinemappingFits.Rd @@ -12,7 +12,7 @@ postprocessFinemappingFits( yScalar = 1, af = NULL, n = NULL, - credibleSetArgs = CredibleSetParam(), + credibleSetParam = CredibleSetParam(), fitRetention = "slim", otherQuantities = NULL, region = NULL, @@ -41,7 +41,7 @@ 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{credibleSetArgs}{How credible sets are built and reported, built with +\item{credibleSetParam}{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 diff --git a/man/getP.Rd b/man/pval.Rd similarity index 74% rename from man/getP.Rd rename to man/pval.Rd index 1765bae4..ed61f24d 100644 --- a/man/getP.Rd +++ b/man/pval.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getP} -\alias{getP} -\alias{getP,SumStatsBase-method} +\name{pval} +\alias{pval} +\alias{pval,SumStatsBase-method} \title{Get Association P-values} \usage{ -getP(x, ...) +pval(x, ...) -\S4method{getP}{SumStatsBase}( +\S4method{pval}{SumStatsBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, @@ -21,8 +21,8 @@ getP(x, ...) \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{studyName}{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.} @@ -31,7 +31,7 @@ this context; \code{NULL} matches all contexts.} 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.} +\code{\link{sumStats}} (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.} @@ -43,9 +43,9 @@ Numeric vector of p-values, or \code{NULL} if not available. Extract the association p-value vector from a \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity tuple. Part of the first-class summary-statistic column set alongside - \code{\link{getZ}} / \code{\link{getBeta}} / \code{\link{getSe}}. + \code{\link{z}} / \code{\link{coef}} / \code{\link{se}}. } \examples{ data(qtlSumStatsExample) -getP(qtlSumStatsExample) +pval(qtlSumStatsExample) } diff --git a/man/getQcDiagnostics.Rd b/man/qcDiagnostics.Rd similarity index 77% rename from man/getQcDiagnostics.Rd rename to man/qcDiagnostics.Rd index bb398f7c..d116c376 100644 --- a/man/getQcDiagnostics.Rd +++ b/man/qcDiagnostics.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getQcDiagnostics} -\alias{getQcDiagnostics} -\alias{getQcDiagnostics,SumStatsBase-method} +\name{qcDiagnostics} +\alias{qcDiagnostics} +\alias{qcDiagnostics,SumStatsBase-method} \title{Get SLALOM / DENTIST Diagnostics} \usage{ -getQcDiagnostics(x, entry = 1L, ...) +qcDiagnostics(x, entry = 1L, ...) -\S4method{getQcDiagnostics}{SumStatsBase}(x, entry = 1L) +\S4method{qcDiagnostics}{SumStatsBase}(x, entry = 1L) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -30,9 +30,9 @@ Return the per-variant LD-mismatch diagnostics table (SLALOM or \code{\link{summaryStatsQc}} when \code{ldMismatchQcMethod} was not \code{"none"}. Convenience accessor over - \code{getQcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. + \code{qcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. } \examples{ data(qtlSumStatsExample) -getQcDiagnostics(qtlSumStatsExample) +qcDiagnostics(qtlSumStatsExample) } diff --git a/man/getQcInfo.Rd b/man/qcInfo.Rd similarity index 77% rename from man/getQcInfo.Rd rename to man/qcInfo.Rd index 0dfab611..bf9b23f7 100644 --- a/man/getQcInfo.Rd +++ b/man/qcInfo.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getQcInfo} -\alias{getQcInfo} -\alias{getQcInfo,SumStatsBase-method} +\name{qcInfo} +\alias{qcInfo} +\alias{qcInfo,SumStatsBase-method} \title{Get QC Audit Record} \usage{ -getQcInfo(x, ...) +qcInfo(x, ...) -\S4method{getQcInfo}{SumStatsBase}(x) +\S4method{qcInfo}{SumStatsBase}(x) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -23,9 +23,9 @@ Return the audit record of QC steps applied to this collection. \code{\link{summaryStatsQc}} has not yet been run. Pipelines that require harmonized sumstats (\code{fineMappingPipeline}, \code{twasWeightsPipeline}, and downstream consumers) reject inputs where - \code{length(getQcInfo(x)) == 0L}. + \code{length(qcInfo(x)) == 0L}. } \examples{ data(qtlSumStatsExample) -getQcInfo(qtlSumStatsExample) +qcInfo(qtlSumStatsExample) } diff --git a/man/qtlAssociationPostprocess.Rd b/man/qtlAssociationPostprocess.Rd index 1e91e239..7d38c3ce 100644 --- a/man/qtlAssociationPostprocess.Rd +++ b/man/qtlAssociationPostprocess.Rd @@ -39,7 +39,7 @@ row column).} (needs \code{p_beta}/\code{beta_shape1}/\code{beta_shape2}) and \code{"bonferroni"} (needs \code{n_variants}). The q-value SNP method adds no stored column -- it is a significance query (see -\code{getSignificantQtls}).} +\code{significantQtls}).} \item{pvalueCol, afCol}{Entry mcol names for the per-variant p-value / allele frequency (defaults \code{"P"} / \code{"af"}).} @@ -72,7 +72,7 @@ entries <- lapply(seq_len(G), function(i) { tes_distance = c(0L, 500L, 900000L, 2000000L)) gr }) -qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), +qss <- QtlSumStats(studyName = rep("s", G), context = rep("brain", G), trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", extraCols = list( n_variants = rep(50L, G), n_variants_filtered = rep(30L, G), diff --git a/man/qtlDatasetFilters.Rd b/man/qtlDatasetFilters.Rd index 7343008e..3f0dc114 100644 --- a/man/qtlDatasetFilters.Rd +++ b/man/qtlDatasetFilters.Rd @@ -2,43 +2,43 @@ % Please edit documentation in R/AllGenerics.R, R/QtlDataset.R \name{qtlDatasetFilters} \alias{qtlDatasetFilters} -\alias{getMafCutoff} -\alias{getMacCutoff} -\alias{getXvarCutoff} -\alias{getImissCutoff} -\alias{getKeepVariants} -\alias{getKeepIndel} -\alias{getMafCutoff,QtlDataset-method} -\alias{getMacCutoff,QtlDataset-method} -\alias{getXvarCutoff,QtlDataset-method} -\alias{getImissCutoff,QtlDataset-method} -\alias{getKeepVariants,QtlDataset-method} -\alias{getKeepIndel,QtlDataset-method} +\alias{mafCutoff} +\alias{macCutoff} +\alias{xvarCutoff} +\alias{imissCutoff} +\alias{keepVariants} +\alias{keepIndel} +\alias{mafCutoff,QtlDataset-method} +\alias{macCutoff,QtlDataset-method} +\alias{xvarCutoff,QtlDataset-method} +\alias{imissCutoff,QtlDataset-method} +\alias{keepVariants,QtlDataset-method} +\alias{keepIndel,QtlDataset-method} \title{QtlDataset Filter Settings} \usage{ -getMafCutoff(x, ...) +mafCutoff(x, ...) -getMacCutoff(x, ...) +macCutoff(x, ...) -getXvarCutoff(x, ...) +xvarCutoff(x, ...) -getImissCutoff(x, ...) +imissCutoff(x, ...) -getKeepVariants(x, ...) +keepVariants(x, ...) -getKeepIndel(x, ...) +keepIndel(x, ...) -\S4method{getMafCutoff}{QtlDataset}(x) +\S4method{mafCutoff}{QtlDataset}(x) -\S4method{getMacCutoff}{QtlDataset}(x) +\S4method{macCutoff}{QtlDataset}(x) -\S4method{getXvarCutoff}{QtlDataset}(x) +\S4method{xvarCutoff}{QtlDataset}(x) -\S4method{getImissCutoff}{QtlDataset}(x) +\S4method{imissCutoff}{QtlDataset}(x) -\S4method{getKeepVariants}{QtlDataset}(x) +\S4method{keepVariants}{QtlDataset}(x) -\S4method{getKeepIndel}{QtlDataset}(x) +\S4method{keepIndel}{QtlDataset}(x) } \arguments{ \item{x}{A \code{QtlDataset}.} @@ -46,10 +46,10 @@ getKeepIndel(x, ...) \item{...}{Additional arguments passed on to methods.} } \value{ -\code{getMafCutoff()}, \code{getMacCutoff()}, - \code{getXvarCutoff()} and \code{getImissCutoff()} single numerics; - \code{getKeepVariants()} a character vector (empty when no restriction - was requested); \code{getKeepIndel()} a single logical. The sample set +\code{mafCutoff()}, \code{macCutoff()}, + \code{xvarCutoff()} and \code{imissCutoff()} single numerics; + \code{keepVariants()} a character vector (empty when no restriction + was requested); \code{keepIndel()} a single logical. The sample set is not among them: it lives in \code{colData(x)} and \code{sampleMap(x)}. } \description{ @@ -60,6 +60,6 @@ The variant- and sample-filter settings a } \examples{ data(qtlDatasetExample) -getMafCutoff(qtlDatasetExample) -getKeepIndel(qtlDatasetExample) +mafCutoff(qtlDatasetExample) +keepIndel(qtlDatasetExample) } diff --git a/man/getQtlDatasets.Rd b/man/qtlDatasets.Rd similarity index 67% rename from man/getQtlDatasets.Rd rename to man/qtlDatasets.Rd index 598d45c1..38ced58b 100644 --- a/man/getQtlDatasets.Rd +++ b/man/qtlDatasets.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/MultiStudyQtlDataset.R -\name{getQtlDatasets} -\alias{getQtlDatasets} -\alias{getQtlDatasets,MultiStudyQtlDataset-method} +\name{qtlDatasets} +\alias{qtlDatasets} +\alias{qtlDatasets,MultiStudyQtlDataset-method} \title{Get the Embedded QtlDataset List} \usage{ -getQtlDatasets(x) +qtlDatasets(x) -\S4method{getQtlDatasets}{MultiStudyQtlDataset}(x) +\S4method{qtlDatasets}{MultiStudyQtlDataset}(x) } \arguments{ \item{x}{A \code{MultiStudyQtlDataset} object.} @@ -21,5 +21,5 @@ Return the named list of \code{QtlDataset} objects carried by a } \examples{ data(multiStudyQtlDatasetExample) -getQtlDatasets(multiStudyQtlDatasetExample) +qtlDatasets(multiStudyQtlDatasetExample) } diff --git a/man/qtlFineMappingExample.Rd b/man/qtlFineMappingExample.Rd index 8ef2075b..88d6bbeb 100644 --- a/man/qtlFineMappingExample.Rd +++ b/man/qtlFineMappingExample.Rd @@ -15,7 +15,7 @@ standard post-processing columns (\code{pip}, \code{logBF}, \code{cs_95} / One credible set of 42 variants. Its \code{min.abs.corr} is 0.626, below the pipeline default of 0.8, so the fixture was built at \code{minAbsCorr = 0.5} to keep the set labelled; \code{cs_95_purity} records the true value, so -\code{getCs(x, minPurity = 0.8)} still filters it out. Built by +\code{credibleSets(x, minPurity = 0.8)} still filters it out. Built by \code{inst/scripts/prepare_example_data.R}. } \description{ @@ -29,7 +29,7 @@ region/context names are synthetic. \examples{ data(qtlFineMappingExample) qtlFineMappingExample -head(getTopLoci(qtlFineMappingExample)) +head(topLoci(qtlFineMappingExample)) } \keyword{data} diff --git a/man/qtlFineMappingLbfExample.Rd b/man/qtlFineMappingLbfExample.Rd index df0dc219..bc84b87d 100644 --- a/man/qtlFineMappingLbfExample.Rd +++ b/man/qtlFineMappingLbfExample.Rd @@ -23,7 +23,7 @@ Derived from the de-identified \code{protocol_example} toy data \examples{ data(qtlFineMappingLbfExample) qtlFineMappingLbfExample -head(getTopLoci(qtlFineMappingLbfExample)) +head(topLoci(qtlFineMappingLbfExample)) } \keyword{data} diff --git a/man/qtlFineMappingPairedExample.Rd b/man/qtlFineMappingPairedExample.Rd index a61a6dd3..f7ddfe63 100644 --- a/man/qtlFineMappingPairedExample.Rd +++ b/man/qtlFineMappingPairedExample.Rd @@ -28,7 +28,7 @@ yields two credible sets. Built by \examples{ data(qtlFineMappingPairedExample) data(qtlSumStatsExample) -fe <- getFineMappingResult(qtlFineMappingPairedExample) +fe <- fineMappingResult(qtlFineMappingPairedExample) computeCsCorrelation(fe, qtlSumStatsExample) } diff --git a/man/qtlSumStatsFromBetaMatrix.Rd b/man/qtlSumStatsFromBetaMatrix.Rd index c8d77ace..687d7bdf 100644 --- a/man/qtlSumStatsFromBetaMatrix.Rd +++ b/man/qtlSumStatsFromBetaMatrix.Rd @@ -7,7 +7,7 @@ qtlSumStatsFromBetaMatrix( bhat, shat, - study, + studyName, ldSketch = NULL, context = colnames(bhat), trait = "mash", @@ -26,7 +26,7 @@ conditions.} \item{shat}{Numeric matrix of standard errors, aligned with \code{bhat} (identical dimensions and row/column order).} -\item{study}{Study identifier (recycled across conditions).} +\item{studyName}{Study identifier (recycled across conditions).} \item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) embedded in the collection, or \code{NULL} (default) -- mash operates @@ -65,7 +65,7 @@ panel <- readGenotypes( 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", +qtlSumStatsFromBetaMatrix(bhat = bhat, shat = shat, studyName = "s1", ldSketch = panel, context = colnames(bhat), trait = "g1", genome = "hg38", n = 100) } diff --git a/man/qtlSumStatsFromZMatrix.Rd b/man/qtlSumStatsFromZMatrix.Rd index 8c1c4023..0d8b2dc6 100644 --- a/man/qtlSumStatsFromZMatrix.Rd +++ b/man/qtlSumStatsFromZMatrix.Rd @@ -6,7 +6,7 @@ \usage{ qtlSumStatsFromZMatrix( z, - study, + studyName, ldSketch = NULL, context = colnames(z), trait = "mash", @@ -22,7 +22,7 @@ qtlSumStatsFromZMatrix( variant ids (ideally \code{chr:pos:A2:A1}); \code{colnames(z)} label the conditions.} -\item{study}{Study identifier (recycled across conditions).} +\item{studyName}{Study identifier (recycled across conditions).} \item{ldSketch}{A genotype panel (see \code{\link{readGenotypes}}) embedded in the collection, or \code{NULL} (default) -- mash operates @@ -68,6 +68,6 @@ 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, +qtlSumStatsFromZMatrix(z = z, studyName = "s1", ldSketch = panel, context = colnames(z), trait = "g1", genome = "hg38", n = 100) } diff --git a/man/qtlSumStatsMulticontextExample.Rd b/man/qtlSumStatsMulticontextExample.Rd index 98da18b5..006ffb3a 100644 --- a/man/qtlSumStatsMulticontextExample.Rd +++ b/man/qtlSumStatsMulticontextExample.Rd @@ -23,7 +23,7 @@ works with both \code{inputScale = "beta"} (the default) and \examples{ data(qtlSumStatsMulticontextExample) qtlSumStatsMulticontextExample -getContexts(qtlSumStatsMulticontextExample) +contexts(qtlSumStatsMulticontextExample) } \keyword{data} diff --git a/man/getRefPanel.Rd b/man/refPanel.Rd similarity index 82% rename from man/getRefPanel.Rd rename to man/refPanel.Rd index 2914a936..8ad2b6f5 100644 --- a/man/getRefPanel.Rd +++ b/man/refPanel.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{getRefPanel} -\alias{getRefPanel} -\alias{getRefPanel,LdData-method} +\name{refPanel} +\alias{refPanel} +\alias{refPanel,LdData-method} \title{Get Reference Panel (data.frame)} \usage{ -getRefPanel(x) +refPanel(x) -\S4method{getRefPanel}{LdData}(x) +\S4method{refPanel}{LdData}(x) } \arguments{ \item{x}{An \code{LdData}.} @@ -27,5 +27,5 @@ gr <- GenomicRanges::GRanges("22", ld <- LdData(correlation = cor(X), variants = gr, blockMetadata = S4Vectors::DataFrame( chrom = "22", start = 1L, end = 1000L)) -getRefPanel(ld) +refPanel(ld) } diff --git a/man/getRefVariantInfo.Rd b/man/refVariantInfo.Rd similarity index 85% rename from man/getRefVariantInfo.Rd rename to man/refVariantInfo.Rd index 046e731d..8c5250db 100644 --- a/man/getRefVariantInfo.Rd +++ b/man/refVariantInfo.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/genotypeIo.R -\name{getRefVariantInfo} -\alias{getRefVariantInfo} +\name{refVariantInfo} +\alias{refVariantInfo} \title{Get variant information from any LD reference source} \usage{ -getRefVariantInfo(source, region = NULL) +refVariantInfo(source, region = NULL) } \arguments{ \item{source}{Genotype file path/prefix or LD metadata file path.} @@ -25,5 +25,5 @@ file and extracts variant info. \examples{ meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", package = "pecotmr") -getRefVariantInfo(meta, region = "chr22:10000000-19000000") +refVariantInfo(meta, region = "chr22:10000000-19000000") } diff --git a/man/getRegionVcp.Rd b/man/regionVcp.Rd similarity index 63% rename from man/getRegionVcp.Rd rename to man/regionVcp.Rd index c940c5fe..9f9733fb 100644 --- a/man/getRegionVcp.Rd +++ b/man/regionVcp.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ColocBoostResult.R -\name{getRegionVcp} -\alias{getRegionVcp} -\alias{getRegionVcp,ColocBoostResult-method} +\name{regionVcp} +\alias{regionVcp} +\alias{regionVcp,ColocBoostResult-method} \title{Region-Wide Variant Colocalization Probabilities} \usage{ -getRegionVcp(x, ...) +regionVcp(x, ...) -\S4method{getRegionVcp}{ColocBoostResult}(x) +\S4method{regionVcp}{ColocBoostResult}(x) } \arguments{ \item{x}{A \code{\linkS4class{ColocBoostResult}}.} @@ -20,9 +20,9 @@ A \code{GRanges} carrying a \code{vcp} column, or \code{NULL}. \description{ The marginal \code{vcp} for every variant in the analysed region, not just the confidence-set members. Distinct from - \code{\link{getColocVariants}}, which reports the per-set \code{vcp} of + \code{\link{colocVariants}}, which reports the per-set \code{vcp} of members only. } \examples{ -methods::existsMethod("getRegionVcp", "ColocBoostResult") +methods::existsMethod("regionVcp", "ColocBoostResult") } diff --git a/man/getResidualizedGenotypes.Rd b/man/residualizedGenotypes.Rd similarity index 88% rename from man/getResidualizedGenotypes.Rd rename to man/residualizedGenotypes.Rd index 1a8c6393..f7721deb 100644 --- a/man/getResidualizedGenotypes.Rd +++ b/man/residualizedGenotypes.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{getResidualizedGenotypes} -\alias{getResidualizedGenotypes} -\alias{getResidualizedGenotypes,QtlDataset-method} +\name{residualizedGenotypes} +\alias{residualizedGenotypes} +\alias{residualizedGenotypes,QtlDataset-method} \title{Get Residualized Genotypes} \usage{ -getResidualizedGenotypes(x, ...) +residualizedGenotypes(x, ...) -\S4method{getResidualizedGenotypes}{QtlDataset}( +\S4method{residualizedGenotypes}{QtlDataset}( x, contexts, traitId = NULL, @@ -60,5 +60,5 @@ Residualize the genotype matrix against the per-context } \examples{ data(qtlDatasetExample) -getResidualizedGenotypes(qtlDatasetExample, contexts = "brain") +residualizedGenotypes(qtlDatasetExample, contexts = "brain") } diff --git a/man/getResidualizedPhenotypes.Rd b/man/residualizedPhenotypes.Rd similarity index 90% rename from man/getResidualizedPhenotypes.Rd rename to man/residualizedPhenotypes.Rd index 6e582be4..d99534fa 100644 --- a/man/getResidualizedPhenotypes.Rd +++ b/man/residualizedPhenotypes.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{getResidualizedPhenotypes} -\alias{getResidualizedPhenotypes} -\alias{getResidualizedPhenotypes,QtlDataset-method} +\name{residualizedPhenotypes} +\alias{residualizedPhenotypes} +\alias{residualizedPhenotypes,QtlDataset-method} \title{Get Residualized Phenotypes} \usage{ -getResidualizedPhenotypes(x, ...) +residualizedPhenotypes(x, ...) -\S4method{getResidualizedPhenotypes}{QtlDataset}( +\S4method{residualizedPhenotypes}{QtlDataset}( x, contexts, traitId = NULL, @@ -69,5 +69,5 @@ Residualize the per-context phenotype matrices against the } \examples{ data(qtlDatasetExample) -getResidualizedPhenotypes(qtlDatasetExample, contexts = "brain") +residualizedPhenotypes(qtlDatasetExample, contexts = "brain") } diff --git a/man/resolveWeights.Rd b/man/resolveWeights.Rd index fd6ba527..df7285d5 100644 --- a/man/resolveWeights.Rd +++ b/man/resolveWeights.Rd @@ -10,21 +10,27 @@ resolveWeights(x, ...) \S4method{resolveWeights}{FineMappingResultBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, region = NULL ) -\S4method{resolveWeights}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) +\S4method{resolveWeights}{TwasWeights}( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL +) } \arguments{ \item{x}{A \code{TwasWeights} or a \code{FineMappingResult}.} \item{...}{Reserved for future use.} -\item{study, context, trait, method}{Optional length-1 selectors pinning one +\item{studyName, 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.} @@ -46,7 +52,7 @@ Return an aligned \code{(variantIds, weights)} pair from a } \examples{ data(twasWeightsExample) -w <- resolveWeights(twasWeightsExample, study = "protocol_example", +w <- resolveWeights(twasWeightsExample, studyName = "protocol_example", context = "bulk_rnaseq", trait = "ENSG00000130538", method = "susie") length(w$variantIds) } diff --git a/man/getRetainedMass.Rd b/man/retainedMass.Rd similarity index 84% rename from man/getRetainedMass.Rd rename to man/retainedMass.Rd index 7ee8036b..23cbdec1 100644 --- a/man/getRetainedMass.Rd +++ b/man/retainedMass.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getRetainedMass} -\alias{getRetainedMass} -\alias{getRetainedMass,FineMappingResultBase-method} +\name{retainedMass} +\alias{retainedMass} +\alias{retainedMass,FineMappingResultBase-method} \title{Per-Effect Retained Posterior Mass} \usage{ -getRetainedMass(x, ...) +retainedMass(x, ...) -\S4method{getRetainedMass}{FineMappingResultBase}(x) +\S4method{retainedMass}{FineMappingResultBase}(x) } \arguments{ \item{x}{A fine-mapping collection.} @@ -38,7 +38,7 @@ Reported always, never used as a filter. The mass is data(qtlFineMappingExample) data(gwasFineMappingExample) # Nothing has been reconciled yet, so there is no mass to report. -nrow(getRetainedMass(qtlFineMappingExample)) +nrow(retainedMass(qtlFineMappingExample)) both <- intersectVariants(qtlFineMappingExample, gwasFineMappingExample) -getRetainedMass(both$x) +retainedMass(both$x) } diff --git a/man/getSampleIds.Rd b/man/sampleIds.Rd similarity index 76% rename from man/getSampleIds.Rd rename to man/sampleIds.Rd index 58be4d17..c150ccb8 100644 --- a/man/getSampleIds.Rd +++ b/man/sampleIds.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R -\name{getSampleIds} -\alias{getSampleIds} -\alias{getSampleIds,GenotypeHandle-method} +\name{sampleIds} +\alias{sampleIds} +\alias{sampleIds,GenotypeHandle-method} \title{Get Sample Identifiers} \usage{ -getSampleIds(x) +sampleIds(x) -\S4method{getSampleIds}{GenotypeHandle}(x) +\S4method{sampleIds}{GenotypeHandle}(x) } \arguments{ \item{x}{A \code{GenotypeHandle}.} diff --git a/man/getScaleResiduals.Rd b/man/scaleResiduals.Rd similarity index 64% rename from man/getScaleResiduals.Rd rename to man/scaleResiduals.Rd index 36691450..34028a0b 100644 --- a/man/getScaleResiduals.Rd +++ b/man/scaleResiduals.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{getScaleResiduals} -\alias{getScaleResiduals} -\alias{getScaleResiduals,QtlDataset-method} +\name{scaleResiduals} +\alias{scaleResiduals} +\alias{scaleResiduals,QtlDataset-method} \title{Get scaleResiduals Flag} \usage{ -getScaleResiduals(x) +scaleResiduals(x) -\S4method{getScaleResiduals}{QtlDataset}(x) +\S4method{scaleResiduals}{QtlDataset}(x) } \arguments{ \item{x}{A \code{QtlDataset} object.} @@ -21,5 +21,5 @@ Whether residualization accessors scale residuals to unit } \examples{ data(qtlDatasetExample) -getScaleResiduals(qtlDatasetExample) +scaleResiduals(qtlDatasetExample) } diff --git a/man/getScoreStats.Rd b/man/scoreStats.Rd similarity index 66% rename from man/getScoreStats.Rd rename to man/scoreStats.Rd index f1c71c22..01c957e8 100644 --- a/man/getScoreStats.Rd +++ b/man/scoreStats.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getScoreStats} -\alias{getScoreStats} -\alias{getScoreStats,H2Estimate-method} +\name{scoreStats} +\alias{scoreStats} +\alias{scoreStats,H2Estimate-method} \title{Get Score Statistics} \usage{ -getScoreStats(object) +scoreStats(object) -\S4method{getScoreStats}{H2Estimate}(object) +\S4method{scoreStats}{H2Estimate}(object) } \arguments{ \item{object}{An \code{H2Estimate} object.} @@ -20,5 +20,5 @@ Extract score statistics for candidate annotations. } \examples{ data(h2EstimateExample) -getScoreStats(h2EstimateExample) +scoreStats(h2EstimateExample) } diff --git a/man/getSe.Rd b/man/se.Rd similarity index 76% rename from man/getSe.Rd rename to man/se.Rd index 12c3ba67..adec8fac 100644 --- a/man/getSe.Rd +++ b/man/se.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getSe} -\alias{getSe} -\alias{getSe,SumStatsBase-method} +\name{se} +\alias{se} +\alias{se,SumStatsBase-method} \title{Get Effect-Size Standard Errors} \usage{ -getSe(x, ...) +se(x, ...) -\S4method{getSe}{SumStatsBase}( +\S4method{se}{SumStatsBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, @@ -21,8 +21,8 @@ getSe(x, ...) \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{studyName}{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.} @@ -31,7 +31,7 @@ this context; \code{NULL} matches all contexts.} 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.} +\code{\link{sumStats}} (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.} @@ -46,5 +46,5 @@ Extract the effect-size standard-error vector from a } \examples{ data(qtlSumStatsExample) -getSe(qtlSumStatsExample) +se(qtlSumStatsExample) } diff --git a/man/shrinkLd.Rd b/man/shrinkLd.Rd index d9d0ea12..f8cd5f8c 100644 --- a/man/shrinkLd.Rd +++ b/man/shrinkLd.Rd @@ -4,12 +4,12 @@ \alias{shrinkLd} \title{Apply LD Shrinkage} \usage{ -shrinkLd(R, nRef, shrinkageType = "wen_stephens", geneticMap = NULL) +shrinkLd(R, nSamples, shrinkageType = "wen_stephens", geneticMap = NULL) } \arguments{ \item{R}{Numeric matrix, sample LD correlation matrix.} -\item{nRef}{Integer, reference panel sample size.} +\item{nSamples}{Integer, reference panel sample size.} \item{shrinkageType}{Character, one of "wen_stephens", "constant".} diff --git a/man/getSignificantQtls.Rd b/man/significantQtls.Rd similarity index 87% rename from man/getSignificantQtls.Rd rename to man/significantQtls.Rd index cf69a0c2..3c3afedf 100644 --- a/man/getSignificantQtls.Rd +++ b/man/significantQtls.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/qtlAssociationPostprocess.R -\name{getSignificantQtls} -\alias{getSignificantQtls} -\alias{getSignificantQtls,QtlSumStats-method} +\name{significantQtls} +\alias{significantQtls} +\alias{significantQtls,QtlSumStats-method} \title{Extract Significant cis-QTL Variants} \usage{ -getSignificantQtls(x, ...) +significantQtls(x, ...) -\S4method{getSignificantQtls}{QtlSumStats}( +\S4method{significantQtls}{QtlSumStats}( x, method = c("permutation", "bonferroni_original", "bonferroni_filtered", "qvalue"), threshold = NULL @@ -48,11 +48,11 @@ entries <- lapply(seq_len(G), function(i) { tes_distance = c(0L, 500L, 900000L, 2000000L)) gr }) -qss <- QtlSumStats(study = rep("s", G), context = rep("brain", G), +qss <- QtlSumStats(studyName = rep("s", G), context = rep("brain", G), trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", 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) +significantQtls(pp) } diff --git a/man/sldscPostprocessingPipeline.Rd b/man/sldscPostprocessingPipeline.Rd index 3b2bfe32..31d9cd01 100644 --- a/man/sldscPostprocessingPipeline.Rd +++ b/man/sldscPostprocessingPipeline.Rd @@ -52,8 +52,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7 * seq(0.9, 1.1, length.out = 10), 10, n, - dimnames = list(NULL, cats)), + annotationJackknifeCoefs = matrix(1e-7 * seq(0.9, 1.1, length.out = 10), + 10, n, dimnames = list(NULL, cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), @@ -66,7 +66,7 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sldscData <- SldscData(annot = annot, frq = frq, traits = traits) +sldscData <- SldscData(annotData = annot, frqData = frq, traits = traits) sldscPostprocessingPipeline(sldscData = sldscData) } \seealso{ diff --git a/man/getTraitRun.Rd b/man/sldscResults.Rd similarity index 59% rename from man/getTraitRun.Rd rename to man/sldscResults.Rd index c1f509fa..f4907f82 100644 --- a/man/getTraitRun.Rd +++ b/man/sldscResults.Rd @@ -1,18 +1,19 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/SldscData.R -\name{getTraitRun} -\alias{getTraitRun} -\alias{getTraitRun,SldscData-method} -\title{Get one trait's run from an SldscData} +\name{sldscResults} +\alias{sldscResults} +\alias{sldscResults,SldscData-method} +\title{Get sLDSC Results from an SldscData} \usage{ -getTraitRun(x, trait, ...) +sldscResults(x, trait = NULL, ...) -\S4method{getTraitRun}{SldscData}(x, trait, mode = c("single", "joint"), idx = NULL) +\S4method{sldscResults}{SldscData}(x, trait = NULL, mode = c("single", "joint"), idx = NULL) } \arguments{ \item{x}{An \code{\link{SldscData}} object.} -\item{trait}{Character. Trait name.} +\item{trait}{Character trait name, or \code{NULL} (default) to return the +named list of per-trait \code{single}/\code{joint} runs for all traits.} \item{...}{Further arguments: \code{mode} (\code{"single"}/\code{"joint"}) and \code{idx} (which single run).} @@ -22,10 +23,13 @@ and \code{idx} (which single run).} \item{idx}{Integer. Index of the trait run to select.} } \value{ -A single run list, the list of single runs, or \code{NULL}. +The named list of per-trait runs when \code{trait} is \code{NULL}; + otherwise a single run list, the list of single runs, or \code{NULL}. } \description{ -Get one trait's run from an SldscData +Return the stratified LD-score regression runs held by an + \code{\link{SldscData}}: every trait's runs when \code{trait} is + \code{NULL}, otherwise the selected run(s) for that one trait. } \examples{ mkRun <- function(cats) { @@ -37,8 +41,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -50,6 +54,6 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) -getTraitRun(sd, "traitX") +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) +sldscResults(sd, "traitX") } diff --git a/man/sldscSubsetMeta.Rd b/man/sldscSubsetMeta.Rd index ac7afd80..23a6d96f 100644 --- a/man/sldscSubsetMeta.Rd +++ b/man/sldscSubsetMeta.Rd @@ -42,8 +42,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -55,7 +55,7 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) +sd <- SldscData(annotData = annot, frqData = frq, traits = traits) pp <- sldscPostprocessingPipeline(sd) sldscSubsetMeta(pp, subsetTraits = "traitX") } diff --git a/man/getSnpIdx.Rd b/man/snpIdx.Rd similarity index 83% rename from man/getSnpIdx.Rd rename to man/snpIdx.Rd index 5542edca..3965937f 100644 --- a/man/getSnpIdx.Rd +++ b/man/snpIdx.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{getSnpIdx} -\alias{getSnpIdx} -\alias{getSnpIdx,LdData-method} +\name{snpIdx} +\alias{snpIdx} +\alias{snpIdx,LdData-method} \title{Get SNP Indices} \usage{ -getSnpIdx(x) +snpIdx(x) -\S4method{getSnpIdx}{LdData}(x) +\S4method{snpIdx}{LdData}(x) } \arguments{ \item{x}{An \code{LdData}.} @@ -27,5 +27,5 @@ gr <- GenomicRanges::GRanges("22", ld <- LdData(correlation = cor(X), variants = gr, blockMetadata = S4Vectors::DataFrame( chrom = "22", start = 1L, end = 1000L)) -getSnpIdx(ld) +snpIdx(ld) } diff --git a/man/getSnpInfo.Rd b/man/snpInfo.Rd similarity index 86% rename from man/getSnpInfo.Rd rename to man/snpInfo.Rd index b2837dc9..5a680e82 100644 --- a/man/getSnpInfo.Rd +++ b/man/snpInfo.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GenotypeHandle.R -\name{getSnpInfo} -\alias{getSnpInfo} -\alias{getSnpInfo,GenotypeHandle-method} +\name{snpInfo} +\alias{snpInfo} +\alias{snpInfo,GenotypeHandle-method} \title{Get SNP Info} \usage{ -getSnpInfo(x) +snpInfo(x) -\S4method{getSnpInfo}{GenotypeHandle}(x) +\S4method{snpInfo}{GenotypeHandle}(x) } \arguments{ \item{x}{An object carrying cached SNP metadata.} diff --git a/man/standardizeSldscTrait.Rd b/man/standardizeSldscTrait.Rd index d75f8fa6..f103b7b2 100644 --- a/man/standardizeSldscTrait.Rd +++ b/man/standardizeSldscTrait.Rd @@ -16,7 +16,7 @@ standardizeSldscTrait( } \arguments{ \item{sldscData}{An \code{\link{SldscData}} object (the run is pulled from it -via \code{getTraitRun}).} +via \code{sldscResults}).} \item{trait}{Character. Trait name (a key of the SldscData traits list).} @@ -53,8 +53,8 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) + annotationJackknifeCoefs = matrix(1e-7, 10, n, dimnames = list(NULL, + cats)), nBlocks = 10L) } annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) @@ -65,7 +65,7 @@ mkTrait <- function() { mkRun(c("annot_B_0", "baselineLD_0"))), joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } -sd <- SldscData(annot = annot, frq = frq, +sd <- SldscData(annotData = annot, frqData = frq, traits = setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY"))) sdAnnot <- computeSldscAnnotSd(sd) MRef <- computeSldscMRef(sd) diff --git a/man/standardizeTauStar.Rd b/man/standardizeTauStar.Rd index 67da8ea3..e61e9232 100644 --- a/man/standardizeTauStar.Rd +++ b/man/standardizeTauStar.Rd @@ -4,13 +4,13 @@ \alias{standardizeTauStar} \title{Standardize Tau to Tau-Star (Gazal et al. 2017)} \usage{ -standardizeTauStar(tau, tauBlocks, sdAnnot, MRef, h2g) +standardizeTauStar(tau, annotationJackknifeCoefs, sdAnnot, MRef, h2g) } \arguments{ \item{tau}{Numeric vector of per-annotation regression coefficients.} -\item{tauBlocks}{Numeric matrix (nBlocks x nAnnotations) of block-level tau -estimates from delete-one jackknife.} +\item{annotationJackknifeCoefs}{Numeric matrix (nBlocks x nAnnotations) of +block-level tau estimates from delete-one jackknife.} \item{sdAnnot}{Numeric vector of per-annotation standard deviations, same length as \code{tau}.} diff --git a/man/getEnrichment.Rd b/man/stratifiedHeritabilityEnrichment.Rd similarity index 56% rename from man/getEnrichment.Rd rename to man/stratifiedHeritabilityEnrichment.Rd index 8f891c3f..e197a122 100644 --- a/man/getEnrichment.Rd +++ b/man/stratifiedHeritabilityEnrichment.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{getEnrichment} -\alias{getEnrichment} -\alias{getEnrichment,H2Estimate-method} +\name{stratifiedHeritabilityEnrichment} +\alias{stratifiedHeritabilityEnrichment} +\alias{stratifiedHeritabilityEnrichment,H2Estimate-method} \title{Get Enrichment Estimates} \usage{ -getEnrichment(object) +stratifiedHeritabilityEnrichment(object) -\S4method{getEnrichment}{H2Estimate}(object) +\S4method{stratifiedHeritabilityEnrichment}{H2Estimate}(object) } \arguments{ \item{object}{An \code{H2Estimate} object.} @@ -20,5 +20,5 @@ Extract annotation enrichment estimates from a result object. } \examples{ data(h2EstimateExample) -getEnrichment(h2EstimateExample) +stratifiedHeritabilityEnrichment(h2EstimateExample) } diff --git a/man/studyName.Rd b/man/studyName.Rd new file mode 100644 index 00000000..6d3da4bd --- /dev/null +++ b/man/studyName.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, +% R/CtwasResult.R, R/QtlDataset.R, R/MultiStudyQtlDataset.R, R/twasWeights.R +\name{studyName} +\alias{studyName} +\alias{studyName,SumStatsBase-method} +\alias{studyName,FineMappingResultBase-method} +\alias{studyName,CtwasResult-method} +\alias{studyName,QtlDataset-method} +\alias{studyName,MultiStudyQtlDataset-method} +\alias{studyName,TwasWeights-method} +\title{Get Study Identifier} +\usage{ +studyName(x) + +\S4method{studyName}{SumStatsBase}(x) + +\S4method{studyName}{FineMappingResultBase}(x) + +\S4method{studyName}{CtwasResult}(x) + +\S4method{studyName}{QtlDataset}(x) + +\S4method{studyName}{MultiStudyQtlDataset}(x) + +\S4method{studyName}{TwasWeights}(x) +} +\arguments{ +\item{x}{A \code{QtlDataset} object.} +} +\value{ +Character (length 1). +} +\description{ +Return the study identifier carried by a \code{QtlDataset}. +} +\examples{ +data(qtlDatasetExample) +studyName(qtlDatasetExample) +} diff --git a/man/getSumStats-GwasSumStats-method.Rd b/man/sumStats-GwasSumStats-method.Rd similarity index 81% rename from man/getSumStats-GwasSumStats-method.Rd rename to man/sumStats-GwasSumStats-method.Rd index f8884e6b..b0f47423 100644 --- a/man/getSumStats-GwasSumStats-method.Rd +++ b/man/sumStats-GwasSumStats-method.Rd @@ -1,12 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/gwasSumStats.R -\name{getSumStats,GwasSumStats-method} -\alias{getSumStats,GwasSumStats-method} +\name{sumStats,GwasSumStats-method} +\alias{sumStats,GwasSumStats-method} \title{Get a GWAS Study's Summary-Statistic GRanges} \usage{ -\S4method{getSumStats}{GwasSumStats}( +\S4method{sumStats}{GwasSumStats}( x, - study = NULL, + studyName = NULL, ranges = NULL, context = NULL, trait = NULL, @@ -16,7 +16,7 @@ \arguments{ \item{x}{A \code{GwasSumStats} object.} -\item{study}{Character (length 1) study identifier. Optional when the +\item{studyName}{Character (length 1) study identifier. Optional when the collection has a single row.} \item{ranges}{Optional \code{GRanges} restricting the returned variants to diff --git a/man/getSumStats.Rd b/man/sumStats.Rd similarity index 82% rename from man/getSumStats.Rd rename to man/sumStats.Rd index 395231d1..d3d0d292 100644 --- a/man/getSumStats.Rd +++ b/man/sumStats.Rd @@ -1,19 +1,19 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/MultiStudyQtlDataset.R, % R/qtlSumStats.R -\name{getSumStats} -\alias{getSumStats} -\alias{getSumStats,MultiStudyQtlDataset-method} -\alias{getSumStats,QtlSumStats-method} +\name{sumStats} +\alias{sumStats} +\alias{sumStats,MultiStudyQtlDataset-method} +\alias{sumStats,QtlSumStats-method} \title{Get a Single Summary-Statistic Entry or Embedded Collection} \usage{ -getSumStats(x, ...) +sumStats(x, ...) -\S4method{getSumStats}{MultiStudyQtlDataset}(x) +\S4method{sumStats}{MultiStudyQtlDataset}(x) -\S4method{getSumStats}{QtlSumStats}( +\S4method{sumStats}{QtlSumStats}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, @@ -26,8 +26,8 @@ getSumStats(x, ...) \item{...}{Class-specific selection arguments (see above).} -\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to -this study; \code{NULL} matches all studies.} +\item{studyName}{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.} @@ -42,7 +42,7 @@ enriched by \code{\link{qtlAssociationPostprocess}}, a logical \code{significant} mcol for that method is added to the returned entry (the significance is derived on the fly, not stored). Flat export flattens this full entry GRanges (all mcols) directly; note -\code{\link{getSumStatsDf}} is a fixed GWAS-schema view and does not +\code{\link{as.data.frame}} is a fixed GWAS-schema view and does not carry the association columns.} \item{ranges}{A \code{GRanges} or \code{NULL} (default). A selected tuple can @@ -69,5 +69,5 @@ Behavior depends on the class of \code{x}: } \examples{ data(qtlSumStatsExample) -getSumStats(qtlSumStatsExample) +sumStats(qtlSumStatsExample) } diff --git a/man/sumStatsDataFrame.Rd b/man/sumStatsDataFrame.Rd new file mode 100644 index 00000000..d768793d --- /dev/null +++ b/man/sumStatsDataFrame.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/gwasSumStats.R, R/qtlSumStats.R +\name{as.data.frame,GwasSumStats-method} +\alias{as.data.frame,GwasSumStats-method} +\alias{sumStatsDataFrame} +\alias{as.data.frame,QtlSumStats-method} +\title{Coerce Summary Statistics to a Data Frame} +\usage{ +\S4method{as.data.frame}{GwasSumStats}( + x, + row.names = NULL, + optional = FALSE, + studyName = NULL, + require = character(0), + derive = c("none", "zFromBetaSe"), + keepChrPrefix = TRUE, + ... +) + +\S4method{as.data.frame}{QtlSumStats}( + x, + row.names = NULL, + optional = FALSE, + studyName = NULL, + context = NULL, + trait = NULL, + require = character(0), + derive = c("none", "zFromBetaSe"), + keepChrPrefix = TRUE, + ... +) +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{row.names, optional}{Accepted for compatibility with +\code{as.data.frame} and ignored.} + +\item{studyName}{Character (length 1) or \code{NULL}. Restrict the selection +to this study; \code{NULL} matches all studies.} + +\item{require}{Character vector. Columns that must be present (derived if +necessary) in the returned summary-statistics data frame.} + +\item{derive}{Whether to derive missing standard columns from the available +ones; \code{"zFromBetaSe"} recovers \code{z} from \code{beta}/\code{se}.} + +\item{keepChrPrefix}{Logical. If \code{TRUE}, keep the \code{chr} prefix on +chromosome names; otherwise strip it.} + +\item{...}{Unused.} + +\item{context}{Character (length 1) or \code{NULL}. Restrict the selection to +this context; \code{NULL} matches all contexts (\code{QtlSumStats} only).} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits (\code{QtlSumStats} only).} +} +\value{ +A \code{data.frame}. +} +\description{ +Coerce one tuple of a \code{GwasSumStats} or + \code{QtlSumStats} collection to a per-variant \code{data.frame} in the + standardized layout \code{variant_id, chrom, pos, A1, A2, z, beta, se, N, + maf} (optional columns omitted when absent on the entry). This is the + table view of \code{\link{sumStats}}, which returns the same selection as + a \code{GRanges}; coercion rather than a return-type argument is the + Bioconductor idiom for choosing a representation. +} +\examples{ +data(qtlSumStatsExample) +head(as.data.frame(qtlSumStatsExample)) +} diff --git a/man/summaryStatsQc.Rd b/man/summaryStatsQc.Rd index 54de9e61..1de43473 100644 --- a/man/summaryStatsQc.Rd +++ b/man/summaryStatsQc.Rd @@ -7,7 +7,7 @@ summaryStatsQc( sumstats, sumstatsFilterArgs = SumstatsFilterParam(), - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), keepVariants = NULL, skipRegion = NULL, signalScreenArgs = SignalScreenParam(), @@ -32,7 +32,7 @@ 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 +\item{panelFilterParam}{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 @@ -150,7 +150,7 @@ optional RAISS imputation. No Bioconductor genome / dbSNP packages required. The returned collection has its \code{qcInfo} slot populated with a per-entry audit record (variant counts, drop counts at each step, which filters fired, etc.). Fine-mapping and TWAS-weights pipelines reject SumStats inputs where -\code{length(getQcInfo(x)) == 0L}. +\code{length(qcInfo(x)) == 0L}. Column-availability error contract: a non-zero \code{infoCutoff} requires every entry to carry an \code{INFO} column, and a non-zero \code{nCutoff} diff --git a/man/getSusieAlpha.Rd b/man/susieAlpha.Rd similarity index 72% rename from man/getSusieAlpha.Rd rename to man/susieAlpha.Rd index 3e64385d..42d89ce2 100644 --- a/man/getSusieAlpha.Rd +++ b/man/susieAlpha.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/CtwasResult.R, % R/CtwasResultEntry.R -\name{getSusieAlpha} -\alias{getSusieAlpha} -\alias{getSusieAlpha,CtwasResult-method} -\alias{getSusieAlpha,CtwasResultEntry-method} +\name{susieAlpha} +\alias{susieAlpha} +\alias{susieAlpha,CtwasResult-method} +\alias{susieAlpha,CtwasResultEntry-method} \title{Get cTWAS Per-effect Susie Alpha Table} \usage{ -getSusieAlpha(x, ...) +susieAlpha(x, ...) -\S4method{getSusieAlpha}{CtwasResult}(x) +\S4method{susieAlpha}{CtwasResult}(x) -\S4method{getSusieAlpha}{CtwasResultEntry}(x) +\S4method{susieAlpha}{CtwasResultEntry}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry} or \code{CtwasResult}.} @@ -31,7 +31,7 @@ Return the full per-effect susie alpha table } \examples{ cre <- CtwasResultEntry( - finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), + posteriors = 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))) -getSusieAlpha(cre) +susieAlpha(cre) } diff --git a/man/getSusieFit.Rd b/man/susieFit.Rd similarity index 75% rename from man/getSusieFit.Rd rename to man/susieFit.Rd index 3d93df2c..c549a0a8 100644 --- a/man/getSusieFit.Rd +++ b/man/susieFit.Rd @@ -1,32 +1,32 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, % R/fineMappingRow.R -\name{getSusieFit} -\alias{getSusieFit} -\alias{getSusieFit,FineMappingResultBase-method} -\alias{getSusieFit,FineMappingRow-method} +\name{susieFit} +\alias{susieFit} +\alias{susieFit,FineMappingResultBase-method} +\alias{susieFit,FineMappingRow-method} \title{Get SuSiE Fit} \usage{ -getSusieFit(x, ...) +susieFit(x, ...) -\S4method{getSusieFit}{FineMappingResultBase}( +\S4method{susieFit}{FineMappingResultBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, region = NULL ) -\S4method{getSusieFit}{FineMappingRow}(x) +\S4method{susieFit}{FineMappingRow}(x) } \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} \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{studyName}{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.} @@ -52,5 +52,5 @@ Extract the SuSiE fit object from a fine-mapping entry or } \examples{ data(qtlFineMappingExample) -getSusieFit(qtlFineMappingExample) +susieFit(qtlFineMappingExample) } diff --git a/man/getSusieResult.Rd b/man/susieResult.Rd similarity index 86% rename from man/getSusieResult.Rd rename to man/susieResult.Rd index 928f5060..c2ed60eb 100644 --- a/man/getSusieResult.Rd +++ b/man/susieResult.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fineMappingWrappers.R -\name{getSusieResult} -\alias{getSusieResult} +\name{susieResult} +\alias{susieResult} \title{Extract the trimmed SuSiE fit from a finemapping pipeline result} \usage{ -getSusieResult(conData) +susieResult(conData) } \arguments{ \item{conData}{List. The method-layer entry from a finemapping pipeline @@ -21,5 +21,5 @@ attached. } \examples{ data(qtlSumStatsExample) -getSusieResult(qtlSumStatsExample) +susieResult(qtlSumStatsExample) } diff --git a/man/getCandidates.Rd b/man/testedAnnotations.Rd similarity index 55% rename from man/getCandidates.Rd rename to man/testedAnnotations.Rd index 8cdae494..2b44535f 100644 --- a/man/getCandidates.Rd +++ b/man/testedAnnotations.Rd @@ -1,20 +1,24 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AnnotationMatrix.R -\name{getCandidates} -\alias{getCandidates} -\title{Get Candidate Annotations} +% Please edit documentation in R/AllGenerics.R, R/AnnotationMatrix.R +\name{testedAnnotations} +\alias{testedAnnotations} +\alias{testedAnnotations,AnnotationMatrix-method} +\title{Get Tested Annotations} \usage{ -getCandidates(annot) +testedAnnotations(x) + +\S4method{testedAnnotations}{AnnotationMatrix}(x) } \arguments{ -\item{annot}{An \code{AnnotationMatrix} object.} +\item{x}{An \code{AnnotationMatrix} object.} } \value{ An \code{AnnotationMatrix} with only candidate annotations. } \description{ Extract only candidate-tier annotations from an - \code{AnnotationMatrix}. + \code{AnnotationMatrix} -- the annotations whose enrichment is being + tested, as opposed to the baseline set they are tested against. } \examples{ snpRanges <- GenomicRanges::GRanges( @@ -24,5 +28,5 @@ annotations <- matrix(rbinom(50, 1, 0.3), 10, 5, meta <- data.frame(name = paste0("annot", 1:5), tier = c(rep("baseline", 3), rep("candidate", 2)), type = "binary") am <- AnnotationMatrix(annotations, snpRanges, annotationMeta = meta) -getCandidates(am) +testedAnnotations(am) } diff --git a/man/getTopLoci.Rd b/man/topLoci.Rd similarity index 67% rename from man/getTopLoci.Rd rename to man/topLoci.Rd index 1dd621f0..41f7eaa2 100644 --- a/man/getTopLoci.Rd +++ b/man/topLoci.Rd @@ -1,17 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getTopLoci} -\alias{getTopLoci} -\alias{getTopLoci,FineMappingResultBase-method} +\name{topLoci} +\alias{topLoci} +\alias{topLoci,FineMappingResultBase-method} \title{Get Top Loci (posterior view)} \usage{ -getTopLoci(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) +topLoci(x, signalCutoff = 0.025, ...) -\S4method{getTopLoci}{FineMappingResultBase}( +\S4method{topLoci}{FineMappingResultBase}( x, - type = c("data.frame", "GRanges"), signalCutoff = 0.025, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -23,16 +22,14 @@ getTopLoci(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) \arguments{ \item{x}{A \code{FineMappingRow} or \code{FineMappingResult}.} -\item{type}{One of \code{"data.frame"} (default) or \code{"GRanges"}.} - \item{signalCutoff}{Numeric (length 1). Drop rows where \code{pip <= signalCutoff}. Default \code{0.025}. Use \code{signalCutoff = 0} to keep every variant.} \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{studyName}{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.} @@ -52,11 +49,17 @@ 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.} +verbatim -- a \code{data.frame}, not a \code{GRanges} -- so neither the +projection nor \code{signalCutoff} applies.} } \value{ -A \code{data.frame} or a \code{GRanges}. +A \code{GRanges}, one range per retained variant, carrying the + per-variant columns in \code{mcols()}; when the selectors match more than + one entry the row-identity columns are carried there too. Take a table + with \code{as.data.frame()} (which adds the standard + \code{seqnames}/\code{start}/... columns) or + \code{as.data.frame(S4Vectors::mcols(.))} for the per-variant columns + alone. \code{raw = TRUE} returns the stored \code{data.frame} instead. } \description{ Extract the per-variant posterior fine-mapping payload as either @@ -69,5 +72,5 @@ Extract the per-variant posterior fine-mapping payload as either } \examples{ data(qtlFineMappingExample) -getTopLoci(qtlFineMappingExample) +topLoci(qtlFineMappingExample) } diff --git a/man/traitNames.Rd b/man/traitNames.Rd new file mode 100644 index 00000000..c25030fa --- /dev/null +++ b/man/traitNames.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/GwasFineMappingResult.R, +% R/H2Estimate.R, R/QtlFineMappingResult.R, R/SldscData.R, R/qtlSumStats.R, +% R/twasWeights.R +\name{traitNames} +\alias{traitNames} +\alias{traitNames,GwasFineMappingResult-method} +\alias{traitNames,H2Estimate-method} +\alias{traitNames,QtlFineMappingResult-method} +\alias{traitNames,SldscData-method} +\alias{traitNames,QtlSumStats-method} +\alias{traitNames,TwasWeights-method} +\title{Get Unique Trait Names} +\usage{ +traitNames(x) + +\S4method{traitNames}{GwasFineMappingResult}(x) + +\S4method{traitNames}{H2Estimate}(x) + +\S4method{traitNames}{QtlFineMappingResult}(x) + +\S4method{traitNames}{SldscData}(x) + +\S4method{traitNames}{QtlSumStats}(x) + +\S4method{traitNames}{TwasWeights}(x) +} +\arguments{ +\item{x}{The object.} +} +\value{ +Character vector of unique trait names; length 1 for an + \code{H2Estimate}. +} +\description{ +Return the unique trait identifiers carried by a collection + class (e.g., \code{QtlSumStats}), the trait names of an + \code{\link{SldscData}}, or the single trait label an + \code{H2Estimate} was computed for. +} +\examples{ +data(qtlSumStatsExample) +traitNames(qtlSumStatsExample) +} diff --git a/man/getTraitPosition.Rd b/man/traitPosition.Rd similarity index 66% rename from man/getTraitPosition.Rd rename to man/traitPosition.Rd index 0515e459..18ea2152 100644 --- a/man/getTraitPosition.Rd +++ b/man/traitPosition.Rd @@ -1,23 +1,23 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/QtlDataset.R, % R/qtlSumStats.R, R/twasWeights.R -\name{getTraitPosition} -\alias{getTraitPosition} -\alias{getTraitPosition,FineMappingResultBase-method} -\alias{getTraitPosition,QtlDataset-method} -\alias{getTraitPosition,QtlSumStats-method} -\alias{getTraitPosition,TwasWeights-method} +\name{traitPosition} +\alias{traitPosition} +\alias{traitPosition,FineMappingResultBase-method} +\alias{traitPosition,QtlDataset-method} +\alias{traitPosition,QtlSumStats-method} +\alias{traitPosition,TwasWeights-method} \title{Get Per-Row Trait Positions} \usage{ -getTraitPosition(x, ...) +traitPosition(x, ...) -\S4method{getTraitPosition}{FineMappingResultBase}(x) +\S4method{traitPosition}{FineMappingResultBase}(x) -\S4method{getTraitPosition}{QtlDataset}(x, traitId = NULL) +\S4method{traitPosition}{QtlDataset}(x, traitId = NULL) -\S4method{getTraitPosition}{QtlSumStats}(x, traitId = NULL) +\S4method{traitPosition}{QtlSumStats}(x, traitId = NULL) -\S4method{getTraitPosition}{TwasWeights}(x) +\S4method{traitPosition}{TwasWeights}(x) } \arguments{ \item{x}{The object.} @@ -35,7 +35,7 @@ A \code{GRanges} with one range per row of \code{x}, or an empty Return the molecular feature's OWN genomic coordinates (the gene / peak range; TSS = \code{start()}) for each row of a per-tuple collection, as a \code{GRanges} with one range per row. Distinct from - \code{\link{getRegion}} (the fine-mapping window for a + \code{\link{genomicRegion}} (the fine-mapping window for a \code{FineMappingResult}): the true trait position cannot be inferred from summary statistics, so it is threaded from the QtlDataset \code{rowRanges} or an explicit QtlSumStats trait-position and carried as provenance onto @@ -43,5 +43,5 @@ Return the molecular feature's OWN genomic coordinates (the gene } \examples{ data(qtlDatasetExample) -getTraitPosition(qtlDatasetExample) +traitPosition(qtlDatasetExample) } diff --git a/man/twasEngineOptions.Rd b/man/twasEngineOptions.Rd index e911fbf7..ac60502c 100644 --- a/man/twasEngineOptions.Rd +++ b/man/twasEngineOptions.Rd @@ -69,14 +69,17 @@ Options forwarded to the engine behind a TWAS weight method, 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}}. + \code{GlmnetOptions}, \code{NcvregOptions} and \code{DprOptions} cannot + check for an UNKNOWN name: \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. Separately, and in all of them, a name pecotmr supplies + itself is refused --- \code{GlmnetOptions(alpha=)} and + \code{NcvregOptions(penalty=)} select the penalty family, which is the + calling wrapper's to set. See \code{\link{MethodOptions}}. } \examples{ GlmnetOptions(nfold = 10) -QggOptions(nit = 1000) +QggOptions(updateB = TRUE) LassosumOptions(thr = 1e-4) } diff --git a/man/twasPredict.Rd b/man/twasPredict.Rd index fcba3ac6..2077a75f 100644 --- a/man/twasPredict.Rd +++ b/man/twasPredict.Rd @@ -34,8 +34,9 @@ data(multiTraitData) X <- multiTraitData$X[, 1:4] colnames(X) <- sprintf("chr1:\%d:A:G", 100L * (1:4)) twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), - weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -tw <- TwasWeights(study = "s1", context = "brain", trait = "g1", + weights = rep(0.1, 4), cvResult = list(rsq = 0.5), + weightStandardized = FALSE) +tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", method = "susie", entry = list(twe)) twasPredict(X, tw) } diff --git a/man/twasWeightsEntry.Rd b/man/twasWeightsEntry.Rd new file mode 100644 index 00000000..2f8c3d58 --- /dev/null +++ b/man/twasWeightsEntry.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/twasWeights.R +\name{twasWeights} +\alias{twasWeights} +\alias{twasWeights,TwasWeights-method} +\title{Get a Single TWAS Weights Entry} +\usage{ +twasWeights(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) + +\S4method{twasWeights}{TwasWeights}(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) +} +\arguments{ +\item{x}{A \code{TwasWeights} object.} + +\item{studyName, context, trait, method}{Single character identifiers. All +required when the collection has more than one row; optional when the +collection has a single row.} +} +\value{ +A \code{TwasWeightsRow} object. +} +\description{ +Return the \code{TwasWeightsRow} for one \code{(study, + context, trait, method)} row of a \code{TwasWeights} collection. +} +\examples{ +twe <- twasWeightsRow( + variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), + cvResult = list(rsq = 0.5), weightStandardized = FALSE) +tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", + method = "susie", entry = list(twe)) +twasWeights(tw, studyName = "s1", context = "brain", trait = "g1", + method = "susie") +} diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index 24e4b30f..87b1fe72 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -16,7 +16,7 @@ twasWeightsPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, - genotypeFilterArgs = GenotypeFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), jointRegions = FALSE, jointSpecification = NULL, fineMappingResult = NULL, @@ -30,7 +30,7 @@ twasWeightsPipeline(data, ...) nPCs = 10L, fitRetention = c("slim", "none", "full"), residualizationArgs = ResidualizationParam(), - dataType = NULL, + weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, seed = NULL @@ -45,9 +45,9 @@ twasWeightsPipeline(data, ...) fineMappingResult = NULL, twasWeights = NULL, fitRetention = c("slim", "none", "full"), - dataType = NULL, + weightsDataType = NULL, verbose = 1L, - panelFilterArgs = PanelFilterParam(), + panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam() ) @@ -58,8 +58,8 @@ twasWeightsPipeline(data, ...) traitId = NULL, region = NULL, cisWindow = NULL, - genotypeFilterArgs = GenotypeFilterParam(), - panelFilterArgs = PanelFilterParam(), + genotypeFilterParam = GenotypeFilterParam(), + panelFilterParam = PanelFilterParam(), jointRegions = FALSE, jointSpecification = NULL, fineMappingResult = NULL, @@ -68,7 +68,7 @@ twasWeightsPipeline(data, ...) fitFullData = TRUE, estimatePi = TRUE, fitRetention = c("slim", "none", "full"), - dataType = NULL, + weightsDataType = NULL, naAction = c("drop", "impute"), verbose = 1, residualizationArgs = ResidualizationParam(), @@ -107,9 +107,9 @@ 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{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 +\item{genotypeFilterParam}{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 @@ -206,8 +206,8 @@ components fitted per context when \code{usePCA = TRUE} (default \item{residualizationArgs}{Covariate residualization settings, built with \code{\link{ResidualizationParam}} and forwarded to - \code{\link{getResidualizedPhenotypes}} / - \code{\link{getResidualizedGenotypes}}: \code{phenotypeCovariates} and + \code{\link{residualizedPhenotypes}} / + \code{\link{residualizedGenotypes}}: \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 @@ -221,7 +221,7 @@ components fitted per context when \code{usePCA = TRUE} (default 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 +\item{weightsDataType}{Optional data-type label recorded on every \code{TwasWeightsRow$dataType} (e.g. \code{"expression"}).} \item{naAction}{Character. How to handle missing values in the extracted @@ -238,7 +238,7 @@ 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, +\item{panelFilterParam}{For QtlSumStats: LD-reference-panel filters, built with \code{\link{PanelFilterParam}}. See \emph{Panel filters on the RSS path} above.} diff --git a/man/twasWeightsRow.Rd b/man/twasWeightsRow.Rd index df6be10b..f552e8f9 100644 --- a/man/twasWeightsRow.Rd +++ b/man/twasWeightsRow.Rd @@ -7,10 +7,10 @@ twasWeightsRow( variantIds, weights, - fits = NULL, + methodFits = NULL, cvResult = NULL, - standardized = FALSE, - dataType = NULL + weightStandardized = FALSE, + weightsDataType = NULL ) } \arguments{ @@ -20,14 +20,14 @@ coordinates (\code{chrom:pos:ref:alt}).} \item{weights}{Per-variant weights, aligned to \code{variantIds} (a vector, or a matrix with one column per condition).} -\item{fits}{Optional per-method fit payload.} +\item{methodFits}{Optional per-method fit payload.} \item{cvResult}{Optional cross-validation payload.} -\item{standardized}{Whether the weights are already on the standardized +\item{weightStandardized}{Whether the weights are already on the standardized scale.} -\item{dataType}{Optional data-type label.} +\item{weightsDataType}{Optional data-type label.} } \value{ A \code{\linkS4class{TwasWeightsRow}}. @@ -43,7 +43,7 @@ row <- twasWeightsRow( weights = c(0.4, -0.2) ) TwasWeights( - study = "s1", context = "brain", trait = "g1", method = "lasso", + studyName = "s1", context = "brain", trait = "g1", method = "lasso", entry = list(row) ) } diff --git a/man/updateMashModelCov.Rd b/man/updateMashModelCov.Rd index 45dfe2fa..64baf09a 100644 --- a/man/updateMashModelCov.Rd +++ b/man/updateMashModelCov.Rd @@ -28,7 +28,7 @@ data(mashInputExample) mi <- mashInputExample mk <- function(b, s) { qtlSumStatsFromBetaMatrix(as.matrix(mi[[b]]), as.matrix(mi[[s]]), - study = "mash") + studyName = "mash") } ssl <- list(strong = mk("strong.b", "strong.s"), random = mk("random.b", "random.s"), null = mk("null.b", "null.s")) diff --git a/man/getVarY.Rd b/man/varY.Rd similarity index 67% rename from man/getVarY.Rd rename to man/varY.Rd index 50034020..5021ef5f 100644 --- a/man/getVarY.Rd +++ b/man/varY.Rd @@ -1,25 +1,25 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, % R/qtlSumStats.R -\name{getVarY} -\alias{getVarY} -\alias{getVarY,GwasSumStats-method} -\alias{getVarY,QtlSumStats-method} +\name{varY} +\alias{varY} +\alias{varY,GwasSumStats-method} +\alias{varY,QtlSumStats-method} \title{Get Phenotype Variance} \usage{ -getVarY(x, ...) +varY(x, ...) -\S4method{getVarY}{GwasSumStats}(x, study = NULL) +\S4method{varY}{GwasSumStats}(x, studyName = NULL) -\S4method{getVarY}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL) +\S4method{varY}{QtlSumStats}(x, studyName = NULL, context = NULL, trait = 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{studyName}{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.} @@ -37,5 +37,5 @@ Extract phenotype variance from a \code{GwasSumStats} or } \examples{ data(qtlSumStatsExample) -getVarY(qtlSumStatsExample) +varY(qtlSumStatsExample) } diff --git a/man/variantColumnReplace.Rd b/man/variantColumnReplace.Rd new file mode 100644 index 00000000..9504b498 --- /dev/null +++ b/man/variantColumnReplace.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +\name{af<-} +\alias{af<-} +\alias{variantColumnReplace} +\alias{maf<-} +\alias{nSamples<-} +\alias{af<-,SumStatsBase,numeric-method} +\alias{af<-,SumStatsBase,GRanges-method} +\alias{maf<-,SumStatsBase,numeric-method} +\alias{maf<-,SumStatsBase,GRanges-method} +\alias{nSamples<-,SumStatsBase,numeric-method} +\alias{nSamples<-,SumStatsBase,GRanges-method} +\title{Replace a Per-Variant Column} +\usage{ +af(x, ...) <- value + +maf(x, ...) <- value + +nSamples(x, ...) <- value + +\S4method{af}{SumStatsBase,numeric}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value + +\S4method{af}{SumStatsBase,GRanges}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value + +\S4method{maf}{SumStatsBase,numeric}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value + +\S4method{maf}{SumStatsBase,GRanges}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value + +\S4method{nSamples}{SumStatsBase,numeric}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value + +\S4method{nSamples}{SumStatsBase,GRanges}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{...}{Unused.} + +\item{value}{A \code{numeric} vector (positional) or a \code{GRanges} +carrying \code{A1}/\code{A2} plus one value column (matched).} + +\item{studyName, context, trait}{Selectors pinning one entry; \code{context} +and \code{trait} are \code{QtlSumStats}-only.} +} +\value{ +The object, with that entry's column replaced. +} +\description{ +Supply or overwrite one per-variant column of a + \code{GwasSumStats} / \code{QtlSumStats} entry after construction -- + the usual case being an effect-allele frequency the source file did not + carry. Dispatch is on \code{value}: + \describe{ + \item{\code{numeric}}{positional: the vector is in the entry's own + variant order and must have exactly one value per variant. Length is + checked hard, because a recycled or truncated vector is otherwise + silently wrong.} + \item{\code{GRanges}}{matched: paired to the entry on + \code{(chrom, pos, A1, A2)} via \code{matchVariants}, so ordering + does not matter. \code{A1}/\code{A2} are \strong{required} in + \code{mcols()} so an allele swap can be detected, and exactly one + other \code{mcols} column carries the values. Entry variants the + replacement does not name are set \code{NA}.} + } + An allele swap sends \code{af} to \code{1 - af}, so \code{af<-} + complements a flipped match. \code{maf} is \code{min(af, 1 - af)} and + \code{nSamples} is a count, both swap-invariant, so neither is + complemented. +} +\examples{ +data(qtlSumStatsExample) +x <- qtlSumStatsExample +af(x) <- runif(length(variantIds(x))) +head(af(x)) +} diff --git a/man/getVariantIds.Rd b/man/variantIds.Rd similarity index 63% rename from man/getVariantIds.Rd rename to man/variantIds.Rd index 97cf284d..b659c0de 100644 --- a/man/getVariantIds.Rd +++ b/man/variantIds.Rd @@ -1,51 +1,51 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/LdData.R, % R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R -\name{getVariantIds} -\alias{getVariantIds} -\alias{getVariantIds,FineMappingResultBase-method} -\alias{getVariantIds,SumStatsBase-method} -\alias{getVariantIds,LdData-method} -\alias{getVariantIds,FineMappingRow-method} -\alias{getVariantIds,TwasWeights-method} -\alias{getVariantIds,TwasWeightsRow-method} +\name{variantIds} +\alias{variantIds} +\alias{variantIds,FineMappingResultBase-method} +\alias{variantIds,SumStatsBase-method} +\alias{variantIds,LdData-method} +\alias{variantIds,FineMappingRow-method} +\alias{variantIds,TwasWeights-method} +\alias{variantIds,TwasWeightsRow-method} \title{Get Variant IDs} \usage{ -getVariantIds(x, ...) +variantIds(x, ...) -\S4method{getVariantIds}{FineMappingResultBase}( +\S4method{variantIds}{FineMappingResultBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, region = NULL ) -\S4method{getVariantIds}{SumStatsBase}( +\S4method{variantIds}{SumStatsBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, ranges = NULL ) -\S4method{getVariantIds}{LdData}(x) +\S4method{variantIds}{LdData}(x) -\S4method{getVariantIds}{FineMappingRow}(x) +\S4method{variantIds}{FineMappingRow}(x) -\S4method{getVariantIds}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) +\S4method{variantIds}{TwasWeights}(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) -\S4method{getVariantIds}{TwasWeightsRow}(x) +\S4method{variantIds}{TwasWeightsRow}(x) } \arguments{ \item{x}{The 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{studyName}{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.} @@ -61,7 +61,7 @@ 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.} +\code{\link{sumStats}} (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.} @@ -76,5 +76,5 @@ Extract variant ID vector from an object that carries one (e.g., } \examples{ data(qtlFineMappingExample) -getVariantIds(qtlFineMappingExample) +variantIds(qtlFineMappingExample) } diff --git a/man/getVariantInfo.Rd b/man/variantInfo.Rd similarity index 79% rename from man/getVariantInfo.Rd rename to man/variantInfo.Rd index 497a8371..56692083 100644 --- a/man/getVariantInfo.Rd +++ b/man/variantInfo.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdData.R -\name{getVariantInfo} -\alias{getVariantInfo} -\alias{getVariantInfo,LdData-method} +\name{variantInfo} +\alias{variantInfo} +\alias{variantInfo,LdData-method} \title{Get Variant GRanges} \usage{ -getVariantInfo(x) +variantInfo(x) -\S4method{getVariantInfo}{LdData}(x) +\S4method{variantInfo}{LdData}(x) } \arguments{ \item{x}{An \code{LdData}.} @@ -26,5 +26,5 @@ gr <- GenomicRanges::GRanges("22", ld <- LdData(correlation = cor(X), variants = gr, blockMetadata = S4Vectors::DataFrame( chrom = "22", start = 1L, end = 1000L)) -getVariantInfo(ld) +variantInfo(ld) } diff --git a/man/getStandardized.Rd b/man/weightStandardized.Rd similarity index 61% rename from man/getStandardized.Rd rename to man/weightStandardized.Rd index f7a2008b..f9e6ab6c 100644 --- a/man/getStandardized.Rd +++ b/man/weightStandardized.Rd @@ -1,25 +1,31 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/twasWeights.R, % R/twasWeightsRow.R -\name{getStandardized} -\alias{getStandardized} -\alias{getStandardized,TwasWeights-method} -\alias{getStandardized,TwasWeightsRow-method} +\name{weightStandardized} +\alias{weightStandardized} +\alias{weightStandardized,TwasWeights-method} +\alias{weightStandardized,TwasWeightsRow-method} \title{Get Standardized Flag} \usage{ -getStandardized(x, ...) +weightStandardized(x, ...) -\S4method{getStandardized}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) +\S4method{weightStandardized}{TwasWeights}( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL +) -\S4method{getStandardized}{TwasWeightsRow}(x) +\S4method{weightStandardized}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} \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{studyName}{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.} @@ -38,5 +44,5 @@ Check whether weights are on the standardized scale. } \examples{ data(ctwasWeightsExample) -getStandardized(ctwasWeightsExample) +weightStandardized(ctwasWeightsExample) } diff --git a/man/getWeights.Rd b/man/weights-methods.Rd similarity index 54% rename from man/getWeights.Rd rename to man/weights-methods.Rd index 93948089..d8127857 100644 --- a/man/getWeights.Rd +++ b/man/weights-methods.Rd @@ -1,25 +1,27 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/twasWeights.R, -% R/twasWeightsRow.R -\name{getWeights} -\alias{getWeights} -\alias{getWeights,TwasWeights-method} -\alias{getWeights,TwasWeightsRow-method} +% Please edit documentation in R/twasWeights.R, R/twasWeightsRow.R +\name{weights,TwasWeights-method} +\alias{weights,TwasWeights-method} +\alias{weights-methods} +\alias{weights,TwasWeightsRow-method} \title{Get TWAS Weights} \usage{ -getWeights(x, ...) +\S4method{weights}{TwasWeights}( + object, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + ... +) -\S4method{getWeights}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) - -\S4method{getWeights}{TwasWeightsRow}(x) +\S4method{weights}{TwasWeightsRow}(object, ...) } \arguments{ -\item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} - -\item{...}{Class-specific selection arguments.} +\item{object}{A \code{TwasWeightsRow} or \code{TwasWeights}.} -\item{study}{Character (length 1) or \code{NULL}. Restrict the selection to -this study; \code{NULL} matches all studies.} +\item{studyName}{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.} @@ -29,6 +31,8 @@ this trait; \code{NULL} matches all traits.} \item{method}{Character (length 1) or \code{NULL}. Restrict the selection to this fine-mapping / weight method; \code{NULL} matches all methods.} + +\item{...}{Class-specific selection arguments.} } \value{ A numeric vector or matrix of weights. @@ -39,6 +43,7 @@ Extract weights from a \code{TwasWeightsRow} or from one entry } \examples{ twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), - weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -getWeights(twe) + weights = rep(0.1, 4), cvResult = list(rsq = 0.5), + weightStandardized = FALSE) +weights(twe) } diff --git a/man/getDataType.Rd b/man/weightsDataType.Rd similarity index 60% rename from man/getDataType.Rd rename to man/weightsDataType.Rd index 4a015c91..93572c4b 100644 --- a/man/getDataType.Rd +++ b/man/weightsDataType.Rd @@ -1,25 +1,31 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/twasWeights.R, % R/twasWeightsRow.R -\name{getDataType} -\alias{getDataType} -\alias{getDataType,TwasWeights-method} -\alias{getDataType,TwasWeightsRow-method} +\name{weightsDataType} +\alias{weightsDataType} +\alias{weightsDataType,TwasWeights-method} +\alias{weightsDataType,TwasWeightsRow-method} \title{Get Data Type} \usage{ -getDataType(x, ...) +weightsDataType(x, ...) -\S4method{getDataType}{TwasWeights}(x, study = NULL, context = NULL, trait = NULL, method = NULL) +\S4method{weightsDataType}{TwasWeights}( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL +) -\S4method{getDataType}{TwasWeightsRow}(x) +\S4method{weightsDataType}{TwasWeightsRow}(x) } \arguments{ \item{x}{A \code{TwasWeightsRow} or \code{TwasWeights}.} \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{studyName}{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.} @@ -38,6 +44,7 @@ Extract the data-type tag. } \examples{ twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), - weights = rep(0.1, 4), cvResult = list(rsq = 0.5), standardized = FALSE) -getDataType(twe) + weights = rep(0.1, 4), cvResult = list(rsq = 0.5), + weightStandardized = FALSE) +weightsDataType(twe) } diff --git a/man/writeSumStatsVcf.Rd b/man/writeSumStatsVcf.Rd index e9cbcdb2..484012c5 100644 --- a/man/writeSumStatsVcf.Rd +++ b/man/writeSumStatsVcf.Rd @@ -8,13 +8,13 @@ \usage{ writeSumStatsVcf(x, outputPath, sampleName = NULL, ...) -\S4method{writeSumStatsVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, study = NULL) +\S4method{writeSumStatsVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, studyName = NULL) \S4method{writeSumStatsVcf}{FineMappingResultBase}( x, outputPath, sampleName = NULL, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, method = NULL, @@ -36,8 +36,8 @@ method name from the S4 object).} \item{...}{Additional arguments passed to methods.} -\item{study}{Character or \code{NULL}. Restrict the written records to this -study; \code{NULL} includes all studies.} +\item{studyName}{Character or \code{NULL}. Restrict the written records to +this study; \code{NULL} includes all studies.} \item{context}{Character or \code{NULL}. Restrict the written records to this context; \code{NULL} includes all contexts.} diff --git a/man/getZ.Rd b/man/z.Rd similarity index 77% rename from man/getZ.Rd rename to man/z.Rd index 66276017..9bb1dd83 100644 --- a/man/getZ.Rd +++ b/man/z.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{getZ} -\alias{getZ} -\alias{getZ,SumStatsBase-method} +\name{z} +\alias{z} +\alias{z,SumStatsBase-method} \title{Get Z-scores} \usage{ -getZ(x, ...) +z(x, ...) -\S4method{getZ}{SumStatsBase}( +\S4method{z}{SumStatsBase}( x, - study = NULL, + studyName = NULL, context = NULL, trait = NULL, annotateSignificance = NULL, @@ -23,8 +23,8 @@ getZ(x, ...) \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{studyName}{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.} @@ -33,7 +33,7 @@ this context; \code{NULL} matches all contexts.} 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.} +\code{\link{sumStats}} (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.} @@ -47,5 +47,5 @@ Extract z-score vector from a \code{GwasSumStats} or } \examples{ data(qtlSumStatsExample) -getZ(qtlSumStatsExample) +z(qtlSumStatsExample) } diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index a83c85ed..db5426f7 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -109,7 +109,7 @@ makeGwasSumStatsFromDf <- function( varY <- NA_real_ } GwasSumStats( - study = traitName, + studyName = traitName, entry = list(.dfToSumstatsGr(df)), genome = genome, ldSketch = .testGenotypeHandle(), @@ -162,7 +162,7 @@ makeGwasBlock <- function( stringsAsFactors = FALSE ) obj <- GwasSumStats( - study = "trait1", + studyName = "trait1", entry = list(.dfToSumstatsGr(df)), genome = genome, ldSketch = .blockGenotypeHandle(bp), @@ -222,7 +222,7 @@ makeTestLdData <- function( chrom = "chr1", startBp = 1000L, rho = 0.5, - nRef = 500L + nSamples = 500L ) { gr <- .testLdVariants(n, chrom, startBp) R <- .testArBlock(n, rho) @@ -234,7 +234,7 @@ makeTestLdData <- function( correlation = R, variants = gr, blockMetadata = .testBlockMetadata(n, chrom, gr), - nRef = nRef + nSamples = nSamples ) } @@ -245,13 +245,13 @@ makeTestLdDataMultiBlock <- function( chrom = "chr1", startBp = 1000L, rho = 0.5, - nRef = 500L + nSamples = 500L ) { gr <- .testLdVariants(sum(sizes), chrom, startBp) LdData( correlation = map(sizes, .testArBlock, rho = rho), variants = gr, blockMetadata = .testBlockMetadata(sizes, chrom, gr), - nRef = nRef + nSamples = nSamples ) } diff --git a/tests/testthat/helper-s4Constructors.R b/tests/testthat/helper-s4Constructors.R index ccffad52..bfade90e 100644 --- a/tests/testthat/helper-s4Constructors.R +++ b/tests/testthat/helper-s4Constructors.R @@ -58,14 +58,14 @@ context("s4Constructors") .sc_makeTwasWeightsRow <- function( p = 5L, - standardized = FALSE, - dataType = "expression" + weightStandardized = FALSE, + weightsDataType = "expression" ) { twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = rnorm(p), - standardized = standardized, - dataType = dataType + weightStandardized = weightStandardized, + weightsDataType = weightsDataType ) } diff --git a/tests/testthat/helper-showMethods.R b/tests/testthat/helper-showMethods.R index 990445a1..e20ea623 100644 --- a/tests/testthat/helper-showMethods.R +++ b/tests/testthat/helper-showMethods.R @@ -51,12 +51,12 @@ context("show methods") ) } -.sh_makeTwEntry <- function(p = 4, standardized = FALSE) { +.sh_makeTwEntry <- function(p = 4, weightStandardized = FALSE) { twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = rep(0.1, p), cvResult = list(rsq = 0.5), - standardized = standardized + weightStandardized = weightStandardized ) } @@ -86,9 +86,9 @@ context("show methods") ) } -.sh_makeQtlDataset <- function(study = "study1") { +.sh_makeQtlDataset <- function(studyName = "study1") { QtlDataset( - study = study, + studyName = studyName, genotypes = .sh_makeGenotypeHandle(), phenotypes = list(brain = .sh_makeSe()), genotypeCovariates = matrix(0, nrow = 50, ncol = 0) diff --git a/tests/testthat/helper-sldsc.R b/tests/testthat/helper-sldsc.R index c6d44959..dd6d7e93 100644 --- a/tests/testthat/helper-sldsc.R +++ b/tests/testthat/helper-sldsc.R @@ -246,7 +246,7 @@ # Per-block tau has to vary: a constant matrix gives a jackknife # tauStarSe of exactly 0, which drops every trait from the # DerSimonian-Laird meta (nTraits == 0 and all-NA meta rows). - tauBlocks = matrix( + annotationJackknifeCoefs = matrix( rep(tau * seq(0.9, 1.1, length.out = nBlocks), n), nBlocks, n, @@ -295,5 +295,5 @@ tr } traits <- setNames(map(traitNames, function(.) mkTrait()), traitNames) - SldscData(annot = annot, frq = frq, traits = traits) + SldscData(annotData = annot, frqData = frq, traits = traits) } diff --git a/tests/testthat/test_AllClasses.R b/tests/testthat/test_AllClasses.R index c36e0f03..4d3e45ed 100644 --- a/tests/testthat/test_AllClasses.R +++ b/tests/testthat/test_AllClasses.R @@ -2,8 +2,8 @@ context("AllClasses (virtual base classes)") # Most slots / accessors on the concrete subclasses are exercised in their # own test files; these tests target the *base-class* behaviors that the -# concrete subclasses inherit without overriding (getStudy on SumStatsBase, -# getQcDiagnostics body branches, and the zero-row adjustPips short-circuit +# concrete subclasses inherit without overriding (studyName on SumStatsBase, +# qcDiagnostics body branches, and the zero-row adjustPips short-circuit # on FineMappingResultBase). # =========================================================================== @@ -49,7 +49,7 @@ context("AllClasses (virtual base classes)") .alc_makeGwasSumStats <- function(qcInfo = list()) { GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.alc_makeGr()), genome = "hg19", ldSketch = .alc_makeHandle(), @@ -83,30 +83,30 @@ context("AllClasses (virtual base classes)") } # =========================================================================== -# SumStatsBase: getStudy (inherited by QtlSumStats / GwasSumStats) +# SumStatsBase: studyName (inherited by QtlSumStats / GwasSumStats) # =========================================================================== -test_that("SumStatsBase: getStudy on a GwasSumStats returns unique study names", { +test_that("SumStatsBase: studyName on a GwasSumStats returns unique study names", { ss <- .alc_makeGwasSumStats() - expect_equal(getStudy(ss), "g1") + expect_equal(studyName(ss), "g1") }) # =========================================================================== -# SumStatsBase: getQcDiagnostics — every branch +# SumStatsBase: qcDiagnostics — every branch # =========================================================================== -test_that("SumStatsBase: getQcDiagnostics returns NULL on empty qcInfo", { +test_that("SumStatsBase: qcDiagnostics returns NULL on empty qcInfo", { ss <- .alc_makeGwasSumStats() # qcInfo = list() by default - expect_null(getQcDiagnostics(ss)) + expect_null(qcDiagnostics(ss)) }) -test_that("SumStatsBase: getQcDiagnostics returns NULL when entryAudit slot is absent", { +test_that("SumStatsBase: qcDiagnostics returns NULL when entryAudit slot is absent", { # qcInfo has steps but no entryAudit -> nothing to return. ss <- .alc_makeGwasSumStats(qcInfo = list(step1 = "ok")) - expect_null(getQcDiagnostics(ss)) + expect_null(qcDiagnostics(ss)) }) -test_that("SumStatsBase: getQcDiagnostics returns the per-entry diagnostics by index", { +test_that("SumStatsBase: qcDiagnostics returns the per-entry diagnostics by index", { diag1 <- data.frame(SNP = "rs1", outlier = FALSE, stringsAsFactors = FALSE) diag2 <- data.frame(SNP = "rs2", outlier = TRUE, stringsAsFactors = FALSE) qc <- list( @@ -116,11 +116,11 @@ test_that("SumStatsBase: getQcDiagnostics returns the per-entry diagnostics by i ) ) ss <- .alc_makeGwasSumStats(qcInfo = qc) - expect_identical(getQcDiagnostics(ss, entry = 1L), diag1) - expect_identical(getQcDiagnostics(ss, entry = 2L), diag2) + expect_identical(qcDiagnostics(ss, entry = 1L), diag1) + expect_identical(qcDiagnostics(ss, entry = 2L), diag2) }) -test_that("SumStatsBase: getQcDiagnostics(entry = NULL) returns the populated entries only", { +test_that("SumStatsBase: qcDiagnostics(entry = NULL) returns the populated entries only", { diag1 <- data.frame(SNP = "rs1", outlier = FALSE, stringsAsFactors = FALSE) # Entry 2's audit has no ldMismatchDiagnostics field; should be filtered. qc <- list( @@ -130,32 +130,32 @@ test_that("SumStatsBase: getQcDiagnostics(entry = NULL) returns the populated en ) ) ss <- .alc_makeGwasSumStats(qcInfo = qc) - out <- getQcDiagnostics(ss, entry = NULL) + out <- qcDiagnostics(ss, entry = NULL) expect_type(out, "list") expect_equal(length(out), 1L) expect_named(out, "1") expect_identical(out[["1"]], diag1) }) -test_that("SumStatsBase: getQcDiagnostics(entry = NULL) returns NULL when no entry has diagnostics", { +test_that("SumStatsBase: qcDiagnostics(entry = NULL) returns NULL when no entry has diagnostics", { qc <- list(entryAudit = list(list(other = 1), list(other = 2))) ss <- .alc_makeGwasSumStats(qcInfo = qc) - expect_null(getQcDiagnostics(ss, entry = NULL)) + expect_null(qcDiagnostics(ss, entry = NULL)) }) -test_that("SumStatsBase: getQcDiagnostics errors on out-of-range entry", { +test_that("SumStatsBase: qcDiagnostics errors on out-of-range entry", { qc <- list( entryAudit = list(list(ldMismatchDiagnostics = data.frame(z = 1))) ) ss <- .alc_makeGwasSumStats(qcInfo = qc) - expect_error(getQcDiagnostics(ss, entry = 0L), "must be a single integer") - expect_error(getQcDiagnostics(ss, entry = 99L), "must be a single integer") + expect_error(qcDiagnostics(ss, entry = 0L), "must be a single integer") + expect_error(qcDiagnostics(ss, entry = 99L), "must be a single integer") expect_error( - getQcDiagnostics(ss, entry = c(1L, 2L)), + qcDiagnostics(ss, entry = c(1L, 2L)), "must be a single integer" ) expect_error( - getQcDiagnostics(ss, entry = "first"), + qcDiagnostics(ss, entry = "first"), "must be a single integer" ) }) @@ -167,7 +167,7 @@ test_that("SumStatsBase: getQcDiagnostics errors on out-of-range entry", { test_that("FineMappingResultBase: adjustPips on a zero-row collection returns the input unchanged", { e <- .alc_makeFmEntry(3) res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) @@ -180,11 +180,11 @@ test_that("FineMappingResultBase: adjustPips on a zero-row collection returns th }) # =========================================================================== -# getTopLoci(type = "GRanges") + aggregate-view branches on FineMappingResultBase +# topLoci() ranges + aggregate-view branches on FineMappingResultBase # =========================================================================== .alc_makeFmr2 <- function() { QtlFineMappingResult( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("t1", "t2"), method = c("susie", "susie"), @@ -193,12 +193,11 @@ test_that("FineMappingResultBase: adjustPips on a zero-row collection returns th ) } -test_that("getTopLoci(type='GRanges'): a pinned single entry returns a GRanges", { +test_that("topLoci(): a pinned single entry returns a GRanges", { fmr <- .alc_makeFmr2() - gr <- getTopLoci( + gr <- topLoci( fmr, - type = "GRanges", - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie" @@ -206,52 +205,64 @@ test_that("getTopLoci(type='GRanges'): a pinned single entry returns a GRanges", expect_s4_class(gr, "GRanges") }) -test_that("getTopLoci(type='GRanges'): aggregating >1 entry is rejected", { - expect_error( - getTopLoci(.alc_makeFmr2(), type = "GRanges"), - "requires type = 'data.frame'" - ) +test_that("topLoci(): aggregating >1 entry also returns a GRanges", { + # Converting to ranges after stacking is what makes this work: the + # row-identity columns become mcols. The old type = "GRanges" branch had + # to refuse anything but a single pinned entry. + gr <- topLoci(.alc_makeFmr2()) + expect_s4_class(gr, "GRanges") + expect_true(all( + c("study", "context", "trait", "method") %in% + names(S4Vectors::mcols(gr)) + )) +}) + +test_that("topLoci(raw = TRUE) stays a table", { + # The stored canonical table has no posterior projection to put on a + # range, so raw is the one form that is not a GRanges. + raw <- topLoci(.alc_makeFmr2(), raw = TRUE) + expect_true(is.data.frame(raw)) }) test_that("FineMappingResultBase aggregate view: empty per-entry views -> 0-row frame", { - # .alc_makeFmEntry has no credible sets, so getCs aggregates to nothing. - expect_equal(nrow(getCs(.alc_makeFmr2())), 0L) + # .alc_makeFmEntry has no credible sets, so credibleSets aggregates to nothing. + expect_equal(nrow(credibleSets(.alc_makeFmr2())), 0L) }) test_that("FineMappingResultBase aggregate view: a no-match selector re-raises the selection error", { - expect_error(getCs(.alc_makeFmr2(), study = "nope"), "entries") + expect_error(credibleSets(.alc_makeFmr2(), studyName = "nope"), "entries") }) test_that("FineMappingResultBase aggregate view: an empty collection yields a 0-row frame", { empty <- QtlFineMappingResult( - study = character(0), + studyName = character(0), context = character(0), trait = character(0), method = character(0), entry = list(), ldSketch = .alc_makeHandle() ) - expect_equal(nrow(getCs(empty)), 0L) + expect_equal(nrow(credibleSets(empty)), 0L) }) # =========================================================================== -# Variant reconciliation: intersectVariants + getRetainedMass +# Variant reconciliation: intersectVariants + retainedMass # =========================================================================== -.rc_makeFmr <- function(vids, study = "s1", L = 3L, seed = 3L) { +.rc_makeFmr <- function(vids, studyName = "s1", maxNumSingleEffects = 3L, seed = 3L) { set.seed(seed) p <- length(vids) - lbf <- matrix(rnorm(L * p, sd = 3), L, p, dimnames = list(NULL, vids)) + lbf <- matrix(rnorm(maxNumSingleEffects * p, sd = 3), maxNumSingleEffects, p, dimnames = list(NULL, vids)) alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) e <- fineMappingRow( vids, - list(pip = pip, alpha = alpha, lbf_variable = lbf, V = rep(1, L)), + list(pip = pip, alpha = alpha, lbf_variable = lbf, V = rep(1, maxNumSingleEffects)), data.frame(variant_id = vids, pip = pip, stringsAsFactors = FALSE) ) QtlFineMappingResult( - study = study, + studyName = studyName, context = "c1", trait = "g1", method = "susie", @@ -263,35 +274,35 @@ test_that("FineMappingResultBase aggregate view: an empty collection yields a 0- test_that("intersectVariants restricts both sides to the shared variants", { x <- .rc_makeFmr(.rc_vids(1:30)) - y <- .rc_makeFmr(.rc_vids(20:50), study = "s2") + y <- .rc_makeFmr(.rc_vids(20:50), studyName = "s2") out <- intersectVariants(x, y) expect_setequal(names(out), c("x", "y")) shared <- .rc_vids(20:30) expect_setequal( - getVariantIds(pecotmr:::.collectionEntry(out$x, 1L)), + variantIds(pecotmr:::.collectionEntry(out$x, 1L)), shared ) expect_setequal( - getVariantIds(pecotmr:::.collectionEntry(out$y, 1L)), + variantIds(pecotmr:::.collectionEntry(out$y, 1L)), shared ) # Both sides end up scored on the SAME variant set, which is what coloc # needs -- a pair scored on two different sets is not comparable. expect_equal( - getVariantIds(pecotmr:::.collectionEntry(out$x, 1L)), - getVariantIds(pecotmr:::.collectionEntry(out$y, 1L)) + variantIds(pecotmr:::.collectionEntry(out$x, 1L)), + variantIds(pecotmr:::.collectionEntry(out$y, 1L)) ) }) test_that("intersectVariants oneSided adjusts only x", { x <- .rc_makeFmr(.rc_vids(1:30)) - y <- .rc_makeFmr(.rc_vids(20:50), study = "s2") + y <- .rc_makeFmr(.rc_vids(20:50), studyName = "s2") out <- intersectVariants(x, y, oneSided = TRUE) expect_s4_class(out, "QtlFineMappingResult") expect_setequal( - getVariantIds(pecotmr:::.collectionEntry(out, 1L)), + variantIds(pecotmr:::.collectionEntry(out, 1L)), .rc_vids(20:30) ) # y is untouched: TWAS / MR / cTWAS reconcile the QTL side to the GWAS @@ -303,22 +314,22 @@ test_that("intersectVariants errors when the two share no variants", { # Returning two empty collections would be indistinguishable from # "reconciled fine, nothing colocalizes" -- a different conclusion. x <- .rc_makeFmr(.rc_vids(1:10)) - y <- .rc_makeFmr(sprintf("chr9:%d:A:G", 100L * 1:10), study = "s2") + y <- .rc_makeFmr(sprintf("chr9:%d:A:G", 100L * 1:10), studyName = "s2") expect_error(intersectVariants(x, y), "share no variants") }) test_that("intersectVariants matches variants allele-aware", { # A chr-prefix difference must not read as no-overlap. x <- .rc_makeFmr(.rc_vids(1:10)) - y <- .rc_makeFmr(sprintf("%d:%d:A:G", 1L, 100L * 5:14), study = "s2") + y <- .rc_makeFmr(sprintf("%d:%d:A:G", 1L, 100L * 5:14), studyName = "s2") out <- intersectVariants(x, y) expect_length(unlist(out$x, use.names = FALSE), 6L) }) -test_that("getRetainedMass reports per-effect surviving mass", { +test_that("retainedMass reports per-effect surviving mass", { x <- .rc_makeFmr(.rc_vids(1:40)) adj <- adjustPips(x, .rc_vids(1:20)) - mass <- getRetainedMass(adj) + mass <- retainedMass(adj) expect_equal(nrow(mass), 3L) # one row per effect expect_true(all(mass$retainedMass > 0 & mass$retainedMass <= 1)) @@ -328,108 +339,108 @@ test_that("getRetainedMass reports per-effect surviving mass", { expect_true(all(c("study", "context", "trait", "method") %in% names(mass))) }) -test_that("getRetainedMass is the PRE-renormalization share", { +test_that("retainedMass is the PRE-renormalization share", { # After renormalization every effect row sums to 1, so the surviving share # is only knowable at adjustment time. A value of 1 across the board would # mean the diagnostic was reading the post-normalized alpha. x <- .rc_makeFmr(.rc_vids(1:40)) adj <- adjustPips(x, .rc_vids(1:20)) - mass <- getRetainedMass(adj) + mass <- retainedMass(adj) expect_false(all(abs(mass$retainedMass - 1) < 1e-9)) - fit <- getSusieFit(pecotmr:::.collectionEntry(adj, 1L)) + fit <- susieFit(pecotmr:::.collectionEntry(adj, 1L)) expect_equal(rowSums(fit$alpha), rep(1, 3L), tolerance = 1e-10) }) -test_that("getRetainedMass reports nothing for a fit never reconciled", { +test_that("retainedMass reports nothing for a fit never reconciled", { # Not a vector of 1s: nothing was dropped, so there is no surviving-share # to report, and implying a subset happened would be misleading. x <- .rc_makeFmr(.rc_vids(1:10)) - expect_equal(nrow(getRetainedMass(x)), 0L) - expect_equal(nrow(getRetainedMass(x[0L])), 0L) + expect_equal(nrow(retainedMass(x)), 0L) + expect_equal(nrow(retainedMass(x[0L])), 0L) }) -test_that("getRetainedMass: empty result has the populated result's schema", { +test_that("retainedMass: empty result has the populated result's schema", { # A caller that selects `study` must not break only when there is nothing # to report, so the zero-row shape has to match the non-zero-row shape. data(qtlFineMappingExample, envir = environment()) data(gwasFineMappingExample, envir = environment()) - empty <- getRetainedMass(qtlFineMappingExample) + empty <- retainedMass(qtlFineMappingExample) expect_equal(nrow(empty), 0L) both <- intersectVariants( qtlFineMappingExample, gwasFineMappingExample ) - full <- getRetainedMass(both$x) + full <- retainedMass(both$x) expect_gt(nrow(full), 0L) expect_equal(colnames(empty), colnames(full)) expect_equal(nrow(bind_rows(empty, full)), nrow(full)) }) -test_that("getRetainedMass: identity columns follow the concrete class", { +test_that("retainedMass: identity columns follow the concrete class", { # A GWAS collection has no context / trait, so neither should its table. data(gwasFineMappingExample, envir = environment()) - cols <- colnames(getRetainedMass(gwasFineMappingExample)) + cols <- colnames(retainedMass(gwasFineMappingExample)) expect_true(all(is_in(c("study", "method"), cols))) expect_false(any(is_in(c("context", "trait"), cols))) }) # --------------------------------------------------------------------------- -# getVariantIds on SumStatsBase. +# variantIds on SumStatsBase. # # One method serves GwasSumStats and QtlSumStats: each class's own -# getSumStats() knows its selectors and owns the ambiguity error, so this +# sumStats() knows its selectors and owns the ambiguity error, so this # delegates rather than re-deciding when a collection is addressable. # --------------------------------------------------------------------------- -test_that("getVariantIds returns a single-row collection's ids", { +test_that("variantIds returns a single-row collection's ids", { data(qtlSumStatsExample, envir = environment()) data(gwasSumStatsS4Example, envir = environment()) - qtl <- getVariantIds(qtlSumStatsExample) - gwas <- getVariantIds(gwasSumStatsS4Example) + qtl <- variantIds(qtlSumStatsExample) + gwas <- variantIds(gwasSumStatsS4Example) expect_type(qtl, "character") expect_equal(length(qtl), sum(lengths(qtlSumStatsExample))) expect_equal(length(gwas), sum(lengths(gwasSumStatsS4Example))) }) -test_that("getVariantIds renders ids the same way the row classes do", { +test_that("variantIds renders ids the same way the row classes do", { # .grVariantIds is the one renderer, so an id is the same string whichever # object produced it -- which is what lets these be intersected at all. data(qtlSumStatsExample, envir = environment()) expect_equal( - getVariantIds(qtlSumStatsExample), - getSumStatsDf(qtlSumStatsExample, require = "Z")$variant_id + variantIds(qtlSumStatsExample), + as.data.frame(qtlSumStatsExample, require = "Z")$variant_id ) - expect_match(getVariantIds(qtlSumStatsExample)[[1L]], "^chr[^:]+:\\d+:") + expect_match(variantIds(qtlSumStatsExample)[[1L]], "^chr[^:]+:\\d+:") }) -test_that("getVariantIds selects one row of a multi-row collection", { +test_that("variantIds selects one row of a multi-row collection", { data(qtlSumStatsMulticontextExample, envir = environment()) mc <- qtlSumStatsMulticontextExample expect_gt(nrow(mc), 1L) - ids <- getVariantIds( + ids <- variantIds( mc, - study = mc$study[[1L]], + studyName = mc$study[[1L]], context = "blood", trait = mc$trait[[1L]] ) expect_equal(length(ids), lengths(mc)[[which(mc$context == "blood")]]) }) -test_that("getVariantIds defers the ambiguity error to the class", { +test_that("variantIds defers the ambiguity error to the class", { # Not re-implemented here: the message names the selectors that class # actually takes, and duplicating it would let the two drift. data(qtlSumStatsMulticontextExample, envir = environment()) expect_error( - getVariantIds(qtlSumStatsMulticontextExample), + variantIds(qtlSumStatsMulticontextExample), "Pass `study`, `context`, and `trait`" ) }) -test_that("getVariantIds on an empty collection defers too", { +test_that("variantIds on an empty collection defers too", { data(qtlSumStatsExample, envir = environment()) - expect_error(getVariantIds(qtlSumStatsExample[0]), "no rows") + expect_error(variantIds(qtlSumStatsExample[0]), "no rows") }) # =========================================================================== @@ -443,10 +454,10 @@ test_that("getVariantIds on an empty collection defers too", { # renormalization requires): one on chr1, one on chr9 so it can be made to # miss `keepVariants` entirely. .ac_twoEntry <- function() { - a <- .rc_makeFmr(.rc_vids(1:10), study = "s1") - b <- .rc_makeFmr(sprintf("chr9:%d:A:G", 100L * 1:10), study = "s2") + a <- .rc_makeFmr(.rc_vids(1:10), studyName = "s1") + b <- .rc_makeFmr(sprintf("chr9:%d:A:G", 100L * 1:10), studyName = "s2") QtlFineMappingResult( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c1"), trait = c("g1", "g1"), method = c("susie", "susie"), @@ -478,14 +489,14 @@ test_that("adjustPips drops non-overlapping entries and says so", { # =========================================================================== # .ssStitchElements()'s `ranges` filter # -# getSumStats(x, ranges = ) is a documented argument that nothing exercised: +# sumStats(x, ranges = ) is a documented argument that nothing exercised: # every call left it NULL and returned through the early exit, so the # chromosome test and the overlap intersection were both cold. # =========================================================================== -test_that("getSumStats(ranges=) narrows the variants to the window", { +test_that("sumStats(ranges=) narrows the variants to the window", { data(gwasSumStatsS4Example) - full <- getSumStats(gwasSumStatsS4Example) + full <- sumStats(gwasSumStatsS4Example) span <- range(GenomicRanges::start(full)) win <- GenomicRanges::GRanges( as.character(GenomicRanges::seqnames(full))[[1L]], @@ -494,19 +505,19 @@ test_that("getSumStats(ranges=) narrows the variants to the window", { span[[1L]] + (span[[2L]] - span[[1L]]) %/% 4L ) ) - sub <- getSumStats(gwasSumStatsS4Example, ranges = win) + sub <- sumStats(gwasSumStatsS4Example, ranges = win) expect_s4_class(sub, "GRanges") expect_lt(length(sub), length(full)) expect_gt(length(sub), 0L) expect_true(all(IRanges::overlapsAny(sub, win))) }) -test_that("getSumStats(ranges=) on another chromosome returns nothing", { +test_that("sumStats(ranges=) on another chromosome returns nothing", { # The chromosome test short-circuits before overlapsAny(), which would # otherwise warn about disjoint seqlevels. data(gwasSumStatsS4Example) off <- GenomicRanges::GRanges("chrZZ", IRanges::IRanges(1L, 100L)) - sub <- suppressWarnings(getSumStats(gwasSumStatsS4Example, ranges = off)) + sub <- suppressWarnings(sumStats(gwasSumStatsS4Example, ranges = off)) expect_s4_class(sub, "GRanges") expect_equal(length(sub), 0L) }) @@ -553,3 +564,155 @@ test_that("retained mass is NULL for a fit that never went through reconciliatio expect_null(pecotmr:::.rcFitRetainedMass("not a fit")) expect_equal(pecotmr:::.rcFitRetainedMass(list(retained_mass = 0.8)), 0.8) }) + +# =========================================================================== +# Variant-level replacement: af<- / maf<- / nSamples<- dispatch on `value` +# =========================================================================== + +# A replacement GRanges over the same variants as `x`, with the alleles in +# the given orientation and one payload column. +.alc_replacementGr <- function(x, swap = FALSE, k = NULL, payload = 0.3) { + ids <- variantIds(x) + p <- parseVariantId(ids) + idx <- if (is.null(k)) seq_along(ids) else seq_len(k) + gr <- GenomicRanges::GRanges( + p$chrom[idx], + IRanges::IRanges(p$pos[idx], width = 1L) + ) + a1 <- if (swap) p$A2[idx] else p$A1[idx] + a2 <- if (swap) p$A1[idx] else p$A2[idx] + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + A1 = a1, + A2 = a2, + v = rep(payload, length(idx)) + ) + gr +} + +test_that("af<- numeric is positional and checks length hard", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + n <- length(variantIds(x)) + # The motivating case: the source carried no effect-allele frequency. + expect_null(af(x)) + af(x) <- seq(0.1, 0.4, length.out = n) + expect_equal(length(af(x)), n) + expect_equal(af(x)[[1L]], 0.1) + # A recycled or truncated frequency vector is silently wrong, so length + # is refused rather than recycled. + expect_error(af(x) <- c(0.1, 0.2), "one value per variant") + expect_error(af(x) <- 0.3, "one value per variant") +}) + +test_that("maf<- and nSamples<- numeric are positional too", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + n <- length(variantIds(x)) + # The numeric (positional) half of the dispatch, for the two columns that + # are swap-invariant and so have no allele-matching branch to exercise. + maf(x) <- seq(0.05, 0.2, length.out = n) + expect_equal(length(maf(x)), n) + expect_equal(maf(x)[[1L]], 0.05) + nSamples(x) <- rep(1234, n) + expect_equal(unique(nSamples(x)), 1234) + expect_error(maf(x) <- c(0.1, 0.2), "one value per variant") + expect_error(nSamples(x) <- 1L, "one value per variant") +}) + +test_that("a GRanges replacement warns about variants it could not place", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + gr <- .alc_replacementGr(x, payload = 0.4) + # Two variants shifted far enough to match nothing. Silently dropping + # them would hide a mis-joined replacement table, so it warns and says + # how many were ignored. + extra <- GenomicRanges::shift(gr[1:2], 10000000L) + expect_warning(af(x) <- c(gr, extra), "were ignored") + expect_equal(unique(af(x)), 0.4) +}) + +test_that("the variant-level setters work on a GwasSumStats as well", { + data(gwasSumStatsS4Example) + x <- gwasSumStatsS4Example + n <- length(variantIds(x)) + # A GWAS collection is keyed by study alone, so the row lookup takes the + # non-QtlSumStats branch and the QTL-only selectors are refused. + af(x) <- rep(0.3, n) + expect_equal(unique(af(x)), 0.3) + expect_error( + af(x, context = "brain") <- rep(0.3, n), + "context" + ) +}) + +test_that("af<- GRanges matches on (chrom, pos, A1, A2) regardless of order", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + gr <- .alc_replacementGr(x, payload = 0.25) + af(x) <- gr[rev(seq_along(gr))] + expect_equal(unique(af(x)), 0.25) +}) + +test_that("a flip complements af but leaves maf and nSamples alone", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + swapped <- .alc_replacementGr(x, swap = TRUE, payload = 0.3) + # An allele swap sends af -> 1 - af. maf is min(af, 1 - af) and nSamples + # is a count, so both are swap-invariant -- complementing them would + # corrupt them. + y <- x + af(y) <- swapped + expect_equal(unique(af(y)), 0.7) + z <- x + maf(z) <- swapped + expect_equal(unique(maf(z)), 0.3) + w <- x + nSamples(w) <- swapped + expect_equal(unique(nSamples(w)), 0.3) +}) + +test_that("af<- GRanges requires A1/A2 and exactly one payload column", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + n <- length(variantIds(x)) + p <- parseVariantId(variantIds(x)) + bare <- GenomicRanges::GRanges( + p$chrom, + IRanges::IRanges(p$pos, width = 1L) + ) + S4Vectors::mcols(bare) <- S4Vectors::DataFrame(v = rep(0.3, n)) + # Without A1/A2 a flip cannot be detected, so the value cannot be + # oriented and the write is refused rather than guessed at. + expect_error(af(x) <- bare, "must carry A1 and A2") + two <- .alc_replacementGr(x) + S4Vectors::mcols(two)$extra <- 1 + expect_error(af(x) <- two, "exactly one value column") +}) + +test_that("af<- sets NA for entry variants the replacement omits", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + n <- length(variantIds(x)) + partial <- .alc_replacementGr(x, k = 5L, payload = 0.42) + expect_warning(af(x) <- partial, "were set NA") + a <- af(x) + # Unknown, not unchanged. + expect_equal(sum(!is.na(a)), 5L) + expect_equal(sum(is.na(a)), n - 5L) + expect_equal(unique(a[!is.na(a)]), 0.42) +}) + +test_that("af<- refuses a replacement that matches nothing", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + far <- GenomicRanges::GRanges( + "chr9", + IRanges::IRanges(1:3, width = 1L) + ) + S4Vectors::mcols(far) <- S4Vectors::DataFrame( + A1 = rep("A", 3), + A2 = rep("G", 3), + v = c(0.1, 0.2, 0.3) + ) + expect_error(af(x) <- far, "no variant in the replacement matches") +}) diff --git a/tests/testthat/test_AllGenerics.R b/tests/testthat/test_AllGenerics.R index d2ff8aa5..b1f937fd 100644 --- a/tests/testthat/test_AllGenerics.R +++ b/tests/testthat/test_AllGenerics.R @@ -5,7 +5,7 @@ # A generic with no methods is dead API. It exports a name, generates a help # page, and answers every call with "unable to find an inherited method", which # reads to a user like a bug in their input rather than a gap in the package. -# The refactor produced one of these (`getPhenotypes` briefly had no method at +# The refactor produced one of these (`molecularTraits` briefly had no method at # all), so this is a live failure mode, not a hypothetical. # @noRd diff --git a/tests/testthat/test_AnnotationMatrix.R b/tests/testthat/test_AnnotationMatrix.R index 4fb4bbef..3515d612 100644 --- a/tests/testthat/test_AnnotationMatrix.R +++ b/tests/testthat/test_AnnotationMatrix.R @@ -1,8 +1,9 @@ context("AnnotationMatrix") # Migrated from test_h2Annotations.R: the AnnotationMatrix S4 class + validity, -# its constructor, the getGenome accessor, and the getBaseline / -# getCandidates tier accessors — all now defined in R/AnnotationMatrix.R. +# its constructor, the genome build read from seqinfo, and the +# baselineAnnotations / +# testedAnnotations tier accessors — all now defined in R/AnnotationMatrix.R. # The class is a RangedSummarizedExperiment, so the annotation matrix, # its per-column metadata and its ranges are read with assay(), # colData() and rowRanges() rather than through accessors of our own. @@ -72,7 +73,7 @@ test_that("AnnotationMatrix() constructor creates object from matrix", { expect_s4_class(obj, "AnnotationMatrix") expect_equal(nrow(assay(obj, "annotations")), n) expect_equal(ncol(assay(obj, "annotations")), 3) - expect_equal(getGenome(obj), "hg38") + expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") }) test_that("AnnotationMatrix() sets column names from annotation_meta", { @@ -125,31 +126,31 @@ test_that("AnnotationMatrix accessors round-trip the stored slots", { want <- gr GenomeInfoDb::genome(want) <- "hg38" expect_equal(rowRanges(obj), want) - expect_equal(getGenome(obj), "hg38") + expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") }) -test_that("getBaseline() subsets to baseline-tier only", { +test_that("baselineAnnotations() subsets to baseline-tier only", { n <- 10 gr <- makeTestGRanges(n) meta <- makeTestAnnotationMeta() # 1 baseline, 2 candidate mat <- matrix(0, nrow = n, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta) - baseline <- getBaseline(obj) + baseline <- baselineAnnotations(obj) expect_s4_class(baseline, "AnnotationMatrix") expect_equal(ncol(assay(baseline, "annotations")), 1) expect_true(all(SummarizedExperiment::colData(baseline)$tier == "baseline")) }) -test_that("getCandidates() subsets to candidate-tier only", { +test_that("testedAnnotations() subsets to candidate-tier only", { n <- 10 gr <- makeTestGRanges(n) meta <- makeTestAnnotationMeta() # 1 baseline, 2 candidate mat <- matrix(0, nrow = n, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta) - cand <- getCandidates(obj) + cand <- testedAnnotations(obj) expect_s4_class(cand, "AnnotationMatrix") expect_equal(ncol(assay(cand, "annotations")), 2) diff --git a/tests/testthat/test_ColocBoostResult.R b/tests/testthat/test_ColocBoostResult.R index 355b4e9b..2f125853 100644 --- a/tests/testthat/test_ColocBoostResult.R +++ b/tests/testthat/test_ColocBoostResult.R @@ -27,7 +27,7 @@ test_that("ColocBoostResult: a set holds an arbitrary number of outcomes", { ) expect_equal(nrow(x), 1L) expect_equal(lengths(x$outcomes), 3L) - expect_equal(getColocPairs(x)$nOutcomes, 3L) + expect_equal(colocPairs(x)$nOutcomes, 3L) }) test_that("ColocBoostResult: shares a base with ColocResult", { @@ -89,7 +89,7 @@ test_that("ColocBoostResult: an empty result keeps the column schema", { c("cosId", "analysis", "cosNpc", "isColocalized"), colnames(x) ))) - expect_equal(nrow(getColocPairs(x)), 0L) + expect_equal(nrow(colocPairs(x)), 0L) }) test_that("ColocBoostResult: NULL runs are skipped, not errors", { @@ -139,7 +139,7 @@ test_that("ColocBoostResult: variants keep alleles so ids round-trip", { "xqtl_coloc", outcomeInfo = .cbr_info() ) - expect_equal(getColocVariants(x)$variant_id, "chr1:200:C:T") + expect_equal(colocVariants(x)$variant_id, "chr1:200:C:T") }) test_that("ColocBoostResult: reachable by range, not just identity", { @@ -153,26 +153,26 @@ test_that("ColocBoostResult: reachable by range, not just identity", { expect_equal(sum(lengths(subsetRegion(x, win))), 1L) }) -test_that("getColocBoostOutcomes: joins each outcome to its identity", { +test_that("colocBoostOutcomes: joins each outcome to its identity", { x <- ColocBoostResult( list(.cbr_fake()), "xqtl_coloc", outcomeInfo = .cbr_info() ) - out <- getColocBoostOutcomes(x) + out <- colocBoostOutcomes(x) expect_equal(nrow(out), 2L) expect_setequal(out$outcome, c("t1", "t2")) expect_setequal(out$context, c("ctx1", "ctx2")) expect_true(all(out$trait == "GENE1")) }) -test_that("getRegionVcp spans the region, not just set members", { +test_that("regionVcp spans the region, not just set members", { x <- ColocBoostResult( list(.cbr_fake(nRegion = 6L)), "xqtl_coloc", outcomeInfo = .cbr_info() ) - expect_equal(length(getRegionVcp(x)), 6L) + expect_equal(length(regionVcp(x)), 6L) expect_equal(sum(lengths(x)), 1L) }) @@ -321,7 +321,7 @@ test_that("show counts colocalized and outcome-only sets separately", { # Pooled variants, and the fallbacks for a result missing its summary tables # =========================================================================== -test_that("getColocVariants(pooled = TRUE) collapses to one row per variant", { +test_that("colocVariants(pooled = TRUE) collapses to one row per variant", { # Noisy-OR only: ColocBoost's sets are not per-block slices of one signal, # so there is no mutually-exclusive sum stage the way coloc has. x <- ColocBoostResult( @@ -329,8 +329,8 @@ test_that("getColocVariants(pooled = TRUE) collapses to one row per variant", { c("xqtl_coloc", "gwas_only"), outcomeInfo = .cbr_info() ) - long <- getColocVariants(x) - pooled <- getColocVariants(x, pooled = TRUE) + long <- colocVariants(x) + pooled <- colocVariants(x, pooled = TRUE) expect_lte(nrow(pooled), nrow(long)) expect_equal( anyDuplicated(pooled[, c("analysis", "variant_id")]), @@ -417,7 +417,7 @@ test_that("the views answer an empty collection with empty tables", { empty <- colocboostResultExample[0] expect_equal(length(empty), 0L) expect_equal(nrow(.cbrLongVariants(empty)), 0L) - expect_equal(nrow(getColocBoostOutcomes(empty)), 0L) + expect_equal(nrow(colocBoostOutcomes(empty)), 0L) }) test_that("outcome info defaults to the empty frame and is not joined", { @@ -425,7 +425,7 @@ test_that("outcome info defaults to the empty frame and is not joined", { # outcomes view returns before attempting a join against it. cb <- ColocBoostResult(list(.cbr_fake()), analysis = "xqtl") expect_equal(nrow(cb@outcomeInfo), 0L) - out <- getColocBoostOutcomes(cb) + out <- colocBoostOutcomes(cb) expect_gt(nrow(out), 0L) expect_false(is_in("outcomeTrait", colnames(out))) }) diff --git a/tests/testthat/test_ColocResult.R b/tests/testthat/test_ColocResult.R index 3ba8fad2..3dda7f11 100644 --- a/tests/testthat/test_ColocResult.R +++ b/tests/testthat/test_ColocResult.R @@ -80,7 +80,7 @@ test_that("ColocResult: an empty result still carries the column schema", { x <- ColocResult(.cr_pairs()[0, , drop = FALSE], list()) expect_equal(nrow(x), 0L) expect_true(is_in("PP.H4.abf", colnames(x))) - expect_equal(nrow(getColocPairs(x)), 0L) + expect_equal(nrow(colocPairs(x)), 0L) }) test_that("ColocResult: variants keep their alleles, so ids round-trip", { @@ -88,7 +88,7 @@ test_that("ColocResult: variants keep their alleles, so ids round-trip", { # the alleles an element cannot render its own variant ids. x <- ColocResult(.cr_pairs(), .cr_variants()) expect_equal( - getColocVariants(x)$variant_id, + colocVariants(x)$variant_id, c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") ) }) @@ -100,14 +100,14 @@ test_that("ColocResult: is reachable by range, not just by identity", { expect_equal(length(IRanges::subsetByOverlaps(x, win)), 1L) }) -test_that("getColocVariants: colocPp is the pair posterior times the variant", { +test_that("colocVariants: colocPp is the pair posterior times the variant", { x <- ColocResult(.cr_pairs(pp4 = 0.5), .cr_variants()) - v <- getColocVariants(x) + v <- colocVariants(x) expect_equal(nrow(v), 3L) expect_equal(v$colocPp, 0.5 * c(0.6, 0.3, 0.1)) }) -test_that("getColocGenes: sums within a QTL CS, noisy-ORs across them", { +test_that("colocGenes: sums within a QTL CS, noisy-ORs across them", { # Two QTL credible sets, each tested against two blocks. Within a CS the # per-block results are mutually exclusive (sum); across CSs they are # independent signals (noisy-OR). @@ -117,95 +117,95 @@ test_that("getColocGenes: sums within a QTL CS, noisy-ORs across them", { pp4 = c(0.1, 0.2, 0.3, 0.4) ) x <- ColocResult(pairs, .cr_variants(4L)) - genes <- getColocGenes(x) + genes <- colocGenes(x) expect_equal(nrow(genes), 1L) expect_equal(genes$PP.H4, 1 - (1 - 0.3) * (1 - 0.7)) expect_equal(genes$nQtlCs, 2L) expect_equal(genes$nPairs, 4L) }) -test_that("getColocGenes: clips a sum above 1 and says so", { +test_that("colocGenes: clips a sum above 1 and says so", { pairs <- .cr_pairs( qtlCs = c(1L, 1L), blockId = c("b1", "b2"), pp4 = c(0.7, 0.6) ) x <- ColocResult(pairs, .cr_variants(2L)) - expect_warning(genes <- getColocGenes(x), "competing") + expect_warning(genes <- colocGenes(x), "competing") expect_equal(genes$PP.H4, 1) }) -test_that("getColocGenes: keeps distinct genes apart", { +test_that("colocGenes: keeps distinct genes apart", { pairs <- .cr_pairs(trait = c("g1", "g2"), pp4 = c(0.5, 0.25)) x <- ColocResult(pairs, .cr_variants(2L)) - genes <- getColocGenes(x) + genes <- colocGenes(x) expect_equal(nrow(genes), 2L) expect_setequal(genes$trait, c("g1", "g2")) }) -test_that("getColocGenes: keeps distinct second-side traits apart", { +test_that("colocGenes: keeps distinct second-side traits apart", { # A QTL-QTL colocalization has a trait axis on BOTH sides. Grouping on the # second side's study alone would pool two molecular phenotypes into one # unit and noisy-OR their posteriors together. pairs <- .cr_pairs(gwasTrait = c("h1", "h2"), pp4 = c(0.5, 0.25)) x <- ColocResult(pairs, .cr_variants(2L)) - genes <- getColocGenes(x) + genes <- colocGenes(x) expect_equal(nrow(genes), 2L) expect_setequal(genes$gwasTrait, c("h1", "h2")) }) -test_that("getColocVariants(pooled): pools by the same rule as genes", { +test_that("colocVariants(pooled): pools by the same rule as genes", { pairs <- .cr_pairs( qtlCs = c(1L, 2L), blockId = c("b1", "b1"), pp4 = c(0.5, 0.25) ) x <- ColocResult(pairs, .cr_variants(2L)) - pooled <- getColocVariants(x, pooled = TRUE) + pooled <- colocVariants(x, pooled = TRUE) expect_equal(nrow(pooled), 3L) lead <- pooled[pooled$variant_id == "chr1:100:A:G", ] expect_equal(lead$colocPp, 1 - (1 - 0.5 * 0.6) * (1 - 0.25 * 0.6)) }) -test_that("getColocCredibleSets: takes the smallest set reaching coverage", { +test_that("colocCredibleSets: takes the smallest set reaching coverage", { x <- ColocResult(.cr_pairs(), .cr_variants()) - expect_equal(getColocCredibleSets(x, coverage = 0.5)$csSize, 1L) - expect_equal(getColocCredibleSets(x, coverage = 0.9)$csSize, 2L) - expect_equal(getColocCredibleSets(x, coverage = 0.95)$csSize, 3L) + expect_equal(colocCredibleSets(x, coverage = 0.5)$csSize, 1L) + expect_equal(colocCredibleSets(x, coverage = 0.9)$csSize, 2L) + expect_equal(colocCredibleSets(x, coverage = 0.95)$csSize, 3L) }) -test_that("getColocCredibleSets: reports the lead variant and coverage", { +test_that("colocCredibleSets: reports the lead variant and coverage", { x <- ColocResult(.cr_pairs(), .cr_variants()) - cs <- getColocCredibleSets(x, coverage = 0.9) + cs <- colocCredibleSets(x, coverage = 0.9) expect_equal(cs$leadVariant, "chr1:100:A:G") expect_equal(cs$leadPp, 0.6) expect_equal(cs$csCoverage, 0.9) }) -test_that("getColocCredibleSets: minPp4 drops pairs before any LD work", { +test_that("colocCredibleSets: minPp4 drops pairs before any LD work", { pairs <- .cr_pairs(qtlCs = c(1L, 2L), pp4 = c(0.8, 0.1)) x <- ColocResult(pairs, .cr_variants(2L)) - expect_equal(nrow(getColocCredibleSets(x)), 2L) - expect_equal(nrow(getColocCredibleSets(x, minPp4 = 0.5)), 1L) - expect_equal(nrow(getColocCredibleSets(x, minPp4 = 0.99)), 0L) + expect_equal(nrow(colocCredibleSets(x)), 2L) + expect_equal(nrow(colocCredibleSets(x, minPp4 = 0.5)), 1L) + expect_equal(nrow(colocCredibleSets(x, minPp4 = 0.99)), 0L) }) -test_that("getColocCredibleSets: requireMaxH4 keeps only H4-dominant pairs", { +test_that("colocCredibleSets: requireMaxH4 keeps only H4-dominant pairs", { pairs <- .cr_pairs(qtlCs = c(1L, 2L), pp4 = c(0.8, 0.1)) x <- ColocResult(pairs, .cr_variants(2L)) - cs <- getColocCredibleSets(x, requireMaxH4 = TRUE) + cs <- colocCredibleSets(x, requireMaxH4 = TRUE) expect_equal(nrow(cs), 1L) expect_equal(cs$qtlCs, 1L) }) -test_that("getColocCredibleSets: purity is NA, not passing, without LD", { +test_that("colocCredibleSets: purity is NA, not passing, without LD", { # No LD reference means no evidence either way; reporting a passing value # would let a filtered view silently depend on whether a sketch happened # to be attached. x <- ColocResult(.cr_pairs(), .cr_variants()) - cs <- getColocCredibleSets(x) + cs <- colocCredibleSets(x) expect_true(is.na(cs$purity)) - expect_equal(nrow(getColocCredibleSets(x, minAbsCorr = 0.99)), 1L) + expect_equal(nrow(colocCredibleSets(x, minAbsCorr = 0.99)), 1L) }) test_that("as.data.frame returns the pair view", { @@ -384,7 +384,7 @@ test_that("the views answer an empty collection with empty tables", { expect_equal(length(empty), 0L) expect_equal(nrow(.crLongVariants(empty)), 0L) expect_equal(.crPairFilter(empty, 0, FALSE), integer(0)) - expect_equal(nrow(getColocGenes(empty)), 0L) + expect_equal(nrow(colocGenes(empty)), 0L) }) test_that("pivoting a per-row column that is absent yields the empty frame", { @@ -409,5 +409,5 @@ test_that("a pair with no variants contributes no credible set", { expect_equal(length(cr[[1L]]), 0L) expect_null(.crCsForPair(1L, cr, coverage = 0.95)) # ...and the accessor over that result is an empty table, not an error. - expect_equal(nrow(getColocCredibleSets(cr)), 0L) + expect_equal(nrow(colocCredibleSets(cr)), 0L) }) diff --git a/tests/testthat/test_CtwasResult.R b/tests/testthat/test_CtwasResult.R index 51ac9fd3..0d71d5ef 100644 --- a/tests/testthat/test_CtwasResult.R +++ b/tests/testthat/test_CtwasResult.R @@ -5,7 +5,7 @@ context("CtwasResult") .cr_entry <- function(ids = c("g1", "g2"), pip = c(0.9, 0.1), prior = NULL) { CtwasResultEntry( - finemap = data.frame( + posteriors = data.frame( id = ids, susie_pip = pip, stringsAsFactors = FALSE @@ -23,22 +23,22 @@ context("CtwasResult") test_that("CtwasResult: constructor keyed by (gwasStudy, study, context, method)", { cr <- CtwasResult( gwasStudy = c("D1", "D1"), - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("brain", "liver"), method = c("susie", "susie"), entry = list(.cr_entry(), .cr_entry(ids = "g3", pip = 0.5)) ) expect_s4_class(cr, "CtwasResult") expect_equal(nrow(cr), 2L) - expect_equal(getMethodNames(cr), "susie") - expect_setequal(getContexts(cr), c("brain", "liver")) - expect_equal(getStudy(cr), "Q1") + expect_equal(methodNames(cr), "susie") + expect_setequal(contexts(cr), c("brain", "liver")) + expect_equal(studyName(cr), "Q1") }) -test_that("CtwasResult: getFinemap aggregates rows tagged with run identity", { +test_that("CtwasResult: ctwasPosteriors aggregates rows tagged with run identity", { cr <- CtwasResult( gwasStudy = c("D1", "D1"), - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("brain", "liver"), method = c("susie", "susie"), entry = list( @@ -46,7 +46,7 @@ test_that("CtwasResult: getFinemap aggregates rows tagged with run identity", { .cr_entry(ids = "g3", pip = 0.5) ) ) - fm <- getFinemap(cr) + fm <- ctwasPosteriors(cr) expect_true(all( c("gwasStudy", "study", "context", "method", "id", "susie_pip") %in% names(fm) @@ -55,10 +55,10 @@ test_that("CtwasResult: getFinemap aggregates rows tagged with run identity", { expect_equal(fm$context, c("brain", "brain", "liver")) }) -test_that("CtwasResult: getSusieAlpha aggregates the per-effect table with identity", { +test_that("CtwasResult: susieAlpha aggregates the per-effect table with identity", { cr <- CtwasResult( gwasStudy = c("D1", "D1"), - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("brain", "liver"), method = c("susie", "susie"), entry = list( @@ -66,7 +66,7 @@ test_that("CtwasResult: getSusieAlpha aggregates the per-effect table with ident .cr_entry(ids = "g3", pip = 0.5) ) ) - sa <- getSusieAlpha(cr) + sa <- susieAlpha(cr) expect_equal(nrow(sa), 3L) expect_true(all( c("gwasStudy", "study", "context", "method", "susie_alpha") %in% @@ -80,7 +80,7 @@ test_that("CtwasResult: uniqueness includes joint columns", { expect_error( CtwasResult( gwasStudy = c("D1", "D1"), - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("brain", "brain"), method = c("susie", "susie"), entry = list(.cr_entry(), .cr_entry()) @@ -91,7 +91,7 @@ test_that("CtwasResult: uniqueness includes joint columns", { # context are distinct once jointContexts joins the key cr <- CtwasResult( gwasStudy = c("D1", "D1"), - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("brain", "brain"), method = c("susie", "susie"), entry = list(.cr_entry(), .cr_entry()), @@ -104,7 +104,7 @@ test_that("CtwasResult: rejects a non-CtwasResultEntry payload", { expect_error( CtwasResult( gwasStudy = "D1", - study = "Q1", + studyName = "Q1", context = "brain", method = "susie", entry = list("not an entry") @@ -117,7 +117,7 @@ test_that("CtwasResult: constructor rejects mismatched core-vector lengths", { expect_error( CtwasResult( gwasStudy = c("D1", "D1"), - study = "Q1", + studyName = "Q1", context = "brain", method = "susie", entry = list(.cr_entry()) @@ -130,7 +130,7 @@ test_that("CtwasResult: a joint column of the wrong length is rejected", { expect_error( CtwasResult( gwasStudy = "D1", - study = "Q1", + studyName = "Q1", context = "brain", method = "susie", entry = list(.cr_entry()), @@ -140,31 +140,31 @@ test_that("CtwasResult: a joint column of the wrong length is rejected", { ) }) -test_that("CtwasResult: getFinemap/getSusieAlpha are NULL when empty or all-NULL", { +test_that("CtwasResult: ctwasPosteriors/susieAlpha are NULL when empty or all-NULL", { empty <- CtwasResult( gwasStudy = character(0), - study = character(0), + studyName = character(0), context = character(0), method = character(0), entry = list() ) - expect_null(getFinemap(empty)) - expect_null(getSusieAlpha(empty)) + expect_null(ctwasPosteriors(empty)) + expect_null(susieAlpha(empty)) nullE <- CtwasResult( gwasStudy = "D1", - study = "Q1", + studyName = "Q1", context = "brain", method = "susie", - entry = list(CtwasResultEntry(finemap = NULL, susieAlpha = NULL)) + entry = list(CtwasResultEntry(posteriors = NULL, susieAlpha = NULL)) ) - expect_null(getFinemap(nullE)) - expect_null(getSusieAlpha(nullE)) + expect_null(ctwasPosteriors(nullE)) + expect_null(susieAlpha(nullE)) }) test_that("CtwasResult: show() prints a one-line-per-run summary", { cr <- CtwasResult( gwasStudy = "D1", - study = "Q1", + studyName = "Q1", context = "brain", method = "susie", entry = list(.cr_entry()) @@ -184,7 +184,7 @@ test_that("CtwasResult: show() prints a one-line-per-run summary", { .ctr_res <- function() { CtwasResult( gwasStudy = "D1", - study = "Q1", + studyName = "Q1", context = "brain", method = "susie", entry = list(.cr_entry()) diff --git a/tests/testthat/test_CtwasResultEntry.R b/tests/testthat/test_CtwasResultEntry.R index 9eb9bd60..8f7dcedc 100644 --- a/tests/testthat/test_CtwasResultEntry.R +++ b/tests/testthat/test_CtwasResultEntry.R @@ -1,12 +1,12 @@ context("CtwasResultEntry") # Migrated from test_CtwasResult.R: the per-run cTWAS payload class (constructor -# + getFinemap / getSusieAlpha / getCtwasGroupPriors accessors). The CtwasResult +# + ctwasPosteriors / susieAlpha / ctwasGroupPriors accessors). The CtwasResult # collection tests live in test_CtwasResult.R. test_that("CtwasResultEntry: constructor + accessors round-trip", { e <- CtwasResultEntry( - finemap = data.frame( + posteriors = data.frame( id = c("g1", "g2"), susie_pip = c(0.9, 0.1), stringsAsFactors = FALSE @@ -20,15 +20,15 @@ test_that("CtwasResultEntry: constructor + accessors round-trip", { 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(getCtwasGroupPriors(e)$group_prior, c(brain = 0.01)) + expect_equal(nrow(ctwasPosteriors(e)), 2L) + expect_equal(nrow(susieAlpha(e)), 2L) + expect_equal(ctwasGroupPriors(e)$group_prior, c(brain = 0.01)) }) test_that("CtwasResultEntry: an empty entry is valid and its accessors return NULL", { e <- CtwasResultEntry() expect_s4_class(e, "CtwasResultEntry") - expect_null(getFinemap(e)) - expect_null(getSusieAlpha(e)) - expect_null(getCtwasGroupPriors(e)) + expect_null(ctwasPosteriors(e)) + expect_null(susieAlpha(e)) + expect_null(ctwasGroupPriors(e)) }) diff --git a/tests/testthat/test_GwasFineMappingResult.R b/tests/testthat/test_GwasFineMappingResult.R index 62a5af72..6da3c2a5 100644 --- a/tests/testthat/test_GwasFineMappingResult.R +++ b/tests/testthat/test_GwasFineMappingResult.R @@ -6,7 +6,7 @@ test_that("GwasFineMappingResult: builds a collection keyed by 2-tuple", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(3) res <- GwasFineMappingResult( - study = c("g1", "g2"), + studyName = c("g1", "g2"), method = c("susie", "susie"), entry = list(e1, e2) ) @@ -15,31 +15,31 @@ test_that("GwasFineMappingResult: builds a collection keyed by 2-tuple", { }) test_that("GwasFineMappingResult: region is derived from the variants", { - # getRegion() reports the element's REALIZED variant span, not a nominal + # genomicRegion() reports the element's REALIZED variant span, not a nominal # window parsed out of blockId. A stored window had no correct update # rule under subsetRegion() and would quietly go stale; the span is in # sync by construction. e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), blockId = c("chr1_1_500", "chr2_600_900"), entry = list(e1, e2) ) - reg <- getRegion(res) + reg <- genomicRegion(res) expect_equal(as.character(GenomicRanges::seqnames(reg)), c("chr1", "chr1")) expect_equal(GenomicRanges::start(reg), c(100L, 100L)) expect_equal(GenomicRanges::end(reg), c(300L, 200L)) # A synthetic blockId no longer produces a chrUn sentinel: with the span # derived from the variants there is nothing to fabricate. res2 <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e1) ) expect_equal( - as.character(GenomicRanges::seqnames(getRegion(res2))), + as.character(GenomicRanges::seqnames(genomicRegion(res2))), "chr1" ) }) @@ -53,7 +53,7 @@ test_that("GwasFineMappingResult: validity does not recurse on key subset (#546) # "missing columns: entry". e <- .sc_makeFineMappingRow(3) res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) @@ -71,7 +71,7 @@ test_that("GwasFineMappingResult: errors on length mismatch", { e <- .sc_makeFineMappingRow(3) expect_error( GwasFineMappingResult( - study = c("g1", "g2"), + studyName = c("g1", "g2"), method = c("susie"), entry = list(e) ), @@ -88,7 +88,7 @@ test_that("GwasFineMappingResult: same (study, method), other ranges", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(3, offset = 10000L) res <- GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), entry = list(e1, e2) ) @@ -109,7 +109,7 @@ test_that("GwasFineMappingResult: rejects two rows covering the same range", { e2 <- .sc_makeFineMappingRow(3) expect_error( GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), blockId = c("chr22_1_100", "chr22_200_300"), entry = list(e1, e2) @@ -124,7 +124,7 @@ test_that("GwasFineMappingResult: errors when blockId length mismatches", { e2 <- .sc_makeFineMappingRow(3) expect_error( GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), blockId = "only_one", entry = list(e1, e2) @@ -137,7 +137,7 @@ test_that("GwasFineMappingResult: errors when blockId length mismatches", { test_that("GwasFineMappingResult: show prints summary", { e <- .sc_makeFineMappingRow(3) res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) @@ -152,7 +152,7 @@ test_that("GwasFineMappingResult: show prints summary", { test_that("show.GwasFineMappingResult prints (study, method) summary", { res <- GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susieRss"), entry = list(.sh_makeFmEntry(), .sh_makeFmEntry()) ) @@ -165,7 +165,7 @@ test_that("show.GwasFineMappingResult prints (study, method) summary", { test_that("show.GwasFineMappingResult reports the ldSketch source when present", { res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(.sh_makeFmEntry()), ldSketch = .sh_makeGenotypeHandle() @@ -177,63 +177,63 @@ test_that("show.GwasFineMappingResult reports the ldSketch source when present", # === Tests migrated from test_collectionAccessors.R (GwasFineMappingResult) === -test_that("GwasFineMappingResult: getPip with study/method selectors", { +test_that("GwasFineMappingResult: pip with study/method selectors", { e1 <- .ca_makeFmEntry(3) e2 <- .ca_makeFmEntry(4) res <- GwasFineMappingResult( - study = c("g1", "g2"), + studyName = c("g1", "g2"), method = c("susie", "susie"), entry = list(e1, e2) ) - pip <- getPip(res, study = "g2", method = "susie") + pip <- pip(res, studyName = "g2", method = "susie") expect_equal(length(pip), 4L) }) -test_that("GwasFineMappingResult: getContexts/getTraits return NULL", { +test_that("GwasFineMappingResult: contexts/traitNames return NULL", { e <- .ca_makeFmEntry(3) res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) - expect_null(getContexts(res)) - expect_null(getTraits(res)) + expect_null(contexts(res)) + expect_null(traitNames(res)) }) -test_that("GwasFineMappingResult: getCs/getTopLoci/getSusieFit/getVariantIds dispatch", { +test_that("GwasFineMappingResult: credibleSets/topLoci/susieFit/variantIds dispatch", { e <- .ca_makeFmEntry(3) res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) - expect_equal(nrow(getCs(res)), 2L) - # getTopLoci returns the projected posterior view (filtered by default + expect_equal(nrow(credibleSets(res)), 2L) + # topLoci returns the projected posterior view (filtered by default # signalCutoff = 0.025; .ca_makeTopLoci sets all pip > 0.025 so all rows # survive). Compare on the projected shape, not the slot's raw shape. - tl <- getTopLoci(res, signalCutoff = 0) - expect_equal(nrow(tl), 3L) + tl <- topLoci(res, signalCutoff = 0) + expect_equal(length(tl), 3L) expect_equal(tl$variant_id, .ca_makeTopLoci(3)$variant_id) - expect_equal(getSusieFit(res), list(payload = "fit_n=3")) - expect_equal(length(getVariantIds(res)), 3L) + expect_equal(susieFit(res), list(payload = "fit_n=3")) + expect_equal(length(variantIds(res)), 3L) }) -test_that("GwasFineMappingResult: getTopLoci aggregates per-block rows genome-wide", { +test_that("GwasFineMappingResult: topLoci aggregates per-block rows genome-wide", { # A genome-wide collection: same (study, method) across two region blocks. - # With no selectors getTopLoci now stacks both blocks, tagging each variant + # With no selectors topLoci now stacks both blocks, tagging each variant # with its blockId; context/trait are NA-filled (GWAS keys on region). e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), blockId = c("chr1:1-100", "chr1:200-300"), entry = list(e1, e2) ) - agg <- getTopLoci(res, signalCutoff = 0) - expect_equal(nrow(agg), 5L) + agg <- topLoci(res, signalCutoff = 0) + expect_equal(length(agg), 5L) expect_equal( agg$blockId, c( @@ -246,40 +246,40 @@ test_that("GwasFineMappingResult: getTopLoci aggregates per-block rows genome-wi ) expect_true(all(is.na(agg$context))) expect_true(all(is.na(agg$trait))) - expect_true("variant_id" %in% names(agg)) + expect_true("variant_id" %in% names(S4Vectors::mcols(agg))) }) -test_that("GwasFineMappingResult: getTopLoci region= selects a single block", { +test_that("GwasFineMappingResult: topLoci region= selects a single block", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), blockId = c("chr1:1-100", "chr1:200-300"), entry = list(e1, e2) ) # region= pins one row, so this hits the single-entry fast path (bare table). - tl <- getTopLoci( + tl <- topLoci( res, - study = "g1", + studyName = "g1", method = "susie", region = "chr1:200-300", signalCutoff = 0 ) - expect_equal(nrow(tl), 2L) - expect_false("blockId" %in% names(tl)) + expect_equal(length(tl), 2L) + expect_false("blockId" %in% names(S4Vectors::mcols(tl))) }) -test_that("GwasFineMappingResult: getCs aggregates CS across blocks", { +test_that("GwasFineMappingResult: credibleSets aggregates CS across blocks", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), blockId = c("chr1:1-100", "chr1:200-300"), entry = list(e1, e2) ) - cs <- getCs(res) + cs <- credibleSets(res) expect_equal(nrow(cs), 4L) # 2 CS members per block expect_equal( cs$blockId, @@ -287,7 +287,7 @@ test_that("GwasFineMappingResult: getCs aggregates CS across blocks", { ) expect_true(all(is.na(cs$context))) # region= pins one block -> bare table - bare <- getCs(res, study = "g1", method = "susie", region = "chr1:1-100") + bare <- credibleSets(res, studyName = "g1", method = "susie", region = "chr1:1-100") expect_false("blockId" %in% names(bare)) }) @@ -295,42 +295,42 @@ test_that("GwasFineMappingResult: getCs aggregates CS across blocks", { test_that("GwasFineMappingResult: .tupleSelectRowGwasFmr requires both selectors for multi-row", { e <- .ca_makeFmEntry(3) res <- GwasFineMappingResult( - study = c("g1", "g2"), + studyName = c("g1", "g2"), method = c("susie", "susie"), entry = list(e, e) ) - expect_error(getPip(res), "Pass `study` and `method`") + expect_error(pip(res), "Pass `study` and `method`") expect_error( - getPip(res, study = c("g1", "g2"), method = "susie"), + pip(res, studyName = c("g1", "g2"), method = "susie"), "Must have length 1" ) - expect_error(getPip(res, study = "ghost", method = "susie"), "No entry for") + expect_error(pip(res, studyName = "ghost", method = "susie"), "No entry for") }) -test_that("GwasFineMappingResult: getStudy/getMethodNames inherit from base", { +test_that("GwasFineMappingResult: studyName/methodNames inherit from base", { e <- .ca_makeFmEntry(3) res <- GwasFineMappingResult( - study = c("g1", "g2"), + studyName = c("g1", "g2"), method = c("susie", "susieRss"), entry = list(e, e) ) - expect_setequal(getStudy(res), c("g1", "g2")) - expect_setequal(getMethodNames(res), c("susie", "susieRss")) + expect_setequal(studyName(res), c("g1", "g2")) + expect_setequal(methodNames(res), c("susie", "susieRss")) }) -test_that("GwasFineMappingResult: getMarginalEffects with study/method selectors", { +test_that("GwasFineMappingResult: marginalEffects with study/method selectors", { e1 <- .ca_makeFmEntry(3) e2 <- .ca_makeFmEntry(4) res <- GwasFineMappingResult( - study = c("g1", "g2"), + studyName = c("g1", "g2"), method = c("susie", "susie"), entry = list(e1, e2) ) # Collection-level selection picks the g2 entry, then delegates to the # entry-level getMarginalEffects. - me <- getMarginalEffects(res, study = "g2", method = "susie") + me <- marginalEffects(res, studyName = "g2", method = "susie") expect_s3_class(me, "data.frame") expect_equal(nrow(me), 4L) expect_true(all(c("variant_id", "beta", "se", "z", "p") %in% names(me))) @@ -346,7 +346,7 @@ test_that("GwasFineMappingResult: getMarginalEffects with study/method selectors test_that("validity names a missing identity column", { res <- GwasFineMappingResult( - study = c("g1", "g2"), + studyName = c("g1", "g2"), method = c("susie", "susie"), entry = list(.sc_makeFineMappingRow(3), .sc_makeFineMappingRow(3)) ) @@ -360,7 +360,7 @@ test_that("validity names a missing identity column", { test_that("validity names a missing entry payload column", { res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(.sc_makeFineMappingRow(3)) ) @@ -372,21 +372,21 @@ test_that("validity names a missing entry payload column", { ) }) -test_that("GwasFineMappingResult: getPip(returnList) keys by study|method", { +test_that("GwasFineMappingResult: pip(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"), + studyName = c("g1", "g2"), method = c("susie", "susie"), entry = list(.ca_makeFmEntry(3), .ca_makeFmEntry(4)) ) - got <- getPip(res, study = "g2", method = "susie", returnList = TRUE) + got <- pip(res, studyName = "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"))) + expect_false(is.list(pip(res, studyName = "g2", method = "susie"))) }) test_that("GwasFineMappingResult: context / trait selectors are refused", { @@ -394,27 +394,27 @@ test_that("GwasFineMappingResult: context / trait selectors are refused", { # but a GWAS collection has no such axis, so asking is a mistake rather # than a silent no-op. res <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(.ca_makeFmEntry(3)) ) expect_error( - getPip(res, study = "g1", method = "susie", context = "brain"), + pip(res, studyName = "g1", method = "susie", context = "brain"), "has no context or trait axis" ) expect_error( - getPip(res, study = "g1", method = "susie", context = "brain"), + pip(res, studyName = "g1", method = "susie", context = "brain"), "`context` does not select anything" ) expect_error( - getPip(res, study = "g1", method = "susie", trait = "ENSG_A"), + pip(res, studyName = "g1", method = "susie", trait = "ENSG_A"), "`trait` does not select anything" ) # Both at once: the message pluralises rather than naming one. expect_error( - getPip( + pip( res, - study = "g1", + studyName = "g1", method = "susie", context = "brain", trait = "ENSG_A" @@ -424,9 +424,9 @@ test_that("GwasFineMappingResult: context / trait selectors are refused", { # 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( + length(pip( res, - study = "g1", + studyName = "g1", method = "susie", context = NA, trait = NA diff --git a/tests/testthat/test_GwasSumStats.R b/tests/testthat/test_GwasSumStats.R index 58678ddd..5b84026e 100644 --- a/tests/testthat/test_GwasSumStats.R +++ b/tests/testthat/test_GwasSumStats.R @@ -40,8 +40,8 @@ test_that("makeGwasSumStatsFromDf() constructor creates object from data.frame", expect_s4_class(obj, "GwasSumStats") expect_equal(as.character(obj$study)[[1L]], "height") - expect_equal(getGenome(obj), "hg38") - expect_equal(length(getSumStats(obj)), 20) + expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") + expect_equal(length(sumStats(obj)), 20) }) @@ -49,14 +49,14 @@ test_that("makeGwasSumStatsFromDf() normalizes chr prefix", { df <- makeTestSumstatsDf(5) # Input has CHR = "1" (no prefix) obj <- makeGwasSumStatsFromDf(df) - chrs <- as.character(GenomicRanges::seqnames(getSumStats(obj))) + chrs <- as.character(GenomicRanges::seqnames(sumStats(obj))) expect_true(all(startsWith(chrs, "chr"))) # Input already has "chr" prefix df2 <- df df2$CHR <- "chr1" obj2 <- makeGwasSumStatsFromDf(df2) - chrs2 <- as.character(GenomicRanges::seqnames(getSumStats(obj2))) + chrs2 <- as.character(GenomicRanges::seqnames(sumStats(obj2))) # Should not double-prefix expect_true(all(chrs2 == "chr1")) expect_false(any(grepl("^chrchr", chrs2))) @@ -77,7 +77,7 @@ test_that("makeGwasSumStatsFromDf() removes rows with NA in required columns", { obj <- makeGwasSumStatsFromDf(df), "Removed.*SNPs with missing" ) - expect_equal(length(getSumStats(obj)), 8) + expect_equal(length(sumStats(obj)), 8) }) @@ -85,7 +85,7 @@ test_that("getz() returns correct Z vector", { set.seed(99) df <- makeTestSumstatsDf(5) obj <- makeGwasSumStatsFromDf(df) - z <- getZ(obj) + z <- z(obj) expect_type(z, "double") expect_equal(length(z), 5) }) @@ -94,7 +94,7 @@ test_that("getz() returns correct Z vector", { test_that("getn() returns correct N vector", { df <- makeTestSumstatsDf(5) obj <- makeGwasSumStatsFromDf(df) - n <- getN(obj) + n <- nSamples(obj) expect_equal(length(n), 5) expect_true(all(n == 10000)) }) @@ -103,11 +103,11 @@ test_that("getn() returns correct N vector", { test_that("getmaf() returns MAF when present, NULL when absent", { df <- makeTestSumstatsDf(5) obj_no_maf <- makeGwasSumStatsFromDf(df) - expect_null(getMaf(obj_no_maf)) + expect_null(maf(obj_no_maf)) df$MAF <- runif(5, 0.01, 0.5) obj_with_maf <- makeGwasSumStatsFromDf(df) - maf <- getMaf(obj_with_maf) + maf <- maf(obj_with_maf) expect_type(maf, "double") expect_equal(length(maf), 5) }) @@ -149,7 +149,7 @@ test_that("subsetChr() preserves study-level nCase/nControl/nSample scalars", { N = rep(100L, 3) ) obj <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .sh_makeGenotypeHandle(), @@ -170,27 +170,31 @@ test_that("getvary() returns var_y and NULL cases", { df <- makeTestSumstatsDf(5) obj_null <- makeGwasSumStatsFromDf(df, varY = NULL) - expect_null(getVarY(obj_null)) + expect_null(varY(obj_null)) obj_vy <- makeGwasSumStatsFromDf(df, varY = 4.5) - expect_equal(getVarY(obj_vy), 4.5) + expect_equal(varY(obj_vy), 4.5) }) -test_that("as.data.frame.makeGwasSumStatsFromDf() round-trips", { +test_that("as.data.frame() round-trips in the standardized layout", { df_in <- makeTestSumstatsDf(15) obj <- makeGwasSumStatsFromDf(df_in) df_out <- as.data.frame(obj) + # One coercion per class: as.data.frame() is the table view of + # sumStats(), so it yields the standardized layout rather than the raw + # mcols names. The raw form is still reachable through + # as.data.frame(mcols(sumStats(obj))). expect_true(is.data.frame(df_out)) expect_true(all( - c("SNP", "CHR", "BP", "A1", "A2", "Z", "N") %in% + c("variant_id", "chrom", "pos", "A1", "A2", "z", "N") %in% names(df_out) )) expect_equal(nrow(df_out), 15) - expect_equal(df_out$SNP, df_in$SNP) - # BP should round-trip - expect_equal(df_out$BP, as.integer(df_in$BP)) + expect_equal(df_out$variant_id, df_in$SNP) + # position should round-trip + expect_equal(df_out$pos, as.integer(df_in$BP)) }) @@ -202,7 +206,7 @@ test_that("as.data.frame.makeGwasSumStatsFromDf() round-trips", { test_that("show.GwasSumStats prints nrow and genome build", { ss <- GwasSumStats( - study = c("g1", "g2"), + studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", ldSketch = .sh_makeGenotypeHandle() @@ -221,13 +225,13 @@ test_that("show.GwasSumStats prints nrow and genome build", { # ============================================================================= test_that("GwasSumStats() errors when required args are missing", { - expect_error(GwasSumStats(study = "g1"), "are all required") + expect_error(GwasSumStats(studyName = "g1"), "are all required") }) test_that("GwasSumStats() errors when genome is not a single string", { expect_error( GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.sh_makeQtlSumstatsGr()), genome = c("hg19", "hg38"), ldSketch = .sh_makeGenotypeHandle() @@ -239,7 +243,7 @@ test_that("GwasSumStats() errors when genome is not a single string", { test_that("GwasSumStats() errors when entry is not a list", { expect_error( GwasSumStats( - study = "g1", + studyName = "g1", entry = "not_a_list", genome = "hg19", ldSketch = .sh_makeGenotypeHandle() @@ -251,7 +255,7 @@ test_that("GwasSumStats() errors when entry is not a list", { test_that("GwasSumStats() errors when length(entry) != length(study)", { expect_error( GwasSumStats( - study = c("g1", "g2"), + studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19", ldSketch = .sh_makeGenotypeHandle() @@ -263,7 +267,7 @@ test_that("GwasSumStats() errors when length(entry) != length(study)", { test_that("GwasSumStats() errors when a per-study column has a bad length", { expect_error( GwasSumStats( - study = c("g1", "g2"), + studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", ldSketch = .sh_makeGenotypeHandle(), @@ -275,7 +279,7 @@ test_that("GwasSumStats() errors when a per-study column has a bad length", { test_that("GwasSumStats() attaches extra per-study columns via ...", { obj <- GwasSumStats( - study = c("g1", "g2"), + studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", ldSketch = .sh_makeGenotypeHandle(), @@ -286,7 +290,7 @@ test_that("GwasSumStats() attaches extra per-study columns via ...", { # so a bare `cohort =` here would read as adding an entry. expect_error( GwasSumStats( - study = "g1", + studyName = "g1", entry = list(), genome = "hg19", cohort = "UKB" @@ -295,43 +299,43 @@ test_that("GwasSumStats() attaches extra per-study columns via ...", { ) }) -test_that("getSumStats() errors on an empty GwasSumStats", { +test_that("sumStats() errors on an empty GwasSumStats", { empty <- GwasSumStats( - study = character(0), + studyName = character(0), entry = list(), genome = "hg19", ldSketch = .sh_makeGenotypeHandle(), varY = numeric(0) ) expect_equal(nrow(empty), 0L) - expect_error(getSumStats(empty), "has no rows") + expect_error(sumStats(empty), "has no rows") }) -test_that("getSumStats() on a multi-study GwasSumStats needs a study selector", { +test_that("sumStats() on a multi-study GwasSumStats needs a study selector", { two <- GwasSumStats( - study = c("g1", "g2"), + studyName = c("g1", "g2"), entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), genome = "hg19", ldSketch = .sh_makeGenotypeHandle() ) - expect_error(getSumStats(two), "studies. Pass") - expect_error(getSumStats(two, study = "ghost"), "Unknown study") + expect_error(sumStats(two), "studies. Pass") + expect_error(sumStats(two, studyName = "ghost"), "Unknown study") }) test_that("GwasSumStats: ldSketch is optional (NULL for LD-free workflows)", { ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19" ) # ldSketch omitted -> NULL - expect_null(getLdSketch(ss)) + expect_null(ldSketch(ss)) expect_output(show(ss), "none \\(LD-free\\)") }) test_that("GwasSumStats: a non-GenotypeHandle ldSketch is rejected", { expect_error( GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19", ldSketch = "not_a_handle" @@ -378,7 +382,7 @@ test_that("show(GwasSumStats) does not error", { test_that("GwasSumStats records blockId as the seqname without a manifest", { g <- .gss_variants(c("chr1", "chr1", "chr2"), c(100L, 900L, 300L)) - x <- GwasSumStats(study = "t1", entry = list(g), genome = "hg38") + x <- GwasSumStats(studyName = "t1", entry = list(g), genome = "hg38") expect_equal(length(x), 2L) expect_equal(x$blockId, c("chr1", "chr2")) expect_true(is_in("blockId", colnames(x))) @@ -387,7 +391,7 @@ test_that("GwasSumStats records blockId as the seqname without a manifest", { test_that("GwasSumStats splits by LD block when a manifest is supplied", { g <- .gss_variants("chr1", c(100L, 250L, 900L)) x <- GwasSumStats( - study = "t1", + studyName = "t1", entry = list(g), genome = "hg38", ldBlocks = .gss_ldBlocks() @@ -403,7 +407,7 @@ test_that("GwasSumStats splits by LD block when a manifest is supplied", { test_that("GwasSumStats replicates the study row against each block", { g <- .gss_variants("chr1", c(100L, 900L)) x <- GwasSumStats( - study = "t1", + studyName = "t1", entry = list(g), genome = "hg38", varY = 2, @@ -417,7 +421,7 @@ test_that("GwasSumStats warns about variants outside every LD block", { g <- .gss_variants("chr1", c(100L, 5000L)) expect_warning( x <- GwasSumStats( - study = "t1", + studyName = "t1", entry = list(g), genome = "hg38", ldBlocks = .gss_ldBlocks() @@ -429,7 +433,7 @@ test_that("GwasSumStats warns about variants outside every LD block", { test_that("GwasSumStats keeps blockId aligned across two studies", { x <- GwasSumStats( - study = c("t1", "t2"), + studyName = c("t1", "t2"), entry = list( .gss_variants("chr1", c(100L, 900L)), .gss_variants("chr1", 900L) @@ -443,7 +447,7 @@ test_that("GwasSumStats keeps blockId aligned across two studies", { test_that("GwasSumStats blockId survives subsetting", { x <- GwasSumStats( - study = "t1", + studyName = "t1", entry = list(.gss_variants("chr1", c(100L, 900L))), genome = "hg38", ldBlocks = .gss_ldBlocks() @@ -484,7 +488,7 @@ test_that("GwasSumStats blockId survives subsetting", { test_that("supplying both ldBlocks and blockId is refused", { expect_error( GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.gss_entry()), genome = "hg19", ldBlocks = GenomicRanges::GRanges( @@ -500,7 +504,7 @@ test_that("supplying both ldBlocks and blockId is refused", { test_that("blockId must carry one value per entry", { expect_error( GwasSumStats( - study = c("g1", "g2"), + studyName = c("g1", "g2"), entry = list(.gss_entry(), .gss_entry()), genome = "hg19", blockId = "only-one" @@ -511,7 +515,7 @@ test_that("blockId must carry one value per entry", { test_that("a supplied blockId survives onto the elements", { obj <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.gss_entry()), genome = "hg19", blockId = "chr1:1-10000" @@ -531,7 +535,7 @@ test_that("combineGwasSumStats() row-binds per-block pieces in order", { expect_equal(nrow(out), nrow(a) + nrow(b)) expect_equal(as.character(out$blockId), c("chr1_1_1000", "chr1_1001_2000")) expect_identical(as.list(out), c(as.list(a), as.list(b))) - expect_equal(getGenome(out), "hg19") + expect_equal(unname(GenomeInfoDb::genome(out)), "hg19") }) @@ -551,12 +555,12 @@ test_that("combineGwasSumStats() concatenates the per-element QC audit", { b <- makeGwasBlock("chr1_1001_2000", 1100L, n = 3L) out <- combineGwasSumStats(a, b) - audit <- getQcInfo(out)$entryAudit + audit <- qcInfo(out)$entryAudit expect_length(audit, nrow(out)) # element i's audit still describes element i expect_equal(audit[[1L]]$block, "chr1_1_1000") expect_equal(audit[[2L]]$block, "chr1_1001_2000") - expect_equal(getQcInfo(out)$options, getQcInfo(a)$options) + expect_equal(qcInfo(out)$options, qcInfo(a)$options) }) @@ -567,10 +571,10 @@ test_that("combineGwasSumStats() unions the per-block LD panels", { # Keeping only the first block's panel would leave a two-block collection # whose LD reference covers one block. - expect_equal(nrow(getLdSketch(out)), 8L) + expect_equal(nrow(ldSketch(out)), 8L) expect_equal( - rownames(getLdSketch(out)), - c(rownames(getLdSketch(a)), rownames(getLdSketch(b))) + rownames(ldSketch(out)), + c(rownames(ldSketch(a)), rownames(ldSketch(b))) ) }) @@ -578,8 +582,8 @@ test_that("combineGwasSumStats() unions the per-block LD panels", { test_that("combineGwasSumStats() honours an explicit ldSketch", { a <- makeGwasBlock("chr1_1_1000", 100L) b <- makeGwasBlock("chr1_1001_2000", 1100L) - out <- combineGwasSumStats(a, b, ldSketch = getLdSketch(a)) - expect_identical(getLdSketch(out), getLdSketch(a)) + out <- combineGwasSumStats(a, b, ldSketch = ldSketch(a)) + expect_identical(ldSketch(out), ldSketch(a)) }) @@ -634,24 +638,24 @@ test_that("combineGwasSumStats() validates its inputs", { ) }) -test_that("getSumStats(GwasSumStats) refuses the QtlSumStats selectors", { +test_that("sumStats(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", + studyName = "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(sumStats(gss, context = "brain"), "QtlSumStats selector") + expect_error(sumStats(gss, trait = "G1"), "QtlSumStats selector") expect_error( - getSumStats(gss, annotateSignificance = "qvalue"), + sumStats(gss, annotateSignificance = "qvalue"), "QtlSumStats selector" ) # and the same through an accessor that forwards them - expect_error(getZ(gss, context = "brain"), "QtlSumStats selector") + expect_error(z(gss, context = "brain"), "QtlSumStats selector") # the supported selectors still work - expect_s4_class(getSumStats(gss), "GRanges") - expect_type(getZ(gss), "double") + expect_s4_class(sumStats(gss), "GRanges") + expect_type(z(gss), "double") }) diff --git a/tests/testthat/test_H2Estimate.R b/tests/testthat/test_H2Estimate.R index be452809..ea89e721 100644 --- a/tests/testthat/test_H2Estimate.R +++ b/tests/testthat/test_H2Estimate.R @@ -5,21 +5,21 @@ test_that("H2Estimate constructs with all slots", { obj <- new( "H2Estimate", - h2 = 0.3, - h2Se = 0.05, + estimate = 0.3, + estimateSe = 0.05, intercept = 1.01, interceptSe = 0.02, - local = NULL, + localBlocks = NULL, enrichment = NULL, - tauBlocks = NULL, + annotationJackknifeCoefs = NULL, scoreStats = NULL, method = "lder", nSnps = 10000L, traitName = "height" ) expect_s4_class(obj, "H2Estimate") - expect_equal(getH2(obj), 0.3) - expect_equal(getMethodNames(obj), "lder") + expect_equal(heritabilityEstimate(obj), 0.3) + expect_equal(methodNames(obj), "lder") }) # show() smoke test, moved here from test_showMethods.R so the test @@ -27,13 +27,13 @@ test_that("H2Estimate constructs with all slots", { test_that("show(H2Estimate) does not error", { h2 <- new( "H2Estimate", - h2 = 0.3, - h2Se = 0.05, + estimate = 0.3, + estimateSe = 0.05, intercept = 1.0, interceptSe = 0.01, - local = NULL, + localBlocks = NULL, enrichment = NULL, - tauBlocks = NULL, + annotationJackknifeCoefs = NULL, scoreStats = NULL, method = "lder", nSnps = 1000L, diff --git a/tests/testthat/test_JointGroup.R b/tests/testthat/test_JointGroup.R index 2f1eb8b6..3b3d3f3b 100644 --- a/tests/testthat/test_JointGroup.R +++ b/tests/testthat/test_JointGroup.R @@ -3,9 +3,9 @@ # JointDispatchCell wiring row, and the pipeline marker classes. Construction is # validated, so a malformed group / mistyped cell fails loudly at the source. -.jg_cond <- function(study = "S", context = c("c1", "c2"), trait = "G") { +.jg_cond <- function(studyName = "S", context = c("c1", "c2"), trait = "G") { data.frame( - study = study, + study = studyName, context = context, trait = trait, stringsAsFactors = FALSE diff --git a/tests/testthat/test_LdEigen.R b/tests/testthat/test_LdEigen.R index 672d76d6..4f64c4b6 100644 --- a/tests/testthat/test_LdEigen.R +++ b/tests/testthat/test_LdEigen.R @@ -17,7 +17,7 @@ test_that("LdEigen constructs and validates correctly", { obj <- LdEigen( ldBlocks = ldblocks, snpInfo = snp_info, - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", eigenList = eigen_list, @@ -36,7 +36,7 @@ test_that("LdEigen rejects eigen_list length mismatch", { LdEigen( ldBlocks = ldblocks, snpInfo = makeTestSnpInfo(), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", eigenList = list(list(values = 1)), @@ -55,7 +55,7 @@ test_that("LdEigen rejects invalid eigenvalue_truncation", { LdEigen( ldBlocks = ldblocks, snpInfo = makeTestSnpInfo(), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", eigenList = list(list(), list()), @@ -72,7 +72,7 @@ test_that("show(LdEigen) does not error", { eig <- LdEigen( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", eigenList = list(list(), list()), @@ -88,7 +88,7 @@ test_that("subsetting an LdEigen is refused, not silently allowed", { obj <- LdEigen( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", eigenList = list( @@ -120,30 +120,30 @@ test_that("buildLdEigen decomposes a single-block LdData", { expect_s4_class(ref, "LdEigen") expect_equal(length(ref), 6L) - expect_equal(length(getEigenList(ref)), 1L) - expect_equal(length(getLdBlocks(ref)), 1L) - expect_equal(getNRef(ref), 500L) - expect_false(getInSample(ref)) - expect_equal(getEigenList(ref)[[1]]$snpIdx, 1:6) + expect_equal(length(eigenList(ref)), 1L) + expect_equal(length(ldBlocks(ref)), 1L) + expect_equal(ldPanelNSamples(ref), 500L) + expect_false(inSample(ref)) + expect_equal(eigenList(ref)[[1]]$snpIdx, 1:6) }) test_that("buildLdEigen gives one block per matrix of a multi-block LdData", { ref <- buildLdEigen(makeTestLdDataMultiBlock(sizes = c(4L, 3L))) expect_equal(length(ref), 7L) - blocks <- getEigenList(ref) + blocks <- eigenList(ref) expect_equal(length(blocks), 2L) # snpIdx must index the concatenated variant order, not each block's own. expect_equal(blocks[[1]]$snpIdx, 1:4) expect_equal(blocks[[2]]$snpIdx, 5:7) - expect_equal(length(getLdBlocks(ref)), 2L) + expect_equal(length(ldBlocks(ref)), 2L) }) test_that("buildLdEigen reconstructs the correlation it was given", { ld <- makeTestLdData(n = 6L) - block <- getEigenList(buildLdEigen(ld))[[1]] + block <- eigenList(buildLdEigen(ld))[[1]] rebuilt <- block$vectors %*% diag(block$values) %*% t(block$vectors) - expect_equal(rebuilt, unname(getCorrelation(ld)), tolerance = 1e-10) + expect_equal(rebuilt, unname(ldMatrix(ld)), tolerance = 1e-10) }) test_that("buildLdEigen carries variant identity across from the LdData", { @@ -163,8 +163,8 @@ test_that("buildLdEigen carries variant identity across from the LdData", { test_that("buildLdEigen truncates to the requested eigenvalue mass", { ld <- makeTestLdData(n = 6L) - full <- getEigenList(buildLdEigen(ld))[[1]] - cut <- getEigenList(buildLdEigen(ld, eigenvalueTruncation = 0.9))[[1]] + full <- eigenList(buildLdEigen(ld))[[1]] + cut <- eigenList(buildLdEigen(ld, eigenvalueTruncation = 0.9))[[1]] expect_equal(length(full$values), 6L) expect_lt(length(cut$values), 6L) @@ -176,13 +176,13 @@ test_that("buildLdEigen truncates to the requested eigenvalue mass", { test_that("buildLdEigen prefers an explicit nRef, inSample and genome", { ref <- buildLdEigen( makeTestLdData(), - nRef = 12345L, + nSamples = 12345L, inSample = TRUE, genome = "hg38" ) - expect_equal(getNRef(ref), 12345L) - expect_true(getInSample(ref)) - expect_equal(getGenome(ref), "hg38") + expect_equal(ldPanelNSamples(ref), 12345L) + expect_true(inSample(ref)) + expect_equal(unname(GenomeInfoDb::genome(ref)), "hg38") }) @@ -204,7 +204,7 @@ test_that("LdEigen: argument guards fire", { ok <- list( ldBlocks = ldblocks, snpInfo = snp_info, - nRef = 500L, + nSamples = 500L, eigenList = eigen_list ) expect_error( @@ -216,12 +216,12 @@ test_that("LdEigen: argument guards fire", { "eigenList.*Must be of type 'list'" ) expect_error( - exec(LdEigen, !!!list_modify(ok, !!!list(nRef = 0L))), - "nRef.*Must be >= 1" + exec(LdEigen, !!!list_modify(ok, !!!list(nSamples = 0L))), + "nSamples.*Must be >= 1" ) expect_error( - exec(LdEigen, !!!list_modify(ok, !!!list(nRef = "500"))), - "nRef.*Must be of type 'count'" + exec(LdEigen, !!!list_modify(ok, !!!list(nSamples = "500"))), + "nSamples.*Must be of type 'count'" ) }) @@ -233,7 +233,7 @@ test_that("buildLdEigen: argument guards fire", { package = "pecotmr" ) ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") - expect_error(buildLdEigen(ld, nRef = 0L), "nRef.*Must be >= 1") + expect_error(buildLdEigen(ld, nSamples = 0L), "nSamples.*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 394ee37e..84ac1714 100644 --- a/tests/testthat/test_LdScore.R +++ b/tests/testthat/test_LdScore.R @@ -10,7 +10,7 @@ test_that("LdScore constructs and validates correctly", { obj <- LdScore( ldBlocks = ldblocks, snpInfo = snp_info, - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(runif(n), nrow = n, ncol = 1), @@ -31,7 +31,7 @@ test_that("LdScore rejects ld_scores row mismatch with snp_info", { LdScore( ldBlocks = ldblocks, snpInfo = snp_info, - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(0, nrow = 5, ncol = 1), # wrong rows @@ -50,7 +50,7 @@ test_that("show(LdScore) does not error", { lsr <- LdScore( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(n), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(1, nrow = n, ncol = 1), @@ -66,7 +66,7 @@ test_that("LdScore rejects weights that are not parallel to the variants", { LdScore( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(n), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(runif(n), nrow = n, ncol = 1), @@ -77,20 +77,20 @@ test_that("LdScore rejects weights that are not parallel to the variants", { ) }) -test_that("getLdScoreWeights returns the per-variant weights", { +test_that("mcols exposes the per-variant LD-score weights", { n <- 10 w <- runif(n) obj <- LdScore( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(n), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(runif(n), nrow = n, ncol = 1), ldScoreWeights = w, ldMatrixList = list() ) - expect_equal(getLdScoreWeights(obj), w) + expect_equal(mcols(obj)$ldScoreWeights, w) }) test_that("validity requires the score columns to be present in mcols", { @@ -100,7 +100,7 @@ test_that("validity requires the score columns to be present in mcols", { obj <- LdScore( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(n), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(runif(n), nrow = n, ncol = 1), @@ -123,17 +123,17 @@ test_that("buildLdScore computes per-block sums of r^2", { expect_s4_class(ref, "LdScore") expect_equal(length(ref), 6L) - expect_equal(colnames(getLdScores(ref)), "base_l2") + expect_equal(colnames(mcols(ref)$ldScores), "base_l2") expect_equal( - as.vector(getLdScores(ref)[, 1]), - rowSums(unname(getCorrelation(ld))^2) + as.vector(mcols(ref)$ldScores[, 1]), + rowSums(unname(ldMatrix(ld))^2) ) }) test_that("buildLdScore scores each block against only its own variants", { ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) - scores <- as.vector(getLdScores(buildLdScore(ld))[, 1]) - perBlock <- unlist(map(getCorrelation(ld), function(R) rowSums(R^2))) + scores <- as.vector(mcols(buildLdScore(ld))$ldScores[, 1]) + perBlock <- unlist(map(ldMatrix(ld), function(R) rowSums(R^2))) expect_equal(length(scores), 7L) expect_equal(scores, perBlock) @@ -145,7 +145,7 @@ test_that("buildLdScore scores each block against only its own variants", { test_that("buildLdScore agrees with computeLdScores on the same reference", { for (ld in list(makeTestLdData(n = 6L), makeTestLdDataMultiBlock())) { expect_equal( - as.vector(getLdScores(buildLdScore(ld))[, 1]), + as.vector(mcols(buildLdScore(ld))$ldScores[, 1]), as.vector(computeLdScores(buildLdEigen(ld))[, 1]) ) } @@ -153,14 +153,14 @@ test_that("buildLdScore agrees with computeLdScores on the same reference", { test_that("buildLdScore keeps per-block LD matrices for g-LDSC by default", { ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) - mats <- getLdMatrixList(buildLdScore(ld)) + mats <- ldMatrixList(buildLdScore(ld)) expect_equal(length(mats), 2L) expect_equal(dim(mats[[1]]$R), c(4L, 4L)) expect_equal(mats[[1]]$snpIdx, 1:4) expect_equal(mats[[2]]$snpIdx, 5:7) expect_equal( - length(getLdMatrixList(buildLdScore(ld, keepLdMatrices = FALSE))), + length(ldMatrixList(buildLdScore(ld, keepLdMatrices = FALSE))), 0L ) }) @@ -168,11 +168,11 @@ test_that("buildLdScore keeps per-block LD matrices for g-LDSC by default", { test_that("buildLdScore defaults weights to 1/max(l2, 1)", { ld <- makeTestLdData(n = 6L) ref <- buildLdScore(ld) - l2 <- as.vector(getLdScores(ref)[, 1]) - expect_equal(getLdScoreWeights(ref), 1 / pmax(l2, 1)) + l2 <- as.vector(mcols(ref)$ldScores[, 1]) + expect_equal(mcols(ref)$ldScoreWeights, 1 / pmax(l2, 1)) custom <- buildLdScore(ld, ldScoreWeights = rep(2, 6)) - expect_equal(getLdScoreWeights(custom), rep(2, 6)) + expect_equal(mcols(custom)$ldScoreWeights, rep(2, 6)) expect_error( buildLdScore(ld, ldScoreWeights = rep(2, 3)), "ldScoreWeights.*Must have length 6, but has length 3" @@ -187,7 +187,7 @@ test_that("buildLdScore: argument guards fire", { package = "pecotmr" ) ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") - expect_error(buildLdScore(ld, nRef = 0L), "nRef.*Must be >= 1") + expect_error(buildLdScore(ld, nSamples = 0L), "nSamples.*Must be >= 1") expect_error(buildLdScore(ld, inSample = NA), "inSample.*May not be NA") expect_error( buildLdScore(ld, keepLdMatrices = NA), diff --git a/tests/testthat/test_LdStatistic.R b/tests/testthat/test_LdStatistic.R index ba0c0b68..a02d715f 100644 --- a/tests/testthat/test_LdStatistic.R +++ b/tests/testthat/test_LdStatistic.R @@ -1,22 +1,23 @@ # 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 +# The build is read from seqinfo() via GenomeInfoDb::genome(), which the +# virtual LdStatistic and its concrete subclasses (LdEigen / LdScore) all +# inherit from GRanges; exercise it through a concrete # LdScore instance. Fixtures (makeTestLdBlocks / makeTestSnpInfo) come # from helper-h2Classes.R. -test_that("getGenome returns the genome build string (via an LdScore subclass)", { +test_that("genome() reports the build from seqinfo (via an LdScore)", { n <- 10 obj <- LdScore( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(n), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(runif(n), nrow = n, ncol = 1), ldScoreWeights = runif(n), ldMatrixList = list() ) - expect_equal(getGenome(obj), "hg19") + expect_equal(unname(GenomeInfoDb::genome(obj)), "hg19") }) # =========================================================================== @@ -34,7 +35,7 @@ test_that("getGenome returns the genome build string (via an LdScore subclass)", args <- list( ldBlocks = makeTestLdBlocks(), snpInfo = makeTestSnpInfo(n), - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(runif(n), nrow = n, ncol = 1), @@ -46,13 +47,14 @@ test_that("getGenome returns the genome build string (via an LdScore subclass)", exec(LdScore, !!!args) } -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 +test_that("validity rejects an nSamples that is not a positive integer", { + # Matched on the validity text, not just the name: the argument name + # alone # also appears in R's own argument-matching errors. - 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) + msg <- "Variable 'nSamples'" + expect_error(.lds_score(nSamples = 0L), msg) + expect_error(.lds_score(nSamples = -1L), msg) + expect_error(.lds_score(nSamples = c(10L, 20L)), msg) }) test_that("validity rejects an inSample that is not a single flag", { @@ -68,7 +70,7 @@ test_that("validity rejects an inSample that is not a single flag", { "LdScore", gr, ldBlocks = makeTestLdBlocks(), - nRef = 500L, + nSamples = 500L, inSample = flag, ldMatrixList = list() ) @@ -96,7 +98,7 @@ test_that("validity rejects a statistic carrying no variants", { "LdScore", gr, ldBlocks = makeTestLdBlocks(), - nRef = 500L, + nSamples = 500L, inSample = FALSE, ldMatrixList = list() ), @@ -110,7 +112,7 @@ test_that(".ldStatRanges names the snpInfo columns it is missing", { LdScore( ldBlocks = makeTestLdBlocks(), snpInfo = si[, setdiff(colnames(si), c("A1", "A2"))], - nRef = 500L, + nSamples = 500L, inSample = FALSE, genome = "hg19", ldScores = matrix(runif(4), nrow = 4, ncol = 1), @@ -121,10 +123,10 @@ test_that(".ldStatRanges names the snpInfo columns it is missing", { ) }) -test_that("getLdBlocks returns the blocks the statistic was built against", { +test_that("ldBlocks returns the blocks the statistic was built against", { obj <- .lds_score() - expect_s4_class(getLdBlocks(obj), "GRanges") - expect_equal(length(getLdBlocks(obj)), 2L) + expect_s4_class(ldBlocks(obj), "GRanges") + expect_equal(length(ldBlocks(obj)), 2L) }) @@ -143,8 +145,8 @@ test_that("the builders accept a bare LdData as well as a list of them", { # variant order follows the list order. joined <- buildLdEigen(list(one, two)) expect_equal(length(joined), 7L) - expect_equal(length(getEigenList(joined)), 2L) - expect_equal(getEigenList(joined)[[2]]$snpIdx, 5:7) + expect_equal(length(eigenList(joined)), 2L) + expect_equal(eigenList(joined)[[2]]$snpIdx, 5:7) }) test_that("the builders reject input that is not LdData", { @@ -157,31 +159,34 @@ test_that("the builders reject input that is not LdData", { }) test_that("nRef is taken from the LdData, and disagreement is an error", { - a <- makeTestLdData(n = 4L, nRef = 500L) - b <- makeTestLdData(n = 3L, startBp = 5000L, nRef = 900L) + a <- makeTestLdData(n = 4L, nSamples = 500L) + b <- makeTestLdData(n = 3L, startBp = 5000L, nSamples = 900L) - expect_equal(getNRef(buildLdEigen(list(a, a))), 500L) + expect_equal(ldPanelNSamples(buildLdEigen(list(a, a))), 500L) expect_error(buildLdEigen(list(a, b)), "differing reference panel sizes") # An explicit nRef settles it. - expect_equal(getNRef(buildLdEigen(list(a, b), nRef = 700L)), 700L) + expect_equal(ldPanelNSamples(buildLdEigen(list(a, b), nSamples = 700L)), 700L) }) test_that("the genome build comes from the LdData when the caller names none", { ld <- makeTestLdData() # loadLdMatrix() leaves the build unset, which must stay NA rather than # becoming a made-up default. - expect_true(is.na(getGenome(buildLdEigen(ld)))) + expect_true(is.na(unname(GenomeInfoDb::genome(buildLdEigen(ld))))) tagged <- ld GenomeInfoDb::genome(tagged) <- "hg38" - expect_equal(getGenome(buildLdEigen(tagged)), "hg38") + expect_equal(unname(GenomeInfoDb::genome(buildLdEigen(tagged))), "hg38") # An explicit argument still wins. - expect_equal(getGenome(buildLdEigen(tagged, genome = "hg19")), "hg19") + expect_equal( + unname(GenomeInfoDb::genome(buildLdEigen(tagged, genome = "hg19"))), + "hg19" + ) }) test_that("LD block ranges span the variants each block covers", { ref <- buildLdEigen(makeTestLdDataMultiBlock(sizes = c(4L, 3L))) - blocks <- getLdBlocks(ref) + blocks <- ldBlocks(ref) variants <- GenomicRanges::start(ref) expect_equal( @@ -201,10 +206,10 @@ test_that("an LD block spanning chromosomes is rejected", { levels = c("chr1", "chr2") ) crossChrom <- LdData( - correlation = getCorrelation(ld), + correlation = ldMatrix(ld), variants = gr, - blockMetadata = getBlockMetadata(ld), - nRef = getNRef(ld) + blockMetadata = blockMetadata(ld), + nSamples = ldPanelNSamples(ld) ) expect_error(buildLdEigen(crossChrom), "spans 2 chromosomes") }) @@ -262,7 +267,7 @@ test_that("an LD block spanning chromosomes is rejected", { n = 3L, md = NULL, variantNames = NULL, - nRef = 100L, + nSamples = 100L, correlation = NULL, blockMetadata = NULL ) { @@ -270,7 +275,7 @@ test_that("an LD block spanning chromosomes is rejected", { correlation = correlation %||% diag(n), variants = .ldsVariants(n, md, variantNames), blockMetadata = blockMetadata %||% .ldsBlockMeta(n), - nRef = nRef + nSamples = nSamples ) } @@ -341,7 +346,7 @@ test_that("blocks are taken in order when blockMetadata has no startIdx", { blockMetadata = noIdx )) expect_equal(length(ref), 4L) - expect_equal(length(getLdBlocks(ref)), 2L) + expect_equal(length(ldBlocks(ref)), 2L) }) test_that("a variant table with no A1 column is rejected", { @@ -390,12 +395,12 @@ test_that("a block matrix sized differently from its span is rejected", { test_that("nRef is required when no LdData records one", { expect_error( - buildLdScore(.ldsData(3L, nRef = NA_integer_)), + buildLdScore(.ldsData(3L, nSamples = NA_integer_)), "`nRef` is required" ) }) test_that("an explicit nRef overrides a missing one", { - ref <- buildLdScore(.ldsData(3L, nRef = NA_integer_), nRef = 250L) - expect_equal(getNRef(ref), 250L) + ref <- buildLdScore(.ldsData(3L, nSamples = NA_integer_), nSamples = 250L) + expect_equal(ldPanelNSamples(ref), 250L) }) diff --git a/tests/testthat/test_MashPrior.R b/tests/testthat/test_MashPrior.R index 11082b8d..612286e8 100644 --- a/tests/testthat/test_MashPrior.R +++ b/tests/testthat/test_MashPrior.R @@ -19,9 +19,9 @@ test_that("MashPrior: construct + accessors (full + cv)", { cvFits = list(samplePartition = sp, perFoldFits = perFold) ) expect_s4_class(mp, "MashPrior") - expect_identical(getFullFit(mp)$U, U) - expect_length(getCvFits(mp)$perFoldFits, 3L) - expect_identical(getCvFits(mp)$samplePartition, sp) + expect_identical(fullFit(mp)$U, U) + expect_length(cvFits(mp)$perFoldFits, 3L) + expect_identical(cvFits(mp)$samplePartition, sp) expect_output(show(mp), "MashPrior") }) @@ -29,10 +29,10 @@ test_that("MashPrior: full-only and cv-only bundles", { U <- list(U1 = diag(2)) perFold <- list(list(U = U), list(U = U), list(U = U)) mpFull <- MashPrior(fullFit = list(U = U)) - expect_null(getCvFits(mpFull)) + expect_null(cvFits(mpFull)) mpCv <- MashPrior(cvFits = list(perFoldFits = perFold)) - expect_null(getFullFit(mpCv)) - expect_length(getCvFits(mpCv)$perFoldFits, 3L) + expect_null(fullFit(mpCv)) + expect_length(cvFits(mpCv)$perFoldFits, 3L) }) test_that("MashPrior: validity rejects malformed bundles", { diff --git a/tests/testthat/test_MethodParam.R b/tests/testthat/test_MethodParam.R index 9bb7f315..7abe73f3 100644 --- a/tests/testthat/test_MethodParam.R +++ b/tests/testthat/test_MethodParam.R @@ -157,11 +157,11 @@ test_that("malformed slots are rejected with the caller's own error", { test_that("TwasWeightsMethodsParam shares the rules with its own registry", { p <- TwasWeightsMethodsParam( methods = list(susie = list()), - qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), + qtlDatasetMethods = list(lasso = GlmnetOptions(nfold = 5)), qtlSumStatsMethods = list(lasso = LassosumOptions()) ) expect_s4_class(p, "TwasWeightsMethodsParam") - expect_equal(p$qtlDatasetMethods$lasso$alpha, 0.5) + expect_equal(p$qtlDatasetMethods$lasso$nfold, 5) # The registries differ: prsCs is summary-statistics only, enet # individual only, and both are methods a fine-mapping Param never has. expect_error( @@ -457,7 +457,7 @@ test_that("show renders a slot holding per-method entries", { out <- paste( capture.output(show( FineMappingMethodsParam( - methods = list(susie = SusieOptions(L = 20)) + methods = list(susie = SusieOptions(max_iter = 20)) ) )), collapse = " " @@ -469,7 +469,7 @@ test_that("show renders a slot holding per-method entries", { multi <- paste( capture.output(show(TwasWeightsMethodsParam( methods = list(susie = list()), - qtlDatasetMethods = list(lasso = GlmnetOptions(alpha = 0.5)), + qtlDatasetMethods = list(lasso = GlmnetOptions(nfold = 5)), qtlSumStatsMethods = list(lasso = LassosumOptions()) ))), collapse = " " @@ -518,9 +518,9 @@ test_that("show names a nested Options record by its engine", { }) test_that("show names a nested Param by what it contains", { - # Not by slot name: the reader wants the fields, not "credibleSetArgs". + # Not by slot name: the reader wants the fields, not the bundle name. out <- capture.output(show(GwasFineMappingParam())) - expect_true(any(str_detect(out, "credibleSetArgs"))) + expect_true(any(str_detect(out, "credibleSetParam"))) expect_true(any(str_detect(out, "coverage, secondaryCoverage"))) }) diff --git a/tests/testthat/test_MultiStudyQtlDataset.R b/tests/testthat/test_MultiStudyQtlDataset.R index 7499b0c6..8f4097ff 100644 --- a/tests/testthat/test_MultiStudyQtlDataset.R +++ b/tests/testthat/test_MultiStudyQtlDataset.R @@ -4,24 +4,24 @@ test_that("MultiStudyQtlDataset: combines two QtlDatasets", { qd1 <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) qd2 <- QtlDataset( - study = "s2", + studyName = "s2", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) expect_s4_class(mt, "MultiStudyQtlDataset") - expect_setequal(getStudy(mt), c("s1", "s2")) + expect_setequal(studyName(mt), c("s1", "s2")) }) test_that("MultiStudyQtlDataset: rejects single dataset with no sumStats", { qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) @@ -34,7 +34,7 @@ test_that("MultiStudyQtlDataset: rejects single dataset with no sumStats", { test_that("MultiStudyQtlDataset: rejects unnamed qtlDatasets list", { qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) @@ -69,12 +69,12 @@ test_that("MultiStudyQtlDataset: rejects trait/position conflicts across studies colData = cd2 ) qd1 <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se1) ) qd2 <- QtlDataset( - study = "s2", + studyName = "s2", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se2) ) @@ -109,12 +109,12 @@ test_that("MultiStudyQtlDataset: tolerates chr-prefix-only seqname differences a colData = cd2 ) qd1 <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se1) ) qd2 <- QtlDataset( - study = "s2", + studyName = "s2", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se2) ) @@ -125,7 +125,7 @@ test_that("MultiStudyQtlDataset: tolerates chr-prefix-only seqname differences a }) -test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { +test_that("sumStats(MultiStudyQtlDataset) rejects selection arguments", { # Compose one individual-level QtlDataset with a QtlSumStats of # summary-statistic-only studies (1 + 1 = 2 studies total). gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 1L)) @@ -137,7 +137,7 @@ test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { N = 1000L ) ss <- QtlSumStats( - study = "s3", + studyName = "s3", context = "c1", trait = "t1", entry = list(gr), @@ -145,17 +145,17 @@ test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { ldSketch = .sc_makeGenotypeHandle() ) qd1 <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1), sumStats = ss) # Bare call returns the embedded QtlSumStats collection ... - expect_s4_class(getSumStats(mt), "QtlSumStats") + expect_s4_class(sumStats(mt), "QtlSumStats") # ... but any selection argument is rejected. # Taking no extra formals is the rejection: R names the argument. - expect_error(getSumStats(mt, study = "s1"), "unused argument") + expect_error(sumStats(mt, studyName = "s1"), "unused argument") }) @@ -175,7 +175,7 @@ test_that("MultiStudyQtlDataset: rejects an empty qtlDatasets list", { test_that("MultiStudyQtlDataset: rejects duplicated study names", { qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) @@ -187,7 +187,7 @@ test_that("MultiStudyQtlDataset: rejects duplicated study names", { test_that("MultiStudyQtlDataset: rejects a non-QtlSumStats sumStats", { qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) @@ -201,12 +201,12 @@ test_that("MultiStudyQtlDataset: rejects a non-QtlSumStats sumStats", { }) -test_that("getStudy unions the individual-level and summary-only studies", { +test_that("studyName unions the individual-level and summary-only studies", { # The sumStats arm was never taken: every collection built above carries - # only QtlDatasets, so getStudy() only ever read their names. + # only QtlDatasets, so studyName() only ever read their names. data(qtlSumStatsExample) qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) @@ -214,7 +214,7 @@ test_that("getStudy unions the individual-level and summary-only studies", { qtlDatasets = list(s1 = qd), sumStats = qtlSumStatsExample ) - expect_setequal(getStudy(mt), c("s1", "study1")) + expect_setequal(studyName(mt), c("s1", "study1")) }) test_that("MultiStudyQtlDataset: qtlDatasets guard fires on a non-list", { diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index c88fe97c..84400ac2 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -92,11 +92,11 @@ context("QtlDataset internal helpers") # `...` is the genotype filter now: every caller passes only filter # fields (mafCutoff / xvarCutoff / imissCutoff / keepVariants). QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = pheno, genotypeCovariates = geno_cov, - genotypeFilterArgs = GenotypeFilterParam(...) + genotypeFilterParam = GenotypeFilterParam(...) ) } @@ -249,7 +249,7 @@ test_that(".qtlResolveVariantRegion: traits across chromosomes error", { se1 <- .qh_makeSe(traits = "ENSG_A", chr = "chr1") se2 <- .qh_makeSe(traits = "ENSG_B", chr = "chr2") qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = gh, phenotypes = list(brain = se1, liver = se2), genotypeCovariates = matrix(0, nrow = 12, ncol = 0) @@ -309,7 +309,7 @@ test_that(".qtlResolveVariantRegion: region path expands by cisWindow", { test_that(".qtlVariantIndices: NULL region returns all SNP indices", { qd <- .qh_makeDataset() idx <- pecotmr:::.qtlVariantIndices(qd) - expect_equal(idx, seq_len(nrow(getSnpInfo(getGenotypeHandle(qd))))) + expect_equal(idx, seq_len(nrow(snpInfo(genotypeHandle(qd))))) }) test_that(".qtlVariantIndices: filters by chromosome and BP range", { @@ -337,14 +337,14 @@ test_that(".qtlVariantIndices: returns integer(0) when no overlap", { }) # =========================================================================== -# getTraitPosition / .qtlTraitPos +# traitPosition / .qtlTraitPos # =========================================================================== -test_that("getTraitPosition returns each trait's union genomic span across contexts", { +test_that("traitPosition returns each trait's union genomic span across contexts", { # .qh_makeSe places ENSG1 @ chr1:1000-1500 and ENSG2 @ chr1:2000-2500 in every # context, so each trait's cross-context union span is that single interval. qd <- .qh_makeDataset(contexts = c("brain", "liver")) - gr <- getTraitPosition(qd) + gr <- traitPosition(qd) expect_s4_class(gr, "GRanges") expect_setequal(names(gr), c("ENSG1", "ENSG2")) expect_equal(as.character(GenomicRanges::seqnames(gr["ENSG1"])), "chr1") @@ -352,14 +352,14 @@ test_that("getTraitPosition returns each trait's union genomic span across conte expect_equal(GenomicRanges::end(gr["ENSG1"]), 1499L) # start 1000 + width 500 - 1 expect_equal(GenomicRanges::start(gr["ENSG2"]), 2000L) # single-trait selection routes through the traitId branch of the method - one <- getTraitPosition(qd, traitId = "ENSG2") + one <- traitPosition(qd, traitId = "ENSG2") expect_equal(names(one), "ENSG2") expect_equal(GenomicRanges::start(one), 2000L) }) -test_that("getTraitPosition emits a chrUn sentinel for a trait absent from every context", { +test_that("traitPosition emits a chrUn sentinel for a trait absent from every context", { qd <- .qh_makeDataset(contexts = "brain") - gr <- getTraitPosition(qd, traitId = "NOPE") + gr <- traitPosition(qd, traitId = "NOPE") expect_equal(names(gr), "NOPE") expect_equal(as.character(GenomicRanges::seqnames(gr)), "chrUn") }) @@ -683,29 +683,29 @@ test_that(".qtlBuildResidualizationDesign: intersects sample sets across blocks" rbinom(n_samples * n_snp, 2, 0.3), nrow = n_samples, ncol = n_snp, - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] # Build the SE in variants x samples orientation (matches the real impl). rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -850,35 +850,35 @@ test_that(".qtlExtractBlock: mafCutoff retains variants above the threshold", { function(handle, snpIdx, meanImpute = TRUE) { panel <- matrix( 0, - nrow = length(getSampleIds(handle)), - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + nrow = length(sampleIds(handle)), + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) panel[, "rs1"] <- c(2, 2, 2, 2, 1, 1, 1, 1, 1, 1) # sum 14 -> p = 0.70 panel[, "rs2"] <- c(1, 1, 1, 1, 0, 0, 0, 0, 0, 0) # sum 4 -> p = 0.20 panel[, "rs3"] <- 1 # sum 10 -> p = 0.50 sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, colData = S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) ) } @@ -896,13 +896,13 @@ test_that(".qtlExtractBlock: returns directional af; maf is its minor-allele fol expect_equal(unname(blk$maf), pmin(unname(blk$af), 1 - unname(blk$af))) }) -test_that("getAf: returns directional effect-allele frequency (not folded to MAF)", { +test_that("af: returns directional effect-allele frequency (not folded to MAF)", { qd <- .qh_makeDataset(n_samples = 10L) local_mocked_bindings( extractBlockGenotypes = .qh_directionalExtractor(), .package = "pecotmr" ) - af <- getAf(qd) + af <- af(qd) expect_named(af) # Directional: 0.70 / 0.20 retained verbatim, NOT folded to 0.30 / 0.20. expect_equal(unname(af[["rs1"]]), 0.70) @@ -910,15 +910,15 @@ test_that("getAf: returns directional effect-allele frequency (not folded to MAF expect_equal(unname(af[["rs3"]]), 0.50) }) -test_that("getMaf stays folded while getAf is directional (they fold into each other)", { +test_that("maf stays folded while af is directional (they fold into each other)", { qd <- .qh_makeDataset(n_samples = 10L) local_mocked_bindings( extractBlockGenotypes = .qh_directionalExtractor(), .package = "pecotmr" ) - af <- getAf(qd) - maf <- getMaf(qd) - # getMaf folds rs1's 0.70 down to 0.30; getAf does not. + af <- af(qd) + maf <- maf(qd) + # maf folds rs1's 0.70 down to 0.30; af does not. expect_equal(unname(maf[["rs1"]]), 0.30) expect_equal(unname(maf[names(af)]), pmin(unname(af), 1 - unname(af))) }) @@ -1000,7 +1000,7 @@ context("QtlDataset residualization methods") geno_cov <- matrix(numeric(0), nrow = 0, ncol = 0) } QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = pheno, genotypeCovariates = geno_cov, @@ -1015,28 +1015,28 @@ context("QtlDataset residualization methods") rbinom(n_samples * n_snp, 2, 0.3), nrow = n_samples, ncol = n_snp, - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -1129,31 +1129,31 @@ test_that(".qtlHandleCovariateNa: drop removes any sample with a missing covaria }) # =========================================================================== -# getResidualizedGenotypes (QtlDataset) +# residualizedGenotypes (QtlDataset) # =========================================================================== -test_that("getResidualizedGenotypes: requires contexts", { +test_that("residualizedGenotypes: requires contexts", { qd <- .qr_makeDataset() - expect_error(getResidualizedGenotypes(qd), "`contexts` is required") + expect_error(residualizedGenotypes(qd), "`contexts` is required") expect_error( - getResidualizedGenotypes(qd, contexts = NULL), + residualizedGenotypes(qd, contexts = NULL), "`contexts` is required" ) expect_error( - getResidualizedGenotypes(qd, contexts = character(0)), + residualizedGenotypes(qd, contexts = character(0)), "`contexts` is required" ) }) -test_that("getResidualizedGenotypes: unknown context errors", { +test_that("residualizedGenotypes: unknown context errors", { qd <- .qr_makeDataset() expect_error( - getResidualizedGenotypes(qd, contexts = "ghost"), + residualizedGenotypes(qd, contexts = "ghost"), "Unknown context" ) }) -test_that("getResidualizedGenotypes: empty genotype block short-circuits to G", { +test_that("residualizedGenotypes: empty genotype block short-circuits to G", { qd <- .qr_makeDataset() local_mocked_bindings( extractBlockGenotypes = .qr_mockExtractor(), @@ -1161,17 +1161,17 @@ test_that("getResidualizedGenotypes: empty genotype block short-circuits to G", ) # region with no SNPs in the panel. region <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1, 1000)) - G <- getResidualizedGenotypes(qd, contexts = "brain", region = region) + G <- residualizedGenotypes(qd, contexts = "brain", region = region) expect_equal(ncol(G), 0L) }) -test_that("getResidualizedGenotypes: produces residualized matrix shape", { +test_that("residualizedGenotypes: produces residualized matrix shape", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G <- getResidualizedGenotypes(qd, contexts = "brain") + G <- residualizedGenotypes(qd, contexts = "brain") expect_equal(nrow(G), 12L) expect_equal(ncol(G), 6L) # When scaleResiduals = TRUE (the default), kept columns should have unit sd @@ -1181,13 +1181,13 @@ test_that("getResidualizedGenotypes: produces residualized matrix shape", { expect_true(all(abs(sds[nonZero] - 1) < 1e-6)) }) -test_that("getResidualizedGenotypes: residualizes only against selected pheno covariate", { +test_that("residualizedGenotypes: residualizes only against selected pheno covariate", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G <- getResidualizedGenotypes( + G <- residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam(phenotypeCovariates = "age") @@ -1200,7 +1200,7 @@ test_that("getResidualizedGenotypes: residualizes only against selected pheno co } }) -test_that("getResidualizedGenotypes: respects residualizePhenotype = FALSE", { +test_that("residualizedGenotypes: respects residualizePhenotype = FALSE", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( extractBlockGenotypes = .qr_mockExtractor(), @@ -1208,7 +1208,7 @@ test_that("getResidualizedGenotypes: respects residualizePhenotype = FALSE", { ) # When pheno is disabled, the design becomes intercept-only, so the result # is just the centered (and scaled) raw block. - G1 <- getResidualizedGenotypes( + G1 <- residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -1219,20 +1219,20 @@ test_that("getResidualizedGenotypes: respects residualizePhenotype = FALSE", { expect_equal(ncol(G1), 6L) }) -test_that("getResidualizedGenotypes: precise-name kwarg routes correctly", { +test_that("residualizedGenotypes: precise-name kwarg routes correctly", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G_precise <- getResidualizedGenotypes( + G_precise <- residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( residualizePhenotype = FALSE ) ) - G_conv <- getResidualizedGenotypes( + G_conv <- residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -1248,10 +1248,10 @@ test_that("getResidualizedGenotypes: precise-name kwarg routes correctly", { # 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", { +test_that("residualizedGenotypes refuses a bare list for the bundle", { qd <- .qr_makeDataset(contexts = "brain") expect_error( - getResidualizedGenotypes( + residualizedGenotypes( qd, contexts = "brain", residualizationArgs = list(residualizePhenotype = FALSE) @@ -1260,18 +1260,18 @@ test_that("getResidualizedGenotypes refuses a bare list for the bundle", { ) }) -test_that("getResidualizedGenotypes: joint-context mode intersects samples", { +test_that("residualizedGenotypes: joint-context mode intersects samples", { qd <- .qr_makeDataset(contexts = c("brain", "liver")) local_mocked_bindings( extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G <- getResidualizedGenotypes(qd, contexts = c("brain", "liver")) + G <- residualizedGenotypes(qd, contexts = c("brain", "liver")) expect_equal(nrow(G), 12L) expect_setequal(rownames(G), paste0("s", 1:12)) }) -test_that("getResidualizedGenotypes: includes genotype covariates when supplied", { +test_that("residualizedGenotypes: includes genotype covariates when supplied", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -1283,7 +1283,7 @@ test_that("getResidualizedGenotypes: includes genotype covariates when supplied" extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G <- getResidualizedGenotypes( + G <- residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -1297,7 +1297,7 @@ test_that("getResidualizedGenotypes: includes genotype covariates when supplied" } }) -test_that("getResidualizedGenotypes: mean-imputes missing covariates by default", { +test_that("residualizedGenotypes: mean-imputes missing covariates by default", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -1311,7 +1311,7 @@ test_that("getResidualizedGenotypes: mean-imputes missing covariates by default" .package = "pecotmr" ) # Default covariateNaAction = "impute": no error, all 12 samples retained. - G <- getResidualizedGenotypes( + G <- residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -1322,7 +1322,7 @@ test_that("getResidualizedGenotypes: mean-imputes missing covariates by default" expect_false(anyNA(G)) }) -test_that("getResidualizedGenotypes: covariateNaAction='drop' removes samples with missing covariates", { +test_that("residualizedGenotypes: covariateNaAction='drop' removes samples with missing covariates", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -1335,7 +1335,7 @@ test_that("getResidualizedGenotypes: covariateNaAction='drop' removes samples wi extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G <- getResidualizedGenotypes( + G <- residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -1348,34 +1348,34 @@ test_that("getResidualizedGenotypes: covariateNaAction='drop' removes samples wi }) # =========================================================================== -# getResidualizedPhenotypes (QtlDataset) +# residualizedPhenotypes (QtlDataset) # =========================================================================== -test_that("getResidualizedPhenotypes: requires contexts", { +test_that("residualizedPhenotypes: requires contexts", { qd <- .qr_makeDataset() - expect_error(getResidualizedPhenotypes(qd), "`contexts` is required") + expect_error(residualizedPhenotypes(qd), "`contexts` is required") }) -test_that("getResidualizedPhenotypes: unknown context errors", { +test_that("residualizedPhenotypes: unknown context errors", { qd <- .qr_makeDataset() expect_error( - getResidualizedPhenotypes(qd, contexts = "ghost"), + residualizedPhenotypes(qd, contexts = "ghost"), "Unknown context" ) }) -test_that("getResidualizedPhenotypes: returns one matrix per context", { +test_that("residualizedPhenotypes: returns one matrix per context", { qd <- .qr_makeDataset(contexts = c("brain", "liver")) - res <- getResidualizedPhenotypes(qd, contexts = c("brain", "liver")) + res <- residualizedPhenotypes(qd, contexts = c("brain", "liver")) expect_equal(names(res), c("brain", "liver")) expect_equal(nrow(res$brain), 12L) expect_equal(ncol(res$brain), 2L) expect_equal(nrow(res$liver), 12L) }) -test_that("getResidualizedPhenotypes: residualizes against age covariate", { +test_that("residualizedPhenotypes: residualizes against age covariate", { qd <- .qr_makeDataset(contexts = "brain") - Y <- getResidualizedPhenotypes( + Y <- residualizedPhenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam(phenotypeCovariates = "age") @@ -1386,9 +1386,9 @@ test_that("getResidualizedPhenotypes: residualizes against age covariate", { } }) -test_that("getResidualizedPhenotypes: respects residualizePhenotype = FALSE", { +test_that("residualizedPhenotypes: respects residualizePhenotype = FALSE", { qd <- .qr_makeDataset(contexts = "brain") - Y <- getResidualizedPhenotypes( + Y <- residualizedPhenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -1399,16 +1399,16 @@ test_that("getResidualizedPhenotypes: respects residualizePhenotype = FALSE", { expect_equal(ncol(Y), 2L) }) -test_that("getResidualizedPhenotypes: precise-name kwarg routes correctly", { +test_that("residualizedPhenotypes: precise-name kwarg routes correctly", { qd <- .qr_makeDataset(contexts = "brain") - Y_precise <- getResidualizedPhenotypes( + Y_precise <- residualizedPhenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( residualizePhenotype = FALSE ) ) - Y_conv <- getResidualizedPhenotypes( + Y_conv <- residualizedPhenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -1418,23 +1418,23 @@ test_that("getResidualizedPhenotypes: precise-name kwarg routes correctly", { expect_equal(Y_precise, Y_conv) }) -test_that("getResidualizedPhenotypes: traitId subsets to requested traits", { +test_that("residualizedPhenotypes: traitId subsets to requested traits", { qd <- .qr_makeDataset(contexts = "brain") - Y <- getResidualizedPhenotypes(qd, contexts = "brain", traitId = "ENSG1") + Y <- residualizedPhenotypes(qd, contexts = "brain", traitId = "ENSG1") expect_equal(ncol(Y), 1L) expect_equal(colnames(Y), "ENSG1") }) -test_that("getResidualizedPhenotypes: scaleResiduals = FALSE skips the rescale step", { +test_that("residualizedPhenotypes: scaleResiduals = FALSE skips the rescale step", { qd <- .qr_makeDataset(contexts = "brain", scaleResiduals = FALSE) - Y <- getResidualizedPhenotypes(qd, contexts = "brain") + Y <- residualizedPhenotypes(qd, contexts = "brain") # Without scaling the residual columns generally won't have sd = 1. sds <- apply(Y, 2L, sd) expect_false(any(abs(sds - 1) < 1e-6)) }) # =========================================================================== -# getPhenotypes/getResidualizedPhenotypes naAction +# molecularTraits/residualizedPhenotypes naAction # =========================================================================== # Helper to build a single-context SE with controlled NA placement. @@ -1465,31 +1465,31 @@ test_that("getResidualizedPhenotypes: scaleResiduals = FALSE skips the rescale s ) } -test_that("getPhenotypes naAction='drop' drops samples with any NA in selected traits", { +test_that("molecularTraits naAction='drop' drops samples with any NA in selected traits", { gh <- .qr_makeHandle(n_samples = 8L) se <- .qr_makeSeWithNa(n_samples = 8L, na_idx = c(2L, 5L)) qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- getPhenotypes(qd, contexts = "brain", naAction = "drop") + out <- molecularTraits(qd, contexts = "brain", naAction = "drop") expect_s4_class(out, "SummarizedExperiment") expect_equal(ncol(out), 6L) expect_false(any(is.na(SummarizedExperiment::assay(out)))) }) -test_that("getPhenotypes naAction='impute' mean-imputes NAs per trait", { +test_that("molecularTraits naAction='impute' mean-imputes NAs per trait", { gh <- .qr_makeHandle(n_samples = 8L) se <- .qr_makeSeWithNa(n_samples = 8L, na_idx = c(2L, 5L)) qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- getPhenotypes(qd, contexts = "brain", naAction = "impute") + out <- molecularTraits(qd, contexts = "brain", naAction = "impute") Y <- SummarizedExperiment::assay(out) expect_equal(ncol(Y), 8L) expect_false(any(is.na(Y))) @@ -1500,22 +1500,22 @@ test_that("getPhenotypes naAction='impute' mean-imputes NAs per trait", { expect_equal(Y[1L, 5L], obsMean) }) -test_that("getResidualizedPhenotypes naAction='impute' yields NA-free residuals", { +test_that("residualizedPhenotypes naAction='impute' yields NA-free residuals", { gh <- .qr_makeHandle(n_samples = 8L) se <- .qr_makeSeWithNa(n_samples = 8L, na_idx = c(2L, 5L)) qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - Y <- getResidualizedPhenotypes(qd, contexts = "brain", naAction = "impute") + Y <- residualizedPhenotypes(qd, contexts = "brain", naAction = "impute") expect_false(any(is.na(Y))) expect_equal(nrow(Y), 8L) }) # =========================================================================== -# getPhenotypes/getResidualizedPhenotypes outlierAction +# molecularTraits/residualizedPhenotypes outlierAction # =========================================================================== # Build a single-context SE with a clear multivariate outlier at sample s10. @@ -1551,46 +1551,46 @@ test_that("getResidualizedPhenotypes naAction='impute' yields NA-free residuals" ) } -test_that("getPhenotypes outlierAction='drop' drops a clear multivariate outlier", { +test_that("molecularTraits outlierAction='drop' drops a clear multivariate outlier", { skip_if_not_installed("robustbase") gh <- .qr_makeHandle(n_samples = 30L) se <- .qr_makeSeWithOutlier(n_samples = 30L, outlier_idx = 10L) qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- getPhenotypes(qd, contexts = "brain", outlierAction = "drop") + out <- molecularTraits(qd, contexts = "brain", outlierAction = "drop") expect_s4_class(out, "SummarizedExperiment") expect_lt(ncol(out), 30L) expect_false("s10" %in% colnames(out)) }) -test_that("getPhenotypes outlierAction='keep' is the default and a no-op", { +test_that("molecularTraits outlierAction='keep' is the default and a no-op", { gh <- .qr_makeHandle(n_samples = 30L) se <- .qr_makeSeWithOutlier(n_samples = 30L, outlier_idx = 10L) qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- getPhenotypes(qd, contexts = "brain") + out <- molecularTraits(qd, contexts = "brain") expect_equal(ncol(out), 30L) }) -test_that("getResidualizedPhenotypes outlierAction='drop' drops residualized outliers", { +test_that("residualizedPhenotypes outlierAction='drop' drops residualized outliers", { skip_if_not_installed("robustbase") gh <- .qr_makeHandle(n_samples = 30L) se <- .qr_makeSeWithOutlier(n_samples = 30L, outlier_idx = 10L) qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - Y <- getResidualizedPhenotypes( + Y <- residualizedPhenotypes( qd, contexts = "brain", outlierAction = "drop" @@ -1973,14 +1973,14 @@ test_that("dentist errors when sum_stat missing required columns", { test_that("QtlDataset: builds and validates with a single-context SE", { se <- .sc_makeSe() qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se), genotypeCovariates = matrix(0, nrow = 10, ncol = 0) ) expect_s4_class(qd, "QtlDataset") - expect_equal(getStudy(qd), "study1") - expect_equal(getContexts(qd), "brain") + expect_equal(studyName(qd), "study1") + expect_equal(contexts(qd), "brain") }) @@ -1988,11 +1988,11 @@ test_that("QtlDataset: rejects empty study name", { se <- .sc_makeSe() expect_error( QtlDataset( - study = "", + studyName = "", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se) ), - "Variable 'study'.*at least 1 characters" + "Variable 'studyName'.*at least 1 characters" ) }) @@ -2000,7 +2000,7 @@ test_that("QtlDataset: rejects empty study name", { test_that("QtlDataset: rejects empty phenotype list", { expect_error( QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list() ), @@ -2013,7 +2013,7 @@ test_that("QtlDataset: rejects unnamed phenotype list", { se <- .sc_makeSe() expect_error( QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(se) ), @@ -2025,7 +2025,7 @@ test_that("QtlDataset: rejects unnamed phenotype list", { test_that("QtlDataset: rejects non-SE elements in phenotype list", { expect_error( QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = data.frame(x = 1)) ), @@ -2038,10 +2038,10 @@ test_that("QtlDataset: rejects negative QC cutoffs", { se <- .sc_makeSe() expect_error( QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se), - genotypeFilterArgs = GenotypeFilterParam(mafCutoff = -0.1) + genotypeFilterParam = GenotypeFilterParam(mafCutoff = -0.1) ), "is not >= 0" ) @@ -2075,7 +2075,7 @@ test_that("QtlDataset: rejects shared traits with inconsistent rowRanges", { ) expect_error( QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se1, liver = se2) ), @@ -2110,7 +2110,7 @@ test_that("QtlDataset: tolerates chr-prefix-only seqname differences for a share ) expect_s4_class( QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = se1, liver = se2) ), @@ -2124,7 +2124,7 @@ test_that("QtlDataset: tolerates chr-prefix-only seqname differences for a share test_that("MultiStudyQtlDataset: rejects non-QtlDataset entries", { qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .sc_makeGenotypeHandle(), phenotypes = list(brain = .sc_makeSe()) ) @@ -2148,8 +2148,8 @@ test_that("show.QtlDataset lists context names and trait count", { test_that("show.MultiStudyQtlDataset reports per-source study counts", { - qd1 <- .sh_makeQtlDataset(study = "s1") - qd2 <- .sh_makeQtlDataset(study = "s2") + qd1 <- .sh_makeQtlDataset(studyName = "s1") + qd2 <- .sh_makeQtlDataset(studyName = "s2") mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) out <- capture.output(show(mt)) expect_true(any(grepl( @@ -2161,9 +2161,9 @@ test_that("show.MultiStudyQtlDataset reports per-source study counts", { test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { - qd <- .sh_makeQtlDataset(study = "s1") + qd <- .sh_makeQtlDataset(studyName = "s1") ss <- QtlSumStats( - study = "s2", + studyName = "s2", context = "c1", trait = "t1", entry = list(.sh_makeQtlSumstatsGr()), @@ -2176,7 +2176,7 @@ test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { }) # =========================================================================== -# Multi-region variant extraction: getGenotypes() with a multi-range region +# Multi-region variant extraction: genotypes() with a multi-range region # (the mechanism behind jointRegions). Single-file (chr21) and sharded # (chr21+chr22) handles wrapped in a QtlDataset with a minimal phenotype SE. # =========================================================================== @@ -2201,8 +2201,8 @@ test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { colData = S4Vectors::DataFrame(row.names = samples) ) } -.mr_ncol <- function(qd, region) ncol(getGenotypes(qd, region = region)) -.mr_vids <- function(qd, region) colnames(getGenotypes(qd, region = region)) +.mr_ncol <- function(qd, region) ncol(genotypes(qd, region = region)) +.mr_vids <- function(qd, region) colnames(genotypes(qd, region = region)) test_that("multi-range region unions disjoint sub-ranges on one chromosome", { skip_if_not_installed("snpStats") @@ -2210,11 +2210,11 @@ test_that("multi-range region unions disjoint sub-ranges on one chromosome", { plink1Prefix = file.path(test_data_dir, "test_variants") ) qd <- QtlDataset( - study = "S", + studyName = "S", genotypes = h, - phenotypes = list(ctx = .mr_makeSE(getSampleIds(h))) + phenotypes = list(ctx = .mr_makeSE(sampleIds(h))) ) - bp <- getSnpInfo(h)$BP + bp <- snpInfo(h)$BP lo <- min(bp) hi <- max(bp) mid <- lo + (hi - lo) %/% 2L @@ -2242,11 +2242,11 @@ test_that("multi-range region spans chromosomes on a sharded handle", { ) ) qd <- QtlDataset( - study = "S", + studyName = "S", genotypes = hs, - phenotypes = list(ctx = .mr_makeSE(getSampleIds(hs))) + phenotypes = list(ctx = .mr_makeSE(sampleIds(hs))) ) - bp <- getSnpInfo(GenotypeHandle( + bp <- snpInfo(GenotypeHandle( plink1Prefix = file.path(test_data_dir, "test_variants") ))$BP lo <- min(bp) @@ -2264,8 +2264,8 @@ test_that("multi-range region spans chromosomes on a sharded handle", { expect_gt(n22, 0L) expect_equal(.mr_ncol(qd, rBoth), n21 + n22) - gBoth <- getGenotypes(qd, region = rBoth) - g21 <- getGenotypes(qd, region = r21) + gBoth <- genotypes(qd, region = rBoth) + g21 <- genotypes(qd, region = r21) expect_equal(unname(gBoth[, seq_len(n21)]), unname(g21)) expect_true(all(grepl("_c22$", colnames(gBoth)[(n21 + 1):(n21 + n22)]))) }) @@ -2276,13 +2276,13 @@ test_that("multi-region: single-range extraction is unchanged (regression)", { plink1Prefix = file.path(test_data_dir, "test_variants") ) qd <- QtlDataset( - study = "S", + studyName = "S", genotypes = h, - phenotypes = list(ctx = .mr_makeSE(getSampleIds(h))) + phenotypes = list(ctx = .mr_makeSE(sampleIds(h))) ) - bp <- getSnpInfo(h)$BP + bp <- snpInfo(h)$BP r <- GenomicRanges::GRanges("chr21", IRanges::IRanges(min(bp), max(bp))) - expect_equal(.mr_ncol(qd, r), nrow(getSnpInfo(h))) + expect_equal(.mr_ncol(qd, r), nrow(snpInfo(h))) }) test_that(".qtlResolveVariantRegion rejects a non-GRanges / empty region", { @@ -2291,25 +2291,25 @@ test_that(".qtlResolveVariantRegion rejects a non-GRanges / empty region", { plink1Prefix = file.path(test_data_dir, "test_variants") ) qd <- QtlDataset( - study = "S", + studyName = "S", genotypes = h, - phenotypes = list(ctx = .mr_makeSE(getSampleIds(h))) + phenotypes = list(ctx = .mr_makeSE(sampleIds(h))) ) expect_error( - getGenotypes(qd, region = "chr21:1-2"), + genotypes(qd, region = "chr21:1-2"), "Must inherit from class 'GRanges'" ) expect_error( - getGenotypes(qd, region = GenomicRanges::GRanges()), + genotypes(qd, region = GenomicRanges::GRanges()), "at least one range" ) }) # =========================================================================== -# Accessors: getGenotypeCovariates / getScaleResiduals / getPhenotypeCovariates +# Accessors: genotypeCovariates / scaleResiduals / phenotypeCovariates # =========================================================================== -test_that("getGenotypeCovariates / getScaleResiduals return their slots", { +test_that("genotypeCovariates / scaleResiduals return their slots", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -2322,36 +2322,36 @@ test_that("getGenotypeCovariates / getScaleResiduals return their slots", { scaleResiduals = FALSE ) expect_identical( - getGenotypeCovariates(qd), + genotypeCovariates(qd), pecotmr:::.qtlColDataMatrix(pecotmr:::.qtlGenotypeSe(qd)) ) - expect_equal(unname(getGenotypeCovariates(qd)), unname(gc)) - expect_false(getScaleResiduals(qd)) + expect_equal(unname(genotypeCovariates(qd)), unname(gc)) + expect_false(scaleResiduals(qd)) qd2 <- .qr_makeDataset(contexts = "brain", scaleResiduals = TRUE) - expect_true(getScaleResiduals(qd2)) + expect_true(scaleResiduals(qd2)) }) -test_that("getPhenotypeCovariates returns per-context colData matrices", { +test_that("phenotypeCovariates returns per-context colData matrices", { qd <- .qr_makeDataset(contexts = c("brain", "liver")) - out <- getPhenotypeCovariates(qd, contexts = c("brain", "liver")) + out <- phenotypeCovariates(qd, contexts = c("brain", "liver")) expect_equal(names(out), c("brain", "liver")) expect_true(is.matrix(out$brain)) expect_setequal(colnames(out$brain), c("sex", "age")) expect_equal(nrow(out$brain), 12L) # Single-context request still returns a named list of length 1. - one <- getPhenotypeCovariates(qd, contexts = "liver") + one <- phenotypeCovariates(qd, contexts = "liver") expect_equal(names(one), "liver") }) -test_that("getPhenotypeCovariates: requires contexts and rejects unknown ones", { +test_that("phenotypeCovariates: requires contexts and rejects unknown ones", { qd <- .qr_makeDataset(contexts = "brain") - expect_error(getPhenotypeCovariates(qd), "`contexts` is required") + expect_error(phenotypeCovariates(qd), "`contexts` is required") expect_error( - getPhenotypeCovariates(qd, contexts = character(0)), + phenotypeCovariates(qd, contexts = character(0)), "`contexts` is required" ) expect_error( - getPhenotypeCovariates(qd, contexts = "ghost"), + phenotypeCovariates(qd, contexts = "ghost"), "Unknown context" ) }) @@ -2419,39 +2419,39 @@ test_that(".qtlExtractBlock: keepSamples disjoint from the panel returns a zero- # survives the filter (exercising the mean-impute loop). .qh_naExtractor <- function() { function(handle, snpIdx, meanImpute = TRUE) { - ns <- length(getSampleIds(handle)) - nv <- nrow(getSnpInfo(handle)) + ns <- length(sampleIds(handle)) + nv <- nrow(snpInfo(handle)) set.seed(123L) panel <- matrix( rbinom(ns * nv, 2, 0.4), nrow = ns, ncol = nv, - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) panel["s1", ] <- NA_real_ # fully missing sample -> dropped by imiss panel["s2", "rs2"] <- NA_real_ # scattered NA -> kept then mean-imputed sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, colData = S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) ) } @@ -2474,38 +2474,38 @@ test_that(".qtlExtractBlock: imissCutoff drops high-missingness samples and mean # Extractor with one constant (zero-variance) column to drive the xvar filter. .qh_lowVarExtractor <- function() { function(handle, snpIdx, meanImpute = TRUE) { - ns <- length(getSampleIds(handle)) - nv <- nrow(getSnpInfo(handle)) + ns <- length(sampleIds(handle)) + nv <- nrow(snpInfo(handle)) set.seed(99L) panel <- matrix( rbinom(ns * nv, 2, 0.4), nrow = ns, ncol = nv, - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) panel[, "rs1"] <- 1L # constant column -> variance 0 sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, colData = S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) ) } @@ -2523,36 +2523,36 @@ test_that(".qtlExtractBlock: xvarCutoff drops near-constant (low-variance) varia }) # =========================================================================== -# getPhenotypes: contexts validation, region overlap filtering, empty-Y +# molecularTraits: contexts validation, region overlap filtering, empty-Y # =========================================================================== -test_that("getPhenotypes: requires contexts", { +test_that("molecularTraits: requires contexts", { qd <- .qr_makeDataset() - expect_error(getPhenotypes(qd), "`contexts` is required") + expect_error(molecularTraits(qd), "`contexts` is required") expect_error( - getPhenotypes(qd, contexts = character(0)), + molecularTraits(qd, contexts = character(0)), "`contexts` is required" ) }) -test_that("getPhenotypes: unknown context errors", { +test_that("molecularTraits: unknown context errors", { qd <- .qr_makeDataset() - expect_error(getPhenotypes(qd, contexts = "ghost"), "Unknown context") + expect_error(molecularTraits(qd, contexts = "ghost"), "Unknown context") }) -test_that("getPhenotypes: region keeps only overlapping traits", { +test_that("molecularTraits: region keeps only overlapping traits", { qd <- .qr_makeDataset(contexts = "brain") # brain SE: ENSG1 @ chr1:1000-1499, ENSG2 @ chr1:2000-2499. region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(900, 1600)) - out <- getPhenotypes(qd, contexts = "brain", region = region) + out <- molecularTraits(qd, contexts = "brain", region = region) expect_s4_class(out, "SummarizedExperiment") expect_equal(rownames(out), "ENSG1") }) -test_that("getPhenotypes: non-overlapping region + naAction='drop' hits the empty-Y short-circuit", { +test_that("molecularTraits: non-overlapping region + naAction='drop' hits the empty-Y short-circuit", { qd <- .qr_makeDataset(contexts = "brain") region <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1, 100)) # no overlap - out <- getPhenotypes( + out <- molecularTraits( qd, contexts = "brain", region = region, @@ -2680,7 +2680,7 @@ test_that("QtlDataset rejects a context that does not name its samples", { ) expect_error( QtlDataset( - study = "s1", + studyName = "s1", genotypes = .qr_makeHandle(n_samples = 6L), phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) @@ -2701,7 +2701,7 @@ test_that(".qtlBuildResidualizationDesign: disjoint blocks error", { dimnames = list(paste0("s", 7:12), "pc1") ) qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = gh, phenotypes = list(brain = se), genotypeCovariates = gc @@ -2723,7 +2723,7 @@ test_that(".qtlBuildResidualizationDesign: disjoint blocks error", { # getResidualized{Genotypes,Phenotypes}: disjoint sample-set errors # =========================================================================== -test_that("getResidualizedGenotypes: errors when genotypes and covariates share no samples", { +test_that("residualizedGenotypes: errors when genotypes and covariates share no samples", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -2736,7 +2736,7 @@ test_that("getResidualizedGenotypes: errors when genotypes and covariates share .package = "pecotmr" ) expect_error( - getResidualizedGenotypes( + residualizedGenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -2748,7 +2748,7 @@ test_that("getResidualizedGenotypes: errors when genotypes and covariates share ) }) -test_that("getResidualizedPhenotypes: errors when phenotypes and covariates share no samples", { +test_that("residualizedPhenotypes: errors when phenotypes and covariates share no samples", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -2757,7 +2757,7 @@ test_that("getResidualizedPhenotypes: errors when phenotypes and covariates shar ) qd <- .qr_makeDataset(contexts = "brain", geno_cov = gc) expect_error( - getResidualizedPhenotypes( + residualizedPhenotypes( qd, contexts = "brain", residualizationArgs = ResidualizationParam( @@ -2772,13 +2772,13 @@ test_that("getResidualizedPhenotypes: errors when phenotypes and covariates shar test_that("QtlDataset filter accessors report the construction settings", { data(qtlDatasetExample, envir = environment()) x <- qtlDatasetExample - expect_type(getMafCutoff(x), "double") - expect_length(getMafCutoff(x), 1L) - expect_length(getMacCutoff(x), 1L) - expect_length(getXvarCutoff(x), 1L) - expect_length(getImissCutoff(x), 1L) - expect_type(getKeepIndel(x), "logical") - expect_type(getKeepVariants(x), "character") + expect_type(mafCutoff(x), "double") + expect_length(mafCutoff(x), 1L) + expect_length(macCutoff(x), 1L) + expect_length(xvarCutoff(x), 1L) + expect_length(imissCutoff(x), 1L) + expect_type(keepIndel(x), "logical") + expect_type(keepVariants(x), "character") }) test_that("QtlDataset filter accessors round-trip what was passed in", { @@ -2793,21 +2793,21 @@ test_that("QtlDataset filter accessors round-trip what was passed in", { keepIndel = FALSE ) ) - expect_equal(getMafCutoff(x), 0.05) - expect_equal(getMacCutoff(x), 10) - expect_equal(getXvarCutoff(x), 0.01) - expect_equal(getImissCutoff(x), 0.1) - expect_false(getKeepIndel(x)) + expect_equal(mafCutoff(x), 0.05) + expect_equal(macCutoff(x), 10) + expect_equal(xvarCutoff(x), 0.01) + expect_equal(imissCutoff(x), 0.1) + expect_false(keepIndel(x)) }) -test_that("getGenotypeHandle returns the handle, getGenotypes a dosage block", { - # These are different accessors on purpose: getGenotypes() extracts - # dosages through the filter stack, getGenotypeHandle() hands back the +test_that("genotypeHandle returns the handle, genotypes a dosage block", { + # These are different accessors on purpose: genotypes() extracts + # dosages through the filter stack, genotypeHandle() hands back the # GenotypeHandle the dataset was built on. data(qtlDatasetExample, envir = environment()) x <- qtlDatasetExample - expect_s4_class(getGenotypeHandle(x), "GenotypeHandle") - expect_true(is.matrix(getGenotypes(x))) + expect_s4_class(genotypeHandle(x), "GenotypeHandle") + expect_true(is.matrix(genotypes(x))) }) @@ -2830,7 +2830,7 @@ test_that("getGenotypeHandle returns the handle, getGenotypes a dosage block", { brain <- brain[, seq_len(n_samples - 2L)] liver <- liver[, 3:n_samples] QtlDataset( - study = "study1", + studyName = "study1", genotypes = .qr_makeHandle(n_samples = n_samples), phenotypes = list(brain = brain, liver = liver), genotypeCovariates = matrix( @@ -2850,7 +2850,7 @@ test_that("a QtlDataset is a MultiAssayExperiment of contexts plus genotype", { c("genotype", "brain", "liver") ) # The genotype experiment is not a context. - expect_equal(getContexts(qd), c("brain", "liver")) + expect_equal(contexts(qd), c("brain", "liver")) }) test_that("the sampleMap records which samples each context observes", { @@ -2867,7 +2867,7 @@ test_that("the sampleMap records which samples each context observes", { test_that("the genotype experiment describes variants the way the readers do", { qd <- .qm_makeDataset() gr <- SummarizedExperiment::rowRanges(pecotmr:::.qtlGenotypeSe(qd)) - si <- getSnpInfo(getGenotypeHandle(qd)) + si <- snpInfo(genotypeHandle(qd)) expect_equal(length(gr), nrow(si)) # Same shape as extractBlockGenotypes() returns, so ranges from the two # actually overlap rather than silently missing on a chr prefix. @@ -2883,18 +2883,18 @@ test_that("the dosage assay is delayed and oriented variants x samples", { qd <- .qm_makeDataset() a <- SummarizedExperiment::assay(pecotmr:::.qtlGenotypeSe(qd), "dosage") expect_s4_class(a, "DelayedMatrix") - handle <- getGenotypeHandle(qd) - expect_equal(nrow(a), nrow(getSnpInfo(handle))) - expect_equal(ncol(a), length(getSampleIds(handle))) + handle <- genotypeHandle(qd) + expect_equal(nrow(a), nrow(snpInfo(handle))) + expect_equal(ncol(a), length(sampleIds(handle))) }) test_that("genotype covariates live on the genotype experiment's colData", { qd <- .qm_makeDataset() cd <- SummarizedExperiment::colData(pecotmr:::.qtlGenotypeSe(qd)) expect_equal(colnames(cd), c("pc1", "pc2")) - expect_equal(rownames(cd), getSampleIds(getGenotypeHandle(qd))) + expect_equal(rownames(cd), sampleIds(genotypeHandle(qd))) expect_equal( - getGenotypeCovariates(qd), + genotypeCovariates(qd), pecotmr:::.qtlColDataMatrix( pecotmr:::.qtlGenotypeSe(qd) ) @@ -2906,9 +2906,9 @@ test_that("subsetting by sample keeps the class and its own slots", { out <- qd[, paste0("s", 1:5), ] expect_s4_class(out, "QtlDataset") expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) - expect_equal(getStudy(out), getStudy(qd)) - expect_identical(getGenotypeHandle(out), getGenotypeHandle(qd)) - expect_equal(getMafCutoff(out), getMafCutoff(qd)) + expect_equal(studyName(out), studyName(qd)) + expect_identical(genotypeHandle(out), genotypeHandle(qd)) + expect_equal(mafCutoff(out), mafCutoff(qd)) }) test_that("subsetting by context keeps the genotype experiment", { @@ -2922,8 +2922,8 @@ test_that("subsetting by context keeps the genotype experiment", { names(MultiAssayExperiment::experiments(out)), c("genotype", "brain") ) - expect_equal(getContexts(out), "brain") - expect_equal(ncol(getGenotypeCovariates(out)), 2L) + expect_equal(contexts(out), "brain") + expect_equal(ncol(genotypeCovariates(out)), 2L) expect_true(validObject(out)) }) @@ -2933,7 +2933,7 @@ test_that("subsetting by sample and context together narrows both axes", { qd <- .qm_makeDataset() out <- suppressWarnings(suppressMessages(qd[, paste0("s", 1:5), "brain"])) expect_s4_class(out, "QtlDataset") - expect_equal(getContexts(out), "brain") + expect_equal(contexts(out), "brain") expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) expect_true(validObject(out)) }) @@ -2943,7 +2943,7 @@ test_that("subsetting by feature and context leaves the samples alone", { qd <- .qm_makeDataset() out <- suppressWarnings(suppressMessages(qd[1, , "brain"])) expect_s4_class(out, "QtlDataset") - expect_equal(getContexts(out), "brain") + expect_equal(contexts(out), "brain") expect_equal(nrow(MultiAssayExperiment::colData(out)), 12L) expect_true(validObject(out)) }) @@ -2954,7 +2954,7 @@ test_that("all three subscripts can be given at once", { qd[1, paste0("s", 1:5), "brain"] )) expect_s4_class(out, "QtlDataset") - expect_equal(getContexts(out), "brain") + expect_equal(contexts(out), "brain") expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) expect_true(validObject(out)) }) @@ -2997,7 +2997,7 @@ test_that("keepSamples narrows the dataset rather than recording a filter", { test_that("a context may not be called 'genotype'", { expect_error( QtlDataset( - study = "study1", + studyName = "study1", genotypes = .qr_makeHandle(), phenotypes = list(genotype = .qr_makeSe()) ), @@ -3010,16 +3010,16 @@ test_that("replacing the handle moves the assay's seed with it", { # assay lazy. Moving one without the other would have the dosages # describing a different panel from the one the accessors read. qd <- .qm_makeDataset() - handle <- getGenotypeHandle(qd) + handle <- genotypeHandle(qd) handle@path <- "pecotmr://extdata/elsewhere" out <- pecotmr:::.qtlWithGenotypeHandle(qd, handle) - seedPath <- getPath(pecotmr:::.ghSeedHandle( + seedPath <- path(pecotmr:::.ghSeedHandle( DelayedArray::seed(SummarizedExperiment::assay( pecotmr:::.qtlGenotypeSe(out), "dosage" )) )) - expect_equal(getPath(getGenotypeHandle(out)), "pecotmr://extdata/elsewhere") + expect_equal(path(genotypeHandle(out)), "pecotmr://extdata/elsewhere") expect_equal(seedPath, "pecotmr://extdata/elsewhere") }) @@ -3031,7 +3031,7 @@ test_that("replacing the handle moves the assay's seed with it", { .qmContextCells <- function(qd) { exps <- MultiAssayExperiment::experiments(qd) total <- 0L - for (ctx in getContexts(qd)) { + for (ctx in contexts(qd)) { se <- exps[[ctx]] total <- total + nrow(se) * ncol(se) } @@ -3062,10 +3062,10 @@ test_that("longForm(genotype = TRUE) reads the dosages in", { qd <- qtlDatasetExample lf <- MultiAssayExperiment::longForm(qd, genotype = TRUE) expect_true(is_in("genotype", unique(as.character(lf$assay)))) - handle <- getGenotypeHandle(qd) + handle <- genotypeHandle(qd) expect_equal( sum(as.character(lf$assay) == "genotype"), - nrow(getSnpInfo(handle)) * length(getSampleIds(handle)) + nrow(snpInfo(handle)) * length(sampleIds(handle)) ) }) @@ -3090,14 +3090,14 @@ test_that("QtlDataset accepts the panel readGenotypes returns", { gh <- .qh_makeHandle() panel <- .genotypeExperiment(gh) qd <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = panel, phenotypes = list(brain = .qh_makeSe()) ) expect_s4_class(qd, "QtlDataset") # The slot keeps the handle either way: it is the seed the dosage assay # reads through, not a second copy of the panel. - expect_identical(getGenotypeHandle(qd), gh) + expect_identical(genotypeHandle(qd), gh) expect_equal( dim(qd), dim(.qh_makeDataset(contexts = "brain")) @@ -3111,7 +3111,7 @@ test_that("QtlDataset refuses a panel that has already been subset", { panel <- .genotypeExperiment(gh) expect_error( QtlDataset( - study = "study1", + studyName = "study1", genotypes = panel[1:3, ], phenotypes = list(brain = .qh_makeSe()) ), @@ -3122,7 +3122,7 @@ test_that("QtlDataset refuses a panel that has already been subset", { test_that("QtlDataset still rejects a genotype source it cannot open", { expect_error( QtlDataset( - study = "study1", + studyName = "study1", genotypes = "not a panel", phenotypes = list(brain = .qh_makeSe()) ), diff --git a/tests/testthat/test_QtlFineMappingResult.R b/tests/testthat/test_QtlFineMappingResult.R index 33e31e93..5d02e521 100644 --- a/tests/testthat/test_QtlFineMappingResult.R +++ b/tests/testthat/test_QtlFineMappingResult.R @@ -6,7 +6,7 @@ test_that("QtlFineMappingResult: builds a collection keyed by 4-tuple", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), @@ -14,7 +14,7 @@ test_that("QtlFineMappingResult: builds a collection keyed by 4-tuple", { ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) - expect_null(getLdSketch(res)) + expect_null(ldSketch(res)) }) @@ -26,7 +26,7 @@ test_that("QtlFineMappingResult: validity does not recurse on key subset (#546)" # "missing columns: entry". Guard the reporter's exact scenario. e <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( - study = "s", + studyName = "s", context = "c", trait = "t", method = "qsusie", @@ -42,7 +42,7 @@ test_that("QtlFineMappingResult: validity does not recurse on key subset (#546)" c("study", "context", "trait", "method"), drop = FALSE ] - expect_false("entry" %in% names(sub)) + expect_false("entry" %in% names(S4Vectors::mcols(sub))) }) @@ -50,7 +50,7 @@ test_that("QtlFineMappingResult: stores an LD sketch when supplied", { e <- .sc_makeFineMappingRow(3) gh <- .sc_makeGenotypeHandle() res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -58,8 +58,8 @@ test_that("QtlFineMappingResult: stores an LD sketch when supplied", { ldSketch = gh ) # The slot holds the panel; the handle it reads through is its seed. - expect_s4_class(getLdSketch(res), "RangedSummarizedExperiment") - expect_identical(pecotmr:::.ldSketchHandle(getLdSketch(res)), gh) + expect_s4_class(ldSketch(res), "RangedSummarizedExperiment") + expect_identical(pecotmr:::.ldSketchHandle(ldSketch(res)), gh) }) @@ -67,7 +67,7 @@ test_that("QtlFineMappingResult: errors on length mismatch", { e <- .sc_makeFineMappingRow(3) expect_error( QtlFineMappingResult( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1"), trait = c("t1"), method = c("susie"), @@ -83,7 +83,7 @@ test_that("QtlFineMappingResult: validity rejects duplicate 4-tuples", { e2 <- .sc_makeFineMappingRow(3) expect_error( QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("susie", "susie"), @@ -94,46 +94,46 @@ test_that("QtlFineMappingResult: validity rejects duplicate 4-tuples", { }) -test_that("QtlFineMappingResult: getFineMappingResult returns selected entry", { +test_that("QtlFineMappingResult: fineMappingResult returns selected entry", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2) ) - picked <- getFineMappingResult( + picked <- fineMappingResult( res, - study = "s1", + studyName = "s1", context = "c2", trait = "t1", method = "susie" ) - # getFineMappingResult() returns the single-row COLLECTION for that tuple + # fineMappingResult() returns the single-row COLLECTION for that tuple # -- there is no detached entry object -- so compare what the row carries. expect_s4_class(picked, "QtlFineMappingResult") expect_equal(nrow(picked), 1L) - expect_identical(getVariantIds(picked), getVariantIds(e2)) - expect_identical(getSusieFit(picked), getSusieFit(e2)) - expect_equal(getPip(picked), .fmrRowPip(e2)) + expect_identical(variantIds(picked), variantIds(e2)) + expect_identical(susieFit(picked), susieFit(e2)) + expect_equal(pip(picked), .fmrRowPip(e2)) }) -test_that("QtlFineMappingResult: getFineMappingResult errors on missing tuple", { +test_that("QtlFineMappingResult: fineMappingResult errors on missing tuple", { e <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) expect_error( - getFineMappingResult( + fineMappingResult( res, - study = "ghost", + studyName = "ghost", context = "c1", trait = "t1", method = "susie" @@ -146,24 +146,24 @@ test_that("QtlFineMappingResult: getFineMappingResult errors on missing tuple", test_that("QtlFineMappingResult: single-row collection allows omitting selectors", { e <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) - picked <- getFineMappingResult(res) + picked <- fineMappingResult(res) expect_s4_class(picked, "QtlFineMappingResult") expect_equal(nrow(picked), 1L) - expect_identical(getVariantIds(picked), .fmrPartsVariantIds(e)) - expect_identical(getSusieFit(picked), .fmrPartsSusieFit(e)) + expect_identical(variantIds(picked), .fmrPartsVariantIds(e)) + expect_identical(susieFit(picked), .fmrPartsSusieFit(e)) }) test_that("QtlFineMappingResult: show prints summary", { e <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -176,7 +176,7 @@ test_that("QtlFineMappingResult: show prints summary", { test_that("QtlFineMappingResult: joint columns absent by default", { e <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -193,7 +193,7 @@ test_that("QtlFineMappingResult: accepts jointContexts column", { # Univariate susie at c1 + the c1 slice of an mvsusie joint over (c1, c2): # both real context c1, distinguished by method and the jointContexts tag. res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("susie", "mvsusie"), @@ -211,7 +211,7 @@ test_that("QtlFineMappingResult: jointStudies + jointTraits combine cleanly", { # a different joint fit: univariate; a cross-study+trait mvsusieRss; a # cross-context mvsusie. The joint* tags carry each fit's co-fit membership. res <- QtlFineMappingResult( - study = c("s1", "s1", "s1"), + studyName = c("s1", "s1", "s1"), context = c("c1", "c1", "c1"), trait = c("t1", "t1", "t1"), method = c("susie", "mvsusieRss", "mvsusie"), @@ -232,7 +232,7 @@ test_that("QtlFineMappingResult: uniqueness distinguishes joint members", { # -- one over (c1, c2), one over (c1, c3) -- producing two c1 rows with the # same 4-tuple, kept distinct only by their jointContexts membership. res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("mvsusie", "mvsusie"), @@ -243,7 +243,7 @@ test_that("QtlFineMappingResult: uniqueness distinguishes joint members", { # same 4-tuple AND same jointContexts -> duplicate expect_error( QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("mvsusie", "mvsusie"), @@ -259,7 +259,7 @@ test_that("QtlFineMappingResult: length-mismatched joint vector errors", { e <- .sc_makeFineMappingRow(3) expect_error( QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -278,7 +278,7 @@ test_that("QtlFineMappingResult: length-mismatched joint vector errors", { test_that("show.QtlFineMappingResult prints entry/study/context/trait/method counts", { res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susieRss"), @@ -293,7 +293,7 @@ test_that("show.QtlFineMappingResult prints entry/study/context/trait/method cou test_that("show.QtlFineMappingResult reports the ldSketch source when present", { res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -307,19 +307,19 @@ test_that("show.QtlFineMappingResult reports the ldSketch source when present", # === Tests migrated from test_collectionAccessors.R (QtlFineMappingResult) === -test_that("QtlFineMappingResult: getPip returns named pip vector for selected tuple", { +test_that("QtlFineMappingResult: pip returns named pip vector for selected tuple", { e1 <- .ca_makeFmEntry(3) e2 <- .ca_makeFmEntry(4) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2) ) - pip <- getPip( + pip <- pip( res, - study = "s1", + studyName = "s1", context = "c2", trait = "t1", method = "susie" @@ -329,145 +329,146 @@ test_that("QtlFineMappingResult: getPip returns named pip vector for selected tu }) -test_that("QtlFineMappingResult: getPip(returnList = TRUE) wraps in pipe-keyed list", { +test_that("QtlFineMappingResult: pip(returnList = TRUE) wraps in pipe-keyed list", { e <- .ca_makeFmEntry(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) - out <- getPip(res, returnList = TRUE) + out <- pip(res, returnList = TRUE) expect_true(is.list(out)) expect_equal(names(out), "s1|c1|t1|susie") }) -test_that("QtlFineMappingResult: getCs filters to credible sets", { +test_that("QtlFineMappingResult: credibleSets filters to credible sets", { e <- .ca_makeFmEntry(3) # cs_95 = c("susie_1", "susie_1", "susie_0") res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) - cs <- getCs(res) + cs <- credibleSets(res) expect_equal(nrow(cs), 2L) }) -test_that("QtlFineMappingResult: getTopLoci returns the entry's topLoci (projected)", { +test_that("QtlFineMappingResult: topLoci returns the entry's topLoci (projected)", { e <- .ca_makeFmEntry(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) - tl <- getTopLoci(res, signalCutoff = 0) - expect_equal(nrow(tl), 3L) + tl <- topLoci(res, signalCutoff = 0) + expect_equal(length(tl), 3L) expect_equal(tl$variant_id, .ca_makeTopLoci(3)$variant_id) }) -test_that("QtlFineMappingResult: getTopLoci aggregates entries when selectors do not pin one", { +test_that("QtlFineMappingResult: topLoci aggregates entries when selectors do not pin one", { # Two entries, no selectors: the old behaviour errored ("2 entries; pass # study/context/trait/method"). Now it stacks the per-variant tables, # prefixed with the row identity so variants stay attributable. e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2) ) - agg <- getTopLoci(res, signalCutoff = 0) - expect_equal(nrow(agg), 5L) + agg <- topLoci(res, signalCutoff = 0) + expect_equal(length(agg), 5L) expect_true(all( c("study", "context", "trait", "blockId", "method") %in% - names(agg) + names(S4Vectors::mcols(agg)) )) expect_equal(agg$context, c("c1", "c1", "c1", "c2", "c2")) - expect_true("variant_id" %in% names(agg)) + expect_true("variant_id" %in% names(S4Vectors::mcols(agg))) # QTL results key on context/trait, so blockId is NA-filled. expect_true(all(is.na(agg$blockId))) # the added per-variant `method` must not duplicate the identity column - expect_equal(sum(names(agg) == "method"), 1L) + expect_equal(sum(names(S4Vectors::mcols(agg)) == "method"), 1L) }) -test_that("QtlFineMappingResult: getTopLoci with a full tuple keeps the bare (id-free) table", { +test_that("QtlFineMappingResult: topLoci with a full tuple keeps the bare (id-free) table", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2) ) - tl <- getTopLoci( + tl <- topLoci( res, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", signalCutoff = 0 ) - expect_equal(nrow(tl), 3L) - expect_false("context" %in% names(tl)) # single-entry fast path, unchanged + expect_equal(length(tl), 3L) + # single-entry fast path, unchanged + expect_false(is_in("context", names(S4Vectors::mcols(tl)))) }) -test_that("QtlFineMappingResult: getTopLoci aggregates only the matching subset", { +test_that("QtlFineMappingResult: topLoci aggregates only the matching subset", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2) ) - sub <- getTopLoci(res, context = "c2", signalCutoff = 0) - expect_equal(nrow(sub), 2L) + sub <- topLoci(res, context = "c2", signalCutoff = 0) + expect_equal(length(sub), 2L) expect_equal(unique(sub$context), "c2") }) -test_that("QtlFineMappingResult: getTopLoci on a single-row collection still carries identity columns", { +test_that("QtlFineMappingResult: topLoci on a single-row collection still carries identity columns", { # A no-selector call takes the aggregate path even for one row, so the PIP # table has a uniform shape (identity columns present) whatever the row count # -- callers don't special-case single-entry results. res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(.sc_makeFineMappingRow(4)) ) - tl <- getTopLoci(res, signalCutoff = 0) - expect_equal(nrow(tl), 4L) + tl <- topLoci(res, signalCutoff = 0) + expect_equal(length(tl), 4L) expect_true(all( c("study", "context", "trait", "method", "variant_id") %in% - names(tl) + names(S4Vectors::mcols(tl)) )) expect_equal(unique(tl$context), "c1") }) -test_that("QtlFineMappingResult: getCs aggregates every entry's credible sets with identity columns", { +test_that("QtlFineMappingResult: credibleSets aggregates every entry's credible sets with identity columns", { # e1 (n=3) has cs_95 = susie_1/susie_1/susie_0 -> 2 CS members; e2 (n=2) -> 2. e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2) ) - cs <- getCs(res) + cs <- credibleSets(res) expect_equal(nrow(cs), 4L) expect_true(all( c("study", "context", "trait", "blockId", "method", "variant_id") %in% @@ -475,9 +476,9 @@ test_that("QtlFineMappingResult: getCs aggregates every entry's credible sets wi )) expect_equal(cs$context, c("c1", "c1", "c2", "c2")) # full tuple still returns the bare per-entry credible-set table - bare <- getCs( + bare <- credibleSets( res, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie" @@ -486,66 +487,66 @@ test_that("QtlFineMappingResult: getCs aggregates every entry's credible sets wi expect_equal(nrow(bare), 2L) }) -test_that("QtlFineMappingResult: getMarginalEffects aggregates every entry with identity columns", { +test_that("QtlFineMappingResult: marginalEffects aggregates every entry with identity columns", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), entry = list(e1, e2) ) - me <- getMarginalEffects(res) + me <- marginalEffects(res) expect_equal(nrow(me), 5L) # all topLoci rows (no CS filter) expect_true(all(c("study", "context", "trait", "method") %in% names(me))) expect_equal(unique(me$context), c("c1", "c2")) }) -test_that("QtlFineMappingResult: getSusieFit reads the entry's trimmedFit", { +test_that("QtlFineMappingResult: susieFit reads the entry's trimmedFit", { e <- .ca_makeFmEntry(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) - expect_equal(getSusieFit(res), list(payload = "fit_n=3")) + expect_equal(susieFit(res), list(payload = "fit_n=3")) }) -test_that("QtlFineMappingResult: getVariantIds reads the entry's variantIds", { +test_that("QtlFineMappingResult: variantIds reads the entry's variantIds", { e <- .ca_makeFmEntry(3) res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) - expect_equal(length(getVariantIds(res)), 3L) + expect_equal(length(variantIds(res)), 3L) }) -test_that("QtlFineMappingResult: getStudy/getContexts/getTraits/getMethodNames are unique", { +test_that("QtlFineMappingResult: studyName/contexts/traitNames/methodNames are unique", { e <- .ca_makeFmEntry(3) res <- QtlFineMappingResult( - study = c("s1", "s1", "s2"), + studyName = c("s1", "s1", "s2"), context = c("c1", "c2", "c1"), trait = c("t1", "t1", "t1"), method = c("susie", "susieRss", "susie"), entry = list(e, e, e) ) - expect_setequal(getStudy(res), c("s1", "s2")) - expect_setequal(getContexts(res), c("c1", "c2")) - expect_equal(getTraits(res), "t1") - expect_setequal(getMethodNames(res), c("susie", "susieRss")) + expect_setequal(studyName(res), c("s1", "s2")) + expect_setequal(contexts(res), c("c1", "c2")) + expect_equal(traitNames(res), "t1") + expect_setequal(methodNames(res), c("susie", "susieRss")) }) -test_that("getCvResult works at the QtlFineMappingResult collection level", { +test_that("cvResult works at the QtlFineMappingResult collection level", { tl <- data.frame( variant_id = "chr1:100:A:G", pip = 0.5, @@ -558,16 +559,16 @@ test_that("getCvResult works at the QtlFineMappingResult collection level", { ) e <- fineMappingRow("chr1:100:A:G", list(), tl, cvResult = cv) fmr <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "C", trait = "T", method = "susie", entry = list(e) ) expect_identical( - getCvResult( + cvResult( fmr, - study = "S", + studyName = "S", context = "C", trait = "T", method = "susie" @@ -577,11 +578,11 @@ test_that("getCvResult works at the QtlFineMappingResult collection level", { }) -test_that("QtlFineMappingResult: getMarginalEffects with tuple selectors", { +test_that("QtlFineMappingResult: marginalEffects with tuple selectors", { e1 <- .ca_makeFmEntry(3) e2 <- .ca_makeFmEntry(4) res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("susie", "susie"), @@ -589,9 +590,9 @@ test_that("QtlFineMappingResult: getMarginalEffects with tuple selectors", { ) # Collection-level selection picks the (s1, c2, t1, susie) entry, then # delegates to the entry-level getMarginalEffects. - me <- getMarginalEffects( + me <- marginalEffects( res, - study = "s1", + studyName = "s1", context = "c2", trait = "t1", method = "susie" @@ -615,7 +616,7 @@ test_that("QtlFineMappingResult: getMarginalEffects with tuple selectors", { .qfmr_res <- function() { QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -659,13 +660,13 @@ test_that("a QtlFineMappingResult refuses a region selector", { # 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"), + susieFit(qtlFineMappingExample, region = "chr22:1-2"), "not region-indexed" ) expect_error( - getVariantIds(qtlFineMappingExample, region = "chr22:1-2"), + variantIds(qtlFineMappingExample, region = "chr22:1-2"), "not region-indexed" ) # The supported selectors still work. - expect_type(getSusieFit(qtlFineMappingExample, method = "susie"), "list") + expect_type(susieFit(qtlFineMappingExample, method = "susie"), "list") }) diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 6dfd637f..047e2810 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -640,8 +640,11 @@ test_that("nestTupleRanges round-trips an unmodified flatten", { expect_equal(mcols(back), mcols(mc)) # Collection-level slots survive, which is the point of nesting through a # template rather than rebuilding from the ranges alone. - expect_identical(getLdSketch(back), getLdSketch(mc)) - expect_identical(getGenome(back), getGenome(mc)) + expect_identical(ldSketch(back), ldSketch(mc)) + expect_identical( + unname(GenomeInfoDb::genome(back)), + unname(GenomeInfoDb::genome(mc)) + ) }) test_that("nestTupleRanges returns a filtered flatten to its elements", { @@ -715,7 +718,7 @@ test_that("filter keeps the collection and narrows its elements", { expect_s4_class(out, "QtlSumStats") expect_equal(nrow(out), nrow(mc)) expect_lt(sum(lengths(out)), sum(lengths(mc))) - expect_identical(getLdSketch(out), getLdSketch(mc)) + expect_identical(ldSketch(out), ldSketch(mc)) }) test_that("filter can mix identity and per-range columns", { diff --git a/tests/testthat/test_SldscData.R b/tests/testthat/test_SldscData.R index cfeb02d2..7cb3230b 100644 --- a/tests/testthat/test_SldscData.R +++ b/tests/testthat/test_SldscData.R @@ -9,25 +9,25 @@ test_that("SldscData constructs from in-memory objects", { test_that("SldscData defaults frq to a 0-row data.frame when NULL", { sd <- .sldscMkData(withFrq = FALSE) expect_s4_class(sd, "SldscData") - expect_equal(nrow(getFrqData(sd)), 0L) + expect_equal(nrow(frqData(sd)), 0L) }) -test_that("SldscData errors when `annot` is missing", { - expect_error(SldscData(), "`annot` is required") +test_that("SldscData errors when `annotData` is missing", { + expect_error(SldscData(), "`annotData` is required") }) # ---- validity ---- test_that("validity rejects annot without CHR/SNP", { expect_error( - SldscData(annot = data.frame(SNP = "rs1", annot_A = 1)), + SldscData(annotData = data.frame(SNP = "rs1", annot_A = 1)), "must have columns CHR and SNP" ) }) test_that("validity rejects annot with no annotation column", { expect_error( - SldscData(annot = data.frame(CHR = 1, SNP = "rs1")), + SldscData(annotData = data.frame(CHR = 1, SNP = "rs1")), "at least one annotation column" ) }) @@ -35,8 +35,8 @@ test_that("validity rejects annot with no annotation column", { test_that("validity rejects a non-empty frq without SNP/MAF", { expect_error( SldscData( - annot = data.frame(CHR = 1, SNP = "rs1", a = 1), - frq = data.frame(CHR = 1, foo = 0.2) + annotData = data.frame(CHR = 1, SNP = "rs1", a = 1), + frqData = data.frame(CHR = 1, foo = 0.2) ), "non-empty `frq` must have columns SNP and MAF" ) @@ -46,7 +46,7 @@ test_that("validity rejects unnamed traits", { run <- .sldscMkRun(c("annot_A_0")) expect_error( SldscData( - annot = data.frame(CHR = 1, SNP = "rs1", a = 1), + annotData = data.frame(CHR = 1, SNP = "rs1", a = 1), traits = list(list(single = list(run))) ), "must be a named list" @@ -57,7 +57,7 @@ test_that("validity rejects a trait without a `single` element", { run <- .sldscMkRun(c("annot_A_0")) expect_error( SldscData( - annot = data.frame(CHR = 1, SNP = "rs1", a = 1), + annotData = data.frame(CHR = 1, SNP = "rs1", a = 1), traits = list(traitX = list(joint = run)) ), "must be a list with a `single` element" @@ -66,43 +66,43 @@ test_that("validity rejects a trait without a `single` element", { # ---- accessors ---- -test_that("getAnnotData / getFrqData return the stored frames", { +test_that("annotData / frqData return the stored frames", { sd <- .sldscMkData() - expect_s3_class(getAnnotData(sd), "data.frame") - expect_equal(nrow(getAnnotData(sd)), 6L) - expect_equal(nrow(getFrqData(sd)), 6L) + expect_s3_class(annotData(sd), "data.frame") + expect_equal(nrow(annotData(sd)), 6L) + expect_equal(nrow(frqData(sd)), 6L) }) -test_that("getAnnotCols returns the annotation columns only", { +test_that("annotCols returns the annotation columns only", { sd <- .sldscMkData() - expect_equal(getAnnotCols(sd), c("annot_A", "annot_B")) + expect_equal(annotCols(sd), c("annot_A", "annot_B")) }) -test_that("getTraitRuns / getTraits expose the traits list", { +test_that("sldscResults / traitNames expose the traits list", { sd <- .sldscMkData() - expect_equal(getTraits(sd), c("traitX", "traitY")) - expect_named(getTraitRuns(sd), c("traitX", "traitY")) + expect_equal(traitNames(sd), c("traitX", "traitY")) + expect_named(sldscResults(sd), c("traitX", "traitY")) }) -test_that("getTraitRun retrieves single (by idx), joint, and NULL cases", { +test_that("sldscResults retrieves single (by idx), joint, and NULL cases", { sd <- .sldscMkData() - single1 <- getTraitRun(sd, "traitX", "single", 1L) + single1 <- sldscResults(sd, "traitX", "single", 1L) expect_equal(single1$categories, c("annot_A_0", "baselineLD_0")) expect_equal( - getTraitRun(sd, "traitX", "joint")$categories, + sldscResults(sd, "traitX", "joint")$categories, c("annot_A_0", "annot_B_0", "baselineLD_0") ) # whole single list when idx is NULL - expect_length(getTraitRun(sd, "traitX", "single"), 2L) + expect_length(sldscResults(sd, "traitX", "single"), 2L) # out-of-range idx -> NULL - expect_null(getTraitRun(sd, "traitX", "single", 5L)) + expect_null(sldscResults(sd, "traitX", "single", 5L)) # unknown trait -> NULL - expect_null(getTraitRun(sd, "no_such_trait", "joint")) + expect_null(sldscResults(sd, "no_such_trait", "joint")) }) -test_that("getTraitRun returns NULL joint when a trait has none", { +test_that("sldscResults returns NULL joint when a trait has none", { sd <- .sldscMkData(withJoint = FALSE) - expect_null(getTraitRun(sd, "traitX", "joint")) + expect_null(sldscResults(sd, "traitX", "joint")) }) test_that("show prints a compact summary", { diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index 533ee1c2..d7597f7d 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -29,31 +29,31 @@ context("causalInferencePipeline") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -79,7 +79,7 @@ context("causalInferencePipeline") MAF = rep(0.3, 5) ) GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = .cip_makeHandle(), @@ -96,7 +96,7 @@ context("causalInferencePipeline") weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = method, @@ -113,7 +113,7 @@ context("causalInferencePipeline") variant_id = variant_ids, pip = c(0.9, 0.05, 0.5, 0.8, 0.01), # posterior_mean / posterior_sd carry the "fine-mapped causal effect" - # estimates that getTopLoci surfaces as beta / se in its projected + # estimates that topLoci surfaces as beta / se in its projected # output (the column names downstream MR / TWAS code reads). posterior_mean = c(0.2, 0.05, -0.1, 0.3, 0.0), posterior_sd = rep(0.05, n), @@ -125,7 +125,7 @@ context("causalInferencePipeline") topLoci = tl ) QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -183,7 +183,7 @@ test_that("causalInferencePipeline: rejects GwasFineMappingResult for the QTL sl ) ) gfmr <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(e) ) @@ -203,7 +203,7 @@ test_that("causalInferencePipeline: rejects GwasFineMappingResult for the QTL sl test_that(".cipRequireMatchingLdSketches: NULL twas-side ldSketch is allowed", { # Build a TwasWeights without an ldSketch. twNoLd <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "lasso", @@ -227,7 +227,7 @@ test_that(".cipRequireMatchingLdSketches: NULL twas-side ldSketch is allowed", { test_that(".cipRequireMatchingLdSketches: sample set mismatch errors", { otherPanel <- .cip_makeHandle(sample_prefix = "other") twOther <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "lasso", @@ -334,7 +334,7 @@ test_that("causalInferencePipeline: FMR-only path extracts weights from topLoci$ test_that("causalInferencePipeline: combineMethods appends combined rows", { tw1 <- TwasWeights( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "enet"), @@ -388,7 +388,7 @@ test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, S ) } tw <- TwasWeights( - study = rep("S", 4), + studyName = rep("S", 4), context = rep("c1", 4), trait = c("G", "G", "G", "G2"), method = c("susie", "enet", "lasso", "susie"), @@ -417,7 +417,7 @@ test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, S ) # pval gate: a high-rsq method with a bad CV p-value is excluded. tw2 <- TwasWeights( - study = rep("S", 2), + studyName = rep("S", 2), context = rep("c1", 2), trait = rep("G", 2), method = c("susie", "lasso"), @@ -434,7 +434,7 @@ test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, S expect_equal(f2$method, "lasso") # SS-TWAS: no usable cvResult -> keep all methods in the group. twss <- TwasWeights( - study = rep("S", 2), + studyName = rep("S", 2), context = rep("c1", 2), trait = rep("G", 2), method = c("susie", "lasso"), @@ -489,7 +489,7 @@ test_that(".cipSelectBestMethod: max-rsq finite Z, NA/Inf re-selection, SS-TWAS test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per group", { tw <- TwasWeights( - study = rep("Q1", 2), + studyName = rep("Q1", 2), context = rep("c1", 2), trait = rep("t1", 2), method = c("susie", "lasso"), @@ -521,7 +521,7 @@ test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per gro test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", { tw <- TwasWeights( - study = rep("Q1", 2), + studyName = rep("Q1", 2), context = rep("c1", 2), trait = rep("t1", 2), method = c("susie", "lasso"), @@ -555,7 +555,7 @@ test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods", { tw <- TwasWeights( - study = rep("Q1", 2), + studyName = rep("Q1", 2), context = rep("c1", 2), trait = rep("t1", 2), method = c("susie", "lasso"), @@ -1166,9 +1166,9 @@ test_that("twasZ: error when weights and z have different lengths", { # Phase 2: LD-sketch loading and standardize_genotype_hwe() # =========================================================================== -# Direct unit tests for the MR / metric helpers (mock getTopLoci to feed +# Direct unit tests for the MR / metric helpers (mock topLoci to feed # controlled topLoci frames; gwasDf is a plain data.frame as produced by -# getSumStatsDf upstream). +# as.data.frame upstream). # =========================================================================== .cip_gwasDf <- function( @@ -1202,7 +1202,7 @@ test_that(".cipComputeMr: IVW Wald-ratio over PIP-passing instruments", { se = rep(0.05, 4), stringsAsFactors = FALSE ) - local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") res <- pecotmr:::.cipComputeMr( NULL, .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:4)), c(2, -1.5, 1, 1.8)), @@ -1213,6 +1213,59 @@ test_that(".cipComputeMr: IVW Wald-ratio over PIP-passing instruments", { expect_equal(res$nIV, 3L) # v1, v2, v4 pass + overlap }) +# --------------------------------------------------------------------------- +# Exposure / outcome scale agreement. Without maf + N the outcome falls back +# to z with unit se; the exposure has to follow, or the Wald ratio is a ratio +# of incommensurable units, inflated by 1/seX (answers like -1094 +/- 1105). +# --------------------------------------------------------------------------- + +test_that(".cipComputeMr: the exposure standardizes when maf/N are absent", { + tl <- data.frame( + variant_id = "chr1:100:A:G", + pip = 0.9, + beta = 0.3, + se = 0.01, + stringsAsFactors = FALSE + ) + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + g <- .cip_gwasDf("chr1:100:A:G", 2) + noScale <- g[, setdiff(names(g), c("N", "maf"))] + res <- pecotmr:::.cipComputeMr(NULL, noScale, pipCutoff = 0.5) + # A single instrument, so IVW hands back its own ratio: z / (beta / se). + # Before the fix this was z / beta -- 100x larger for this instrument. + expect_equal(res$nIV, 1L) + expect_equal(res$waldRatio, 2 / (0.3 / 0.01)) + # With maf and N the outcome is a real effect size, so the raw exposure + # stands and the ratio stays interpretable. + keep <- pecotmr:::.cipComputeMr(NULL, g, pipCutoff = 0.5) + expect_equal( + keep$waldRatio, + pecotmr:::.cipZToBeta(2, 0.3, 1000) / 0.3 + ) +}) + +test_that(".cipCsAwareAlign: exposure scale follows the GWAS, both ways", { + raw <- list( + cs = c(1L, 1L), + pip = c(0.6, 0.3), + bhatX = c(0.3, -0.2), + sbhatX = c(0.05, 0.04), + vids = sprintf("chr1:%d:A:G", c(100L, 200L)) + ) + g <- .cip_gwasDf(raw$vids, c(2, -1.5)) + al <- pecotmr:::.cipCsAwareAlign(raw, g, alleleFlip = TRUE) + # maf + N present: both sides are real effect sizes, so the exposure + # keeps its own SE rather than being forced to 1. This is the half that + # was wrong before -- csAware standardized unconditionally. + expect_equal(al$bhatX, raw$bhatX) + expect_equal(al$sbhatX, raw$sbhatX) + # Without them the outcome is z / 1, so the exposure standardizes. + noScale <- g[, setdiff(names(g), c("N", "maf"))] + alNo <- pecotmr:::.cipCsAwareAlign(raw, noScale, alleleFlip = TRUE) + expect_equal(alNo$bhatX, raw$bhatX / raw$sbhatX) + expect_equal(alNo$sbhatX, rep(1, 2)) +}) + # --------------------------------------------------------------------------- # Phase 3: tuple-based (chrom/pos/allele) matching of QTL exposure to GWAS. # Positional ids exercise matchVariants' tuple path (the v1.. fixtures above @@ -1229,7 +1282,7 @@ test_that(".cipComputeMr matches across a chr-prefix difference (tuple match)", se = c(0.05, 0.05), stringsAsFactors = FALSE ) - local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") # GWAS carries the same variants without the "chr" prefix. g <- .cip_gwasDf(c("1:100:A:G", "1:200:A:G"), z = c(2, 1.5)) res <- pecotmr:::.cipComputeMr(NULL, g, pipCutoff = 0.5) @@ -1245,7 +1298,7 @@ test_that(".cipComputeMr includes an allele-swapped GWAS variant and flips the s se = 0.05, stringsAsFactors = FALSE ) - local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") rSame <- pecotmr:::.cipComputeMr( NULL, .cip_gwasDf("chr1:100:A:G", z = 2.0), @@ -1270,7 +1323,7 @@ test_that(".cipComputeMr with alleleFlip = FALSE drops an allele-swapped GWAS va se = 0.05, stringsAsFactors = FALSE ) - local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") # GWAS variant is the ref/alt swap; with flipping disabled it is not matched. rSwap <- pecotmr:::.cipComputeMr( NULL, @@ -1291,7 +1344,7 @@ test_that(".cipComputeMrCsAware matches across a chr-prefix difference", { se = c(0.05, 0.05), stringsAsFactors = FALSE ) - local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") g <- .cip_gwasDf(c("1:100:A:G", "1:200:A:G"), z = c(2, 1.5)) res <- pecotmr:::.cipComputeMrCsAware(NULL, g, cpipCutoff = 0.5) expect_equal(res$nCs, 1L) @@ -1322,12 +1375,12 @@ test_that(".cipComputeMr: NA on empty / missing-col / no-IV / no-overlap / zero- expect_equal(r$nIV, 0L) } local_mocked_bindings( - getTopLoci = function(x, ...) data.frame(), + .cipTopLociTable = function(x, ...) data.frame(), .package = "pecotmr" ) isNa(pecotmr:::.cipComputeMr(NULL, g, 0.5)) # empty local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # no beta/se data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1338,7 +1391,7 @@ test_that(".cipComputeMr: NA on empty / missing-col / no-IV / no-overlap / zero- ) isNa(pecotmr:::.cipComputeMr(NULL, g, 0.5)) local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # none pass data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1351,7 +1404,7 @@ test_that(".cipComputeMr: NA on empty / missing-col / no-IV / no-overlap / zero- ) isNa(pecotmr:::.cipComputeMr(NULL, g, 0.5)) local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # no overlap data.frame( variant_id = paste0("z", 1:4), @@ -1364,7 +1417,7 @@ test_that(".cipComputeMr: NA on empty / missing-col / no-IV / no-overlap / zero- ) isNa(pecotmr:::.cipComputeMr(NULL, g, 0.5)) local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # zero beta data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1387,7 +1440,7 @@ test_that(".cipComputeMrCsAware: CS-aware composite Wald + heterogeneity", { se = rep(0.05, 4), stringsAsFactors = FALSE ) - local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") res <- pecotmr:::.cipComputeMrCsAware( NULL, .cip_gwasDf( @@ -1410,7 +1463,7 @@ test_that(".cipComputeMrCsAware: credible-set column found via the ^cs fallback" se = rep(0.05, 2), stringsAsFactors = FALSE ) - local_mocked_bindings(getTopLoci = function(x) tl, .package = "pecotmr") + local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") res <- pecotmr:::.cipComputeMrCsAware( NULL, .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:2)), c(2, -1.5)), @@ -1423,12 +1476,12 @@ test_that(".cipComputeMrCsAware: naResult on empty / missing-col / no-CS / no-ov g <- .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:4))) isNa <- function(r) expect_true(is.na(r$waldRatio)) local_mocked_bindings( - getTopLoci = function(x, ...) data.frame(), + .cipTopLociTable = function(x, ...) data.frame(), .package = "pecotmr" ) isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5)) # empty local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # no pip col data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1441,7 +1494,7 @@ test_that(".cipComputeMrCsAware: naResult on empty / missing-col / no-CS / no-ov ) isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5)) local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # cs all 0 data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1455,7 +1508,7 @@ test_that(".cipComputeMrCsAware: naResult on empty / missing-col / no-CS / no-ov ) isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5)) local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # no overlap data.frame( variant_id = paste0("z", 1:4), @@ -1469,7 +1522,7 @@ test_that(".cipComputeMrCsAware: naResult on empty / missing-col / no-CS / no-ov ) isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5)) local_mocked_bindings( - getTopLoci = function(x) { + .cipTopLociTable = function(x) { # cpip < cutoff data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1842,7 +1895,7 @@ test_that(".cipScoreQtlTuple skips a tuple with no weights", { test_that(".cipScoreGwasPair skips a pair with no TWAS z", { local_mocked_bindings( - getSumStatsDf = function(...) data.frame(SNP = "v1", Z = 1), + as.data.frame = function(...) data.frame(SNP = "v1", Z = 1), .cipComputeTwasZ = function(...) NULL, .cipPairLabel = function(...) "lab", .package = "pecotmr" @@ -1882,7 +1935,7 @@ test_that(".cipRunMr routes to the CS-aware estimator when asked", { test_that(".cipCvMetric reads metrics wrapped or bare, NA when absent", { local_mocked_bindings( - getCvResult = function(...) list(rsq = 0.42, pval = 0.01), + cvResult = function(...) list(rsq = 0.42, pval = 0.01), .package = "pecotmr" ) # A bare metrics list (no $metrics wrapper) is read directly. @@ -1892,7 +1945,7 @@ test_that(".cipCvMetric reads metrics wrapped or bare, NA when absent", { test_that(".cipCvMetric returns NA when the CV result cannot be read", { local_mocked_bindings( - getCvResult = function(...) stop("nope"), + cvResult = function(...) stop("nope"), .package = "pecotmr" ) expect_true( diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index 46767826..837a508e 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -84,7 +84,7 @@ context("colocPipeline") ) } QtlFineMappingResult( - study = map_chr(tuples, 1L), + studyName = map_chr(tuples, 1L), context = map_chr(tuples, 2L), trait = map_chr(tuples, 3L), method = map_chr(tuples, 4L), @@ -106,14 +106,14 @@ context("colocPipeline") ) } GwasFineMappingResult( - study = map_chr(tuples, 1L), + studyName = map_chr(tuples, 1L), method = map_chr(tuples, 2L), entry = entries, ldSketch = if (with_sketch) .cp_makeHandle() else NULL ) } -.cp_makeGwasSumstats <- function(study = "G1", qc = TRUE) { +.cp_makeGwasSumstats <- function(studyName = "G1", qc = TRUE) { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges( @@ -129,7 +129,7 @@ context("colocPipeline") N = rep(1000L, 5) ) GwasSumStats( - study = study, + studyName = studyName, entry = list(gr), genome = "hg19", ldSketch = .cp_makeHandle(), @@ -137,7 +137,7 @@ context("colocPipeline") ) } -.cp_makeQtlSumstats <- function(study = "Q1", qc = TRUE) { +.cp_makeQtlSumstats <- function(studyName = "Q1", qc = TRUE) { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges( @@ -153,7 +153,7 @@ context("colocPipeline") N = rep(1000L, 5) ) QtlSumStats( - study = study, + studyName = studyName, context = "c1", trait = "t1", entry = list(gr), @@ -165,8 +165,8 @@ context("colocPipeline") # The enrichment lookup takes each side's identity list, as the scoring loop # builds it. -.cp_side <- function(study, context = NA_character_, trait = NA_character_) { - list(study = study, context = context, trait = trait) +.cp_side <- function(studyName, context = NA_character_, trait = NA_character_) { + list(study = studyName, context = context, trait = trait) } .cp_mockColocBfBf <- function() { @@ -245,7 +245,7 @@ test_that(".colocRequireMatchingLdSketches: sample set mismatch errors", { qfmr <- .cp_makeQtlFmr() otherPanel <- .cp_makeHandle(sample_prefix = "other") gfmr <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(.cp_makeFmEntry()), ldSketch = otherPanel @@ -466,7 +466,7 @@ test_that("colocPipeline: empty result has the documented schema", { ) ) gfmr <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(e), ldSketch = .cp_makeHandle() @@ -780,7 +780,7 @@ test_that("enrichment mode reports RCP and LCP alongside the hypotheses", { gwasInput = gfmr, enrichment = enr )) - pairs <- getColocPairs(out) + pairs <- colocPairs(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. @@ -843,7 +843,7 @@ test_that("colocPipeline: enrichment joins on the second side's trait", { gwasInput = other, enrichment = enr )) - pairs <- getColocPairs(out) + pairs <- colocPairs(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( @@ -920,7 +920,7 @@ test_that("colocPipeline: attaches gwasFineMapping when no pairs survive", { topLoci = .cp_tl("chr1:100:A:G", pip = 0) ) resolved <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(e), ldSketch = .cp_makeHandle() @@ -1434,10 +1434,9 @@ 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`" - ) + # Refused at construction now -- ColocOptions() owns the check, so the + # deeper .colocEngineArgs() guard is never reached for this input. + expect_error(ColocOptions(p12 = 1e-5), "supplied by pecotmr") expect_silent( pecotmr:::.colocEngineArgs(ColocOptions(), ColocPriorParam()) ) @@ -1508,24 +1507,24 @@ test_that("GwasFineMappingParam carries only what the inline fit can use", { names(g), c( "methods", - "credibleSetArgs", - "rssArgs", - "panelFilterArgs", - "addSusieInf", + "credibleSetParam", + "susieRssParam", + "panelFilterParam", + "initializeWithSusieInf", "fitRetention" ) ) - # Nested bundles survive: the inline fit gets a real credibleSetArgs. + # Nested bundles survive: the inline fit gets a real Param back. expect_s4_class( GwasFineMappingParam( - credibleSetArgs = CredibleSetParam(coverage = 0.9) - )$credibleSetArgs, + credibleSetParam = CredibleSetParam(coverage = 0.9) + )$credibleSetParam, "CredibleSetParam" ) expect_equal( GwasFineMappingParam( - credibleSetArgs = CredibleSetParam(coverage = 0.9) - )$credibleSetArgs$coverage, + credibleSetParam = CredibleSetParam(coverage = 0.9) + )$credibleSetParam$coverage, 0.9 ) # The fineMappingPipeline settings that cannot apply are absent, not @@ -1547,10 +1546,18 @@ test_that("GwasFineMappingParam carries only what the inline fit can use", { setdiff(names(formals(GwasFineMappingParam)), "methods"), c( accepted, - "credibleSetArgs", - "rssArgs", - "panelFilterArgs", - "addSusieInf", + # Listed explicitly because the S4 method's visible formals + # are only `(data, ...)` -- the per-input-kind arguments are + # documented on the generic -- so there is nothing in `accepted` + # to match them against. The names themselves now agree with the + # pipeline's own; the earlier split that spelled these + # `credibleSetArgs` / `rssArgs` / `panelFilterArgs` / + # `addSusieInf` on pipelines was retired once the + # accessor-shadowing conflict was measured not to arise. + "credibleSetParam", + "susieRssParam", + "panelFilterParam", + "initializeWithSusieInf", "fitRetention" ) ))) @@ -1559,50 +1566,51 @@ test_that("GwasFineMappingParam carries only what the inline fit can use", { test_that("GwasFineMappingParam accessors round-trip a nested bundle", { g <- GwasFineMappingParam() - expect_equal(getFineMappingMethods(g), "susie") - expect_s4_class(getCredibleSetArgs(g), "CredibleSetParam") + expect_equal(fineMappingMethods(g), "susie") + expect_s4_class(credibleSetParam(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) + g2 <- g + cs <- credibleSetParam(g2) + csCoverage(cs) <- 0.8 + credibleSetParam(g2) <- cs + expect_equal(csCoverage(credibleSetParam(g2)), 0.8) + expect_equal(csCoverage(credibleSetParam(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" + susieRssParam(g) <- CredibleSetParam(), + "not valid for @.+susieRssParam" ) + g3 <- g + susieRssParam(g3) <- SusieRssParam(serFallback = TRUE) + expect_s4_class(g3, "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)) + expect_equal(fineMappingMethods(p), "susie") + expect_s4_class(susieRssParam(p), "SusieRssParam") + expect_s4_class(panelFilterParam(p), "PanelFilterParam") + expect_s4_class(credibleSetParam(p), "CredibleSetParam") + expect_true(initializeWithSusieInf(p)) + expect_equal(fitRetention(p), "slim") + + # Replacement edits a copy and leaves the original alone. + edited <- p + fineMappingMethods(edited) <- "susieInf" + initializeWithSusieInf(edited) <- FALSE + fitRetention(edited) <- "full" + panelFilterParam(edited) <- PanelFilterParam() + expect_equal(fineMappingMethods(edited), "susieInf") + expect_false(initializeWithSusieInf(edited)) + expect_equal(fitRetention(edited), "full") + expect_s4_class(panelFilterParam(edited), "PanelFilterParam") + expect_equal(fineMappingMethods(p), "susie") + expect_true(initializeWithSusieInf(p)) }) diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index baebc733..20cae95c 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -39,7 +39,7 @@ context("colocboostPipeline") # # - QTL data is supplied as a QtlDataset / QtlSumStats / MultiStudyQtlDataset # (DFrame-based S4 objects with an ldSketch slot for sumstats inputs and -# getResidualizedGenotypes() / getResidualizedPhenotypes() accessors for +# residualizedGenotypes() / residualizedPhenotypes() accessors for # individual-level inputs). # - GWAS is supplied separately via the gwasSumStats = GwasSumStats(...) # argument. @@ -47,7 +47,7 @@ context("colocboostPipeline") # selection) lives on the QtlDataset constructor and is applied lazily # by its accessors. There is no separate qcRegionalData() pass. # - All summary-statistic QC lives in summaryStatsQc(). The pipeline -# rejects QtlSumStats / GwasSumStats whose getQcInfo() is empty. +# rejects QtlSumStats / GwasSumStats whose qcInfo() is empty. # # Rewriting the legacy tests in place would require fabricating new # QtlDataset / QtlSumStats / GwasSumStats / MultiStudyQtlDataset fixtures @@ -112,31 +112,31 @@ context("colocboostPipeline (S4 dispatch)") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -183,7 +183,7 @@ context("colocboostPipeline (S4 dispatch)") contexts ) QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = phen, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -206,7 +206,7 @@ context("colocboostPipeline (S4 dispatch)") N = rep(1000L, 5) ) QtlSumStats( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", entry = list(gr), @@ -232,7 +232,7 @@ context("colocboostPipeline (S4 dispatch)") N = rep(1000L, 5) ) GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = .cbp_makeHandle(), @@ -413,7 +413,7 @@ test_that("colocboostPipeline(QtlDataset): runs xqtl-only ColocBoost with mocked # ran" is read off the recorded timing rather than off a retained raw # object -- the timing is written whether or not the run produced sets. expect_s4_class(out, "ColocBoostResult") - expect_true(is_in("xqtl_coloc", names(getComputingTime(out)$Analysis))) + expect_true(is_in("xqtl_coloc", names(computingTime(out)$Analysis))) expect_true("X" %in% names(capturedArgs)) }) @@ -488,21 +488,21 @@ test_that("colocboostPipeline: jointGwas merges qtl + gwas sumstats and runs onc separateGwas = FALSE ) ) - expect_true(is_in("joint_gwas", names(getComputingTime(out)$Analysis))) + expect_true(is_in("joint_gwas", names(computingTime(out)$Analysis))) }) -test_that("colocboostPipeline: separateGwas runs once per merged sumstat study", { +test_that("colocboostPipeline: separateGwas runs once per GWAS study", { ss <- .cbp_makeQtlSumStats() gs <- .cbp_makeGwasSumStats() - callCount <- 0 + seen <- list() local_mocked_bindings( extractBlockGenotypes = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( colocboost = function(...) { - callCount <<- callCount + 1L - list(round = callCount) + seen[[length(seen) + 1L]] <<- list(...) + list(round = length(seen)) }, .package = "colocboost" ) @@ -515,14 +515,49 @@ test_that("colocboostPipeline: separateGwas runs once per merged sumstat study", separateGwas = TRUE ) ) - # Driver merges QTL + GWAS sumstats into a single bundle and the - # separate-loop iterates over every merged study label (Q1:c1:t1 + G1). - expect_equal(callCount, 2L) + # ONE run per GWAS study, not per merged sumstat label. The QTL study is + # a non-focal outcome of that run, not a focal "GWAS" of its own: the + # merged bundle holds both sides, so iterating it ran the QTL as its own + # focal GWAS and reported "0 contexts". + expect_equal(length(seen), 1L) + call <- seen[[1L]] + expect_equal(length(call$sumstat), 2L) + expect_equal(call$outcome_names, c("Q1:c1:t1", "G1")) + # The focal outcome is the GWAS, and it is last. + expect_equal(call$focal_outcome_idx, 2L) + expect_equal(call$outcome_names[[call$focal_outcome_idx]], "G1") + # The QTL side's LD travels with it, so the dict covers both sumstats. + expect_equal(nrow(call$dict_sumstatLD), 2L) expect_true( - is_in("separate_gwas", names(getComputingTime(out)$Analysis)) + is_in("separate_gwas", names(computingTime(out)$Analysis)) ) }) +test_that("separateGwas refuses a QTL-only sumstat input", { + ss <- .cbp_makeQtlSumStats() + local_mocked_bindings( + extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr" + ) + # Guarded on GWAS presence, not on "any summary statistics": the old + # `hasSs` guard let a QTL-only input through and ran one focal pass per + # QTL study. + warnings <- character() + withCallingHandlers( + suppressMessages(colocboostPipeline( + ss, + xqtlColoc = FALSE, + jointGwas = FALSE, + separateGwas = TRUE + )), + warning = function(w) { + warnings <<- c(warnings, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + expect_true(any(str_detect(warnings, "GWAS summary statistics"))) +}) + test_that("colocboostPipeline: no analysis flag set is an error", { ss <- .cbp_makeQtlSumStats() local_mocked_bindings( @@ -574,7 +609,7 @@ test_that("colocboostPipeline: GWAS ldSketch mismatch errors during the driver", N = rep(1000L, 5) ) gs <- GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = gh_diff, @@ -748,7 +783,7 @@ test_that("colocboostPipeline(MultiStudyQtlDataset): combines per-study bundles separateGwas = FALSE )) expect_s4_class(out, "ColocBoostResult") - expect_true(is_in("xqtl_coloc", names(getComputingTime(out)$Analysis))) + expect_true(is_in("xqtl_coloc", names(computingTime(out)$Analysis))) # The individual study's outcome is prefixed "study1:" in the combined bundle. expect_true(any(grepl("study1:", names(capturedArgs$Y)))) }) @@ -782,7 +817,7 @@ test_that(".cbIndividualBundle: multi-context bundle names + prefixes outcomes", .package = "colocboost" ) out <- suppressMessages(colocboostPipeline(qd, xqtlColoc = TRUE)) - expect_true(is_in("xqtl_coloc", names(getComputingTime(out)$Analysis))) + expect_true(is_in("xqtl_coloc", names(computingTime(out)$Analysis))) # Two contexts -> two context-prefixed outcomes (covers the xMatch + naming). expect_gte(length(capturedArgs$Y), 2L) }) @@ -1009,9 +1044,9 @@ test_that("colocboost sumstat bundle drops panel-rare variants", { test_that("colocboost RSS cutoffs match .panelVariantFilter", { ss <- .cbf_qcd() ids <- normalizeVariantId( - getSumStatsDf( + as.data.frame( ss, - study = ss$study[[1L]], + studyName = ss$study[[1L]], context = ss$context[[1L]], trait = ss$trait[[1L]], require = "Z" @@ -1021,7 +1056,7 @@ test_that("colocboost RSS cutoffs match .panelVariantFilter", { expect_equal( .cbf_n(ss, mafCutoff = cut), length(.panelVariantFilter( - getLdSketch(ss), + ldSketch(ss), ids, PanelFilterParam(mafCutoff = cut) )), @@ -1032,7 +1067,7 @@ test_that("colocboost RSS cutoffs match .panelVariantFilter", { test_that("colocboost RSS treats MAC as a MAF equivalent", { ss <- .cbf_qcd() - nSamp <- ncol(getLdSketch(ss)) + nSamp <- ncol(ldSketch(ss)) expect_equal( .cbf_n(ss, macCutoff = 0.1 * 2 * nSamp), .cbf_n(ss, mafCutoff = 0.1) @@ -1050,14 +1085,14 @@ test_that(".cbSumstatPair keeps sumstat rows aligned to the LD matrix", { # filtered set has to be passed to the LD build separately rather than by # shrinking that vector. ss <- .cbf_qcd() - df <- getSumStatsDf( + df <- as.data.frame( ss, - study = ss$study[[1L]], + studyName = ss$study[[1L]], context = ss$context[[1L]], trait = ss$trait[[1L]], require = "Z" ) - sketch <- getLdSketch(ss) + sketch <- ldSketch(ss) pair <- suppressMessages(.cbSumstatPair( df = df, ldSketch = sketch, @@ -1075,16 +1110,16 @@ test_that(".cbSumstatPair keeps sumstat rows aligned to the LD matrix", { test_that(".cbSumstatPair returns NULL when a cutoff removes everything", { ss <- .cbf_qcd() - df <- getSumStatsDf( + df <- as.data.frame( ss, - study = ss$study[[1L]], + studyName = ss$study[[1L]], context = ss$context[[1L]], trait = ss$trait[[1L]], require = "Z" ) expect_null(suppressMessages(.cbSumstatPair( df = df, - ldSketch = getLdSketch(ss), + ldSketch = ldSketch(ss), cutoffs = list(mafCutoff = 0.99, macCutoff = 0, imissCutoff = 1) ))) }) @@ -1207,7 +1242,7 @@ test_that(".cbBuildContextXY skips a context with no shared samples", { test_that(".cbResidualizedX reports why genotypes were unavailable", { local_mocked_bindings( - getResidualizedGenotypes = function(...) stop("kaboom"), + residualizedGenotypes = function(...) stop("kaboom"), .package = "pecotmr" ) # The cause is chained via `parent`, not flattened into the text, so the @@ -1363,7 +1398,7 @@ test_that(".cbRunVariants: xqtlColoc runs on a QTL-only sumstat bundle", { qtlSumstatBundle = qtlOnly )) expect_equal(called, "xqtl") - expect_false(is.null(getComputingTime(out)$Analysis$xqtl_coloc)) + expect_false(is.null(computingTime(out)$Analysis$xqtl_coloc)) }) test_that(".cbRunVariants warns instead of silently skipping an analysis", { @@ -1416,7 +1451,7 @@ test_that(".cbRunVariants warns when xqtlColoc has only GWAS sumstats", { )), "xqtlColoc = TRUE was requested" ) - expect_null(getComputingTime(out)$Analysis$xqtl_coloc) + expect_null(computingTime(out)$Analysis$xqtl_coloc) }) test_that("ColocboostOptions() options reach the engine by name", { diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index 1ee7894e..b58e3b08 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -40,6 +40,13 @@ context("ctwasPipeline") ) } +# A panel with its correlation already built, the shape callers saw before +# the LD became on-demand. Tests that assert on R_wgt want it materialized. +.ctp_fullPanel <- function(h) { + p <- pecotmr:::.ctwasPanelFor(h) + c(p, list(R = pecotmr:::.ctwasPanelLd(p))) +} + # Canonical SNP IDs the fixtures use. .ctp_makeHandle() emits these in # chr:pos:A2:A1 form; tests reference them by index via .ctp_snpId(i). .ctp_snpId <- function(i) sprintf("chr1:%d:G:A", 100L * i) @@ -48,31 +55,31 @@ context("ctwasPipeline") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -105,7 +112,7 @@ context("ctwasPipeline") .ctp_makeGwasSumstats <- function(qc = TRUE, blockIds = c("block1", "block2")) { n <- length(blockIds) GwasSumStats( - study = rep("G1", n), + studyName = rep("G1", n), entry = map(seq_len(n), .ctp_blockVariants), genome = "hg19", ldSketch = .ctp_makeHandle(snp_n = 6L * n), @@ -123,7 +130,7 @@ context("ctwasPipeline") weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -154,7 +161,7 @@ context("ctwasPipeline") ) fe <- fineMappingRow(variantIds = vids, susieFit = list(), topLoci = tl) QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -266,14 +273,14 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to # a standardized TwasWeights carrying the same effect vector (both skip cTWAS's # variance scaling). Compare against that, not the default (unstandardized) one. tw_std <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", entry = list(twasWeightsRow( variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0), - standardized = TRUE + weightStandardized = TRUE )), ldSketch = .ctp_makeHandle() ) @@ -302,7 +309,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { # crosses the block boundary. With a per-block filter the gene would # lose v4..v5 (block-2 variants); with a global-union filter all four # weight variants survive. - mkBlockGss <- function(study, snpIds, qc = TRUE) { + mkBlockGss <- function(studyName, snpIds, qc = TRUE) { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges( @@ -318,7 +325,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { N = rep(1000L, length(snpIds)) ) GwasSumStats( - study = study, + studyName = studyName, entry = list(gr), genome = "hg19", ldSketch = .ctp_makeHandle(), @@ -333,7 +340,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { weights = c(0.1, 0.2, 0.3, 0.4) ) tw <- TwasWeights( - study = "G1", + studyName = "G1", context = "c1", trait = "t1", method = "susie", @@ -412,7 +419,7 @@ test_that("CtwasPriorParam rejects an unknown varStructure", { test_that(".ctwasRequireMatchingLdSketches: NULL twas-side handle is allowed", { twNoLd <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -432,6 +439,12 @@ test_that(".ctwasRequireMatchingLdSketches: differently trimmed panels ok", { # One LD reference QC'd separately on the two sides leaves each sketch # trimmed to its own surviving variants, so the panels overlap without # being identical. That is the normal case, not an error. + # + # The overlap note is rate-limited to once per session and the assembly + # tests legitimately trip it first (each block's GWAS panel is narrowed to + # its own variants while the weights carry the whole one), so clear that + # budget here rather than depending on which files ran before this. + rlang::reset_warning_verbosity("pecotmrLdSketchOverlap-ctwasPipeline") twLd <- .ctp_makeHandle(snp_n = 5L) gwasLd <- .ctp_makeHandle(snp_n = 6L) expect_warning( @@ -443,7 +456,7 @@ test_that(".ctwasRequireMatchingLdSketches: differently trimmed panels ok", { test_that(".ctwasRequireMatchingLdSketches: disjoint panels error", { twLd <- .ctp_makeHandle(snp_n = 3L) gwasLd <- .ctp_makeHandle(snp_n = 3L) - si <- getSnpInfo(gwasLd) + si <- snpInfo(gwasLd) si$BP <- si$BP + 1e6L gwasLd@snpInfo <- si expect_error( @@ -590,7 +603,7 @@ test_that(".ctwasBuildSingleRegionInfo: uses the block entry span, not the wider N = 1000L ) gss <- GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = .ctp_makeHandle(), @@ -614,7 +627,7 @@ test_that(".ctwasBuildSingleRegionInfo: multi-chromosome block entry errors", { N = 1000L ) gss <- GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = .ctp_makeHandle(), @@ -646,7 +659,7 @@ test_that(".ctwasSnpInfoForBlock: repairs a tag-allele panel id from A1/A2", { extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) - panel <- pecotmr:::.ctwasComputeFullPanelLd(h) + panel <- .ctp_fullPanel(h) expect_true("chr1:200:G:A" %in% rownames(panel$R)) expect_true("chr1:200:G:A" %in% names(panel$variance)) }) @@ -655,7 +668,7 @@ test_that(".ctwasLdPanelKey: returns the on-disk path for an existing GDS sketch handle <- .ctp_makeHandle() key <- pecotmr:::.ctwasLdPanelKey(handle) expect_true(file.exists(key)) - expect_equal(key, getPath(handle)) + expect_equal(key, path(handle)) }) test_that(".ctwasLdPanelKey: errors when no candidate file exists", { @@ -681,13 +694,102 @@ test_that(".ctwasLdPanelKey: errors when no candidate file exists", { ) }) +# --------------------------------------------------------------------------- +# Per-block LD scoping. Two bugs met here: combineGwasSumStats() UNIONS the +# per-piece sketches, and `[` carries that collection-level slot into every +# block, so each one referenced the whole chromosome; and the panel cache was +# keyed on the backing genotype file, which every block on a chromosome +# shares, so only block 1's panel was ever computed and the rest read it back. +# --------------------------------------------------------------------------- + +test_that(".ctwasPickBlock: narrows the collection sketch to the block", { + ss <- .ctp_makeGwasSumstats() + # The collection's sketch spans both blocks, as combineGwasSumStats + # leaves it. + expect_equal(length(pecotmr:::.ldSketchRanges(ldSketch(ss))), 12L) + byBlock <- pecotmr:::.ctwasGwasByBlock(ss) + sizes <- map_int(byBlock, function(b) { + length(pecotmr:::.ldSketchRanges(ldSketch(b))) + }) + expect_equal(unname(sizes), c(6L, 6L)) + # Narrowed to DIFFERENT variants: block 1 holds 1..6, block 2 holds 7..12. + pos <- map(byBlock, function(b) { + GenomicRanges::start(pecotmr:::.ldSketchRanges(ldSketch(b))) + }) + expect_equal(pos[[1L]], 100L * (1:6)) + expect_equal(pos[[2L]], 100L * (7:12)) +}) + +test_that(".ctwasRegionLdTokens: one distinct, existing token per region", { + ss <- .ctp_makeGwasSumstats() + byBlock <- pecotmr:::.ctwasGwasByBlock(ss) + sketches <- map(byBlock, ldSketch) + tokens <- pecotmr:::.ctwasRegionLdTokens(names(byBlock), sketches) + expect_length(unique(unname(tokens)), 2L) + expect_true(all(file.exists(tokens))) + expect_equal(names(tokens), c("block1", "block2")) +}) + +test_that(".ctwasTokenSlug: sanitizes ids and keeps duplicates apart", { + slug <- pecotmr:::.ctwasTokenSlug( + c("chr19:1-500000", "chr19:500001-1000000", "chr19:1-500000") + ) + expect_false(any(str_detect(slug, ":"))) + # The index prefix separates two ids that sanitize to the same stem. + expect_length(unique(slug), 3L) +}) + +test_that("assembleCtwasInputs: each region gets its own block-sized panel", { + inp <- .ctp_makeMultiBlockInputs() + local_mocked_bindings( + extractBlockGenotypes = .ctp_mockExtractor(), + .package = "pecotmr" + ) + out <- assembleCtwasInputs( + gwasSumStats = inp$gwasSumStats, + twasWeights = inp$twasWeights + ) + expect_length(unique(out$LD_map$LD_file), 2L) + panels <- pecotmr:::.ctwasCachedPanels(out) + expect_length(panels, 2L) + # Block-sized (6x6), not the 12-variant whole-panel LD. + expect_equal(dim(pecotmr:::.ctwasPanelLd(panels[[1L]])), c(6L, 6L)) + expect_equal(dim(pecotmr:::.ctwasPanelLd(panels[[2L]])), c(6L, 6L)) + # And genuinely different LD, not block 1's twice. + expect_false(identical(panels[[1L]]$snpInfo$id, panels[[2L]]$snpInfo$id)) +}) + +test_that(".ctwasResolveLdPaths: re-mints sentinels lost with the session", { + inp <- .ctp_makeMultiBlockInputs() + local_mocked_bindings( + extractBlockGenotypes = .ctp_mockExtractor(), + .package = "pecotmr" + ) + out <- assembleCtwasInputs( + gwasSumStats = inp$gwasSumStats, + twasWeights = inp$twasWeights + ) + before <- pecotmr:::.ctwasCachedPanels(out) + # The sentinels live in the session tempdir; a payload reloaded in a new + # session finds them gone, and ctwas asserts file.exists() on each. + unlink(out$LD_map$LD_file) + restored <- pecotmr:::.ctwasResolveLdPaths(out) + tokens <- restored$LD_map$LD_file + expect_true(all(file.exists(tokens))) + expect_length(unique(tokens), 2L) + # Each region still reaches its OWN panel through the re-keyed loader. + loader <- restored$LD_loader_fun + expect_equal(loader(tokens[[1L]]), pecotmr:::.ctwasPanelLd(before[[1L]])) + expect_equal(loader(tokens[[2L]]), pecotmr:::.ctwasPanelLd(before[[2L]])) +}) + test_that(".ctwasResolveMethod: caller-supplied method wins when present", { e <- twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = c(0.1, 0.2, 0.3) ) tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "mrash", @@ -703,7 +805,7 @@ test_that(".ctwasResolveMethod: caller-supplied unknown method errors", { weights = c(0.1, 0.2, 0.3) ) tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "mrash", @@ -723,7 +825,7 @@ test_that(".ctwasResolveMethod: defaults to ensemble when present among multiple weights = c(0.1, 0.2, 0.3) ) TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = m, @@ -733,7 +835,7 @@ test_that(".ctwasResolveMethod: defaults to ensemble when present among multiple } # Build a multi-method TwasWeights by stitching two methods together. tw <- TwasWeights( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("mrash", "ensemble"), @@ -758,7 +860,7 @@ test_that(".ctwasResolveMethod: single method auto-picked when only one availabl weights = c(0.1, 0.2, 0.3) ) tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "mrash", @@ -770,7 +872,7 @@ test_that(".ctwasResolveMethod: single method auto-picked when only one availabl test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method errors", { tw <- TwasWeights( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("mrash", "susie"), @@ -797,7 +899,7 @@ test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method er # --------------------------------------------------------------------------- .ctp_multiMethodTw <- function(methods = c("mrash", "susie")) { TwasWeights( - study = rep("Q1", length(methods)), + studyName = rep("Q1", length(methods)), context = rep("c1", length(methods)), trait = rep("t1", length(methods)), method = methods, @@ -923,7 +1025,7 @@ test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks # anchor can tell them apart. block1 spans 100-600, block2 spans 700-1200, # so gA @chr1:100 homes to block1 and gB @chr1:800 to block2. tw <- TwasWeights( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("gA", "gB"), method = c("susie", "susie"), @@ -939,7 +1041,7 @@ test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks expect_named(bucketed, c("block1", "block2"), ignore.order = TRUE) expect_equal(as.character(bucketed[["block1"]]$trait), "gA") expect_equal(as.character(bucketed[["block2"]]$trait), "gB") - expect_false(is.null(getLdSketch(bucketed[["block1"]]))) + expect_false(is.null(ldSketch(bucketed[["block1"]]))) }) test_that(".ctwasBucketWeights: errors when source lacks traitPos", { @@ -1019,9 +1121,9 @@ test_that(".ctwasRunToRows: single-context run -> one row, no jointContexts", { expect_equal(rows[[1L]]$study, "Q1") expect_equal(rows[[1L]]$gwasStudy, "D1") expect_true(is.na(rows[[1L]]$jointContexts)) - expect_equal(nrow(getFinemap(rows[[1L]]$entry)), 2L) + expect_equal(nrow(ctwasPosteriors(rows[[1L]]$entry)), 2L) expect_equal( - getCtwasGroupPriors(rows[[1L]]$entry)$group_prior[["c1"]], + ctwasGroupPriors(rows[[1L]]$entry)$group_prior[["c1"]], 0.01 ) }) @@ -1048,9 +1150,9 @@ test_that(".ctwasRunToRows: multi-context run -> per-context rows sharing jointC 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_equal(nrow(ctwasPosteriors(rows[[1L]]$entry)), 2L) expect_named( - getCtwasGroupPriors(rows[[1L]]$entry)$group_prior, + ctwasGroupPriors(rows[[1L]]$entry)$group_prior, c("brain", "liver", "SNP") ) }) @@ -1076,8 +1178,8 @@ test_that(".ctwasRunToRows: empty finemap_res still yields the modeled row", { ) rows <- pecotmr:::.ctwasRunToRows(run, "D1", "susie") expect_length(rows, 1L) - expect_null(getFinemap(rows[[1L]]$entry)) - expect_null(getSusieAlpha(rows[[1L]]$entry)) + expect_null(ctwasPosteriors(rows[[1L]]$entry)) + expect_null(susieAlpha(rows[[1L]]$entry)) }) test_that(".ctwasRunToRows: susieAlpha subset mirrors finemap per context", { @@ -1087,7 +1189,7 @@ test_that(".ctwasRunToRows: susieAlpha subset mirrors finemap per context", { c(c1 = 0.01, SNP = 1e-4) ) rows <- pecotmr:::.ctwasRunToRows(run, "D1", "susie") - sa <- getSusieAlpha(rows[[1L]]$entry) + sa <- susieAlpha(rows[[1L]]$entry) expect_equal(nrow(sa), 2L) expect_true("susie_alpha" %in% names(sa)) }) @@ -1103,7 +1205,7 @@ test_that(".ctwasRunToRows: keepSnps adds a dedicated SNP row; default drops SNP # default: SNP background dropped, only the gene (context) row. rowsOff <- pecotmr:::.ctwasRunToRows(run, "D1", "susie") expect_length(rowsOff, 1L) - expect_true(all(getFinemap(rowsOff[[1L]]$entry)$type == "gene")) + expect_true(all(ctwasPosteriors(rowsOff[[1L]]$entry)$type == "gene")) # keepSnps: one extra study = context = "SNP" row carrying the SNP background. rowsOn <- pecotmr:::.ctwasRunToRows(run, "D1", "susie", keepSnps = TRUE) expect_length(rowsOn, 2L) @@ -1112,16 +1214,16 @@ test_that(".ctwasRunToRows: keepSnps adds a dedicated SNP row; default drops SNP expect_equal(snpRow$context, "SNP") # The payloads are ranged now: SNP rows carry the coordinates their own # variant ids encode, so the count is length() and the columns are mcols. - fm <- getFinemap(snpRow$entry) + fm <- ctwasPosteriors(snpRow$entry) expect_s4_class(fm, "GRanges") expect_length(fm, 2L) expect_true(all(S4Vectors::mcols(fm)$type == "SNP")) - expect_length(getSusieAlpha(snpRow$entry), 2L) + expect_length(susieAlpha(snpRow$entry), 2L) }) test_that(".ctwasFilterMethod: subsets rows to the requested method", { tw <- TwasWeights( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("mrash", "susie"), @@ -1142,7 +1244,7 @@ test_that(".ctwasFilterMethod: subsets rows to the requested method", { expect_equal(as.character(twSub$method), "susie") }) -# Build an ldPanel fixture (matches .ctwasComputeFullPanelLd's return +# Build an ldPanel fixture (the materialized shape, R included) # shape) for the 6-SNP toy panel from .ctp_makeHandle(). .ctp_makeLdPanel <- function(snp_n = 6L) { h <- .ctp_makeHandle(snp_n = snp_n) @@ -1164,7 +1266,7 @@ test_that(".ctwasBuildWeights: scales non-standardized weights by sqrt(variance) ids5 <- map_chr(1:5, .ctp_snpId) rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -1182,14 +1284,14 @@ test_that(".ctwasBuildWeights: standardized weights bypass variance scaling", { ids5 <- map_chr(1:5, .ctp_snpId) rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", entry = list(twasWeightsRow( variantIds = ids5, weights = rawW, - standardized = TRUE + weightStandardized = TRUE )), ldSketch = .ctp_makeHandle() ) @@ -1475,7 +1577,7 @@ test_that(".ctwasBuildWeights: drops variants not present in the LD panel", { ids3 <- map_chr(1:3, .ctp_snpId) missing <- c("chr1:99900:G:A", "chr1:99910:G:A") # not in panel tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -1500,7 +1602,7 @@ test_that(".ctwasBuildWeights: intersects with gwasSnpIds when supplied", { ids5 <- map_chr(1:5, .ctp_snpId) blockIds <- map_chr(c(1, 2, 4), .ctp_snpId) tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -1520,22 +1622,128 @@ test_that(".ctwasBuildWeights: intersects with gwasSnpIds when supplied", { expect_equal(wl[[1L]]$n_wgt, 3L) }) -test_that(".ctwasComputeFullPanelLd: extracts once + returns cached R + snpInfo + variance", { +test_that(".ctwasPanelFor: cheap fields eagerly, correlation on request", { local_mocked_bindings( extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) - out <- pecotmr:::.ctwasComputeFullPanelLd(.ctp_makeHandle(snp_n = 6L)) + out <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) 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)) - expect_equal(rownames(out$R), ids6) + # The n x n correlation is deliberately NOT built here: ctwas pulls a + # region's LD only while fine-mapping, and only for the regions that + # survive screening. + expect_named(out, c("snpInfo", "variance", "sketch")) + expect_null(out$R) expect_setequal( colnames(out$snpInfo), c("chrom", "id", "pos", "alt", "ref") ) expect_named(out$variance, ids6) + # It is built, with the right shape, when something asks. + R <- pecotmr:::.ctwasPanelLd(out) + expect_true(is.matrix(R)) + expect_equal(dim(R), c(6L, 6L)) + expect_equal(rownames(R), ids6) +}) + +test_that(".ctwasPanelLdSubset: refuses a variant absent from the panel", { + local_mocked_bindings( + extractBlockGenotypes = .ctp_mockExtractor(), + .package = "pecotmr" + ) + panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) + vids <- c(.ctp_snpId(2L), "chr22:999999999:A:G") + # Subsetting on a missing id would give an NA row/column that silently + # poisons the correlation, so it is refused by name and count. + expect_error( + pecotmr:::.ctwasPanelLdSubset(panel, vids), + "1 weight variant\\(s\\) absent from the block's LD panel" + ) +}) + +test_that(".ctwasPanelLdSubset: slices a precomputed R when the panel has one", { + local_mocked_bindings( + extractBlockGenotypes = .ctp_mockExtractor(), + .package = "pecotmr" + ) + panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) + vids <- map_chr(c(1L, 3L), .ctp_snpId) + # With R already built, the subset is a slice rather than a recompute. + panel$R <- pecotmr:::.ctwasPanelLd(panel) + out <- pecotmr:::.ctwasPanelLdSubset(panel, vids) + expect_equal(dim(out), c(2L, 2L)) + expect_equal(rownames(out), vids) + expect_equal(out, panel$R[vids, vids]) +}) + +test_that(".ctwasLdMapRegionIds: falls back to positions without region_id", { + # The granular entry points accept hand-built LD_map stubs, which need + # not carry region_id -- and a region_id of the wrong length cannot be + # paired with the resolved blocks either. + expect_equal( + pecotmr:::.ctwasLdMapRegionIds(data.frame(x = 1:3), 3L), + c("1", "2", "3") + ) + expect_equal( + pecotmr:::.ctwasLdMapRegionIds(data.frame(region_id = "a"), 3L), + c("1", "2", "3") + ) + expect_equal( + pecotmr:::.ctwasLdMapRegionIds( + data.frame(region_id = c("a", "b")), 2L + ), + c("a", "b") + ) +}) + +test_that(".ctwasGlobalPanelInfo: NULL when the collection has no sketch", { + # The shared fixture carries a sketch, so build one without: the global + # snpInfo table is only derivable when there is a panel behind it. + gs <- GwasSumStats( + studyName = "G1", + entry = list(.ctp_blockVariants(1L)), + genome = "hg19", + blockId = "block1", + qcInfo = list(step1 = "ok") + ) + expect_null(ldSketch(gs)) + # .ctwasRegionGwasLd reports the missing-sketch case with its own + # message, so this helper must stay quiet and hand back NULL. + expect_null(pecotmr:::.ctwasGlobalPanelInfo(gs)) +}) + +test_that(".ctwasPanelLdSubset: equals the slice of the full correlation", { + local_mocked_bindings( + extractBlockGenotypes = .ctp_mockExtractor(), + .package = "pecotmr" + ) + panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) + vids <- map_chr(c(2L, 4L, 5L), .ctp_snpId) + full <- pecotmr:::.ctwasPanelLd(panel) + # Mean imputation is per column, so correlating a subset of the dosages + # gives the same pairwise values as slicing the whole matrix. + expect_equal( + pecotmr:::.ctwasPanelLdSubset(panel, vids), + full[vids, vids] + ) +}) + +test_that(".ctwasRWgtSource: builds the block matrix only when it pays", { + local_mocked_bindings( + extractBlockGenotypes = .ctp_mockExtractor(), + .package = "pecotmr" + ) + panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) + # One gene on two variants: 4 against 36, so no block matrix is formed. + expect_null(pecotmr:::.ctwasRWgtSource(panel, 2L)) + # Six genes on five variants each: 150 against 36, so form it once. + dense <- pecotmr:::.ctwasRWgtSource(panel, rep(5L, 6L)) + expect_equal(dim(dense), c(6L, 6L)) + # A panel that already carries one is never rebuilt. + expect_identical( + pecotmr:::.ctwasRWgtSource(.ctp_makeLdPanel(), 1L), + .ctp_makeLdPanel()$R + ) }) test_that(".ctwasBuildZGene: builds z_gene from a TWAS-Z GRanges", { @@ -1742,24 +1950,24 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and # Output is a CtwasResult: one (gwasStudy, study, context, method) row. expect_s4_class(out, "CtwasResult") expect_equal(nrow(out), 1L) - expect_equal(getMethodNames(out), "susie") - expect_equal(getStudy(out), "Q1") - expect_equal(getContexts(out), "c1") + expect_equal(methodNames(out), "susie") + expect_equal(studyName(out), "Q1") + expect_equal(contexts(out), "c1") expect_equal(as.character(out$gwasStudy), "G1") # The run's jointly-estimated param is carried on the row. expect_equal( - unname(getCtwasGroupPriors(out$entry[[1L]])$group_prior), + unname(ctwasGroupPriors(out$entry[[1L]])$group_prior), c(0.1, 0.0001) ) - # getFinemap aggregates the per-gene rows, tagged with run identity. - fm <- getFinemap(out) + # ctwasPosteriors aggregates the per-gene rows, tagged with run identity. + fm <- ctwasPosteriors(out) expect_equal(nrow(fm), 2L) expect_true(all( c("gwasStudy", "study", "context", "method", "susie_pip") %in% names(fm) )) expect_setequal(fm$id, c("block1|Q1|c1|t1|susie", "block2|Q1|c1|t1|susie")) - # getSusieAlpha aggregates the fuller per-effect table, likewise tagged. - sa <- getSusieAlpha(out) + # susieAlpha aggregates the fuller per-effect table, likewise tagged. + sa <- susieAlpha(out) expect_equal(nrow(sa), 2L) expect_true(all(c("gwasStudy", "context", "susie_alpha") %in% names(sa))) }) @@ -1809,8 +2017,8 @@ test_that("ctwasPipeline: keepSnps retains the SNP background as a dedicated row out <- ctwasPipeline(inp$gwasSumStats, inp$twasWeights, keepSnps = TRUE) # A gene (c1) row plus the dedicated SNP row. expect_equal(nrow(out), 2L) - expect_setequal(getContexts(out), c("c1", "SNP")) - fm <- getFinemap(out) + expect_setequal(contexts(out), c("c1", "SNP")) + fm <- ctwasPosteriors(out) expect_setequal(fm$type, c("gene", "SNP")) expect_true("chr1:100:G:A" %in% fm$id) }) @@ -1921,7 +2129,9 @@ test_that("mergeCtwasBoundaryRegions passes no unnamed argument to ctwas", { # ...and a user option still arrives spliced, by its own name mergeCtwasBoundaryRegions( .ctp_finemapResult(hasLd = TRUE), - methodArgs = CtwasOptions(min_abs_corr = 0.1) + methodArgs = CtwasOptions( + merge = CtwasMergeOptions(min_abs_corr = 0.1) + ) ) expect_equal(captured$min_abs_corr, 0.1) expect_false(any(names(captured) == "")) @@ -2020,7 +2230,7 @@ test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into Ctwas expect_true(merged) # merging ran expect_s4_class(out, "CtwasResult") # The post-merge PIP (0.99) is what the decomposition carries. - expect_equal(getFinemap(out)$susie_pip, 0.99) + expect_equal(ctwasPosteriors(out)$susie_pip, 0.99) }) # =========================================================================== @@ -2033,11 +2243,11 @@ test_that("asCtwasResult: structures a granular finemap result into a CtwasResul expect_s4_class(cr, "CtwasResult") expect_equal(nrow(cr), 1L) expect_equal(as.character(cr$gwasStudy), "D1") - expect_equal(getStudy(cr), "Q1") # derived from the gene ids - expect_equal(getContexts(cr), "c1") - expect_equal(getMethodNames(cr), "susie") - expect_equal(getFinemap(cr)$susie_pip, 0.90) - expect_false(is.null(getSusieAlpha(cr))) + expect_equal(studyName(cr), "Q1") # derived from the gene ids + expect_equal(contexts(cr), "c1") + expect_equal(methodNames(cr), "susie") + expect_equal(ctwasPosteriors(cr)$susie_pip, 0.90) + expect_false(is.null(susieAlpha(cr))) }) test_that("asCtwasResult: keepSnps adds the dedicated SNP row", { @@ -2053,7 +2263,7 @@ test_that("asCtwasResult: keepSnps adds the dedicated SNP row", { ) ) cr <- asCtwasResult(fmr, keepSnps = TRUE) - expect_setequal(getContexts(cr), c("c1", "SNP")) + expect_setequal(contexts(cr), c("c1", "SNP")) }) test_that("asCtwasResult: errors when the weights mix methods", { @@ -2280,7 +2490,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", data(qtlDatasetExample) gss <- gwasSumStatsS4Example qd <- qtlDatasetExample - gh <- getGenotypeHandle(qd) + gh <- genotypeHandle(qd) # Two 5-variant synthetic genes from the bundled panel, one anchored in # each LD block below. cTWAS's EM runs per region and cannot fit a block @@ -2288,24 +2498,24 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", # the previous per-region list dodged this by putting the SAME GWAS block # and the SAME gene under two region ids. geneOne <- twasWeightsRow( - variantIds = getSnpInfo(gh)$SNP[1:5], + variantIds = snpInfo(gh)$SNP[1:5], weights = c(0.1, -0.2, 0.05, 0.0, 0.3) ) geneTwo <- twasWeightsRow( - variantIds = getSnpInfo(gh)$SNP[9:13], + variantIds = snpInfo(gh)$SNP[9:13], weights = c(0.2, 0.1, -0.15, 0.05, 0.0) ) # A FLAT weight source is placed into blocks by `traitPos`, so each gene # needs the span it sits in. geneSpan <- function(i) { - bp <- getSnpInfo(gh)$BP[i] + bp <- snpInfo(gh)$BP[i] GenomicRanges::GRanges( - str_c("chr", getSnpInfo(gh)$CHR[i][[1L]]), + str_c("chr", snpInfo(gh)$CHR[i][[1L]]), IRanges::IRanges(min(bp), max(bp)) ) } tw <- TwasWeights( - study = rep("study1", 2L), + studyName = rep("study1", 2L), context = rep("brain", 2L), trait = c("ENSG_example", "ENSG_example2"), method = rep("susie", 2L), @@ -2330,11 +2540,11 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", ) names(twoBlocks) <- c("blockA", "blockB") gssTwoBlocks <- GwasSumStats( - study = getStudy(gss), + studyName = studyName(gss), entry = list(unlist(gss)), - genome = getGenome(gss), - ldSketch = getLdSketch(gss), - qcInfo = getQcInfo(gss), + genome = unique(unname(GenomeInfoDb::genome(gss))), + ldSketch = ldSketch(gss), + qcInfo = qcInfo(gss), ldBlocks = twoBlocks ) res <- suppressMessages(suppressWarnings( @@ -2347,8 +2557,11 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", # 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 + regionData = CtwasRegionDataOptions(min_group_size = 1L), + estParam = CtwasEstParamOptions( + min_group_size = 1L, + min_p_single_effect = 0 + ) ) ) )) @@ -2357,13 +2570,13 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", # susie) row (single-context run, so no jointContexts). expect_s4_class(res, "CtwasResult") expect_equal(nrow(res), 1L) - expect_equal(getContexts(res), "brain") - expect_equal(getStudy(res), "study1") - expect_equal(getMethodNames(res), "susie") + expect_equal(contexts(res), "brain") + expect_equal(studyName(res), "study1") + expect_equal(methodNames(res), "susie") expect_false("jointContexts" %in% pecotmr:::.tupleColumnNames(res)) # The gene we passed in was fine-mapped and shows up in the aggregated # finemap table, tagged with the run identity. - fm <- getFinemap(res) + fm <- ctwasPosteriors(res) expect_true(!is.null(fm) && nrow(fm) > 0L) expect_true(all( c("gwasStudy", "study", "context", "method", "susie_pip") %in% names(fm) @@ -2379,7 +2592,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", ))) expect_true(all(fm$context == "brain")) # The fuller per-effect table is retained and reconstructable. - sa <- getSusieAlpha(res) + sa <- susieAlpha(res) expect_true(!is.null(sa) && nrow(sa) > 0L) expect_true(all(c("susie_pip", "susie_alpha", "region_id") %in% names(sa))) }) @@ -2489,21 +2702,21 @@ test_that(".ctwasFilterVariants: returns NULL when no variants survive", { test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", { data(qtlDatasetExample) qd <- qtlDatasetExample - gh <- getGenotypeHandle(qd) - vids <- getSnpInfo(gh)$SNP[1:5] + gh <- genotypeHandle(qd) + vids <- snpInfo(gh)$SNP[1:5] ent <- twasWeightsRow( variantIds = vids, weights = c(0.1, -0.2, 0.05, 0.3, 0.15) ) tw <- TwasWeights( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_example", method = "susie", entry = list(ent), ldSketch = gh ) - ldPanel <- pecotmr:::.ctwasComputeFullPanelLd(gh) + ldPanel <- .ctp_fullPanel(gh) wl <- pecotmr:::.ctwasBuildWeights(tw, ldPanel, maxNumVariants = 3L) expect_equal(wl[[1L]]$n_wgt, 3L) expect_equal(nrow(wl[[1L]]$wgt), 3L) @@ -2514,22 +2727,22 @@ test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", test_that(".ctwasBuildWeights: twasWeightCutoff drops low-magnitude variants", { data(qtlDatasetExample) qd <- qtlDatasetExample - gh <- getGenotypeHandle(qd) - vids <- getSnpInfo(gh)$SNP[1:5] + gh <- genotypeHandle(qd) + vids <- snpInfo(gh)$SNP[1:5] ent <- twasWeightsRow( variantIds = vids, # v1 (0.005) and v3 (0.001) will be dropped at cutoff 0.01 weights = c(0.005, 0.2, 0.001, 0.3, 0.1) ) tw <- TwasWeights( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_example", method = "susie", entry = list(ent), ldSketch = gh ) - ldPanel <- pecotmr:::.ctwasComputeFullPanelLd(gh) + ldPanel <- .ctp_fullPanel(gh) wl <- pecotmr:::.ctwasBuildWeights(tw, ldPanel, twasWeightCutoff = 0.01) expect_equal(wl[[1L]]$n_wgt, 3L) expect_setequal(rownames(wl[[1L]]$wgt), vids[c(2L, 4L, 5L)]) @@ -2706,7 +2919,7 @@ test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolv ids5 <- map_chr(1:5, .ctp_snpId) mkTw <- function(m) { TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = m, @@ -2864,10 +3077,10 @@ test_that(".ctwasBuildWeights: SuSiE renormalization fires when variants are dro ent <- twasWeightsRow( variantIds = c(ids4, bogus), weights = c(0.1, 0.2, 0.3, 0.4, 0.5), - fits = fits + methodFits = fits ) tw <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -2921,7 +3134,7 @@ test_that(".ctwasGetFinemapAux: parses pip + cs_95 membership + purity", { stringsAsFactors = FALSE ) fmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -2943,7 +3156,7 @@ test_that(".ctwasGetFinemapAux: cs_95 without a purity column yields NA purity", stringsAsFactors = FALSE ) fmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -2962,7 +3175,7 @@ test_that(".ctwasGetFinemapAux: no cs_95 column yields empty CS membership", { stringsAsFactors = FALSE ) fmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -2982,7 +3195,7 @@ test_that(".ctwasGetFinemapAux: NULL input, no-match tuple, and empty topLoci al stringsAsFactors = FALSE ) fmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -2992,7 +3205,7 @@ test_that(".ctwasGetFinemapAux: NULL input, no-match tuple, and empty topLoci al expect_null(pecotmr:::.ctwasGetFinemapAux(fmr, "NOPE", "c1", "t1", "susie")) # Matching tuple but an empty topLoci -> NULL. fmrEmpty <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -3027,7 +3240,7 @@ test_that(".ctwasSnpInfoForGwasBlock: returns an empty frame when the block has # GRanges entry with no mcols -> no SNP column -> blockIds is empty. gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 1L)) gss <- GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = .ctp_makeHandle(), @@ -3132,7 +3345,7 @@ test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped ) } tw <- TwasWeights( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("gA", "gX"), method = c("susie", "susie"), @@ -3163,7 +3376,7 @@ test_that(".ctwasBucketWeights: errors when no gene lands in any block", { ) } twOff <- TwasWeights( - study = "Q1", + studyName = "Q1", context = "c1", trait = "gX", method = "susie", @@ -3234,13 +3447,15 @@ test_that("finemapCtwasRegions: an empty screened-region set returns a NULL fine # Bundled example payloads: portable LD tokens # # `LD_map$LD_file` is both something ctwas asserts exists on disk and the key -# pecotmr dispatches on into the cached LD panels. Serialising an absolute -# path made the bundled payloads carry the build machine's path, so -# finemapCtwasRegions() died on `all(file.exists(LD_matrix_files))` for every -# user. They now carry a "pecotmr://extdata/..." token resolved on the way in. +# pecotmr dispatches on into the cached LD panels. Those two duties are why +# the token cannot be the backing genotype file: every block on a chromosome +# shares it, so each block was handed the FIRST block's panel. Each region +# now carries its own sentinel, and a payload read back in a later session +# finds those gone -- .ctwasResolveLdPaths() re-mints one per region and +# re-keys the loader cache onto them. # ============================================================================= -test_that("bundled cTWAS payloads carry a resolvable LD token", { +test_that("bundled cTWAS payloads carry one resolvable token per region", { data(ctwasInputsExample) data(ctwasEstExample) data(ctwasFinemapExample) @@ -3251,16 +3466,24 @@ test_that("bundled cTWAS payloads carry a resolvable LD token", { ctwasFinemapExample )) { tokens <- as.character(payload$LD_map$LD_file) - expect_true(all(startsWith(tokens, "pecotmr://extdata/"))) - resolved <- map_chr( - tokens, - pecotmr:::.resolveCtwasLdToken - ) - expect_true(all(file.exists(resolved))) - expect_equal( - as.character(payload$LD_map$SNP_file), - tokens - ) + # One per region, never shared: the bug was every region reading + # block 1's panel back out of a single key. + expect_equal(length(unique(tokens)), nrow(payload$LD_map)) + expect_equal(as.character(payload$LD_map$SNP_file), tokens) + # Whatever state the sentinels are in on this machine, the resolver + # leaves every region with a token that exists and its own panel. + resolved <- pecotmr:::.ctwasResolveLdPaths(payload) + live <- as.character(resolved$LD_map$LD_file) + expect_true(all(file.exists(live))) + expect_equal(length(unique(live)), nrow(payload$LD_map)) + loader <- resolved$LD_loader_fun + panels <- pecotmr:::.ctwasCachedPanels(resolved) + for (i in seq_along(live)) { + expect_equal( + loader(live[[i]]), + pecotmr:::.ctwasPanelLd(panels[[i]]) + ) + } } }) @@ -3300,7 +3523,9 @@ test_that("finemapCtwasRegions runs from the bundled est payload", { screened <- suppressMessages( screenCtwasRegions( ctwasEstExample, - methodArgs = CtwasOptions(min_nonSNP_PIP = 0) + methodArgs = CtwasOptions( + screen = CtwasScreenOptions(min_nonSNP_PIP = 0) + ) ) ) out <- suppressMessages(finemapCtwasRegions(screened)) @@ -3319,11 +3544,11 @@ test_that("finemapCtwasRegions runs from the bundled est payload", { test_that("ctwas LD assembly reports a missing LD sketch like everything else", { expect_error( - pecotmr:::.ctwasComputeFullPanelLd(NULL), + pecotmr:::.ctwasPanelFor(NULL), "carries no ldSketch" ) expect_error( - pecotmr:::.ctwasComputeFullPanelLd("not a panel"), + pecotmr:::.ctwasPanelFor("not a panel"), "must be a genotype panel" ) }) @@ -3334,7 +3559,7 @@ test_that("the shared validator gives ctwas and .ldFromSketch one message", { error = conditionMessage ) own <- tryCatch( - pecotmr:::.ctwasComputeFullPanelLd(NULL), + pecotmr:::.ctwasPanelFor(NULL), error = conditionMessage ) expect_equal(own, shared) @@ -3631,7 +3856,7 @@ test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { S4Vectors::mcols(emptyGr)$Z <- numeric(0) S4Vectors::mcols(emptyGr)$N <- integer(0) gss <- GwasSumStats( - study = "G1", + studyName = "G1", entry = list(emptyGr), genome = "hg19", blockId = "b1" @@ -3658,7 +3883,7 @@ test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { g } GwasSumStats( - study = c("G1", "G1"), + studyName = c("G1", "G1"), entry = list(mkGr("chr1", c(100L, 200L)), mkGr("chr1", c(300L, 400L))), genome = "hg19", blockId = c("b1", "b2"), @@ -3668,7 +3893,7 @@ test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { test_that(".ctwasFirstPass requires an LD reference on every region", { byBlock <- pecotmr:::.ctwasGwasByBlock(.ctp_noLdGwas()) - expect_null(getLdSketch(byBlock[[1L]])) + expect_null(ldSketch(byBlock[[1L]])) expect_error( pecotmr:::.ctwasFirstPass("b1", byBlock, list(b1 = NULL)), "region 'b1' carries no ldSketch" @@ -3705,7 +3930,7 @@ test_that(".ctwasTraitPosAt is bounded by the traitPos column length", { ) ) res <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(row), traitPos = GenomicRanges::GRanges("chr1", IRanges::IRanges(500, 900)) diff --git a/tests/testthat/test_ctwasWrapper.R b/tests/testthat/test_ctwasWrapper.R index a0f08227..828597a6 100644 --- a/tests/testthat/test_ctwasWrapper.R +++ b/tests/testthat/test_ctwasWrapper.R @@ -6,13 +6,12 @@ context("ctwasWrapper") # that are exercised only through a full run, stay in test_ctwasPipeline.R. # ============================================================================= -test_that("CtwasOptions now reaches compute_gene_z too", { +test_that("the geneZ bundle reaches compute_gene_z", { 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") + # `logfile` was unreachable. It now has its own bundle. + expect_s4_class(CtwasGeneZOptions(logfile = "gene-z.log"), "MethodOptions") seen <- NULL local_mocked_bindings( # The mock must carry the REAL formals: .ctwasInvoke filters the @@ -32,7 +31,7 @@ test_that("CtwasOptions now reaches compute_gene_z too", { pecotmr:::.ctwasEnsureZGene( inputs, numThreads = 1L, - extra = CtwasOptions(logfile = "gene-z.log") + extra = CtwasGeneZOptions(logfile = "gene-z.log") ) expect_equal(seen$logfile, "gene-z.log") expect_equal(seen$ncore, 1L) @@ -52,44 +51,111 @@ test_that("screenCtwasRegions no longer advertises an L it cannot use", { 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))) + expect_true( + "maxNumSingleEffects" %in% names(formals(finemapCtwasRegions)) + ) }) -test_that("CtwasOptions validates against what the ctwas steps accept together", { - a <- CtwasOptions(min_group_size = 2L, min_gene = 1L) +test_that("CtwasOptions nests one bundle per ctwas step", { + skip_if_not_installed("ctwas") + a <- CtwasOptions( + estParam = CtwasEstParamOptions(min_group_size = 2L), + screen = CtwasScreenOptions(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)))) + expect_equal( + names(a), + c( + "geneZ", "regionData", "estParam", "screen", "expand", + "finemap", "merge", "boundaryGenes" + ) + ) + expect_equal(a$estParam$min_group_size, 2L) + expect_equal(a$screen$min_gene, 1L) + # A bare list is refused the same way every other bundle refuses one. + expect_error(CtwasOptions(screen = list(min_gene = 1L)), "CtwasScreen") +}) + +test_that("each step's bundle accepts only that step's names", { + skip_if_not_installed("ctwas") + # This is what the flat bundle could not do: it was checked against the + # UNION of every step's formals, so of 55 names 29 were accepted by + # exactly one step -- and a name aimed at the wrong step was taken and + # then silently dropped. Now it is a construction-time error. + expect_s4_class(CtwasScreenOptions(min_nonSNP_PIP = 0), "MethodOptions") + expect_error( + CtwasFinemapOptions(min_nonSNP_PIP = 0), + "unknown argument" + ) + expect_s4_class(CtwasFinemapOptions(min_abs_corr = 0.1), "MethodOptions") + expect_error(CtwasScreenOptions(min_abs_corr = 0.1), "unknown argument") }) -test_that("CtwasOptions rejects a name no ctwas step accepts", { +test_that("the region-assembly step is no longer undeclared", { + skip_if_not_installed("ctwas") + # assemble_region_data was missing from the flat bundle's callee set even + # though the pipeline calls it, so four of its real options were + # rejected as unknown. + for (nm in c("trim_by", "thin_by", "adjust_boundary_genes", "seed")) { + expect_s4_class( + do.call(CtwasRegionDataOptions, setNames(list(1L), nm)), + "MethodOptions" + ) + } +}) + +test_that("the estParam bundle covers the prefit-EM fallback too", { + skip_if_not_installed("ctwas") + # The pipeline falls back from est_param() to ctwas's internal fit_EM(), + # whose formals are NOT a subset -- so the bundle is checked against + # both and .ctwasInvoke drops whichever the running step lacks. + expect_s4_class( + CtwasEstParamOptions(warn_converge_fail = FALSE), "MethodOptions" + ) + expect_s4_class(CtwasEstParamOptions(EM_tol = 1e-4), "MethodOptions") +}) + +test_that("the merge bundle also accepts its fine-mapping rerun's names", { + skip_if_not_installed("ctwas") + # Both postprocess_region_merging*() forward `...` into a fine-mapping + # rerun, so finemap_regions' formals are legitimate here -- twelve names + # reach the rerun and nothing else. That is why the merge call must not + # be filtered down to the merge function's own formals. + expect_s4_class(CtwasMergeOptions(combine_PIPs = TRUE), "MethodOptions") + expect_s4_class(CtwasMergeOptions(min_abs_corr = 0.1), "MethodOptions") + expect_s4_class(CtwasMergeOptions(coverage = 0.9), "MethodOptions") +}) + +test_that("a step bundle rejects a name no ctwas step accepts", { + skip_if_not_installed("ctwas") # `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), + CtwasEstParamOptions(filter_L = FALSE), "unknown argument\\(s\\) filter_L" ) - expect_error(CtwasOptions(min_genee = 1L), "unknown argument") + expect_error(CtwasScreenOptions(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 =\\)") +test_that("step bundles refuse pecotmr's own pipeline parameters", { + skip_if_not_installed("ctwas") + # These ARE real ctwas formals, so a formals check alone would wave them + # through -- but the pipeline supplies them, so a value set here was + # silently discarded. The error names the setting that takes effect, and + # it is now raised by the step that would have dropped it. expect_error( - CtwasOptions(group_prior_var_structure = "shared_all"), + CtwasRegionDataOptions(thin = 0.1), "CtwasPriorParam\\(thin =\\)" + ) + expect_error( + CtwasEstParamOptions(niter = 10L), "CtwasPriorParam\\(niter =\\)" + ) + expect_error( + CtwasEstParamOptions(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 =\\)") + expect_error(CtwasFinemapOptions(L = 5L), "the pipeline's own") + expect_error(CtwasGeneZOptions(ncore = 4L), "the pipeline's own") + expect_error( + CtwasMergeOptions(maxSNP = 10L), "BoundaryMergeParam\\(maxSnp =\\)" + ) }) diff --git a/tests/testthat/test_exampleData.R b/tests/testthat/test_exampleData.R index d18518aa..c9e1cfd3 100644 --- a/tests/testthat/test_exampleData.R +++ b/tests/testthat/test_exampleData.R @@ -130,10 +130,13 @@ test_that("the bundled LD references describe one shared variant set", { data(ldScoreExample) expect_equal(length(ldEigenExample), length(ldScoreExample)) expect_equal(names(ldEigenExample), names(ldScoreExample)) - expect_equal(getGenome(ldEigenExample), getGenome(ldScoreExample)) + expect_equal( + unname(GenomeInfoDb::genome(ldEigenExample)), + unname(GenomeInfoDb::genome(ldScoreExample)) + ) # Two routes to the same quantity; disagreement means one has drifted. expect_equal( - as.vector(getLdScores(ldScoreExample)[, 1]), + as.vector(mcols(ldScoreExample)$ldScores[, 1]), as.vector(computeLdScores(ldEigenExample)[, 1]) ) }) @@ -142,8 +145,8 @@ test_that("the bundled LD references support a block jackknife", { data(ldEigenExample) data(ldScoreExample) # estimateH2 requires at least two blocks and wants many more. - expect_gte(length(getEigenList(ldEigenExample)), 10L) - expect_gte(length(getLdMatrixList(ldScoreExample)), 10L) + expect_gte(length(eigenList(ldEigenExample)), 10L) + expect_gte(length(ldMatrixList(ldScoreExample)), 10L) expect_gt(length(ldEigenExample), 500L) }) @@ -163,23 +166,23 @@ test_that("every estimateH2 method runs on the bundled LD references", { system.file("extdata", "toy_ref.bed", package = "pecotmr") ) ss <- GwasSumStats( - study = "trait1", + studyName = "trait1", entry = list(gr), - genome = getGenome(ldScoreExample), + genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), ldSketch = panel ) for (method in c("sldsc", "gldsc")) { res <- estimateH2(ss, ldScoreExample, method = method) expect_s4_class(res, "H2Estimate") - expect_true(is.finite(getH2(res)), info = method) - expect_true(is.finite(getH2Se(res)), info = method) - expect_gt(getH2Se(res), 0) + expect_true(is.finite(heritabilityEstimate(res)), info = method) + expect_true(is.finite(heritabilityEstimateSe(res)), info = method) + expect_gt(heritabilityEstimateSe(res), 0) } for (method in c("lder", "hdl")) { res <- suppressWarnings( estimateH2(ss, ldEigenExample, method = method) ) expect_s4_class(res, "H2Estimate") - expect_true(is.finite(getH2(res)), info = method) + expect_true(is.finite(heritabilityEstimate(res)), info = method) } }) diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index a8f9c1dd..d040a0b0 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -34,31 +34,31 @@ context("fineMappingPipeline") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -109,7 +109,7 @@ context("fineMappingPipeline") contexts ) QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = phen, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -138,7 +138,7 @@ context("fineMappingPipeline") .fmp_makeQtlSumStats <- function(qc = TRUE) { QtlSumStats( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", entry = list(.fmp_makeSumstatsGr()), @@ -148,9 +148,9 @@ context("fineMappingPipeline") ) } -.fmp_makeGwasSumStats <- function(qc = TRUE, study = "G1") { +.fmp_makeGwasSumStats <- function(qc = TRUE, studyName = "G1") { GwasSumStats( - study = study, + studyName = studyName, entry = list(.fmp_makeSumstatsGr()), genome = "hg19", ldSketch = .fmp_makeHandle(), @@ -337,8 +337,8 @@ test_that(".fmNormalizeMethods: a methods record keeps kwargs + fills susie L", test_that(".fmNormalizeMethods: L / Lgreedy args override the susie defaults", { res <- pecotmr:::.fmNormalizeMethods( c("susie"), - L = 30L, - Lgreedy = 7L, + maxNumSingleEffects = 30L, + maxNumSingleEffectsGreedy = 7L, inputKind = "QtlDataset" ) expect_equal(res$methodArgs$susie$L, 30L) @@ -457,7 +457,7 @@ test_that(".fmTraitsInRegion: keeps genes overlapping the region; NULL keeps all test_that(".fmResolveSusieChain: chains susie from susieInf when both are requested", { res <- pecotmr:::.fmResolveSusieChain( c("susieInf", "susie"), - addSusieInf = TRUE + initializeWithSusieInf = TRUE ) expect_true(res$chainSusie) expect_true(res$runInf) @@ -467,14 +467,14 @@ test_that(".fmResolveSusieChain: chains susie from susieInf when both are reques test_that(".fmResolveSusieChain: keeps susieInf when explicitly requested", { res <- pecotmr:::.fmResolveSusieChain( c("susieInf", "susie"), - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) expect_true(res$runInf) expect_true(res$keepInf) }) test_that(".fmResolveSusieChain: no chain when addSusieInf=FALSE", { - res <- pecotmr:::.fmResolveSusieChain(c("susie"), addSusieInf = FALSE) + res <- pecotmr:::.fmResolveSusieChain(c("susie"), initializeWithSusieInf = FALSE) expect_false(res$chainSusie) expect_false(res$runInf) }) @@ -498,7 +498,7 @@ test_that(".fmCacheLookup: returns matching entry by 4-tuple", { ) ) fmr <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -531,7 +531,7 @@ test_that(".fmCacheLookupGwas: matches on study/method/blockId", { # when none is supplied; the lookup must include it in the 3-tuple # key (multi-block FMRs disambiguate per-block fits by blockId). fmr <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) @@ -554,7 +554,7 @@ test_that(".fmCacheLookupGwas: the range key disambiguates multi-block FMRs", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(3, offset = 10000L) fmr <- GwasFineMappingResult( - study = c("g1", "g1"), + studyName = c("g1", "g1"), method = c("susie", "susie"), entry = list(e1, e2) ) @@ -581,7 +581,7 @@ test_that(".fmCacheLookup: non-QtlFineMappingResult input returns NULL", { ) ) gwasFmr <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) @@ -599,7 +599,7 @@ test_that(".fmCacheLookupGwas: non-GwasFineMappingResult input returns NULL", { ) ) qtlFmr <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -647,7 +647,7 @@ test_that(".rbindFineMappingResult: rejects non-FineMappingResultBase input", { ) ) fmr <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -674,14 +674,14 @@ test_that(".rbindFineMappingResult: rejects mixed Qtl/Gwas inputs", { ) ) qtlFmr <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", entry = list(e) ) gwasFmr <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", entry = list(e) ) @@ -701,8 +701,8 @@ test_that(".rbindFineMappingResult: concatenates two GwasFineMappingResult colle stringsAsFactors = FALSE ) ) - a <- GwasFineMappingResult(study = "g1", method = "susie", entry = list(e)) - b <- GwasFineMappingResult(study = "g2", method = "susie", entry = list(e)) + a <- GwasFineMappingResult(studyName = "g1", method = "susie", entry = list(e)) + b <- GwasFineMappingResult(studyName = "g2", method = "susie", entry = list(e)) out <- pecotmr:::.rbindFineMappingResult(a, b) expect_s4_class(out, "GwasFineMappingResult") expect_equal(nrow(out), 2L) @@ -719,7 +719,7 @@ test_that("combineFineMappingResults: row-binds same-class collections; rejects ) ) g1 <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", blockId = "r1", entry = list(e) @@ -728,7 +728,7 @@ test_that("combineFineMappingResults: row-binds same-class collections; rejects # (study, method, range), so two rows over the same variants would be the # same block regardless of their labels. g2 <- GwasFineMappingResult( - study = "g1", + studyName = "g1", method = "susie", blockId = "r2", entry = list(.sc_makeFineMappingRow(3, offset = 10000L)) @@ -738,7 +738,7 @@ test_that("combineFineMappingResults: row-binds same-class collections; rejects expect_equal(nrow(out), 2L) expect_equal(nrow(combineFineMappingResults(list(g1, g2))), 2L) # list form q <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -781,13 +781,13 @@ test_that("fineMappingPipeline(QtlDataset): runs univariate dispatch with mocked qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") # 1 context x 2 traits x 1 method = 2 rows. expect_equal(nrow(res), 2L) - expect_setequal(getMethodNames(res), "susie") + expect_setequal(methodNames(res), "susie") }) test_that("fineMappingPipeline(QtlDataset): threads real trait positions into traitPos provenance", { @@ -806,10 +806,10 @@ test_that("fineMappingPipeline(QtlDataset): threads real trait positions into tr qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) - tp <- getTraitPosition(res) + tp <- traitPosition(res) expect_s4_class(tp, "GRanges") expect_length(tp, nrow(res)) expect_true(all(as.character(GenomicRanges::seqnames(tp)) == "chr1")) @@ -822,12 +822,12 @@ test_that("fineMappingPipeline(QtlDataset): threads real trait positions into tr expect_equal(tss[["ENSG_B"]], 2000L) expect_equal(ent[["ENSG_A"]], 1499L) expect_equal(ent[["ENSG_B"]], 2499L) - # getRegion() reports the REALIZED variant span now, not the nominal cis + # genomicRegion() reports the REALIZED variant span now, not the nominal cis # window (traitPos +/- cisWindow). The window is gone because it had no # correct update rule under subsetRegion(); the span is in sync with the # variants by construction. It still sits inside the window the fit was # drawn from, which is what this checks. - reg <- getRegion(res) + reg <- genomicRegion(res) rs <- setNames(GenomicRanges::start(reg), res$trait) re <- setNames(GenomicRanges::end(reg), res$trait) expect_gte(rs[["ENSG_A"]], 1L) # traitPos 1000 - cisWindow, clamped @@ -843,7 +843,7 @@ test_that(".fmAfForX: returns directional effect-allele af aligned to colnames(X .package = "pecotmr" ) region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 100000L)) - # The helper aligns af to dimnames; values come from getAf over the same + # The helper aligns af to dimnames; values come from af over the same # selection. Columns deliberately reordered to test name-based alignment. X <- matrix( 0, @@ -859,7 +859,7 @@ test_that(".fmAfForX: returns directional effect-allele af aligned to colnames(X expect_false(anyNA(af)) # region matched -> every fitted variant has an af expect_equal( af, - unname(getAf(qd, region = region, samples = rownames(X))[colnames(X)]) + unname(af(qd, region = region, samples = rownames(X))[colnames(X)]) ) }) @@ -877,7 +877,7 @@ test_that(".fmAfForX: returns NULL for an empty block or a non-QtlDataset source }) test_that("fineMappingPipeline(QtlDataset): threads directional af into postprocess", { - # Regression for af = NA in getCs: the individual-level univariate path must + # Regression for af = NA in credibleSets: the individual-level univariate path must # forward a non-NULL, directional effect-allele frequency to the # post-processor (which writes it into the topLoci `af` column). qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") @@ -924,7 +924,7 @@ test_that("fineMappingPipeline(QtlDataset): threads directional af into postproc qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) # af forwarded (not left at the NULL default), one value per fitted variant. @@ -948,7 +948,7 @@ test_that("fineMappingPipeline(QtlDataset): seed argument is accepted and runs", qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, seed = 42L ) ) @@ -1011,13 +1011,13 @@ test_that("fineMappingPipeline( qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, usePCA = TRUE, nPCs = 2L ) ) expect_s4_class(res, "QtlFineMappingResult") - expect_setequal(getMethodNames(res), "susie") + expect_setequal(methodNames(res), "susie") pcRows <- as.character(res$trait) %in% c("topPC1", "topPC2") # 3 per-trait univariate susie rows + 2 top-PC rows = 5. expect_equal(sum(pcRows), 2L) @@ -1030,7 +1030,7 @@ test_that(".fmLookupMrmashFit: finds the mr.mash fit by (study, trait)", { twasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2), - fits = fits + methodFits = fits ) } payload <- list( @@ -1041,7 +1041,7 @@ test_that(".fmLookupMrmashFit: finds the mr.mash fit by (study, trait)", { # The joint fit lives on the first mrmash row of the (study, trait) group; # the other context row carries fits = NULL. A non-mrmash row is ignored. tw <- TwasWeights( - study = c("S", "S", "S"), + studyName = c("S", "S", "S"), context = c("c1", "c2", "c1"), trait = c("G", "G", "G"), method = c("mrmash", "mrmash", "enet"), @@ -1067,7 +1067,7 @@ test_that(".fmLookupMrmashCv: finds the per-fold CV payload by (study, trait)", foldFits = list(fold_1 = list(w0 = 1)) ) tw <- TwasWeights( - study = c("S", "S"), + studyName = c("S", "S"), context = c("c1", "c2"), trait = c("G", "G"), method = c("mrmash", "mrmash"), @@ -1079,7 +1079,7 @@ test_that(".fmLookupMrmashCv: finds the per-fold CV payload by (study, trait)", expect_null(lk(NULL, "S", "G")) # A cvResult without foldFits is not a per-fold prior payload -> NULL. tw2 <- TwasWeights( - study = "S", + studyName = "S", context = "c1", trait = "G", method = "mrmash", @@ -1212,13 +1212,13 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips no-signal univ qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, signalScreenArgs = SignalScreenParam(pip = -1) ) ) # ENSG_A screened out, ENSG_B kept -> a single row. expect_equal(nrow(res), 1L) - expect_setequal(getTraits(res), "ENSG_B") + expect_setequal(traitNames(res), "ENSG_B") }) test_that("fineMappingPipeline( @@ -1241,14 +1241,14 @@ test_that("fineMappingPipeline( qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, crossValidationArgs = CrossValidationParam(folds = 3), verbose = 0 ) ) - cv <- getCvResult( + cv <- cvResult( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "susie" @@ -1278,12 +1278,12 @@ test_that("fineMappingPipeline( qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) - expect_null(getCvResult( + expect_null(cvResult( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "susie" @@ -1493,14 +1493,14 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie multi-trait single-context d expect_s4_class(res, "QtlFineMappingResult") # mvsusie multi-trait fans the joint fit out across both traits. expect_equal(nrow(res), 2L) - expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) - expect_setequal(getMethodNames(res), "mvsusie") + expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) + expect_setequal(methodNames(res), "mvsusie") # Engine-built (multivariate) FM rows carry BOTH provenance columns, derived in # the shared .runJointCell seam: traitPos = the bare trait position, region = # traitPos +/- cisWindow (1000). This is the path the univariate pushRow # threading never touches, so it is the regression guard for the engine fix. - tp <- getTraitPosition(res) - reg <- getRegion(res) + tp <- traitPosition(res) + reg <- genomicRegion(res) expect_s4_class(tp, "GRanges") expect_s4_class(reg, "GRanges") tpS <- setNames(GenomicRanges::start(tp), res$trait) @@ -1534,8 +1534,8 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie multi-context single-trait d ) # Multi-context fan-out: one row per context for the shared trait. expect_equal(nrow(res), 2L) - expect_setequal(getContexts(res), c("brain", "liver")) - expect_setequal(getTraits(res), "ENSG_A") + expect_setequal(contexts(res), c("brain", "liver")) + expect_setequal(traitNames(res), "ENSG_A") }) test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip drops null contexts before joint mvsusie", { @@ -1565,7 +1565,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip drops null contexts ) # liver screened out -> the joint fit runs on brain + heart only. expect_equal(nrow(res), 2L) - expect_setequal(getContexts(res), c("brain", "heart")) + expect_setequal(contexts(res), c("brain", "heart")) }) test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < 2 contexts survive", { @@ -1589,13 +1589,13 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < qd, methods = c("susie", "mvsusie"), cisWindow = 1000L, - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, signalScreenArgs = SignalScreenParam(pip = -1) ) ) # mvsusie skipped (only 1 context survives); susie still produced per-context. - expect_setequal(getMethodNames(res), "susie") - expect_false("mvsusie" %in% getMethodNames(res)) + expect_setequal(methodNames(res), "susie") + expect_false("mvsusie" %in% methodNames(res)) }) test_that("fineMappingPipeline(QtlDataset): mvsusie both multi falls back to per-context multi-trait", { @@ -1645,13 +1645,13 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait auto-detection USES the twasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2), - fits = fitParts + methodFits = fitParts ) } # What twasWeightsPipeline(jointSpecification='trait') emits: per-trait rows # each carrying the SHARED joint fit for (study1, brain). tw <- TwasWeights( - study = c("study1", "study1"), + studyName = c("study1", "study1"), context = c("brain", "brain"), trait = c("ENSG_A", "ENSG_B"), method = c("mrmash", "mrmash"), @@ -1740,7 +1740,7 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie resume cache short-circuits ) } cache <- QtlFineMappingResult( - study = c("study1", "study1"), + studyName = c("study1", "study1"), context = c("brain", "brain"), trait = c("ENSG_A", "ENSG_B"), method = c("mvsusie", "mvsusie"), @@ -1801,7 +1801,7 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' produces one joi expect_equal(nrow(res), 4L) expect_true("jointContexts" %in% pecotmr:::.tupleColumnNames(res)) expect_setequal(as.character(res$context), c("brain", "liver")) - expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) + expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) expect_true(all(grepl( "brain;liver|liver;brain", as.character(res$jointContexts) @@ -1827,7 +1827,7 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' + univariate com methods = c("susie", "mvsusie"), cisWindow = 1000L, jointSpecification = "context", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) # susie -> 2 univariate rows (one per context); mvsusie joint over 2 contexts @@ -1949,8 +1949,8 @@ test_that("fineMappingPipeline(QtlDataset): fsusie multi-trait per context dispa ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) - expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) - expect_setequal(getMethodNames(res), "fsusie") + expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) + expect_setequal(methodNames(res), "fsusie") }) # =========================================================================== @@ -1959,13 +1959,13 @@ test_that("fineMappingPipeline(QtlDataset): fsusie multi-trait per context dispa test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across constituent QtlDatasets", { qd1 <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .fmp_makeHandle(), phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) ) qd2 <- QtlDataset( - study = "s2", + studyName = "s2", genotypes = .fmp_makeHandle(), phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -1982,15 +1982,15 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across mt, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") # One row per (study, context, trait, method) tuple. expect_equal(nrow(res), 2L) - expect_setequal(getStudy(res), c("s1", "s2")) + expect_setequal(studyName(res), c("s1", "s2")) # Pure individual-level -> ldSketch should be NULL. - expect_null(getLdSketch(res)) + expect_null(ldSketch(res)) }) test_that("fineMappingPipeline(MultiStudyQtlDataset): per-study options are not dropped", { @@ -2022,21 +2022,21 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): per-study options are not ), methods = "susie", cisWindow = 1000L, - credibleSetArgs = CredibleSetParam(coverage = 0.9), + credibleSetParam = CredibleSetParam(coverage = 0.9), fitRetention = "full", - genotypeFilterArgs = GenotypeFilterParam(mafCutoff = 0.05), + genotypeFilterParam = 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_equal(capX$cfg$genotypeFilterParam$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$credibleSetParam$coverage, 0.9) expect_equal(capSs$cfg$fitRetention, "full") }) @@ -2083,8 +2083,8 @@ test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { mt, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE, - credibleSetArgs = CredibleSetParam(L = 4L, Lgreedy = 2L) + initializeWithSusieInf = FALSE, + credibleSetParam = CredibleSetParam(maxNumSingleEffects = 4L, maxNumSingleEffectsGreedy = 2L) ) ) # The multi-study method had no L / Lgreedy formals of its own before the @@ -2099,13 +2099,13 @@ test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges per region in each study", { qd1 <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .fmp_makeHandle(), phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) ) qd2 <- QtlDataset( - study = "s2", + studyName = "s2", genotypes = .fmp_makeHandle(), phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -2127,15 +2127,15 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges traitId = "ENSG_A", region = regions, jointRegions = FALSE, - addSusieInf = FALSE + initializeWithSusieInf = FALSE )) expect_s4_class(res, "QtlFineMappingResult") # one merged row per study (region collapsed into the entry). expect_equal(nrow(res), 2L) - expect_setequal(getStudy(res), c("s1", "s2")) - fit <- getSusieFit( + expect_setequal(studyName(res), c("s1", "s2")) + fit <- susieFit( res, - study = "s1", + studyName = "s1", context = "brain", trait = "ENSG_A", method = "susie" @@ -2145,7 +2145,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges test_that("fineMappingPipeline(MSQD): embedded sumstats record ldSketch", { qd <- QtlDataset( - study = "s1", + studyName = "s1", genotypes = .fmp_makeHandle(), phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -2164,13 +2164,13 @@ test_that("fineMappingPipeline(MSQD): embedded sumstats record ldSketch", { mt, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") expect_true(nrow(res) >= 2L) # Embedded sumstats has an LD sketch -> the merged result carries it. - expect_s4_class(getLdSketch(res), "RangedSummarizedExperiment") + expect_s4_class(ldSketch(res), "RangedSummarizedExperiment") }) # =========================================================================== @@ -2189,7 +2189,7 @@ test_that("fineMappingPipeline(QtlSumStats): runs end-to-end with mocked RSS fit fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") @@ -2228,12 +2228,12 @@ test_that("fineMappingPipeline(GwasSumStats): runs end-to-end with mocked RSS fi fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "GwasFineMappingResult") expect_equal(nrow(res), 1L) - expect_setequal(getMethodNames(res), "susie") + expect_setequal(methodNames(res), "susie") }) test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { @@ -2259,7 +2259,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { N = perVarN ) gss <- GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = .fmp_makeHandle(), @@ -2306,7 +2306,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) # per-variant N forwarded (all 5 distinct), not the scalar median, not 1. @@ -2319,11 +2319,11 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { # A GwasSumStats whose (single) entry was emptied by summaryStatsQc's PIP screen: # 0-variant entry + qcInfo$entryAudit[[1]]$pipScreenSkipped = TRUE (+ reason). .fmp_makeScreenedGwas <- function( - study = "G1", + studyName = "G1", reason = "no signals above PIP threshold 0.025" ) { GwasSumStats( - study = study, + studyName = studyName, entry = list(GenomicRanges::GRanges()), genome = "hg19", ldSketch = .fmp_makeHandle(), @@ -2342,7 +2342,7 @@ test_that("fineMappingPipeline(GwasSumStats): a PIP-screened region yields an em res <- fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ), "region skipped" ) @@ -2352,7 +2352,7 @@ test_that("fineMappingPipeline(GwasSumStats): a PIP-screened region yields an em test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only the real region", { gss <- GwasSumStats( - study = c("Gskip", "Greal"), + studyName = c("Gskip", "Greal"), entry = list(GenomicRanges::GRanges(), .fmp_makeSumstatsGr()), genome = "hg19", ldSketch = .fmp_makeHandle(), @@ -2373,7 +2373,7 @@ test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only t fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_equal(unique(as.character(res$study)), "Greal") # screened study absent @@ -2382,7 +2382,7 @@ test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only t test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even without the flag", { gss <- GwasSumStats( - study = "G1", + studyName = "G1", entry = list(GenomicRanges::GRanges()), genome = "hg19", ldSketch = .fmp_makeHandle(), @@ -2392,7 +2392,7 @@ test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "GwasFineMappingResult") @@ -2401,7 +2401,7 @@ test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefully", { qss <- QtlSumStats( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", entry = list(GenomicRanges::GRanges()), @@ -2418,7 +2418,7 @@ test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefu fineMappingPipeline( qss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") @@ -2439,14 +2439,14 @@ test_that("fineMappingPipeline(GwasSumStats): serFallback + reliable R keeps mul fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb" ) ) ) - sf <- getSusieFit(res, study = "G1", method = "susie") + sf <- susieFit(res, studyName = "G1", method = "susie") # Multi-effect fit reported (payload keeps the multi tag, not the ser tag). expect_equal(sf$payload$multiTag, "multi") expect_false(sf$serFallbackUsed) @@ -2467,14 +2467,14 @@ test_that("fineMappingPipeline(GwasSumStats): serFallback + unreliable R falls b fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb" ) ) ) - sf <- getSusieFit(res, study = "G1", method = "susie") + sf <- susieFit(res, studyName = "G1", method = "susie") # Reported result is the single-effect ser_model. expect_equal(sf$payload$serTag, "ser") expect_true(sf$serFallbackUsed) @@ -2496,10 +2496,10 @@ test_that("fineMappingPipeline(GwasSumStats): serFallback=FALSE default is behav fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) - sf <- getSusieFit(res, study = "G1", method = "susie") + sf <- susieFit(res, studyName = "G1", method = "susie") # No fallback even though flag=TRUE; multi-effect result kept. expect_equal(sf$payload$multiTag, "multi") # Feature off: the susieFit carries NO diagnostic fields (byte-identical to @@ -2522,8 +2522,8 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb" ) @@ -2545,8 +2545,8 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rFinite = 12345, rMismatch = "eb" @@ -2567,8 +2567,8 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb_mix" ) @@ -2588,8 +2588,8 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( control = SusieRssControlOptions( check_prior = TRUE, mismatch_estimator = "map" @@ -2613,7 +2613,7 @@ test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFini fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_null(cap5$rssControl) @@ -2631,15 +2631,15 @@ test_that("fineMappingPipeline(GwasSumStats): keepFullFit='all' retains fit on n fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb", keepFullFit = "all" ) ) ) - sf <- getSusieFit(res, study = "G1", method = "susie") + sf <- susieFit(res, studyName = "G1", method = "susie") expect_false(is.null(sf$multiEffectFit)) expect_equal(sf$multiEffectFit$multiTag, "multi") }) @@ -2657,8 +2657,8 @@ test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the sus fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE, - credibleSetArgs = CredibleSetParam(L = 4L, Lgreedy = 2L) + initializeWithSusieInf = FALSE, + credibleSetParam = CredibleSetParam(maxNumSingleEffects = 4L, maxNumSingleEffectsGreedy = 2L) ) ) # QtlDataset and GwasSumStats have always taken these; QtlSumStats did not, @@ -2680,8 +2680,8 @@ test_that("fineMappingPipeline(QtlSumStats): per-method L beats the top-level L" fineMappingPipeline( ss, methods = list(susie = list(L = 7L)), - addSusieInf = FALSE, - credibleSetArgs = CredibleSetParam(L = 4L) + initializeWithSusieInf = FALSE, + credibleSetParam = CredibleSetParam(maxNumSingleEffects = 4L) ) ) expect_equal(cap$userArgs$L, 7L) @@ -2700,7 +2700,7 @@ test_that("fineMappingPipeline(QtlSumStats): serFallback=FALSE default leaves th fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") @@ -2709,9 +2709,9 @@ test_that("fineMappingPipeline(QtlSumStats): serFallback=FALSE default leaves th # mock flags the fit unreliable -- so the result is byte-identical to before. expect_null(cap$rFinite) expect_equal(cap$rMismatch, "none") - sf <- getSusieFit( + sf <- susieFit( res, - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie" @@ -2733,16 +2733,16 @@ test_that("fineMappingPipeline(QtlSumStats): serFallback + reliable R keeps mult fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb" ) ) ) - sf <- getSusieFit( + sf <- susieFit( res, - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie" @@ -2767,16 +2767,16 @@ test_that("fineMappingPipeline(QtlSumStats): serFallback + unreliable R falls ba fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb" ) ) ) - sf <- getSusieFit( + sf <- susieFit( res, - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie" @@ -2803,8 +2803,8 @@ test_that("fineMappingPipeline(QtlSumStats): rFinite/rMismatch forwarded; rFinit fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb" ) @@ -2826,8 +2826,8 @@ test_that("fineMappingPipeline(QtlSumStats): rFinite/rMismatch forwarded; rFinit fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rFinite = 12345, rMismatch = "eb" @@ -2849,17 +2849,17 @@ test_that("fineMappingPipeline(QtlSumStats): keepFullFit='all' retains fit on no fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE, - rssArgs = SusieRssParam( + initializeWithSusieInf = FALSE, + susieRssParam = SusieRssParam( serFallback = TRUE, rMismatch = "eb", keepFullFit = "all" ) ) ) - sf <- getSusieFit( + sf <- susieFit( res, - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie" @@ -2896,7 +2896,7 @@ test_that("fineMappingPipeline(QtlSumStats): ser dispatches via .fmFitSusieSer", ) res <- suppressMessages(fineMappingPipeline(ss, methods = "ser")) expect_s4_class(res, "QtlFineMappingResult") - expect_setequal(getMethodNames(res), "ser") + expect_setequal(methodNames(res), "ser") }) test_that("fineMappingPipeline(GwasSumStats): ser dispatches via .fmFitSusieSer", { @@ -2909,7 +2909,7 @@ test_that("fineMappingPipeline(GwasSumStats): ser dispatches via .fmFitSusieSer" ) res <- suppressMessages(fineMappingPipeline(gss, methods = "ser")) expect_s4_class(res, "GwasFineMappingResult") - expect_setequal(getMethodNames(res), "ser") + expect_setequal(methodNames(res), "ser") }) test_that("ser is sumstat-only: rejected on QtlDataset, allowed on all sumstat kinds", { @@ -2928,8 +2928,8 @@ test_that("ser is sumstat-only: rejected on QtlDataset, allowed on all sumstat k test_that(".fmNormalizeMethods does not inject L / L_greedy for ser", { norm <- pecotmr:::.fmNormalizeMethods( "ser", - L = 20L, - Lgreedy = 5L, + maxNumSingleEffects = 20L, + maxNumSingleEffectsGreedy = 5L, inputKind = "QtlDataset" ) expect_null(norm$methodArgs[["ser"]][["L"]]) @@ -2965,7 +2965,7 @@ test_that("fineMappingPipeline(ANY): unsupported input class errors", { e1 <- .fmp_makeSumstatsGr() e2 <- .fmp_makeSumstatsGr() QtlSumStats( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c2"), trait = c("t1", "t1"), entry = list(e1, e2), @@ -2990,7 +2990,7 @@ test_that("fineMappingPipeline( # Build a single-context-per-(study, trait) collection. Mvsusie requires # at least two contexts per (study, trait) group. ss <- QtlSumStats( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("t1", "t2"), entry = list(.fmp_makeSumstatsGr(), .fmp_makeSumstatsGr()), @@ -3044,7 +3044,7 @@ test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fi ) ) cache <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -3065,7 +3065,7 @@ test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fi fineMappingPipeline( ss, methods = "susie", - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, fineMappingResult = cache ) ) @@ -3093,7 +3093,7 @@ test_that("fineMappingPipeline(GwasSumStats): cache hit short-circuits the RSS f # entry's GRanges. .fmp_makeSumstatsGr() yields chr1 positions 100..500, # so the cache row must use blockId = "chr1_100_500" to hit. cache <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", blockId = "chr1_100_500", entry = list(cachedEntry), @@ -3113,7 +3113,7 @@ test_that("fineMappingPipeline(GwasSumStats): cache hit short-circuits the RSS f fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, fineMappingResult = cache ) ) @@ -3136,7 +3136,7 @@ test_that("fineMappingPipeline(GwasSumStats): wrong-shape cache (QtlFineMappingR ) ) wrongCache <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -3156,7 +3156,7 @@ test_that("fineMappingPipeline(GwasSumStats): wrong-shape cache (QtlFineMappingR fineMappingPipeline( gss, methods = "susie", - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, fineMappingResult = wrongCache ) ) @@ -3177,7 +3177,7 @@ test_that("fineMappingPipeline(QtlDataset): cache hit avoids the fitter", { ) ) cache <- QtlFineMappingResult( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "susie", @@ -3198,7 +3198,7 @@ test_that("fineMappingPipeline(QtlDataset): cache hit avoids the fitter", { qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, fineMappingResult = cache ) ) @@ -3300,8 +3300,8 @@ test_that(".fmResidGeno / .fmResidPheno forward the bundle to the accessors", { matrix(0, 0, 0) } local_mocked_bindings( - getResidualizedGenotypes = fakeGeno, - getResidualizedPhenotypes = fakePheno, + residualizedGenotypes = fakeGeno, + residualizedPhenotypes = fakePheno, .package = "pecotmr" ) res <- ResidualizationParam( @@ -3325,7 +3325,7 @@ test_that(".fmResidGeno / .fmResidPheno forward the bundle to the accessors", { test_that("an absent bundle becomes the constructor's own defaults", { captured <- NULL local_mocked_bindings( - getResidualizedPhenotypes = function(x, ...) { + residualizedPhenotypes = function(x, ...) { captured <<- list(...) matrix(0, 0, 0) }, @@ -3376,7 +3376,7 @@ test_that("an absent bundle becomes the constructor's own defaults", { # Replacement APIs (do NOT speculatively port — that is out of scope for # this cleanup): `fineMappingPipeline()` dispatched on `GwasSumStats` / # `QtlSumStats` / `QtlDataset`; `summaryStatsQc()` (returns a SumStats -# with `getQcInfo()` populated); `fineMappingRow(variantIds, ...)`; +# with `qcInfo()` populated); `fineMappingRow(variantIds, ...)`; # `result$finemappingEntry` (was `result$finemappingResult`). # =========================================================================== @@ -3475,14 +3475,14 @@ test_that("fineMappingPipeline(QtlDataset): jointRegions=FALSE merges per-region traitId = "ENSG_A", region = regions, jointRegions = FALSE, - addSusieInf = FALSE + initializeWithSusieInf = FALSE )) expect_s4_class(res, "QtlFineMappingResult") # 1 ctx x 1 trait x 1 method -> a single merged row, not one per region. expect_equal(nrow(res), 1L) - fit <- getSusieFit( + fit <- susieFit( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "susie" @@ -3508,12 +3508,12 @@ test_that("fineMappingPipeline(QtlDataset): jointRegions=TRUE fits one concatena traitId = "ENSG_A", region = regions, jointRegions = TRUE, - addSusieInf = FALSE + initializeWithSusieInf = FALSE )) expect_equal(nrow(res), 1L) - fit <- getSusieFit( + fit <- susieFit( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "susie" @@ -3549,9 +3549,9 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie jointRegions=FALSE merges pe jointRegions = FALSE )) expect_equal(nrow(res), 2L) # joint fit fanned out to both traits - fit <- getSusieFit( + fit <- susieFit( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie" @@ -3582,9 +3582,9 @@ test_that("fineMappingPipeline(QtlDataset): fsusie jointRegions=FALSE merges per jointRegions = FALSE )) expect_equal(nrow(res), 2L) - fit <- getSusieFit( + fit <- susieFit( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "fsusie" @@ -3624,9 +3624,9 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec + jointRegions=FALSE merge # merged across the 2 regions. expect_equal(nrow(res), 4L) expect_setequal(as.character(res$context), c("brain", "liver")) - fit <- getSusieFit( + fit <- susieFit( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie" @@ -3651,7 +3651,7 @@ test_that(".fmCheckMethodCapabilities: empty token list is a no-op", { test_that(".fmCacheLookupGwas: NULL / non-GwasFineMappingResult -> NULL", { expect_null(pecotmr:::.fmCacheLookupGwas(NULL, "G1", "susie", "chr1:1-100")) fmr <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "susie", @@ -3790,7 +3790,7 @@ test_that(".fmTopPcScores: nPCs = 0 -> k < 1 -> NULL", { test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec returns the joint result", { ss <- .fmp_makeQtlSumStats() jr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "mvsusie", @@ -3893,7 +3893,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): region + cisWindow is reje test_that("fineMappingPipeline(MultiStudyQtlDataset): mvsusie-only jointSpec returns the joint result", { mt <- .fmp_makeMultiStudy() jr <- QtlFineMappingResult( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie", @@ -4036,7 +4036,7 @@ 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), - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = 0.7, signalCutoff = 0.1, @@ -4125,7 +4125,7 @@ test_that("fineMappingPipeline(QtlSumStats): susieInf RSS chain (mocked)", { fineMappingPipeline( ss, methods = "susieInf", - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, verbose = 1 ) ) @@ -4145,12 +4145,12 @@ test_that("fineMappingPipeline(GwasSumStats): susieInf RSS chain (mocked)", { fineMappingPipeline( gss, methods = "susieInf", - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, verbose = 1 ) ) expect_s4_class(res, "GwasFineMappingResult") - expect_setequal(getMethodNames(res), "susieInf") + expect_setequal(methodNames(res), "susieInf") }) test_that(".fmFoldWeights covers mvPrior residual var, missing rownames, unknown token", { @@ -4250,9 +4250,9 @@ test_that(".fmWeightsCv skips a fold that holds out every sample", { # --- method-level branches (drive the pipeline methods with mocked fitters) --- -test_that(".fmAfForX returns NULL when getAf yields nothing", { +test_that(".fmAfForX returns NULL when af yields nothing", { qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - local_mocked_bindings(getAf = function(...) NULL, .package = "pecotmr") + local_mocked_bindings(af = function(...) NULL, .package = "pecotmr") X <- matrix( 0, 3, @@ -4276,7 +4276,7 @@ test_that("fineMappingPipeline(QtlDataset): explicit valid contexts arg is honor methods = "susie", contexts = "brain", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") @@ -4299,7 +4299,7 @@ test_that("fineMappingPipeline(QtlDataset): region selects traits by rowRanges o qd, methods = "susie", region = region, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") @@ -4328,7 +4328,7 @@ test_that("fineMappingPipeline(QtlDataset): too few shared samples errors", { qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE )), "too few shared samples" ) @@ -4346,7 +4346,7 @@ test_that("fineMappingPipeline(QtlDataset): errors when no tuple produces a resu qd, methods = "susie", cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE )), "no .*tuples" ) @@ -4371,7 +4371,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA fine-maps top PCs of a multi- usePCA = TRUE, nPCs = 1L, cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") @@ -4394,7 +4394,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips single-trait contexts", usePCA = TRUE, nPCs = 1L, cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) ) # single-trait context -> PC loop hits `length(traits) < 2L` next; only the @@ -4424,7 +4424,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointSpec with no intersec # the mvsusie joint dispatch is mocked to keep a non-empty result (no 1647). .fmp_jr <- function() { QtlFineMappingResult( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie", @@ -4454,7 +4454,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a context whose PCA yie usePCA = TRUE, nPCs = 1L, cisWindow = 1000L, - addSusieInf = FALSE + initializeWithSusieInf = FALSE )) expect_false(any(grepl("PC", as.character(res$trait)))) }) @@ -4465,7 +4465,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA reuses a cached PC entry", { traits = c("ENSG_A", "ENSG_B") ) cachedFMR <- QtlFineMappingResult( - study = "study1", + studyName = "study1", context = "brain", trait = "topPC1", method = "susie", @@ -4495,7 +4495,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA reuses a cached PC entry", { usePCA = TRUE, nPCs = 1L, cisWindow = 1000L, - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, fineMappingResult = cachedFMR )) expect_true(any(as.character(res$trait) == "topPC1")) # 1584 cache hit @@ -4600,7 +4600,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block screened out fineMappingPipeline( ss, methods = "susie", - panelFilterArgs = PanelFilterParam(...) + panelFilterParam = PanelFilterParam(...) ) )))) } @@ -4624,10 +4624,10 @@ test_that("fineMappingPipeline RSS cutoffs agree with .panelVariantFilter", { # no more (which would mean something else is filtering) and no fewer # (which would mean the cutoff silently did nothing). ss <- .rssf_qcd() - ids <- getVariantIds(ss) + ids <- variantIds(ss) for (cut in c(0.05, 0.2)) { expected <- length(.panelVariantFilter( - getLdSketch(ss), + ldSketch(ss), ids, PanelFilterParam(mafCutoff = cut) )) @@ -4641,7 +4641,7 @@ test_that("fineMappingPipeline RSS cutoffs agree with .panelVariantFilter", { test_that("fineMappingPipeline RSS treats MAC as a MAF equivalent", { ss <- .rssf_qcd() - nSamp <- ncol(getLdSketch(ss)) + nSamp <- ncol(ldSketch(ss)) expect_equal( .rssf_n(ss, macCutoff = 0.1 * 2 * nSamp), .rssf_n(ss, mafCutoff = 0.1) @@ -4658,7 +4658,7 @@ test_that("fineMappingPipeline RSS honours a missingness cutoff", { test_that(".fmExtractZn keeps z, ids and n aligned after filtering", { ss <- .rssf_qcd() entry <- pecotmr:::.collectionEntry(ss, 1L) - sketch <- getLdSketch(ss) + sketch <- ldSketch(ss) unfiltered <- pecotmr:::.fmExtractZn(entry, "t") filtered <- suppressMessages(pecotmr:::.fmExtractZn( entry, @@ -4825,8 +4825,8 @@ test_that("pecotmr's own seeded arguments are not checked against the engine", { # a susieR formal and must not be reported as a user mistake. norm <- pecotmr:::.fmNormalizeMethods( "susieInf", - L = 5L, - Lgreedy = 2L, + maxNumSingleEffects = 5L, + maxNumSingleEffectsGreedy = 2L, inputKind = "QtlDataset" ) expect_true(is_in("L_greedy", names(norm$methodArgs$susieInf))) @@ -4917,14 +4917,22 @@ test_that("each input path offers only the methods it implements", { expect_null(pecotmr:::.fmTokenPathConfig("ser", "QtlDataset")) }) -test_that("CredibleSetParam owns L / Lgreedy", { +test_that("CredibleSetParam owns the single-effect bounds", { # 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) + # SuSiE-family token as the engine's own `L` / `L_greedy` rather than + # read by postprocessFinemappingFits() -- but that is a plumbing + # difference, not a different setting. + expect_equal(CredibleSetParam()$maxNumSingleEffects, 10L) + expect_false( + "maxNumSingleEffectsGreedy" %in% names(CredibleSetParam()) + ) + expect_equal( + CredibleSetParam( + maxNumSingleEffectsGreedy = 3L + )$maxNumSingleEffectsGreedy, + 3L + ) # addSusieInf stands alone: it selects a chained initialisation between # methods rather than describing credible sets. expect_false("addSusieInf" %in% names(formals(CredibleSetParam))) @@ -5033,18 +5041,20 @@ test_that("every recursion forwards each cfg field its callee accepts", { 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_equal(csCoverage(cs), 0.95) + expect_equal(maxNumSingleEffects(cs), 10L) + expect_null(medianAbsCorr(cs)) + + # Copy semantics: replacement rebinds a modified copy, so another name + # holding the original still sees the old value. + cs2 <- cs + csCoverage(cs2) <- 0.9 + expect_equal(csCoverage(cs2), 0.9) + expect_equal(csCoverage(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") + # The slot's declared type still holds through a replacement. + expect_error(csCoverage(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 @@ -5052,24 +5062,34 @@ test_that("CredibleSetParam accessors read and replace, L is get-only", { ns <- asNamespace("pecotmr") expect_false(exists("setL", envir = ns, inherits = FALSE)) expect_false(exists("setLgreedy", envir = ns, inherits = FALSE)) - expect_true(is.function(getLgreedy)) + expect_true(is.function(maxNumSingleEffectsGreedy)) }) 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") + # + # The accessor is now the field name itself -- the get* prefix is gone -- + # except where the bare field name would have been unusable or taken, so + # those three are named here rather than derived. Writers are the + # matching `<-` replacement generics. + getOnly <- c("maxNumSingleEffects", "maxNumSingleEffectsGreedy") + # The slots now carry their accessors' names, so `coverage` is the only + # field whose accessor is not derivable from it. + renamed <- c(coverage = "csCoverage") ns <- asNamespace("pecotmr") for (f in names(formals(CredibleSetParam))) { - stem <- str_c(str_to_upper(str_sub(f, 1L, 1L)), str_sub(f, 2L)) + accessor <- if (is_in(f, names(renamed))) renamed[[f]] else f expect_true( - exists(str_c("get", stem), envir = ns, inherits = FALSE), - info = paste("no getter for", f) + exists(accessor, envir = ns, inherits = FALSE), + info = paste("no accessor for", f) ) + # The writer is the replacement form of the accessor name, not a + # set* function: `csCoverage(p) <- v`, never `setCoverage(p, v)`. expect_equal( - exists(str_c("set", stem), envir = ns, inherits = FALSE), + exists(str_c(accessor, "<-"), envir = ns, inherits = FALSE), !is_in(f, getOnly), - info = paste("setter presence wrong for", f) + info = paste("replacement presence wrong for", f) ) } }) @@ -5080,23 +5100,146 @@ test_that("CredibleSetParam accessors read and replace every field", { # 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") + expect_equal(secondaryCoverage(cs), c(0.7, 0.5)) + expect_equal(signalCutoff(cs), 0.025) + expect_equal(minAbsCorr(cs), 0.8) + expect_false(includeAllCs(cs)) + expect_equal(perCsColumns(cs), "none") + expect_null(maxNumSingleEffectsGreedy(cs)) + + # Replacement on a copy; `cs` itself keeps its original values. + edited <- cs + secondaryCoverage(edited) <- 0.6 + signalCutoff(edited) <- 0.1 + minAbsCorr(edited) <- 0.5 + medianAbsCorr(edited) <- 0.4 + includeAllCs(edited) <- TRUE + perCsColumns(edited) <- "alpha" + expect_equal(secondaryCoverage(edited), 0.6) + expect_equal(signalCutoff(edited), 0.1) + expect_equal(minAbsCorr(edited), 0.5) + expect_equal(medianAbsCorr(edited), 0.4) + expect_true(includeAllCs(edited)) + expect_equal(perCsColumns(edited), "alpha") + expect_equal(secondaryCoverage(cs), c(0.7, 0.5)) + expect_false(includeAllCs(cs)) + + # Replacement revalidates, so a wrong-typed value is refused. + expect_error(includeAllCs(cs) <- "yes", "includeAllCs") +}) + +# --------------------------------------------------------------------------- +# CredibleSetParam validity +# --------------------------------------------------------------------------- + +test_that("CredibleSetParam validity accepts every legitimate construction", { + expect_s4_class(CredibleSetParam(), "CredibleSetParam") + expect_s4_class( + CredibleSetParam(coverage = 0.9, includeAllCs = TRUE), + "CredibleSetParam" + ) + expect_s4_class( + CredibleSetParam(maxNumSingleEffects = 4L, maxNumSingleEffectsGreedy = 2L), + "CredibleSetParam" + ) + expect_s4_class( + CredibleSetParam(perCsColumns = "alpha"), + "CredibleSetParam" + ) + # No secondary coverages is a legitimate request, not a missing value. + expect_s4_class( + CredibleSetParam(secondaryCoverage = numeric(0)), + "CredibleSetParam" + ) + # medianAbsCorr is optional. + expect_null(medianAbsCorr(CredibleSetParam())) +}) + +test_that("CredibleSetParam validity catches range and length errors", { + # The slot type admits any numeric, so without validity each of these + # was accepted -- out of range, wrong length, and empty alike. + expect_error(CredibleSetParam(coverage = 1.5), "coverage") + expect_error(CredibleSetParam(coverage = c(0.9, 0.95)), "coverage") + expect_error(CredibleSetParam(coverage = numeric(0)), "coverage") + expect_error(CredibleSetParam(minAbsCorr = -1), "minAbsCorr") + expect_error(CredibleSetParam(signalCutoff = 2), "signalCutoff") + expect_error( + CredibleSetParam(secondaryCoverage = c(0.7, 3)), + "secondaryCoverage" + ) + expect_error(CredibleSetParam(maxNumSingleEffects = 0), "maxNumSingleEffects") + expect_error(CredibleSetParam(maxNumSingleEffects = 2.5), "maxNumSingleEffects") + expect_error( + CredibleSetParam(maxNumSingleEffectsGreedy = 0), + "maxNumSingleEffectsGreedy" + ) +}) + +test_that("CredibleSetParam setters are held to the same checks", { + cs <- CredibleSetParam() + # The setter path used to bypass every one of these: its body is + # `x@slot <- value; validObject(x)`, and before setValidity() existed + # validObject() only checked the slot's type. + expect_error(csCoverage(cs) <- 1.5, "coverage") + expect_error(csCoverage(cs) <- c(0.9, 0.95), "coverage") + expect_error(minAbsCorr(cs) <- -1, "minAbsCorr") + expect_error(signalCutoff(cs) <- 2, "signalCutoff") + expect_error(secondaryCoverage(cs) <- c(0.7, 3), "secondaryCoverage") + # perCsColumns was the sharpest asymmetry: the constructor refused a + # bad level via arg_match() while the setter accepted it. + expect_error(perCsColumns(cs) <- "bogus", "perCsColumns") + # Valid replacements still go through. + ok <- cs + csCoverage(ok) <- 0.9 + minAbsCorr(ok) <- 0.5 + medianAbsCorr(ok) <- 0.4 + expect_equal(csCoverage(ok), 0.9) + expect_equal(minAbsCorr(ok), 0.5) + expect_equal(medianAbsCorr(ok), 0.4) +}) + +test_that("CredibleSetParam validity rejects non-scalar counts and flags", { + # Reached by poking a VALID object: new() straight from the prototype + # fails on `coverage` first, and the constructor guards these before + # validity ever sees them. + p <- CredibleSetParam() + q <- p + q@maxNumSingleEffects <- numeric(0) + expect_error(validObject(q), "maxNumSingleEffects must be a single") + q <- p + q@maxNumSingleEffects <- NA_real_ + expect_error(validObject(q), "maxNumSingleEffects must be a single") + q <- p + q@includeAllCs <- NA + expect_error(validObject(q), "includeAllCs must be a single") + q <- p + q@includeAllCs <- c(TRUE, FALSE) + expect_error(validObject(q), "includeAllCs must be a single") + # A nullable slot left NULL is fine -- nullability is the slot type's + # job, so the value checks simply pass a NULL through. + q <- p + q@maxNumSingleEffectsGreedy <- NULL + expect_true(validObject(q)) +}) + +test_that("SerOptions and FsusieOptions refuse what their wrappers own", { + # The susie_ser and susiF arms of .fmOwnedEngineArgs(): ser takes only + # the coverage half of csHome, and susiF owns five wrapper settings on + # top of its data arguments. + expect_error(SerOptions(z = 1), "supplied by pecotmr") + expect_error(SerOptions(n = 100L), "supplied by pecotmr") + expect_error(SerOptions(coverage = 0.9), "csCoverage") + expect_error(FsusieOptions(L = 2), "maxNumSingleEffects") + expect_error(FsusieOptions(min_purity = 0.5), "minPurity") + expect_error(FsusieOptions(max_scale = 6), "maxScale") + # ser does NOT own L -- susie_ser is single-effect by construction, so + # the csHome entry it takes is coverage alone. + expect_s4_class(SerOptions(prior_variance = 1), "MethodOptions") +}) + +test_that(".fmOwnedEngineArgs owns nothing for an unknown engine", { + expect_equal( + pecotmr:::.fmOwnedEngineArgs("susieR::not_a_real_engine"), + character(0) + ) }) diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index 290b0283..dea98f4c 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -2,10 +2,10 @@ # Helper for adjustPips tests, migrated from test_dataStructures.R -.makeAdjustEntry <- function(vids, L = 2L) { +.makeAdjustEntry <- function(vids, maxNumSingleEffects = 2L) { p <- length(vids) set.seed(11L) - lbf <- matrix(rnorm(L * p), nrow = L, ncol = p) + lbf <- matrix(rnorm(maxNumSingleEffects * p), nrow = maxNumSingleEffects, ncol = p) colnames(lbf) <- vids alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) @@ -15,7 +15,7 @@ pip = pip, alpha = alpha, lbf_variable = lbf, - mu = matrix(0, L, p), + mu = matrix(0, maxNumSingleEffects, p), X_column_scale_factors = rep(1, p) ), topLoci = data.frame( @@ -30,10 +30,10 @@ # =========================================================================== -# Tests migrated from test_dataStructures.R (getTopLoci, adjustPips) +# Tests migrated from test_dataStructures.R (topLoci, adjustPips) # =========================================================================== -test_that(".fmrRowTopLoci(type='GRanges') converts topLoci data.frame to GRanges", { +test_that(".fmrRowTopLoci() tables convert to ranges", { tl <- data.frame( variant_id = c("1:100:A:G", "1:200:C:T"), pip = c(0.9, 0.1), @@ -48,26 +48,31 @@ test_that(".fmrRowTopLoci(type='GRanges') converts topLoci data.frame to GRanges susieFit = list(), topLoci = tl ) - gr <- .fmrRowTopLoci(ent, type = "GRanges") + # .fmrRowTopLoci() is the per-row table; topLoci() converts once, after + # the aggregate view has stacked the rows, so the conversion is tested + # through the converter it now lives in. + out <- .fmrRowTopLoci(ent) + expect_s3_class(out, "data.frame") + gr <- pecotmr:::.fmeTopLociGRanges(out) expect_s4_class(gr, "GRanges") expect_equal(length(gr), 2) expect_equal(S4Vectors::mcols(gr)$pip, c(0.9, 0.1)) }) -test_that(".fmrRowTopLoci(type='GRanges') handles empty input", { +test_that(".fmrRowTopLoci() empty input converts to empty ranges", { ent <- fineMappingRow( variantIds = character(0), susieFit = list(), topLoci = data.frame() ) - gr <- .fmrRowTopLoci(ent, type = "GRanges") + gr <- pecotmr:::.fmeTopLociGRanges(.fmrRowTopLoci(ent)) expect_s4_class(gr, "GRanges") expect_equal(length(gr), 0) }) -test_that("getTopLoci defaults to data.frame", { +test_that(".fmrRowTopLoci() always returns the per-row table", { tl <- data.frame( variant_id = "1:100:A:G", pip = 0.9, @@ -94,15 +99,15 @@ test_that("adjustPips renormalizes PIPs on a kept FineMappingRow subset", { keep <- vids[2:5] adj <- adjustPips(entry, keep) expect_s4_class(adj, "FineMappingRow") - expect_equal(getVariantIds(adj), keep) - expect_equal(ncol(getSusieFit(adj)$lbf_variable), 4) + expect_equal(variantIds(adj), keep) + expect_equal(ncol(susieFit(adj)$lbf_variable), 4) # Renormalized: each effect's alpha row sums to 1 (when row has any signal) - expect_true(all(abs(rowSums(getSusieFit(adj)$alpha) - 1) < 1e-10)) + expect_true(all(abs(rowSums(susieFit(adj)$alpha) - 1) < 1e-10)) # PIPs match topLoci - expect_equal(.fmrPartsTopLoci(adj)$pip, getSusieFit(adj)$pip) + expect_equal(.fmrPartsTopLoci(adj)$pip, susieFit(adj)$pip) # PIPs change under renormalization origPips <- .fmrRowPip(entry) - expect_false(identical(unname(origPips[keep]), getSusieFit(adj)$pip)) + expect_false(identical(unname(origPips[keep]), susieFit(adj)$pip)) }) @@ -122,8 +127,8 @@ test_that("adjustPips tolerates a chr-prefix difference between entry and keepVa keep <- paste0("1:", 2:5, ":A:G") # same variants, no "chr" prefix adj <- adjustPips(entry, keep) expect_s4_class(adj, "FineMappingRow") - expect_equal(getVariantIds(adj), vids[2:5]) # entry keeps its own labels - expect_equal(ncol(getSusieFit(adj)$lbf_variable), 4) + expect_equal(variantIds(adj), vids[2:5]) # entry keeps its own labels + expect_equal(ncol(susieFit(adj)$lbf_variable), 4) }) @@ -133,7 +138,7 @@ test_that("adjustPips on a FineMappingResultBase collection renormalizes each en entryA <- .makeAdjustEntry(vidsA) entryB <- .makeAdjustEntry(vidsB) fmr <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("g1", "g1"), method = c("susie", "susie"), @@ -144,8 +149,8 @@ test_that("adjustPips on a FineMappingResultBase collection renormalizes each en adj <- adjustPips(fmr, keep) expect_s4_class(adj, "QtlFineMappingResult") expect_equal(nrow(adj), 2L) - expect_equal(getVariantIds(pecotmr:::.collectionEntry(adj, 1L)), keep) - expect_equal(getVariantIds(pecotmr:::.collectionEntry(adj, 2L)), keep) + expect_equal(variantIds(pecotmr:::.collectionEntry(adj, 1L)), keep) + expect_equal(variantIds(pecotmr:::.collectionEntry(adj, 2L)), keep) }) @@ -165,13 +170,13 @@ test_that("FineMappingRow: constructor stores slots and accessors return them", sprintf("chr9:%d:A:G", 100L * (1:3)) ) expect_equal(.fmrPartsSusieFit(entry), list(payload = 1L)) - # getTopLoci returns the projected posterior view, not the raw slot + # topLoci returns the projected posterior view, not the raw slot out <- .fmrRowTopLoci(entry, signalCutoff = 0) expect_equal(out$variant_id, sprintf("chr9:%d:A:G", 100L * (1:3))) }) -test_that("FineMappingRow: getPip returns named pip vector keyed by variant_id", { +test_that("FineMappingRow: pip returns named pip vector keyed by variant_id", { entry <- .sc_makeFineMappingRow(3) pip <- .fmrRowPip(entry) expect_equal(length(pip), 3L) @@ -198,7 +203,7 @@ test_that("FineMappingRow: resolveWeights returns topLoci posterior effect align }) -test_that("FineMappingRow: getPip returns numeric(0) when topLoci is empty", { +test_that("FineMappingRow: pip returns numeric(0) when topLoci is empty", { entry <- fineMappingRow( variantIds = character(0), susieFit = list(), @@ -212,14 +217,14 @@ test_that("FineMappingRow: getPip returns numeric(0) when topLoci is empty", { }) -test_that("FineMappingRow: getCs filters to rows in any credible set", { +test_that("FineMappingRow: credibleSets filters to rows in any credible set", { entry <- .sc_makeFineMappingRow(3) # last row has cs_95 = "susie_0" res <- .fmrRowCs(entry) expect_equal(nrow(res), 2L) }) -test_that("FineMappingRow: getCs/getTopLoci surface the directional af column", { +test_that("FineMappingRow: credibleSets/topLoci surface the directional af column", { # Regression: the posterior view must carry the topLoci `af` (effect-allele # frequency) through to .fmrRowCs() / .fmrRowTopLoci(), not drop it to NA. The # value is directional (0.87 > 0.5), so a folded MAF would be a bug. @@ -299,7 +304,7 @@ test_that("FineMappingRow cvResult defaults to NULL and rejects non-list", { test_that("QtlFineMappingResult: rejects rows that are not row payloads", { expect_error( QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -336,9 +341,9 @@ test_that("show.FineMappingRow reports variant count and CS count", { }) -# === getMarginalEffects maxPval filter === +# === marginalEffects maxPval filter === -test_that("FineMappingRow: getMarginalEffects applies the maxPval filter", { +test_that("FineMappingRow: marginalEffects applies the maxPval filter", { tl <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), pip = c(0.9, 0.5, 0.1), @@ -357,9 +362,9 @@ test_that("FineMappingRow: getMarginalEffects applies the maxPval filter", { }) -# === getCs empty / cs-less topLoci projections === +# === credibleSets empty / cs-less topLoci projections === -test_that("FineMappingRow: getCs returns empty posterior view when topLoci is empty", { +test_that("FineMappingRow: credibleSets returns empty posterior view when topLoci is empty", { entry <- fineMappingRow( variantIds = character(0), susieFit = list(), @@ -376,7 +381,7 @@ test_that("FineMappingRow: getCs returns empty posterior view when topLoci is em }) -test_that("FineMappingRow: getCs returns empty posterior view when the cs column is absent", { +test_that("FineMappingRow: credibleSets returns empty posterior view when the cs column is absent", { tl <- data.frame( variant_id = c("chr9:100:A:G", "chr9:200:A:G"), pip = c(0.1, 0.2), @@ -444,7 +449,7 @@ test_that("FineMappingRow: adjustPips subsets mu2 and recomputes posterior_sd", adj <- adjustPips(entry, keep) expect_s4_class(adj, "FineMappingRow") # mu2 carried through the variant subsetting alongside lbf/mu. - expect_equal(ncol(getSusieFit(adj)$mu2), 3L) + expect_equal(ncol(susieFit(adj)$mu2), 3L) # posterior_mean / posterior_sd recomputed from the subset alpha/mu/mu2. expect_equal(nrow(.fmrPartsTopLoci(adj)), 3L) expect_true("posterior_sd" %in% names(.fmrPartsTopLoci(adj))) @@ -452,7 +457,7 @@ test_that("FineMappingRow: adjustPips subsets mu2 and recomputes posterior_sd", expect_true(all(.fmrPartsTopLoci(adj)$posterior_sd >= 0)) }) -test_that("getCs / getTopLoci minPurity filters CS by purity, independent of coverage + pip", { +test_that("credibleSets / topLoci minPurity filters CS by purity, independent of coverage + pip", { # Two 0.95 credible sets: CS1 (v1,v2) pure (0.9), CS2 (v3,v4) impure (0.3); v5 non-CS. vn <- paste0("chr1:", (1:5) * 100, ":A:G") L <- 2L @@ -481,13 +486,13 @@ test_that("getCs / getTopLoci minPurity filters CS by purity, independent of cov tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") e <- fineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) - # getCs: minPurity is orthogonal to coverage -> keeps only the pure CS members + # credibleSets: minPurity is orthogonal to coverage -> keeps only the pure CS members expect_equal(nrow(.fmrRowCs(e, coverage = 0.95)), 4L) expect_equal( .fmrRowCs(e, coverage = 0.95, minPurity = 0.8)$variant_id, vn[1:2] ) - # getTopLoci: minPurity is orthogonal to the pip cutoff -> drops impure-CS + # topLoci: minPurity is orthogonal to the pip cutoff -> drops impure-CS # variants (v3,v4), keeps pure-CS (v1,v2) and non-CS (v5) expect_setequal( .fmrRowTopLoci(e, signalCutoff = 0, minPurity = 0.8)$variant_id, @@ -504,11 +509,11 @@ test_that("getCs / getTopLoci minPurity filters CS by purity, independent of cov # A fit whose alpha was built from a deliberately NON-uniform prior, so the # stored-alpha route and the rebuild-from-lbf route disagree. -.makeNonUniformPriorEntry <- function(vids, prior, L = 2L, seed = 404L) { +.makeNonUniformPriorEntry <- function(vids, prior, maxNumSingleEffects = 2L, seed = 404L) { p <- length(vids) set.seed(seed) - lbf <- matrix(rnorm(L * p, sd = 2), L, p, dimnames = list(NULL, vids)) - w <- exp(sweep(lbf, 1L, apply(lbf, 1L, max), `-`)) * rep(prior, each = L) + lbf <- matrix(rnorm(maxNumSingleEffects * p, sd = 2), maxNumSingleEffects, p, dimnames = list(NULL, vids)) + w <- exp(sweep(lbf, 1L, apply(lbf, 1L, max), `-`)) * rep(prior, each = maxNumSingleEffects) alpha <- w / rowSums(w) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) list( @@ -540,9 +545,9 @@ test_that("adjustPips renormalizes stored alpha, honouring a non-uniform prior", expected <- built$alpha[, keepIdx, drop = FALSE] expected <- expected / rowSums(expected) - expect_equal(unname(getSusieFit(adj)$alpha), unname(expected)) + expect_equal(unname(susieFit(adj)$alpha), unname(expected)) expect_equal( - getSusieFit(adj)$pip, + susieFit(adj)$pip, as.numeric(1 - apply(1 - expected, 2, prod)) ) # The old route -- rebuilding alpha from lbf_variable with a uniform prior @@ -550,7 +555,7 @@ test_that("adjustPips renormalizes stored alpha, honouring a non-uniform prior", uniform <- lbfToAlpha(built$lbf[, keepIdx, drop = FALSE]) expect_gt(max(abs(unname(uniform) - unname(expected))), 1e-6) # `pi` is carried along, subset to the retained variants. - expect_equal(getSusieFit(adj)[["pi"]], prior[keepIdx]) + expect_equal(susieFit(adj)[["pi"]], prior[keepIdx]) }) test_that("adjustPips does not mistake `pip` for the prior `pi`", { @@ -560,8 +565,8 @@ test_that("adjustPips does not mistake `pip` for the prior `pi`", { entry <- .makeAdjustEntry(vids) expect_null(.fmrPartsSusieFit(entry)[["pi"]]) adj <- adjustPips(entry, vids[2:4]) - expect_null(getSusieFit(adj)[["pi"]]) - expect_length(getSusieFit(adj)[["pip"]], 3L) + expect_null(susieFit(adj)[["pi"]]) + expect_length(susieFit(adj)[["pip"]], 3L) }) test_that("adjustPips refuses an Omega-weighted (susieInf / susieAsh) fit", { @@ -597,12 +602,12 @@ test_that("adjustPips keeps the null_weight column in the renormalization", { ) keepIdx <- c(1L, 3L, 5L) adj <- adjustPips(entry, vids[keepIdx]) - adjAlpha <- getSusieFit(adj)$alpha + adjAlpha <- susieFit(adj)$alpha expect_equal(ncol(adjAlpha), length(keepIdx) + 1L) - expect_equal(getSusieFit(adj)[["null_index"]], length(keepIdx) + 1L) + expect_equal(susieFit(adj)[["null_index"]], length(keepIdx) + 1L) expect_equal(rowSums(adjAlpha), rep(1, L)) - expect_length(getSusieFit(adj)[["pip"]], length(keepIdx)) + expect_length(susieFit(adj)[["pip"]], length(keepIdx)) # Null mass survives: the retained variants alone do not sum to 1. expect_lt(max(rowSums(adjAlpha[, seq_along(keepIdx), drop = FALSE])), 1) expected <- alpha[, c(keepIdx, p + 1L), drop = FALSE] @@ -656,7 +661,7 @@ test_that("adjustPips recomputes credible sets instead of remapping indices", { ) keepIdx <- 1:3 adj <- adjustPips(entry, vids[keepIdx]) - sets <- getSusieFit(adj)$sets + sets <- susieFit(adj)$sets # Every recomputed index addresses a retained variant. expect_true(all(unlist(sets$cs) %in% seq_along(keepIdx))) @@ -687,10 +692,10 @@ test_that("adjustPips subsets mvsusie-shaped coef rows and 3-D clfsr", { keepIdx <- c(2L, 4L) adj <- adjustPips(mv, vids[keepIdx]) - expect_equal(getSusieFit(adj)$coef, fit$coef[keepIdx, , drop = FALSE]) - expect_equal(dim(getSusieFit(adj)$clfsr), c(L, length(keepIdx), R)) + expect_equal(susieFit(adj)$coef, fit$coef[keepIdx, , drop = FALSE]) + expect_equal(dim(susieFit(adj)$clfsr), c(L, length(keepIdx), R)) expect_equal( - getSusieFit(adj)$clfsr, + susieFit(adj)$clfsr, fit$clfsr[, keepIdx, , drop = FALSE] ) }) @@ -706,11 +711,11 @@ test_that(".fmrRowTopLoci(raw = TRUE) returns the stored table verbatim", { }) # =========================================================================== -# getLbf (merged from test_getLbf.R when R/getLbf.R was folded +# lbf (merged from test_getLbf.R when R/getLbf.R was folded # into R/FineMappingRow.R + R/AllClasses.R) # =========================================================================== -test_that("getLbf returns the wide variant x effect lbf matrix", { +test_that("lbf returns the wide variant x effect lbf matrix", { vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") lbf <- matrix(c(3.0, 2.5, 0.1, 0.1, 0.1, 2.0), nrow = 2, byrow = TRUE) # L=2 x p=3 fit <- list( @@ -737,7 +742,7 @@ test_that("getLbf returns the wide variant x effect lbf matrix", { expect_equal(w$lbf_L2, lbf[2, ]) # effect 2's lbf across variants }) -test_that("getLbf is empty when the fit carries no lbf matrix", { +test_that("lbf is empty when the fit carries no lbf matrix", { e <- fineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), @@ -750,10 +755,10 @@ test_that("getLbf is empty when the fit carries no lbf matrix", { expect_equal(nrow(.fmrRowLbf(e)), 0L) }) -test_that("getLbf aggregates over a collection, carrying identity + NA-filling ragged effects", { +test_that("lbf aggregates over a collection, carrying identity + NA-filling ragged effects", { vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - mkEntry <- function(L) { - lbf <- matrix(seq_len(L * length(vids)), nrow = L, byrow = TRUE) # L x p + mkEntry <- function(maxNumSingleEffects) { + lbf <- matrix(seq_len(maxNumSingleEffects * length(vids)), nrow = maxNumSingleEffects, byrow = TRUE) # L x p fit <- structure( list(lbf_variable = lbf, pip = rep(0.3, length(vids))), class = "susie" @@ -771,13 +776,13 @@ test_that("getLbf aggregates over a collection, carrying identity + NA-filling r # Two entries with different effect counts (L = 2 vs 3) exercise the NA-fill of # the ragged lbf_L columns described in the collection method's contract. res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("brain", "blood"), trait = c("g", "g"), method = c("susie", "susie"), entry = list(mkEntry(2L), mkEntry(3L)) ) - w <- getLbf(res) + w <- lbf(res) expect_true(all( c("study", "context", "trait", "method", "variant_id") %in% names(w) )) @@ -789,11 +794,11 @@ test_that("getLbf aggregates over a collection, carrying identity + NA-filling r }) # =========================================================================== -# getCredibleSetSummary (merged from test_credibleSetSummary.R +# credibleSetSummary (merged from test_credibleSetSummary.R # when R/credibleSetSummary.R was folded in) # =========================================================================== -test_that("getCredibleSetSummary returns one row per CS with size/purity/V/logBF/lead", { +test_that("credibleSetSummary returns one row per CS with size/purity/V/logBF/lead", { vn <- paste0("chr1:", (1:5) * 100, ":A:G") L <- 2L P <- 5L @@ -857,7 +862,7 @@ test_that("getCredibleSetSummary returns one row per CS with size/purity/V/logBF expect_equal(s$lead_variant, c("chr1:100:A:G", "chr1:300:A:G")) }) -test_that("getCredibleSetSummary is empty when there are no credible sets", { +test_that("credibleSetSummary is empty when there are no credible sets", { vn <- c("chr1:100:A:G", "chr1:200:C:T") fit <- list( alpha = matrix(c(0.2, 0.1), 1, 2), @@ -877,7 +882,7 @@ test_that("getCredibleSetSummary is empty when there are no credible sets", { expect_equal(nrow(.fmrRowCredibleSetSummary(e)), 0L) }) -test_that("getCredibleSetSummary is empty when the requested coverage column is absent", { +test_that("credibleSetSummary is empty when the requested coverage column is absent", { # topLoci carries only cs_95 / cs_70 / cs_50; asking for coverage 0.99 finds no # cs_99 column -> the .csSummaryFit guard returns the empty summary. vn <- c("chr1:100:A:G", "chr1:200:C:T") @@ -893,7 +898,7 @@ test_that("getCredibleSetSummary is empty when the requested coverage column is expect_equal(nrow(.fmrRowCredibleSetSummary(e, coverage = 0.99)), 0L) }) -test_that("getCredibleSetSummary reports NA cs_log_bf when the fit carries no lbf matrix", { +test_that("credibleSetSummary reports NA cs_log_bf when the fit carries no lbf matrix", { # A trimmed fit drops lbf_variable: the per-effect single-effect logBF degrades # to NA while the max-member cs_log10bf still comes from the topLoci. vn <- c("chr1:100:A:G", "chr1:200:C:T") @@ -916,7 +921,7 @@ test_that("getCredibleSetSummary reports NA cs_log_bf when the fit carries no lb expect_equal(s$cs_log10bf, 2.5) }) -test_that("getCredibleSetSummary reports NA cs_log_bf when the effect's lbf row is all non-finite", { +test_that("credibleSetSummary reports NA cs_log_bf when the effect's lbf row is all non-finite", { # effect 1's lbf row is entirely -Inf, so the finite subset is empty and the # logSumExp path short-circuits to NA. vn <- c("chr1:100:A:G", "chr1:200:C:T") @@ -934,7 +939,7 @@ test_that("getCredibleSetSummary reports NA cs_log_bf when the effect's lbf row expect_true(is.na(.fmrRowCredibleSetSummary(e)$cs_log_bf)) }) -test_that("getCredibleSetSummary aggregates across a collection with entry identity", { +test_that("credibleSetSummary aggregates across a collection with entry identity", { mkEntry <- function() { vn <- c("chr1:100:A:G", "chr1:200:C:T") tl <- data.frame( @@ -948,13 +953,13 @@ test_that("getCredibleSetSummary aggregates across a collection with entry ident fineMappingRow(variantIds = vn, susieFit = list(x = 1), topLoci = tl) } res <- QtlFineMappingResult( - study = c("s", "s"), + studyName = c("s", "s"), context = c("brain", "blood"), trait = c("g", "g"), method = c("susie", "susie"), entry = list(mkEntry(), mkEntry()) ) - s <- getCredibleSetSummary(res) + s <- credibleSetSummary(res) expect_true(all( c("study", "context", "trait", "method", "cs") %in% names(s) )) @@ -1071,7 +1076,7 @@ test_that("fsusieCredibleBand + fsusieAffectedRegions aggregate across a collect skip_if_not_installed("wavethresh") fit <- .fsa_makeFit() # deterministic; reuse for both rows res <- QtlFineMappingResult( - study = c("s", "s"), + studyName = c("s", "s"), context = c("brain", "blood"), trait = c("g", "g"), method = c("fsusie", "fsusie"), @@ -1116,7 +1121,7 @@ test_that("fsusieAffectedRegions on a collection of non-fSuSiE entries is an emp ) ) res <- QtlFineMappingResult( - study = "s", + studyName = "s", context = "c", trait = "t", method = "susie", @@ -1225,7 +1230,7 @@ test_that("fsusieAffectedRegions yields NA direction for a region outside the gr expect_true(is.na(S4Vectors::mcols(gr)$direction)) }) -test_that("getCs warns when the coverage has no purity column to filter on", { +test_that("credibleSets warns when the coverage has no purity column to filter on", { # minPurity is orthogonal to coverage, so asking for it at a coverage that # produced no credible sets leaves nothing to filter. Skipping silently # would look like "the filter ran and kept everything". @@ -1314,16 +1319,16 @@ test_that("topLoci must list the variants in the same order", { # adjustPips: fits this code cannot slice safely # =========================================================================== -.fmr_susieFit <- function(p = 5L, L = 2L, seed = 7L) { +.fmr_susieFit <- function(p = 5L, maxNumSingleEffects = 2L, seed = 7L) { set.seed(seed) - lbf <- matrix(rnorm(L * p, sd = 3), L, p) + lbf <- matrix(rnorm(maxNumSingleEffects * p, sd = 3), maxNumSingleEffects, p) alpha <- lbfToAlpha(lbf) list( alpha = alpha, - mu = matrix(0.3, L, p), - mu2 = matrix(1.2, L, p), + mu = matrix(0.3, maxNumSingleEffects, p), + mu2 = matrix(1.2, maxNumSingleEffects, p), lbf_variable = lbf, - V = rep(1, L), + V = rep(1, maxNumSingleEffects), pip = as.numeric(1 - apply(1 - alpha, 2, prod)) ) } diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 0a604f22..e85eb091 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -170,31 +170,31 @@ test_that("lbfToAlpha with mixed zero and nonzero rows", { test_that("get_cs_index finds variant in credible set", { susie_cs <- list(L1 = c(1, 2, 3), L2 = c(4, 5)) - idx <- pecotmr:::getCsIndex(2, susie_cs) + idx <- pecotmr:::csIndex(2, susie_cs) expect_equal(unname(idx), 1) }) test_that("get_cs_index returns NA for variant not in any CS", { susie_cs <- list(L1 = c(1, 2), L2 = c(4, 5)) - idx <- pecotmr:::getCsIndex(3, susie_cs) + idx <- pecotmr:::csIndex(3, susie_cs) expect_true(is.na(idx)) }) test_that("get_cs_index returns all CS indices when variant in multiple", { susie_cs <- list(L1 = c(1, 2, 3), L2 = c(2, 4, 5)) - idx <- pecotmr:::getCsIndex(2, susie_cs) + idx <- pecotmr:::csIndex(2, susie_cs) expect_equal(unname(idx), c(1, 2)) }) test_that("get_cs_index returns all matching CS regardless of size", { susie_cs <- list(L1 = c(1, 2, 3, 4, 5), L2 = c(2, 3)) - result <- pecotmr:::getCsIndex(2, susie_cs) + result <- pecotmr:::csIndex(2, susie_cs) expect_equal(unname(result), c(1, 2)) }) test_that("get_cs_index handles empty CS list", { susie_cs <- list() - result <- pecotmr:::getCsIndex(1, susie_cs) + result <- pecotmr:::csIndex(1, susie_cs) expect_true(is.na(result)) }) @@ -209,7 +209,7 @@ test_that("get_cs_index returns correct CS assignment with real susie fit", { fit <- susieR::susie(X, y, L = 5) # With beta[1]=2 and sd=0.5, susie should find a CS containing variant 1 expect_false(is.null(fit$sets$cs)) - idx <- pecotmr:::getCsIndex(1, fit$sets$cs) + idx <- pecotmr:::csIndex(1, fit$sets$cs) expect_true(is.numeric(unname(idx))) expect_true(all(idx >= 1)) }) @@ -223,7 +223,7 @@ test_that("get_top_variants_idx returns combined PIP and CS variants", { pip = c(0.01, 0.15, 0.02, 0.5, 0.01), sets = list(cs = list(L1 = c(1, 2))) ) - result <- pecotmr:::getTopVariantsIdx(susie_output, signalCutoff = 0.1) + result <- pecotmr:::topVariantsIdx(susie_output, signalCutoff = 0.1) expect_true(1 %in% result) expect_true(2 %in% result) expect_true(4 %in% result) @@ -235,7 +235,7 @@ test_that("get_top_variants_idx with no CS", { pip = c(0.01, 0.5, 0.02, 0.8, 0.01), sets = list(cs = NULL) ) - result <- pecotmr:::getTopVariantsIdx(susie_output, signalCutoff = 0.1) + result <- pecotmr:::topVariantsIdx(susie_output, signalCutoff = 0.1) expect_equal(result, c(2, 4)) }) @@ -244,7 +244,7 @@ test_that("get_top_variants_idx with all low PIPs", { pip = c(0.01, 0.02, 0.03), sets = list(cs = list(L1 = c(1, 2))) ) - result <- pecotmr:::getTopVariantsIdx(susie_output, signalCutoff = 0.5) + result <- pecotmr:::topVariantsIdx(susie_output, signalCutoff = 0.5) expect_equal(result, c(1, 2)) }) @@ -253,7 +253,7 @@ test_that("get_top_variants_idx with high cutoff and no CS", { pip = c(0.01, 0.02, 0.03), sets = list(cs = NULL) ) - result <- pecotmr:::getTopVariantsIdx(susie_output, signalCutoff = 0.5) + result <- pecotmr:::topVariantsIdx(susie_output, signalCutoff = 0.5) expect_length(result, 0) }) @@ -264,7 +264,7 @@ test_that("get_top_variants_idx with high cutoff and no CS", { test_that("get_cs_info maps variants to CS numbers", { susie_cs <- list(L1 = c(1, 2), L3 = c(4, 5, 6)) top_idx <- c(1, 3, 5) - result <- pecotmr:::getCsInfo(susie_cs, top_idx) + result <- pecotmr:::csInfo(susie_cs, top_idx) # Now returns data.frame(variant_idx, cs_idx) with one row per (variant, CS) pair expect_true(is.data.frame(result)) expect_equal(result$variant_idx, c(1, 3, 5)) @@ -274,7 +274,7 @@ test_that("get_cs_info maps variants to CS numbers", { test_that("get_cs_info handles all variants outside CS", { susie_cs <- list(L1 = c(1, 2)) top_idx <- c(5, 6, 7) - result <- pecotmr:::getCsInfo(susie_cs, top_idx) + result <- pecotmr:::csInfo(susie_cs, top_idx) expect_true(is.data.frame(result)) expect_true(all(result$cs_idx == 0)) }) @@ -282,7 +282,7 @@ test_that("get_cs_info handles all variants outside CS", { test_that("get_cs_info reports variant in multiple CSs as multiple rows", { susie_cs <- list(L1 = c(1, 2, 3), L3 = c(2, 3, 4)) top_idx <- c(1, 2, 4) - result <- pecotmr:::getCsInfo(susie_cs, top_idx) + result <- pecotmr:::csInfo(susie_cs, top_idx) expect_true(is.data.frame(result)) # variant 2 is in both L1 and L3, so it gets two rows expect_equal(nrow(result), 4) @@ -394,12 +394,12 @@ test_that("init_prior_sd returns n standard deviations", { # ============================================================================= # Helper: build a minimal synthetic SuSiE-family output for post-processing -makeFakeSusieOutput <- function(p = 5, L = 3, has_V = TRUE) { +makeFakeSusieOutput <- function(p = 5, maxNumSingleEffects = 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), - lbf_variable = matrix(0, nrow = L, ncol = p), + alpha = matrix(1 / p, nrow = maxNumSingleEffects, ncol = p), + lbf_variable = matrix(0, nrow = maxNumSingleEffects, ncol = p), sets = list( cs = NULL, requestedCoverage = 0.95 @@ -407,7 +407,7 @@ makeFakeSusieOutput <- function(p = 5, L = 3, has_V = TRUE) { niter = 10 ) if (has_V) { - out$V <- rep(1, L) + out$V <- rep(1, maxNumSingleEffects) } out } @@ -416,7 +416,7 @@ test_that("postprocessFinemappingFits keeps all effects when V is NULL", { skip_if_not_installed("susieR") p <- 5 L <- 3 - fake_output <- makeFakeSusieOutput(p, L = L, has_V = FALSE) + fake_output <- makeFakeSusieOutput(p, maxNumSingleEffects = L, has_V = FALSE) R <- diag(p) colnames(R) <- rownames(R) <- names(fake_output$pip) post <- postprocessFinemappingFits( @@ -428,7 +428,7 @@ test_that("postprocessFinemappingFits keeps all effects when V is NULL", { ), dataX = R, dataY = list(z = rnorm(p)), - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -482,7 +482,7 @@ test_that("postprocessFinemappingFits stores outcome_names, coef, and clfsr for dataY = NULL, xScalar = 1, yScalar = 1, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -763,7 +763,7 @@ if (!exists(".makeUnivariateData", inherits = FALSE)) { dataY = inp$data_y, otherQuantities = otherQuantities, region = region, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( signalCutoff = signalCutoff ) ) @@ -931,7 +931,7 @@ test_that("buildTopLoci: mvsusie per-condition lfsr + effect (long)", { expect_false(any(c("conditional_effect", "lfsr") %in% names(tl0))) }) -test_that("getTopLoci surfaces mvsusie conditional_effect + lfsr through the projector", { +test_that("topLoci surfaces mvsusie conditional_effect + lfsr through the projector", { tl <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:C:T"), chrom = "1", @@ -1020,7 +1020,7 @@ test_that("buildTopLoci: per-variant logBF is the max single-effect lbf", { tl <- buildTopLoci(fit, cst, variantNames = vids, method = "susie") expect_true("logBF" %in% names(tl)) expect_equal(tl$logBF, apply(lbf, 2, max)) # c(2.0, 3.0, 0.2) - # surfaced through getTopLoci's projection too + # surfaced through topLoci's projection too e <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) expect_true("logBF" %in% names(.fmrRowTopLoci(e, signalCutoff = 0))) }) @@ -1081,7 +1081,7 @@ test_that("buildTopLoci: RSS per-variant N threads; list dataY isn't 1", { n = perVarN, method = "susie", dataY = list(z = rnorm(length(variant_ids))), - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( signalCutoff = 0 ) ) @@ -1097,7 +1097,7 @@ test_that("buildTopLoci: RSS per-variant N threads; list dataY isn't 1", { af = NULL, method = "susie", dataY = list(z = rnorm(length(variant_ids))), - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( signalCutoff = 0 ) ) @@ -1129,7 +1129,7 @@ test_that("buildTopLoci: individual-level vector dataY fills N with nSamples", { af = NULL, method = "susie", dataY = y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( signalCutoff = 0 ) ) @@ -1203,7 +1203,7 @@ test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", cst, variantNames = vn, method = "susie", - credibleSetArgs = CredibleSetParam(perCsColumns = "full") + credibleSetParam = CredibleSetParam(perCsColumns = "full") ) expect_equal(tl1$within_cs_pip_cs1, alpha[1, ]) expect_equal(tl1$cs_logbf_cs1, lbf[1, ]) @@ -1216,7 +1216,7 @@ test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", cst, variantNames = vn, method = "susie", - credibleSetArgs = CredibleSetParam(perCsColumns = "alpha") + credibleSetParam = CredibleSetParam(perCsColumns = "alpha") ) expect_false(any(grepl("^cs_logbf_|^cs_effect_", names(tl2)))) expect_setequal( @@ -1231,7 +1231,7 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) # alpha-wide column on REAL data (the synthetic case above pins the exact # arithmetic; this pins that it flows on a real fit). data("qtlFineMappingExample", package = "pecotmr") - fit <- getSusieFit(qtlFineMappingExample) + fit <- susieFit(qtlFineMappingExample) vn <- colnames(fit$alpha) member <- fit$sets$cs$L1 # 42 real CS member indices expect_gt(length(member), 1L) @@ -1249,7 +1249,7 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) csTables, variantNames = vn, method = "susie", - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( signalCutoff = 0, perCsColumns = "alpha" ) @@ -1270,7 +1270,7 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) csTables, variantNames = vn, method = "susie", - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( signalCutoff = 0, perCsColumns = "full" ) @@ -1288,7 +1288,7 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) csTables, variantNames = vn, method = "susie", - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( signalCutoff = 0, perCsColumns = "full" ) @@ -1352,7 +1352,7 @@ test_that("postprocessFinemappingFits forwards medianAbsCorr to susie_get_cs (OR list(susie = fit), dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, minAbsCorr = 0.999, medianAbsCorr = NULL @@ -1362,7 +1362,7 @@ test_that("postprocessFinemappingFits forwards medianAbsCorr to susie_get_cs (OR list(susie = fit), dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, minAbsCorr = 0.999, medianAbsCorr = 0.1 @@ -1378,7 +1378,7 @@ test_that("postprocessFinemappingFits with medianAbsCorr = NULL is a no-op", { list(susie = fit), dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -1386,7 +1386,7 @@ test_that("postprocessFinemappingFits with medianAbsCorr = NULL is a no-op", { list(susie = fit), dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, medianAbsCorr = NULL ) @@ -1435,7 +1435,7 @@ test_that("per-method CS indices are independent across susie and susieInf (post fits, dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = c(0.7, 0.5) ) @@ -1510,7 +1510,7 @@ test_that("overlapping CS across methods produces one row per method", { fits, dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = c(0.7, 0.5) ) @@ -1544,7 +1544,7 @@ test_that("formatFinemappingOutput exposes exactly one top_loci field; no top_lo fits, dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -1563,7 +1563,7 @@ test_that("postprocessFinemappingFits does not return top_loci_long anywhere", { list(susie = fit), dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -1658,7 +1658,7 @@ test_that("formatFinemappingOutput exposes finemappingEntry with S4 accessors", list(susie = fit), dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -1798,7 +1798,7 @@ test_that("fsusieWrapper errors when fsusieR is not installed", { X = X, Y = Y, pos = seq_len(4), - L = 3, + maxNumSingleEffects = 3, prior = "mixture_normal", maxSnpEm = 100, covLev = 0.95, @@ -1831,7 +1831,7 @@ test_that("fsusieWrapper low-purity branch sets cs to list(NULL) and cs_corr to X = X, Y = Y, pos = seq_len(4), - L = 3, + maxNumSingleEffects = 3, prior = "mixture_normal", maxSnpEm = 100, covLev = 0.95, @@ -1875,7 +1875,7 @@ test_that("fsusieWrapper high-purity branch builds sets", { X = X, Y = Y, pos = seq_len(4), - L = 3, + maxNumSingleEffects = 3, prior = "mixture_normal", maxSnpEm = 100, covLev = 0.95, @@ -2453,7 +2453,7 @@ test_that("postprocessFinemappingFit.susiF post-processes an fsusie fit (empty-C ), dataY = NULL, otherQuantities = list(condition_id = "ctx"), - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -2475,7 +2475,7 @@ test_that("postprocessFinemappingFit.susieInf labels credible sets with the susi method = "susieInf", dataX = d$X, dataY = d$y, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ) ) @@ -2507,7 +2507,7 @@ test_that(".postprocessFinemappingFitCommon trim=FALSE stores the untrimmed fit" dimnames = list(NULL, c("chr1:100:A:G", "chr1:200:C:T")) ), dataY = NULL, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95 ), fitRetention = "full" @@ -3056,7 +3056,7 @@ test_that("fsusieWeights errors without a fit and on an unusable (trimmed, no co .msc_fmr <- function(entries, method = "susie") { n <- length(entries) QtlFineMappingResult( - study = rep("S", n), + studyName = rep("S", n), context = paste0("c", seq_len(n)), trait = rep("t", n), method = rep(method, n), @@ -3183,14 +3183,14 @@ test_that("mergeSusieCs: non-FineMappingResult input errors", { # The example fine-mapping fixtures (chr22:32.1Mb) and the LD-source fixtures # (chr22:14.5Mb) cover disjoint regions, so we build a self-consistent case: a # hand-made multi-CS fit over the SumStats sketch's own 200 variants. -# A single-row QtlFineMappingResult, which is what getFineMappingResult() now +# A single-row QtlFineMappingResult, which is what fineMappingResult() now # returns and what computeCsCorrelation() dispatches on. topLoci carries one # row per variant: the old fixture paired a non-empty variant list with an # EMPTY topLoci, which the row-payload builder rejects as misaligned. .ccMakeEntry <- function(vids, cs) { pip <- stats::runif(length(vids)) QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -3209,15 +3209,15 @@ test_that("mergeSusieCs: non-FineMappingResult input errors", { test_that("computeCsCorrelation (SumStats) matches get_cs_correlation", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(getLdSketch(ss)) + vids <- rownames(ldSketch(ss)) set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) cc <- computeCsCorrelation(fe, ss) # Reference: the same LD (from the sketch, aligned to the fit variables) # fed to the same fit. Equality proves the on-demand path + alignment. - xcorr <- pecotmr:::.ldFromSketch(getLdSketch(ss), vids, onMissing = "error") + xcorr <- pecotmr:::.ldFromSketch(ldSketch(ss), vids, onMissing = "error") ref <- susieR::get_cs_correlation( - list(sets = getSusieFit(fe)$sets, pip = getSusieFit(fe)$pip), + list(sets = susieFit(fe)$sets, pip = susieFit(fe)$pip), Xcorr = xcorr ) expect_equal(dim(cc), c(2L, 2L)) @@ -3227,7 +3227,7 @@ test_that("computeCsCorrelation (SumStats) matches get_cs_correlation", { test_that("computeCsCorrelation is NULL for fewer than two credible sets", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(getLdSketch(ss)) + vids <- rownames(ldSketch(ss)) set.seed(1) expect_null(computeCsCorrelation(.ccMakeEntry(vids, list()), ss)) expect_null( @@ -3237,7 +3237,7 @@ test_that("computeCsCorrelation is NULL for fewer than two credible sets", { test_that("computeCsCorrelation requires a QtlDataset / SumStats ldSource", { data(qtlSumStatsExample) - vids <- rownames(getLdSketch(qtlSumStatsExample)) + vids <- rownames(ldSketch(qtlSumStatsExample)) set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) expect_error(computeCsCorrelation(fe, 42), "requires a QtlDataset") @@ -3250,7 +3250,7 @@ test_that("computeCsCorrelation requires a QtlDataset / SumStats ldSource", { test_that("computeCsCorrelation errors when a fit variant is off-panel", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(getLdSketch(ss)) + vids <- rownames(ldSketch(ss)) vids[1] <- "chr22:99999999:A:G" set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) @@ -3260,10 +3260,10 @@ test_that("computeCsCorrelation errors when a fit variant is off-panel", { test_that("computeCsCorrelation resolves on the paired fixture", { data(qtlFineMappingPairedExample) data(qtlSumStatsExample) - fe <- getFineMappingResult(qtlFineMappingPairedExample) + fe <- fineMappingResult(qtlFineMappingPairedExample) cc <- computeCsCorrelation(fe, qtlSumStatsExample) expect_true(is.matrix(cc)) - expect_equal(nrow(cc), length(getSusieFit(fe)$sets$cs)) + expect_equal(nrow(cc), length(susieFit(fe)$sets$cs)) expect_equal(unname(diag(cc)), rep(1, nrow(cc))) expect_equal(cc, t(cc)) }) @@ -3272,7 +3272,7 @@ test_that("computeCsCorrelation (QtlDataset) matches the sumstat path", { data(qtlFineMappingPairedExample) data(qtlDatasetExample) data(qtlSumStatsExample) - fe <- getFineMappingResult(qtlFineMappingPairedExample) + fe <- fineMappingResult(qtlFineMappingPairedExample) ccGeno <- computeCsCorrelation(fe, qtlDatasetExample) ccSketch <- computeCsCorrelation(fe, qtlSumStatsExample) # qtlDatasetExample genotypes are the same panel as qtlSumStatsExample's @@ -3343,7 +3343,7 @@ context("post_finemapping_cs_extraction") ) } QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -3356,20 +3356,20 @@ context("post_finemapping_cs_extraction") } # =========================================================================== -# getSusieResult +# susieResult # =========================================================================== -test_that("getSusieResult returns NULL for empty input", { - result <- getSusieResult(list()) +test_that("susieResult returns NULL for empty input", { + result <- susieResult(list()) expect_null(result) }) -test_that("getSusieResult returns NULL when finemappingEntry missing", { - result <- getSusieResult(list(some_data = 42)) +test_that("susieResult returns NULL when finemappingEntry missing", { + result <- susieResult(list(some_data = 42)) expect_null(result) }) -test_that("getSusieResult returns trimmed result when present", { +test_that("susieResult returns trimmed result when present", { mock_result <- list(pip = c(0.1, 0.5, 0.3), sets = list(cs = list())) con_data <- list( finemappingEntry = .testFineMappingRow( @@ -3377,7 +3377,7 @@ test_that("getSusieResult returns trimmed result when present", { susieFit = mock_result ) ) - result <- getSusieResult(con_data) + result <- susieResult(con_data) expect_equal(result, mock_result) }) @@ -3465,7 +3465,7 @@ test_that("extractCsInfo extracts single CS correctly", { test_that("extractCsInfo builds correlation columns from the ldSource", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(getLdSketch(ss)) + vids <- rownames(ldSketch(ss)) set.seed(1) fit <- list( sets = list(cs = list(L_1 = c(1L, 2L, 3L), L_2 = c(90L, 91L))), @@ -3525,10 +3525,10 @@ test_that("extractCsInfo computes p_value from z-score", { }) # =========================================================================== -# getSusieResult: trimmed fit is empty +# susieResult: trimmed fit is empty # =========================================================================== -test_that("getSusieResult returns NULL when the trimmed susie fit is empty", { +test_that("susieResult returns NULL when the trimmed susie fit is empty", { conData <- list( # An empty fit with variants present: topLoci must still be aligned # row-for-row, which the entry did not enforce. @@ -3542,7 +3542,7 @@ test_that("getSusieResult returns NULL when the trimmed susie fit is empty", { ) ) ) - expect_null(getSusieResult(conData)) + expect_null(susieResult(conData)) }) @@ -3624,9 +3624,9 @@ test_that("correlation extraction reports NA when every value is self-correlatio expect_equal(mixed$min_corr, 0.5) }) -test_that("getSusieResult returns NULL when there is no fine-mapping entry", { - expect_null(getSusieResult(list(finemappingEntry = NULL))) - expect_null(getSusieResult(list(finemappingEntry = 42))) +test_that("susieResult returns NULL when there is no fine-mapping entry", { + expect_null(susieResult(list(finemappingEntry = NULL))) + expect_null(susieResult(list(finemappingEntry = 42))) }) @@ -3941,7 +3941,7 @@ test_that("susieInf is skipped as a result when it was only a chain input", { methodArgs = list(), verbose = 0, label = "lab", - rssArgs = SusieRssParam( + susieRssParam = SusieRssParam( rFinite = NULL, rMismatch = NULL, control = NULL, @@ -3968,7 +3968,7 @@ test_that("susieInf is returned as its own fit when it was requested", { ), "INFFIT" ) - rssArgs <- pecotmr:::.fmRssFitOne( + res <- pecotmr:::.fmRssFitOne( "susieInf", asked, "INFFIT", @@ -3979,15 +3979,15 @@ test_that("susieInf is returned as its own fit when it was requested", { methodArgs = list(), verbose = 0, label = "lab", - rssArgs = SusieRssParam( + susieRssParam = SusieRssParam( rFinite = NULL, rMismatch = NULL, control = NULL, serFallback = FALSE ) ) - expect_equal(rssArgs$fit, "INFFIT") - expect_false(rssArgs$isStd) + expect_equal(res$fit, "INFFIT") + expect_false(res$isStd) }) @@ -4032,7 +4032,7 @@ test_that("includeAllCs widens to every effect rather than the kept ones", { scale = c(1, 1), primaryCsPos = c(0L, 1L), effectOf = c(1L, 2L), - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( includeAllCs = TRUE, perCsColumns = "alpha" ) @@ -4186,7 +4186,7 @@ test_that(".fmFitXBlock skips a token that produced no fit", { X = NULL, y = NULL, toRun = c("susie", "lasso"), - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) # The NULL-fit token contributes no entry rather than an empty one. expect_equal(names(out), "lasso") @@ -4223,7 +4223,7 @@ test_that(".fmRssFitStd threads the shared susieInf fit when chained", { methodArgs = list(), verbose = 0, label = "lab", - rssArgs = SusieRssParam( + susieRssParam = SusieRssParam( rFinite = NULL, rMismatch = NULL, control = NULL, @@ -4251,7 +4251,7 @@ test_that(".fmFitRssBlock skips a token that produced no fit", { R = NULL, n = 100L, toRun = c("susie", "susieAsh"), - addSusieInf = FALSE + initializeWithSusieInf = FALSE ) expect_equal(names(out), "susieAsh") }) @@ -4357,7 +4357,7 @@ test_that(".btlCondLfsr yields all-NA when the primary CS is empty", { test_that("mergeSusieCs returns NULL when no row carries a credible set", { res <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(.fmw_pipRow()) ) @@ -4380,9 +4380,9 @@ test_that(".extractCsEntryRows needs a resolvable pip column", { expect_null(pecotmr:::.extractCsEntryRows(1L, list("dummy"), "cs_95")) }) -test_that("getSusieResult returns NULL for an empty susie fit", { - expect_null(getSusieResult(list())) - expect_null(getSusieResult(list(a = 1))) +test_that("susieResult returns NULL for an empty susie fit", { + expect_null(susieResult(list())) + expect_null(susieResult(list(a = 1))) row <- fineMappingRow( variantIds = "chr1:1:A:G", susieFit = list(), @@ -4393,12 +4393,12 @@ test_that("getSusieResult returns NULL for an empty susie fit", { ) ) res <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(row) ) # A FineMappingResult is present, but it carries no fit to return. - expect_null(getSusieResult(list(finemappingEntry = res))) + expect_null(susieResult(list(finemappingEntry = res))) }) test_that(".btlFullFitBlock defaults the primary CS position to zeros", { @@ -4515,7 +4515,7 @@ test_that("mergeSusieCs returns NULL when the combined table is empty", { .package = "pecotmr" ) res <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(.fmw_pipRow()) ) @@ -5082,13 +5082,13 @@ test_that(".fmFitXBlock fits the susieInf indiv chain + cross-validates (mocked) X, y, toRun = "susieInf", - addSusieInf = FALSE, + initializeWithSusieInf = FALSE, methodArgs = list(susieInf = list()), verbose = 1, ctx = "brain", tid = "ENSG_A", cvFolds = 3L, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = 0.7, signalCutoff = 0.1, @@ -5104,14 +5104,17 @@ test_that("each fine-mapping constructor checks ONE engine entry point", { # 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) + # The probe has to be path-specific AND not pecotmr-owned: `L` and `z` + # are both refused now (they are seeded / supplied by the pipeline), so + # `intercept` (susie only) and `bhat` (susie_rss only) stand in. + expect_s4_class(SusieOptions(intercept = FALSE), "MethodOptions") + expect_false(SusieOptions(intercept = FALSE)$intercept) 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") + # `bhat` belongs to susie_rss alone. + expect_error(SusieOptions(bhat = 1), "unknown argument\\(s\\) bhat") + expect_s4_class(SusieRssOptions(bhat = 1), "MethodOptions") }) test_that("splitting the paths makes the individual mvsusie engine checkable", { diff --git a/tests/testthat/test_genotypeHandle.R b/tests/testthat/test_genotypeHandle.R index 4d6a93d3..373c9c17 100644 --- a/tests/testthat/test_genotypeHandle.R +++ b/tests/testthat/test_genotypeHandle.R @@ -61,34 +61,34 @@ test_that("GenotypeHandle: path = .gds uses readGenotypes (gds backend)", { skip_if_not_installed("SNPRelate") h <- GenotypeHandle(path = gds_path) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "gds") - expect_equal(getNSamples(h), 100L) - expect_equal(nrow(getSnpInfo(h)), 349L) + expect_equal(genotypeFormat(h), "gds") + expect_equal(nSamples(h), 100L) + expect_equal(nrow(snpInfo(h)), 349L) }) test_that("GenotypeHandle: path = .vcf.gz uses readGenotypes (vcf backend)", { skip_if_not_installed("VariantAnnotation") h <- GenotypeHandle(path = vcf_path) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "vcf") - expect_equal(getNSamples(h), 100L) + expect_equal(genotypeFormat(h), "vcf") + expect_equal(nSamples(h), 100L) }) test_that("GenotypeHandle: plink1Prefix builds a plink1 handle", { skip_if_not_installed("snpStats") h <- GenotypeHandle(plink1Prefix = plink_prefix) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink1") - expect_equal(getNSamples(h), 100L) - expect_equal(nrow(getSnpInfo(h)), 349L) + expect_equal(genotypeFormat(h), "plink1") + expect_equal(nSamples(h), 100L) + expect_equal(nrow(snpInfo(h)), 349L) }) test_that("GenotypeHandle: plink2Prefix builds a plink2 handle", { skip_if_not_installed("pgenlibr") h <- GenotypeHandle(plink2Prefix = plink_prefix) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink2") - expect_equal(getNSamples(h), 100L) + expect_equal(genotypeFormat(h), "plink2") + expect_equal(nSamples(h), 100L) }) # =========================================================================== @@ -103,8 +103,8 @@ test_that("GenotypeHandle: bed/bim/fam triplet with matching stems builds plink1 fam = paste0(plink_prefix, ".fam") ) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink1") - expect_equal(getNSamples(h), 100L) + expect_equal(genotypeFormat(h), "plink1") + expect_equal(nSamples(h), 100L) }) test_that(".genotypeHandleFromPlink1Triplet: errors when stems disagree", { @@ -137,7 +137,7 @@ test_that("GenotypeHandle: pgen/pvar/psam triplet with matching stems builds pli psam = paste0(plink_prefix, ".psam") ) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink2") + expect_equal(genotypeFormat(h), "plink2") }) test_that(".genotypeHandleFromPlink2Triplet: accepts .pvar.zst by stripping the .zst", { @@ -267,7 +267,7 @@ test_that("GenotypeHandle ldMeta: dispatches to gds reader for .gds path", { on.exit(unlink(f), add = TRUE) h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "gds") + expect_equal(genotypeFormat(h), "gds") }) test_that("GenotypeHandle ldMeta: dispatches to vcf reader for .vcf.gz path", { @@ -276,7 +276,7 @@ test_that("GenotypeHandle ldMeta: dispatches to vcf reader for .vcf.gz path", { on.exit(unlink(f), add = TRUE) h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "vcf") + expect_equal(genotypeFormat(h), "vcf") }) test_that("GenotypeHandle ldMeta: dispatches to plink1 reader for .bed path", { @@ -285,7 +285,7 @@ test_that("GenotypeHandle ldMeta: dispatches to plink1 reader for .bed path", { on.exit(unlink(f), add = TRUE) h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink1") + expect_equal(genotypeFormat(h), "plink1") }) test_that("GenotypeHandle ldMeta: dispatches to plink2 reader for .pgen path", { @@ -294,7 +294,7 @@ test_that("GenotypeHandle ldMeta: dispatches to plink2 reader for .pgen path", { on.exit(unlink(f), add = TRUE) h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink2") + expect_equal(genotypeFormat(h), "plink2") }) test_that("GenotypeHandle ldMeta: .cor.xz payload is rejected (out of scope)", { @@ -331,7 +331,7 @@ test_that("GenotypeHandle constructs and validates correctly", { pgenPtr = NULL ) expect_s4_class(obj, "GenotypeHandle") - expect_equal(getFormat(obj), "gds") + expect_equal(genotypeFormat(obj), "gds") expect_true(methods::validObject(obj)) }) @@ -383,9 +383,9 @@ test_that("genoMeta (named vector) builds a sharded handle", { ) ) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink1") - expect_equal(sort(names(getChromPaths(h))), c("21", "22")) - expect_equal(nrow(getSnpInfo(h)), 2L * 349L) + expect_equal(genotypeFormat(h), "plink1") + expect_equal(sort(names(chromPaths(h))), c("21", "22")) + expect_equal(nrow(snpInfo(h)), 2L * 349L) }) test_that("genoMeta meta-file resolves payloads relative to its own directory", { @@ -398,8 +398,8 @@ test_that("genoMeta meta-file resolves payloads relative to its own directory", metafile ) h <- GenotypeHandle(genoMeta = metafile) - expect_equal(sort(names(getChromPaths(h))), c("21", "22")) - expect_equal(nrow(getSnpInfo(h)), 2L * 349L) + expect_equal(sort(names(chromPaths(h))), c("21", "22")) + expect_equal(nrow(snpInfo(h)), 2L * 349L) }) test_that(".parseChromMeta matches chrom/path columns by name (order- and extra-column-tolerant)", { @@ -522,11 +522,11 @@ test_that("genoMeta chroms reads only the requested shard", { ) full <- GenotypeHandle(genoMeta = meta) only21 <- GenotypeHandle(genoMeta = meta, chroms = "21") - expect_equal(names(getChromPaths(only21)), "21") - expect_equal(nrow(getSnpInfo(only21)), 349L) + expect_equal(names(chromPaths(only21)), "21") + expect_equal(nrow(snpInfo(only21)), 349L) # chr21 is the first shard, so the kept rows/fileIdx match the full handle's. - expect_equal(getSnpInfo(only21)$SNP, getSnpInfo(full)$SNP[1:349]) - expect_equal(getSnpInfo(only21)$fileIdx, getSnpInfo(full)$fileIdx[1:349]) + expect_equal(snpInfo(only21)$SNP, snpInfo(full)$SNP[1:349]) + expect_equal(snpInfo(only21)$fileIdx, snpInfo(full)$fileIdx[1:349]) }) test_that("genoMeta chroms canonicalises chromosome labels", { @@ -539,7 +539,7 @@ test_that("genoMeta chroms canonicalises chromosome labels", { ), chroms = "chr21" ) - expect_equal(names(getChromPaths(h)), "21") + expect_equal(names(chromPaths(h)), "21") }) test_that("genoMeta chroms falls back to all shards when none match", { @@ -553,7 +553,7 @@ test_that("genoMeta chroms falls back to all shards when none match", { ), chroms = "9" ) - expect_equal(sort(names(getChromPaths(h))), c("21", "22")) + expect_equal(sort(names(chromPaths(h))), c("21", "22")) }) test_that("genoMeta chroms skips a shard whose file does not exist", { @@ -565,7 +565,7 @@ test_that("genoMeta chroms skips a shard whose file does not exist", { "21" = "/no/such/chr21/prefix" ) h <- GenotypeHandle(genoMeta = meta, chroms = "22") - expect_equal(names(getChromPaths(h)), "22") + expect_equal(names(chromPaths(h)), "22") expect_error(GenotypeHandle(genoMeta = meta, chroms = c("22", "21"))) }) @@ -582,7 +582,7 @@ test_that("chroms is rejected for a non-genoMeta source", { # =========================================================================== # .genotypeHandleFromLdMeta: row-resolution error branches. -# The real getRegionalLdMeta errors earlier for genuinely-uncovered regions +# The real regionalLdMeta errors earlier for genuinely-uncovered regions # (see the "region with no covering row" test above), so we mock it to drive # the post-resolution branches (0 rows, >1 row, unsupported payload ext) # without crafting whole on-disk meta layouts. @@ -590,7 +590,7 @@ test_that("chroms is rejected for a non-genoMeta source", { test_that(".genotypeHandleFromLdMeta errors when no LD-meta row covers the region", { local_mocked_bindings( - getRegionalLdMeta = function(...) { + regionalLdMeta = function(...) { list( intersections = list( LD_file_paths = character(0), @@ -608,7 +608,7 @@ test_that(".genotypeHandleFromLdMeta errors when no LD-meta row covers the regio test_that(".genotypeHandleFromLdMeta errors when the region spans multiple rows", { local_mocked_bindings( - getRegionalLdMeta = function(...) { + regionalLdMeta = function(...) { list( intersections = list( LD_file_paths = c("/tmp/a.bed", "/tmp/b.bed"), @@ -626,7 +626,7 @@ test_that(".genotypeHandleFromLdMeta errors when the region spans multiple rows" test_that(".genotypeHandleFromLdMeta errors on an unsupported payload extension", { local_mocked_bindings( - getRegionalLdMeta = function(...) { + regionalLdMeta = function(...) { list( intersections = list( LD_file_paths = "/tmp/foo.txt", @@ -685,32 +685,32 @@ test_that(".resolveGenotypeShard honours explicit plink1 format and .bed extensi skip_if_not_installed("snpStats") h1 <- pecotmr:::.resolveGenotypeShard(plink_prefix, format = "plink1") expect_s4_class(h1, "GenotypeHandle") - expect_equal(getFormat(h1), "plink1") + expect_equal(genotypeFormat(h1), "plink1") h2 <- pecotmr:::.resolveGenotypeShard(paste0(plink_prefix, ".bed")) - expect_equal(getFormat(h2), "plink1") + expect_equal(genotypeFormat(h2), "plink1") }) test_that(".resolveGenotypeShard honours explicit plink2 format and .pgen extension", { skip_if_not_installed("pgenlibr") h1 <- pecotmr:::.resolveGenotypeShard(plink_prefix, format = "plink2") expect_s4_class(h1, "GenotypeHandle") - expect_equal(getFormat(h1), "plink2") + expect_equal(genotypeFormat(h1), "plink2") h2 <- pecotmr:::.resolveGenotypeShard(paste0(plink_prefix, ".pgen")) - expect_equal(getFormat(h2), "plink2") + expect_equal(genotypeFormat(h2), "plink2") }) test_that(".resolveGenotypeShard dispatches gds via explicit format and .gds extension", { skip_if_not_installed("SNPRelate") h1 <- pecotmr:::.resolveGenotypeShard(gds_path, format = "gds") - expect_equal(getFormat(h1), "gds") + expect_equal(genotypeFormat(h1), "gds") h2 <- pecotmr:::.resolveGenotypeShard(gds_path) - expect_equal(getFormat(h2), "gds") + expect_equal(genotypeFormat(h2), "gds") }) test_that(".resolveGenotypeShard dispatches vcf by extension", { skip_if_not_installed("VariantAnnotation") h <- pecotmr:::.resolveGenotypeShard(vcf_path) - expect_equal(getFormat(h), "vcf") + expect_equal(genotypeFormat(h), "vcf") }) test_that(".resolveGenotypeShard probes the .pgen sidecar for an extension-less prefix", { @@ -764,29 +764,29 @@ test_that("extractBlockGenotypes answers an empty index without a reader", { # taking the session down rather than raising a catchable condition. The # sharded branch always returned early; the single-file branch did not. data(qtlDatasetExample, envir = environment()) - gh <- getGenotypeHandle(qtlDatasetExample) + gh <- genotypeHandle(qtlDatasetExample) se <- extractBlockGenotypes(gh, snpIdx = integer(0)) expect_s4_class(se, "SummarizedExperiment") expect_equal(nrow(se), 0L) - expect_equal(ncol(se), getNSamples(gh)) + expect_equal(ncol(se), nSamples(gh)) }) test_that("genotypeDelayedArray reports variants x samples", { # The Bioconductor assay orientation, which is the TRANSPOSE of - # getGenotypes(). Backwards, this returns a plausible matrix and a + # genotypes(). Backwards, this returns a plausible matrix and a # silently transposed LD matrix. data(qtlDatasetExample, envir = environment()) qd <- qtlDatasetExample - da <- genotypeDelayedArray(getGenotypeHandle(qd)) + da <- genotypeDelayedArray(genotypeHandle(qd)) expect_s4_class(da, "DelayedMatrix") - expect_equal(dim(da), rev(dim(getGenotypes(qd)))) + expect_equal(dim(da), rev(dim(genotypes(qd)))) }) -test_that("genotypeDelayedArray values match getGenotypes transposed", { +test_that("genotypeDelayedArray values match genotypes transposed", { data(qtlDatasetExample, envir = environment()) qd <- qtlDatasetExample - da <- genotypeDelayedArray(getGenotypeHandle(qd)) - truth <- t(getGenotypes(qd)) + da <- genotypeDelayedArray(genotypeHandle(qd)) + truth <- t(genotypes(qd)) got <- as.matrix(da[1:5, 1:4]) expect_equal(unname(got), unname(truth[1:5, 1:4])) expect_identical(rownames(got), rownames(truth)[1:5]) @@ -795,16 +795,16 @@ test_that("genotypeDelayedArray values match getGenotypes transposed", { test_that("a NULL index means every row or column, not none", { data(qtlDatasetExample, envir = environment()) - gh <- getGenotypeHandle(qtlDatasetExample) + gh <- genotypeHandle(qtlDatasetExample) seed <- DelayedArray::seed(genotypeDelayedArray(gh)) full <- S4Arrays::extract_array(seed, list(NULL, NULL)) - expect_equal(dim(full), c(nrow(getSnpInfo(gh)), getNSamples(gh))) + expect_equal(dim(full), c(nrow(snpInfo(gh)), nSamples(gh))) }) test_that("the seed answers an empty extraction on either axis", { data(qtlDatasetExample, envir = environment()) seed <- DelayedArray::seed( - genotypeDelayedArray(getGenotypeHandle(qtlDatasetExample)) + genotypeDelayedArray(genotypeHandle(qtlDatasetExample)) ) expect_equal( dim(S4Arrays::extract_array(seed, list(integer(0), NULL))), @@ -821,21 +821,21 @@ test_that("genotypeDelayedArray stores the sample axis once, derives it on read" # duplicated between GhSeed@dn[[2]] and handle@sampleIds. The seed stores only # the variant axis; dimnames() derives the sample axis from the handle. data(qtlDatasetExample, envir = environment()) - gh <- getGenotypeHandle(qtlDatasetExample) + gh <- genotypeHandle(qtlDatasetExample) seed <- genotypeDelayedArray(gh)@seed expect_null(seed@dn[[2L]]) # not stored - expect_identical(dimnames(seed)[[2L]], as.character(getSampleIds(gh))) # derived + expect_identical(dimnames(seed)[[2L]], as.character(sampleIds(gh))) # derived expect_identical(dimnames(seed)[[1L]], seed@dn[[1L]]) # variant axis stored expect_equal(dim(seed)[[2L]], length(dimnames(seed)[[2L]])) # dm consistent }) test_that(".emptyGenotypeHandle empties the sample axis as well as the variants", { data(qtlDatasetExample, envir = environment()) - gh <- getGenotypeHandle(qtlDatasetExample) + gh <- genotypeHandle(qtlDatasetExample) e <- pecotmr:::.emptyGenotypeHandle(gh) - expect_equal(nrow(getSnpInfo(e)), 0L) - expect_equal(length(getSampleIds(e)), 0L) - expect_equal(getNSamples(e), 0L) + expect_equal(nrow(snpInfo(e)), 0L) + expect_equal(length(sampleIds(e)), 0L) + expect_equal(nSamples(e), 0L) # the rebuilt seed is a consistent 0 x 0 (no 0 x nSamples mismatch) seed <- genotypeDelayedArray(e)@seed expect_equal(dim(seed), c(0L, 0L)) @@ -844,17 +844,17 @@ test_that(".emptyGenotypeHandle empties the sample axis as well as the variants" test_that(".emptySketch drops the sample axis on an RSE sketch", { data(qtlDatasetExample, envir = environment()) - gh <- getGenotypeHandle(qtlDatasetExample) + gh <- genotypeHandle(qtlDatasetExample) empty <- pecotmr:::.emptySketch(pecotmr:::.genotypeExperiment(gh)) h <- pecotmr:::.ldSketchHandle(empty) - expect_equal(length(getSampleIds(h)), 0L) - expect_equal(nrow(getSnpInfo(h)), 0L) + expect_equal(length(sampleIds(h)), 0L) + expect_equal(nrow(snpInfo(h)), 0L) }) test_that("nothing is read until a block is actually touched", { # The point of the seed: a panel can be described without being read. data(qtlDatasetExample, envir = environment()) - gh <- getGenotypeHandle(qtlDatasetExample) + gh <- genotypeHandle(qtlDatasetExample) reads <- 0L # Captured before mocking: calling extractBlockGenotypes by name inside # the mock would re-enter the mock, not the reader. @@ -878,7 +878,7 @@ test_that("nothing is read until a block is actually touched", { test_that("only the requested variants are read", { data(qtlDatasetExample, envir = environment()) - gh <- getGenotypeHandle(qtlDatasetExample) + gh <- genotypeHandle(qtlDatasetExample) seen <- integer(0) realExtract <- extractBlockGenotypes local_mocked_bindings( @@ -891,7 +891,7 @@ test_that("only the requested variants are read", { da <- genotypeDelayedArray(gh) invisible(as.matrix(da[1:5, 1:4])) expect_true(all(seen <= 5L)) - expect_lt(sum(seen), nrow(getSnpInfo(gh))) + expect_lt(sum(seen), nrow(snpInfo(gh))) }) test_that("genotypeDelayedArray rejects a non-handle", { @@ -924,7 +924,7 @@ 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", { +test_that("pgenPtr 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( @@ -936,5 +936,5 @@ test_that("getPgenPtr returns the handle's pgen pointer", { sampleIds = paste0("sample_", 1:100), pgenPtr = NULL ) - expect_null(getPgenPtr(h)) + expect_null(pgenPtr(h)) }) diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index c4b9e734..a30ff15d 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -557,10 +557,10 @@ test_that(".colocFilterCsByConcentration returns numeric index vector", { }) # =========================================================================== -# getRefVariantInfo +# refVariantInfo # =========================================================================== -test_that("getRefVariantInfo processes precomputed bim with 6 columns", { +test_that("refVariantInfo processes precomputed bim with 6 columns", { td <- test_path("test_data") meta_file <- file.path(td, "ld_meta_refinfo_6col_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) @@ -577,13 +577,13 @@ test_that("getRefVariantInfo processes precomputed bim with 6 columns", { file = meta_file, append = TRUE ) - result <- getRefVariantInfo(meta_file, "chr1:1000-1190") + result <- refVariantInfo(meta_file, "chr1:1000-1190") expect_true(is.data.frame(result)) expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% colnames(result))) expect_equal(nrow(result), 5L) }) -test_that("getRefVariantInfo processes precomputed bim with 9 columns", { +test_that("refVariantInfo processes precomputed bim with 9 columns", { td <- test_path("test_data") meta_file <- file.path(td, "ld_meta_refinfo_9col_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) @@ -600,7 +600,7 @@ test_that("getRefVariantInfo processes precomputed bim with 9 columns", { file = meta_file, append = TRUE ) - result <- getRefVariantInfo(meta_file, "chr1:1000-1190") + result <- refVariantInfo(meta_file, "chr1:1000-1190") expect_true(all( c( "chrom", @@ -692,10 +692,10 @@ test_that("invertMinmaxScaling errors on mismatched lengths", { # =========================================================================== # =========================================================================== -# getRefVariantInfo with PLINK2 fixture +# refVariantInfo with PLINK2 fixture # =========================================================================== -test_that("getRefVariantInfo returns variant info for PLINK2 source", { +test_that("refVariantInfo returns variant info for PLINK2 source", { skip_if_not_installed("pgenlibr") meta_file <- file.path(test_path("test_data"), "ld_meta_refinfo_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) @@ -706,7 +706,7 @@ test_that("getRefVariantInfo returns variant info for PLINK2 source", { file = meta_file, append = TRUE ) - result <- getRefVariantInfo(meta_file, region = "chr21:17513228-17592874") + result <- refVariantInfo(meta_file, region = "chr21:17513228-17592874") expect_true(is.data.frame(result)) expect_equal(nrow(result), 349L) expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% names(result))) @@ -715,7 +715,7 @@ test_that("getRefVariantInfo returns variant info for PLINK2 source", { expect_true(all(result$allele_freq > 0 & result$allele_freq < 1)) }) -test_that("getRefVariantInfo filters by subregion", { +test_that("refVariantInfo filters by subregion", { skip_if_not_installed("pgenlibr") meta_file <- file.path( test_path("test_data"), @@ -729,12 +729,12 @@ test_that("getRefVariantInfo filters by subregion", { file = meta_file, append = TRUE ) - result <- getRefVariantInfo(meta_file, region = "chr21:17513228-17550000") + result <- refVariantInfo(meta_file, region = "chr21:17513228-17550000") expect_true(nrow(result) < 349L) expect_true(all(result$pos >= 17513228 & result$pos <= 17550000)) }) -test_that("getRefVariantInfo returns variant info for VCF source", { +test_that("refVariantInfo returns variant info for VCF source", { skip_if_not_installed("VariantAnnotation") meta_file <- file.path( test_path("test_data"), @@ -749,7 +749,7 @@ test_that("getRefVariantInfo returns variant info for VCF source", { append = TRUE ) result <- suppressWarnings( - getRefVariantInfo(meta_file, region = "chr21:17513228-17592874") + refVariantInfo(meta_file, region = "chr21:17513228-17592874") ) expect_true(is.data.frame(result)) expect_equal(nrow(result), 349L) @@ -758,7 +758,7 @@ test_that("getRefVariantInfo returns variant info for VCF source", { expect_true(all(result$allele_freq > 0 & result$allele_freq < 1)) }) -test_that("getRefVariantInfo returns variant info for GDS source", { +test_that("refVariantInfo returns variant info for GDS source", { skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") meta_file <- file.path( @@ -773,14 +773,14 @@ test_that("getRefVariantInfo returns variant info for GDS source", { file = meta_file, append = TRUE ) - result <- getRefVariantInfo(meta_file, region = "chr21:17513228-17592874") + result <- refVariantInfo(meta_file, region = "chr21:17513228-17592874") expect_true(is.data.frame(result)) expect_equal(nrow(result), 349L) expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% names(result))) expect_true("allele_freq" %in% names(result)) }) -test_that("getRefVariantInfo VCF filters by subregion", { +test_that("refVariantInfo VCF filters by subregion", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Rsamtools") meta_file <- file.path( @@ -796,13 +796,13 @@ test_that("getRefVariantInfo VCF filters by subregion", { append = TRUE ) result <- suppressWarnings( - getRefVariantInfo(meta_file, region = "chr21:17513228-17550000") + refVariantInfo(meta_file, region = "chr21:17513228-17550000") ) expect_true(nrow(result) < 349L) expect_true(all(result$pos >= 17513228 & result$pos <= 17550000)) }) -test_that("getRefVariantInfo returns consistent results across formats", { +test_that("refVariantInfo returns consistent results across formats", { skip_if_not_installed("pgenlibr") skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") @@ -835,8 +835,8 @@ test_that("getRefVariantInfo returns consistent results across formats", { append = TRUE ) - info_plink <- getRefVariantInfo(meta_plink, region = region) - info_gds <- getRefVariantInfo(meta_gds, region = region) + info_plink <- refVariantInfo(meta_plink, region = region) + info_gds <- refVariantInfo(meta_gds, region = region) expect_equal(nrow(info_plink), nrow(info_gds)) expect_equal(info_plink$pos, info_gds$pos) @@ -915,7 +915,7 @@ test_that("matchVariantsToKeep filters to specified variants", { file.path(td, "test_variants"), format = "plink2" ) - vi <- pecotmr:::.snpInfoToVariantInfo(getSnpInfo(handle)) + vi <- pecotmr:::.snpInfoToVariantInfo(snpInfo(handle)) # Write a keep file as tab-delimited with chrom/pos columns keep_file <- tempfile(fileext = ".tsv") @@ -938,7 +938,7 @@ test_that("matchVariantsToKeep returns all FALSE for non-matching variants", { file.path(td, "test_variants"), format = "plink2" ) - vi <- pecotmr:::.snpInfoToVariantInfo(getSnpInfo(handle)) + vi <- pecotmr:::.snpInfoToVariantInfo(snpInfo(handle)) keep_file <- tempfile(fileext = ".tsv") on.exit(unlink(keep_file), add = TRUE) @@ -1037,7 +1037,7 @@ test_that("matchVariantsToKeep uses position-only matching when no alleles", { file.path(td, "test_variants"), format = "plink2" ) - vi <- pecotmr:::.snpInfoToVariantInfo(getSnpInfo(handle)) + vi <- pecotmr:::.snpInfoToVariantInfo(snpInfo(handle)) keep_file <- tempfile(fileext = ".tsv") on.exit(unlink(keep_file), add = TRUE) @@ -1068,9 +1068,9 @@ test_that("readGenotypes loads plink2 handle with all variants", { format = "plink2" ) expect_s4_class(handle, "GenotypeHandle") - expect_equal(getNSamples(handle), 100L) - expect_equal(nrow(getSnpInfo(handle)), 349L) - rse <- extractBlockGenotypes(handle, seq_len(nrow(getSnpInfo(handle)))) + expect_equal(nSamples(handle), 100L) + expect_equal(nrow(snpInfo(handle)), 349L) + rse <- extractBlockGenotypes(handle, seq_len(nrow(snpInfo(handle)))) expect_s4_class(rse, "SummarizedExperiment") dosage <- SummarizedExperiment::assay(rse, "dosage") expect_equal(nrow(dosage), 349L) @@ -1120,7 +1120,7 @@ test_that("loadGenotypeRegion filters by keep_variants_path for plink2", { file.path(td, "test_variants"), format = "plink2" ) - vi <- pecotmr:::.snpInfoToVariantInfo(getSnpInfo(handle)) + vi <- pecotmr:::.snpInfoToVariantInfo(snpInfo(handle)) keep_file <- tempfile(fileext = ".tsv") on.exit(unlink(keep_file), add = TRUE) @@ -1154,8 +1154,8 @@ test_that("readGenotypes plink2 sample names match psam IIDs", { file.path(td, "test_variants"), format = "plink2" ) - expect_true(all(grepl("^(HG|NA)\\d+", getSampleIds(handle)))) - expect_equal(length(unique(getSampleIds(handle))), 100L) + expect_true(all(grepl("^(HG|NA)\\d+", sampleIds(handle)))) + expect_equal(length(unique(sampleIds(handle))), 100L) }) # =========================================================================== @@ -1267,9 +1267,9 @@ test_that("readGenotypes creates plink1 handle", { skip_if_not_installed("snpStats") handle <- readGenotypeHandle(plink_prefix, format = "plink1") expect_s4_class(handle, "GenotypeHandle") - expect_equal(getFormat(handle), "plink1") - expect_equal(getNSamples(handle), n_samples) - expect_equal(nrow(getSnpInfo(handle)), n_variants) + expect_equal(genotypeFormat(handle), "plink1") + expect_equal(nSamples(handle), n_samples) + expect_equal(nrow(snpInfo(handle)), n_variants) }) test_that("loadGenotypeRegion loads plink1 via dispatch", { @@ -1291,15 +1291,15 @@ test_that("readGenotypes creates plink2 handle", { skip_if_not_installed("pgenlibr") handle <- readGenotypeHandle(plink_prefix, format = "plink2") expect_s4_class(handle, "GenotypeHandle") - expect_equal(getFormat(handle), "plink2") - expect_equal(getNSamples(handle), n_samples) - expect_equal(nrow(getSnpInfo(handle)), n_variants) + expect_equal(genotypeFormat(handle), "plink2") + expect_equal(nSamples(handle), n_samples) + expect_equal(nrow(snpInfo(handle)), n_variants) }) test_that("extractBlockGenotypes works for plink2", { skip_if_not_installed("pgenlibr") handle <- readGenotypeHandle(plink_prefix, format = "plink2") - rse <- extractBlockGenotypes(handle, seq_len(nrow(getSnpInfo(handle)))) + rse <- extractBlockGenotypes(handle, seq_len(nrow(snpInfo(handle)))) expect_s4_class(rse, "SummarizedExperiment") dosage <- SummarizedExperiment::assay(rse, "dosage") expect_equal(nrow(dosage), n_variants) @@ -1343,9 +1343,9 @@ test_that("readGenotypes creates vcf handle", { skip_if_not_installed("VariantAnnotation") handle <- readGenotypeHandle(vcf_path, format = "vcf") expect_s4_class(handle, "GenotypeHandle") - expect_equal(getFormat(handle), "vcf") - expect_equal(getNSamples(handle), n_samples) - expect_equal(nrow(getSnpInfo(handle)), n_variants) + expect_equal(genotypeFormat(handle), "vcf") + expect_equal(nSamples(handle), n_samples) + expect_equal(nrow(snpInfo(handle)), n_variants) }) test_that("loadGenotypeRegion loads VCF via dispatch", { @@ -1391,9 +1391,9 @@ test_that("readGenotypes creates gds handle", { skip_if_not_installed("gdsfmt") handle <- readGenotypeHandle(gds_path, format = "gds") expect_s4_class(handle, "GenotypeHandle") - expect_equal(getFormat(handle), "gds") - expect_equal(getNSamples(handle), n_samples) - expect_equal(nrow(getSnpInfo(handle)), n_variants) + expect_equal(genotypeFormat(handle), "gds") + expect_equal(nSamples(handle), n_samples) + expect_equal(nrow(snpInfo(handle)), n_variants) }) test_that("loadGenotypeRegion loads GDS via dispatch", { @@ -1467,8 +1467,8 @@ test_that("PLINK1 and PLINK2 readGenotypes return consistent alleles", { h1 <- readGenotypeHandle(plink_prefix, format = "plink1") h2 <- readGenotypeHandle(plink_prefix, format = "plink2") - expect_equal(getSnpInfo(h1)$A1, getSnpInfo(h2)$A1) - expect_equal(getSnpInfo(h1)$A2, getSnpInfo(h2)$A2) + expect_equal(snpInfo(h1)$A1, snpInfo(h2)$A1) + expect_equal(snpInfo(h1)$A2, snpInfo(h2)$A2) }) # --- loadGenotypeRegion (dispatch) ----------------------------------------- @@ -1525,7 +1525,7 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { skip_if_not_installed("pgenlibr") stem <- test_path("test_data", "test_variants") handle <- readGenotypeHandle(stem, format = "plink2") - n_snps <- nrow(getSnpInfo(handle)) + n_snps <- nrow(snpInfo(handle)) skip_if(n_snps == 0, "No SNPs in handle") rse <- extractBlockGenotypes(handle, seq_len(min(5L, n_snps))) @@ -1534,7 +1534,7 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { dosage <- SummarizedExperiment::assay(rse, "dosage") # Bioc convention: variants x samples expect_equal(nrow(dosage), min(5L, n_snps)) - expect_equal(ncol(dosage), getNSamples(handle)) + expect_equal(ncol(dosage), nSamples(handle)) # rowRanges should have variant info rr <- SummarizedExperiment::rowRanges(rse) expect_true("A1" %in% names(S4Vectors::mcols(rr))) @@ -1547,10 +1547,10 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { # Build a minimal FineMappingRow with a known lbf_variable so PIP # renormalization can be checked end-to-end. -.makeAdjustEntry <- function(vids, L = 2L) { +.makeAdjustEntry <- function(vids, maxNumSingleEffects = 2L) { p <- length(vids) set.seed(11L) - lbf <- matrix(rnorm(L * p), nrow = L, ncol = p) + lbf <- matrix(rnorm(maxNumSingleEffects * p), nrow = maxNumSingleEffects, ncol = p) colnames(lbf) <- vids alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) @@ -1560,7 +1560,7 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { pip = pip, alpha = alpha, lbf_variable = lbf, - mu = matrix(0, L, p), + mu = matrix(0, maxNumSingleEffects, p), X_column_scale_factors = rep(1, p) ), topLoci = data.frame( @@ -1653,11 +1653,11 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { ref22 <- spec$ref("_chr22") shard <- GenotypeHandle(genoMeta = c("21" = spec$p21, "22" = spec$p22)) expect_s4_class(shard, "GenotypeHandle") - expect_equal(getFormat(shard), getFormat(ref21)) - expect_equal(sort(names(getChromPaths(shard))), c("21", "22")) - n21 <- nrow(getSnpInfo(ref21)) - n22 <- nrow(getSnpInfo(ref22)) - expect_equal(nrow(getSnpInfo(shard)), n21 + n22) + expect_equal(genotypeFormat(shard), genotypeFormat(ref21)) + expect_equal(sort(names(chromPaths(shard))), c("21", "22")) + n21 <- nrow(snpInfo(ref21)) + n22 <- nrow(snpInfo(ref22)) + expect_equal(nrow(snpInfo(shard)), n21 + n22) # A chr21 request routes to the chr21 payload (== single-file chr21). expect_equal(.shardDose(shard, 1:5), .shardDose(ref21, 1:5)) # A chr22 request routes to the chr22 payload, and the global->local index @@ -1678,7 +1678,7 @@ test_that("extractBlockGenotypes returns SummarizedExperiment", { shard <- GenotypeHandle( genoMeta = c("21" = spec$p21, "22" = spec$p22) ) - n21 <- nrow(getSnpInfo(ref21)) + n21 <- nrow(snpInfo(ref21)) em <- extractBlockGenotypes(shard, c(1L, 2L, n21 + 1L, n21 + 2L)) dm <- unname(as.matrix(SummarizedExperiment::assay(em, "dosage"))) expect_equal(nrow(dm), 4L) @@ -1707,8 +1707,8 @@ test_that("single-shard sharded handle equals the single-file handle", { sh <- GenotypeHandle( genoMeta = c("21" = file.path(test_data_dir, "test_variants")) ) - expect_equal(length(getChromPaths(sh)), 1L) - expect_equal(nrow(getSnpInfo(sh)), nrow(getSnpInfo(ref))) + expect_equal(length(chromPaths(sh)), 1L) + expect_equal(nrow(snpInfo(sh)), nrow(snpInfo(ref))) expect_equal(.shardDose(sh, 1:10), .shardDose(ref, 1:10)) }) @@ -1752,10 +1752,10 @@ test_that("genoMeta meta-file form matches the named-vector form", { "22" = file.path(td_abs, "test_variants_chr22") ) ) - expect_equal(nrow(getSnpInfo(hFile)), nrow(getSnpInfo(hVec))) + expect_equal(nrow(snpInfo(hFile)), nrow(snpInfo(hVec))) expect_equal( - sort(names(getChromPaths(hFile))), - sort(names(getChromPaths(hVec))) + sort(names(chromPaths(hFile))), + sort(names(chromPaths(hVec))) ) expect_equal(.shardDose(hFile, 1:5), .shardDose(hVec, 1:5)) }) @@ -1765,7 +1765,7 @@ test_that("genoMeta meta-file form matches the named-vector form", { # missing-chromosome block paths, format-specific extractor edge cases, the # GDS LD path, .h2DetectFormat / .plinkStem branches, resolvePlink2Paths # validation, readAfreq zstd guard, readStochasticMeta validation, the plink1 -# getRefVariantInfo path with a multi-row region, and the non-integer-dosage +# refVariantInfo path with a multi-row region, and the non-integer-dosage # warning in loadGenotypeRegion. # =========================================================================== @@ -1839,8 +1839,8 @@ test_that("extractBlockGenotypes on a sharded handle handles an empty block", { expect_s4_class(se, "SummarizedExperiment") dosage <- SummarizedExperiment::assay(se, "dosage") expect_equal(nrow(dosage), 0L) - expect_equal(ncol(dosage), getNSamples(shard)) - expect_equal(colnames(dosage), getSampleIds(shard)) + expect_equal(ncol(dosage), nSamples(shard)) + expect_equal(colnames(dosage), sampleIds(shard)) }) test_that("sharded extraction errors for a chromosome with no payload", { @@ -1854,8 +1854,8 @@ test_that("sharded extraction errors for a chromosome with no payload", { ) # Drop the chr22 payload but keep its variants in @snpInfo, so routing a # chr22 request finds no per-chromosome file. - shard@chromPaths <- getChromPaths(shard)["21"] - idx22 <- which(pecotmr:::canonChrom(getSnpInfo(shard)$CHR) == "22")[1] + shard@chromPaths <- chromPaths(shard)["21"] + idx22 <- which(pecotmr:::canonChrom(snpInfo(shard)$CHR) == "22")[1] expect_error( extractBlockGenotypes(shard, idx22), "no per-chromosome file for chromosome" @@ -1948,7 +1948,7 @@ test_that(".extractBlockVcf parses missing genotypes as NA", { skip_if_not_installed("Rsamtools") bg <- .gioMakeMissingGtVcf() handle <- readGenotypeHandle(bg, format = "vcf") - expect_equal(nrow(getSnpInfo(handle)), 2L) + expect_equal(nrow(snpInfo(handle)), 2L) # meanImpute=FALSE keeps the "./." dosages as NA se <- extractBlockGenotypes(handle, 1:2, meanImpute = FALSE) dosage <- SummarizedExperiment::assay(se, "dosage") @@ -2001,7 +2001,7 @@ test_that("computeLd on a GDS panel uses the in-memory path", { expect_true(all(is.finite(R))) expect_false(anyNA(R)) expect_equal(unname(diag(R)), rep(1, 6), tolerance = 1e-6) - expect_identical(rownames(R), getSnpInfo(handle)$SNP[1:6]) + expect_identical(rownames(R), snpInfo(handle)$SNP[1:6]) }) test_that("computeLd returns identity when extraction is NULL", { @@ -2165,9 +2165,9 @@ test_that("readStochasticMeta errors when generic file lacks required columns", ) }) -# --- getRefVariantInfo: plink1 .bed path + multi-row region filter ----------- +# --- refVariantInfo: plink1 .bed path + multi-row region filter ----------- -test_that("getRefVariantInfo reads variant info from a plink1 source", { +test_that("refVariantInfo reads variant info from a plink1 source", { td <- test_path("test_data") meta_file <- file.path(td, "ld_meta_refinfo_plink1_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) @@ -2178,13 +2178,13 @@ test_that("getRefVariantInfo reads variant info from a plink1 source", { file = meta_file, append = TRUE ) - info <- getRefVariantInfo(meta_file) # no region -> all variants + info <- refVariantInfo(meta_file) # no region -> all variants expect_true(is.data.frame(info)) expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% names(info))) expect_gt(nrow(info), 0L) }) -test_that("getRefVariantInfo applies a multi-row data.frame region filter", { +test_that("refVariantInfo applies a multi-row data.frame region filter", { skip_if_not_installed("pgenlibr") td <- test_path("test_data") meta_file <- file.path(td, "ld_meta_refinfo_multirow_tmp.tsv") @@ -2204,7 +2204,7 @@ test_that("getRefVariantInfo applies a multi-row data.frame region filter", { end = c(17550000L, 17592874L), stringsAsFactors = FALSE ) - info <- getRefVariantInfo(meta_file, region = region_df) + info <- refVariantInfo(meta_file, region = region_df) expect_true(is.data.frame(info)) expect_equal(nrow(info), 349L) expect_true(all(info$pos >= 17513228 & info$pos <= 17592874)) @@ -2220,7 +2220,7 @@ test_that("loadGenotypeRegion warns on non-integer dosages without a sidecar", { # non-integer values and emits its warning. testthat::local_mocked_bindings( .extractBlockPlink2 = function(handle, snpIdx) { - matrix(0.5, nrow = getNSamples(handle), ncol = length(snpIdx)) + matrix(0.5, nrow = nSamples(handle), ncol = length(snpIdx)) }, .package = "pecotmr" ) @@ -2237,7 +2237,7 @@ test_that(".withFileIdx + readers attach a sequential fileIdx to snpInfo", { test_path("test_data/test_variants"), format = "plink2" ) - si <- getSnpInfo(h) + si <- snpInfo(h) expect_true("fileIdx" %in% names(si)) expect_identical(si$fileIdx, seq_len(nrow(si))) }) @@ -2247,15 +2247,15 @@ test_that(".subsetGenotypeHandle keeps PLINK2 reads correct for kept variants", test_path("test_data/test_variants"), format = "plink2" ) - si <- getSnpInfo(h) + si <- snpInfo(h) want <- c(2L, 4L, 5L, 9L) dosFull <- pecotmr:::.dosageMatrix(h, want, meanImpute = TRUE) # Keep a reordered superset so the wanted variants move to NEW row positions; # fileIdx must rescue the (now-shifted) positional PLINK2 read. keep <- c(9L, 5L, 4L, 2L, 7L, 1L) hSub <- pecotmr:::.subsetGenotypeHandle(h, keep) - expect_equal(nrow(getSnpInfo(hSub)), length(keep)) - expect_identical(getSnpInfo(hSub)$fileIdx, keep) # original file order retained + expect_equal(nrow(snpInfo(hSub)), length(keep)) + expect_identical(snpInfo(hSub)$fileIdx, keep) # original file order retained wantSub <- match(want, keep) dosSub <- pecotmr:::.dosageMatrix(hSub, wantSub, meanImpute = TRUE) expect_equal(unname(dosFull), unname(dosSub)) @@ -2268,7 +2268,7 @@ test_that(".subsetGenotypeHandle is NULL-safe and a no-op when nothing dropped", format = "plink2" ) expect_identical( - pecotmr:::.subsetGenotypeHandle(h, seq_len(nrow(getSnpInfo(h)))), + pecotmr:::.subsetGenotypeHandle(h, seq_len(nrow(snpInfo(h)))), h ) }) @@ -2287,7 +2287,7 @@ test_that(".subsetGenotypeHandle is NULL-safe and a no-op when nothing dropped", .gio_orderCheck <- function(fmt, path) { handle <- readGenotypeHandle(path, format = fmt) perm <- c(4L, 1L, 6L, 2L, 5L, 3L) - si <- getSnpInfo(handle) + si <- snpInfo(handle) seq6 <- extractBlockGenotypes(handle, 1:6, meanImpute = FALSE) seP <- extractBlockGenotypes(handle, perm, meanImpute = FALSE) a6 <- as.matrix(SummarizedExperiment::assay(seq6, "dosage")) @@ -2333,7 +2333,7 @@ test_that("LD from a sketch does not depend on the request order", { test_path("test_data", "test_variants"), format = "plink1" ) - ids <- getSnpInfo(handle)$SNP[1:6] + ids <- snpInfo(handle)$SNP[1:6] shuffled <- ids[c(4L, 1L, 6L, 2L, 5L, 3L)] sorted <- pecotmr:::.ldFromSketch(handle, ids, label = "t") mixed <- pecotmr:::.ldFromSketch(handle, shuffled, label = "t") @@ -2386,7 +2386,7 @@ test_that("onDisk LD labels and orders by the request", { idx <- c(4L, 1L, 6L, 2L, 5L, 3L) R <- computeLd(handle, snpIdx = idx, backend = "snprelate", onDisk = TRUE) # snpgdsLDMat() returns file order and labels nothing; both are corrected. - expect_identical(rownames(R), getSnpInfo(handle)$SNP[idx]) + expect_identical(rownames(R), snpInfo(handle)$SNP[idx]) expect_identical(colnames(R), rownames(R)) }) @@ -2428,7 +2428,7 @@ test_that("ordering uses FILE position, not the snpInfo row number", { ) keep <- c(9L, 2L, 7L, 4L) sub <- pecotmr:::.subsetGenotypeHandle(handle, keep) - expect_identical(getSnpInfo(sub)$fileIdx, keep) + expect_identical(snpInfo(sub)$fileIdx, keep) got <- as.matrix(SummarizedExperiment::assay( extractBlockGenotypes(sub, seq_along(keep), meanImpute = FALSE), "dosage" @@ -2460,10 +2460,10 @@ test_that("readGenotypes returns a panel, not a handle", { format = "plink1" ) # variants x samples, the Bioconductor orientation. - expect_equal(nrow(panel), nrow(getSnpInfo(handle))) + expect_equal(nrow(panel), nrow(snpInfo(handle))) expect_equal( ncol(panel), - length(getSampleIds( + length(sampleIds( pecotmr:::.ghSeedHandle( DelayedArray::seed(SummarizedExperiment::assay(panel, "dosage")) ) @@ -2597,7 +2597,7 @@ test_that("a legacy handle without fileIdx is not subset", { pgenPtr = NULL ) sub <- pecotmr:::.subsetGenotypeHandle(h, 1L) - expect_equal(nrow(pecotmr:::getSnpInfo(sub)), 3L) + expect_equal(nrow(pecotmr:::snpInfo(sub)), 3L) }) test_that("covariate colData aligns to the panel's samples", { @@ -2659,7 +2659,7 @@ test_that("block extraction rejects a format it has no reader for", { "GenotypeHandle", path = "/tmp/x", format = "zzz", - snpInfo = getSnpInfo(h), + snpInfo = snpInfo(h), nSamples = 1L, sampleIds = "s1", pgenPtr = NULL diff --git a/tests/testthat/test_h2Annotations.R b/tests/testthat/test_h2Annotations.R index ab2c33fd..5fd8199f 100644 --- a/tests/testthat/test_h2Annotations.R +++ b/tests/testthat/test_h2Annotations.R @@ -231,7 +231,7 @@ test_that("readannotations with BED file creates AnnotationMatrix", { expect_equal(nrow(assay(result, "annotations")), 3) expect_equal(ncol(assay(result, "annotations")), 1) expect_equal(colnames(assay(result, "annotations")), "enhancer") - expect_equal(getGenome(result), "hg38") + expect_equal(unname(GenomeInfoDb::genome(result)), "hg38") # Auto-detected meta should be binary, candidate tier expect_equal(SummarizedExperiment::colData(result)$type, "binary") expect_equal(SummarizedExperiment::colData(result)$tier, "candidate") diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index 17fb603a..9383b999 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -37,7 +37,7 @@ makeTestEigenRef <- function(nSnps = 20, nBlocks = 2) { LdEigen( ldBlocks = ld_blocks, snpInfo = snp_info, - nRef = 500000L, + nSamples = 500000L, inSample = FALSE, genome = "hg19", eigenList = eigen_list, @@ -93,7 +93,7 @@ makeTestScoreRef <- function( LdScore( ldBlocks = ld_blocks, snpInfo = snp_info, - nRef = 500000L, + nSamples = 500000L, inSample = FALSE, genome = "hg19", ldScores = ld_scores, @@ -144,7 +144,7 @@ makeTestH2Estimate <- function(with_enrichment = TRUE) { } set.seed(55) - tauBlocks <- if (with_enrichment) { + annotationJackknifeCoefs <- if (with_enrichment) { matrix( rnorm(20), nrow = 10, @@ -157,13 +157,13 @@ makeTestH2Estimate <- function(with_enrichment = TRUE) { new( "H2Estimate", - h2 = 0.3, - h2Se = 0.05, + estimate = 0.3, + estimateSe = 0.05, intercept = 1.01, interceptSe = 0.02, - local = NULL, + localBlocks = NULL, enrichment = enrich, - tauBlocks = tauBlocks, + annotationJackknifeCoefs = annotationJackknifeCoefs, scoreStats = NULL, method = "lder", nSnps = 100L, @@ -252,7 +252,7 @@ test_that("computeLdScores LdEigen annotation column names match", { test_that("computeLdScores LdScore without annotations returns stored ld_scores", { score_ref <- makeTestScoreRef() result <- computeLdScores(score_ref) - expect_identical(result, getLdScores(score_ref)) + expect_identical(result, mcols(score_ref)$ldScores) }) test_that("computeLdScores LdScore with annotations but no ld_matrix_list errors", { @@ -277,24 +277,24 @@ test_that("getlocal returns the local slot", { ) h2_obj <- new( "H2Estimate", - h2 = 0.3, - h2Se = 0.05, + estimate = 0.3, + estimateSe = 0.05, intercept = 1.0, interceptSe = 0.01, - local = local_df, + localBlocks = local_df, enrichment = NULL, - tauBlocks = NULL, + annotationJackknifeCoefs = NULL, scoreStats = NULL, method = "lder", nSnps = 100L, traitName = "test" ) - expect_identical(getLocal(h2_obj), local_df) + expect_identical(localH2Blocks(h2_obj), local_df) }) test_that("getenrichment returns the enrichment slot", { h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) - result <- getEnrichment(h2_obj) + result <- stratifiedHeritabilityEnrichment(h2_obj) expect_true(is.data.frame(result)) expect_equal(result$annotation, c("annot1", "annot2")) }) @@ -307,39 +307,39 @@ test_that("getscorestats returns the scoreStats slot", { ) h2_obj <- new( "H2Estimate", - h2 = 0.3, - h2Se = 0.05, + estimate = 0.3, + estimateSe = 0.05, intercept = 1.0, interceptSe = 0.01, - local = NULL, + localBlocks = NULL, enrichment = NULL, - tauBlocks = NULL, + annotationJackknifeCoefs = NULL, scoreStats = scoreStats, method = "lder", nSnps = 100L, traitName = "test" ) - expect_identical(getScoreStats(h2_obj), scoreStats) + expect_identical(scoreStats(h2_obj), scoreStats) }) test_that("accessors return NULL when slots are NULL", { h2_obj <- new( "H2Estimate", - h2 = 0.3, - h2Se = 0.05, + estimate = 0.3, + estimateSe = 0.05, intercept = 1.0, interceptSe = 0.01, - local = NULL, + localBlocks = NULL, enrichment = NULL, - tauBlocks = NULL, + annotationJackknifeCoefs = NULL, scoreStats = NULL, method = "lder", nSnps = 100L, traitName = "test" ) - expect_null(getLocal(h2_obj)) - expect_null(getEnrichment(h2_obj)) - expect_null(getScoreStats(h2_obj)) + expect_null(localH2Blocks(h2_obj)) + expect_null(stratifiedHeritabilityEnrichment(h2_obj)) + expect_null(scoreStats(h2_obj)) }) # =========================================================================== @@ -360,7 +360,7 @@ test_that("h2EstimateToSldscTrait returns correct list structure", { "propH2", "propSnps", "h2g", - "tauBlocks", + "annotationJackknifeCoefs", "nBlocks" ) expect_true(all(expected_names %in% names(result))) @@ -368,7 +368,7 @@ test_that("h2EstimateToSldscTrait returns correct list structure", { expect_equal(result$categories, c("annot1", "annot2")) expect_equal(result$h2g, 0.3) - expect_true(is.matrix(result$tauBlocks)) + expect_true(is.matrix(result$annotationJackknifeCoefs)) expect_equal(result$nBlocks, 10L) expect_equal(names(result$tau), c("annot1", "annot2")) expect_equal(names(result$enrichment), c("annot1", "annot2")) @@ -389,13 +389,13 @@ test_that("h2EstimateToSldscTrait errors when enrichment is NULL", { ) }) -test_that("h2EstimateToSldscTrait creates 1-row dummy when tauBlocks is NULL", { +test_that("h2EstimateToSldscTrait creates 1-row dummy when annotationJackknifeCoefs is NULL", { h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) - h2_obj@tauBlocks <- NULL + h2_obj@annotationJackknifeCoefs <- NULL result <- h2EstimateToSldscTrait(h2_obj) - expect_equal(nrow(result$tauBlocks), 1) + expect_equal(nrow(result$annotationJackknifeCoefs), 1) expect_equal(result$nBlocks, 1L) - expect_equal(colnames(result$tauBlocks), c("annot1", "annot2")) + expect_equal(colnames(result$annotationJackknifeCoefs), c("annot1", "annot2")) }) # =========================================================================== @@ -450,7 +450,7 @@ makeTestSumstatsForRef <- function( stringsAsFactors = FALSE ) GwasSumStats( - study = traitName, + studyName = traitName, entry = list(.dfToGwasGr(df)), genome = "hg19", ldSketch = makeTestGwasGenotypeHandle(), @@ -468,13 +468,13 @@ test_that("estimateh2 with method='lder' returns H2Estimate with correct slots", result <- estimateH2(ss, eigen_ref, method = "lder") expect_s4_class(result, "H2Estimate") - expect_true(is.numeric(getH2(result))) - expect_true(is.numeric(getH2Se(result))) - expect_true(is.numeric(getIntercept(result))) - expect_true(is.numeric(getInterceptSe(result))) - expect_equal(getMethodNames(result), "lder") - expect_equal(getNSnps(result), nSnps(ss)) - expect_equal(getTraitName(result), "test") + expect_true(is.numeric(heritabilityEstimate(result))) + expect_true(is.numeric(heritabilityEstimateSe(result))) + expect_true(is.numeric(heritabilityIntercept(result))) + expect_true(is.numeric(heritabilityInterceptSe(result))) + expect_equal(methodNames(result), "lder") + expect_equal(nSnps(result), nSnps(ss)) + expect_equal(traitNames(result), "test") }) # =========================================================================== @@ -487,10 +487,10 @@ test_that("estimateh2 with method='lder' returns H2Estimate with correct slots", # Rebuild `ss`'s single entry with the mcols kept and the ranges replaced. .reposition <- function(ss, gr) { - entry <- getSumStats(ss) + entry <- sumStats(ss) S4Vectors::mcols(gr) <- S4Vectors::mcols(entry) GwasSumStats( - study = "test", + studyName = "test", entry = list(gr), genome = "hg19", ldSketch = makeTestGwasGenotypeHandle() @@ -501,8 +501,8 @@ test_that("estimateH2 rejects a sumstats with a different variant count", { ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef(ref) short <- GwasSumStats( - study = "test", - entry = list(getSumStats(ss)[1:10]), + studyName = "test", + entry = list(sumStats(ss)[1:10]), genome = "hg19", ldSketch = makeTestGwasGenotypeHandle() ) @@ -558,8 +558,8 @@ test_that("estimateH2 rejects a genome build mismatch", { ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef(ref) hg38 <- GwasSumStats( - study = "test", - entry = list(getSumStats(ss)), + studyName = "test", + entry = list(sumStats(ss)), genome = "hg38", ldSketch = makeTestGwasGenotypeHandle() ) @@ -592,8 +592,8 @@ test_that("unstratified S-LDSC runs without the per-block LD matrices", { expect_error(estimateH2(ss, noMat, method = "gldsc"), "per-block LD") res <- estimateH2(ss, noMat, method = "sldsc") expect_s4_class(res, "H2Estimate") - expect_equal(getMethodNames(res), "sldsc") - expect_true(is.finite(getH2(res))) + expect_equal(methodNames(res), "sldsc") + expect_true(is.finite(heritabilityEstimate(res))) }) test_that("stratified S-LDSC needs the per-block LD matrices", { @@ -612,7 +612,7 @@ test_that("S-LDSC reports an enrichment table when stratified", { annot <- makeTestAnnotations(nSnps = length(ref)) res <- estimateH2(ss, ref, method = "sldsc", annotations = annot) - enr <- getEnrichment(res) + enr <- stratifiedHeritabilityEnrichment(res) expect_s3_class(enr, "data.frame") expect_equal(nrow(enr), 2L) expect_true(all( @@ -628,7 +628,7 @@ test_that("S-LDSC reports an enrichment table when stratified", { ) %in% names(enr) )) - expect_false(is.null(getTauBlocks(res))) + expect_false(is.null(annotationJackknifeCoefs(res))) }) test_that("S-LDSC requires an LdScore, not an LdEigen", { @@ -708,7 +708,7 @@ test_that("the S-LDSC weights reproduce upstream Hsq.weights", { IRanges::IRanges(start = starts, end = ends) ), snpInfo = snpInfo, - nRef = 500000L, + nSamples = 500000L, inSample = FALSE, genome = "hg19", eigenvalueTruncation = 1.0, @@ -718,7 +718,7 @@ 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(map(getEigenList(ref), function(b) b$values)) + values <- unlist(map(eigenList(ref), function(b) b$values)) expect_true(any(values < 0)) expect_true(min(values) > -1e-6) # noise, not structure }) @@ -728,7 +728,7 @@ test_that("estimateH2 survives negative eigenvalues from rank-deficient LD", { ss <- makeTestSumstatsForRef(ref) res <- estimateH2(ss, ref, method = "lder") expect_s4_class(res, "H2Estimate") - expect_false(is.na(getH2(res))) + expect_false(is.na(heritabilityEstimate(res))) }) test_that(".lderWeights never returns a negative weight", { @@ -800,7 +800,7 @@ test_that("estimateH2 accepts a chr-prefix difference between the two sides", { # 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]], + as.character(GenomicRanges::seqnames(sumStats(ss)))[[1]], "1" ) expect_s4_class(estimateH2(ss, ref, method = "lder"), "H2Estimate") @@ -813,11 +813,11 @@ test_that("estimateh2 with var_y correction runs without error", { traitName = "cc_trait", varY = 4.0 ) - expect_equal(getVarY(ss), 4.0) + expect_equal(varY(ss), 4.0) result <- estimateH2(ss, eigen_ref, method = "lder") expect_s4_class(result, "H2Estimate") - expect_true(is.numeric(getH2(result))) + expect_true(is.numeric(heritabilityEstimate(result))) }) test_that("estimateh2 with method='gldsc' returns H2Estimate", { @@ -826,11 +826,11 @@ test_that("estimateh2 with method='gldsc' returns H2Estimate", { result <- estimateH2(ss, score_ref, method = "gldsc") expect_s4_class(result, "H2Estimate") - expect_true(is.numeric(getH2(result))) - expect_true(is.numeric(getH2Se(result))) - expect_equal(getMethodNames(result), "gldsc") - expect_equal(getNSnps(result), nSnps(ss)) - expect_equal(getTraitName(result), "test") + expect_true(is.numeric(heritabilityEstimate(result))) + expect_true(is.numeric(heritabilityEstimateSe(result))) + expect_equal(methodNames(result), "gldsc") + expect_equal(nSnps(result), nSnps(ss)) + expect_equal(traitNames(result), "test") }) test_that("estimateh2 with method='hdl' returns H2Estimate", { @@ -843,11 +843,11 @@ test_that("estimateh2 with method='hdl' returns H2Estimate", { ) expect_s4_class(result, "H2Estimate") - expect_true(is.numeric(getH2(result))) - expect_true(is.numeric(getH2Se(result))) - expect_equal(getMethodNames(result), "hdl") - expect_equal(getNSnps(result), nSnps(ss)) - expect_equal(getTraitName(result), "test") + expect_true(is.numeric(heritabilityEstimate(result))) + expect_true(is.numeric(heritabilityEstimateSe(result))) + expect_equal(methodNames(result), "hdl") + expect_equal(nSnps(result), nSnps(ss)) + expect_equal(traitNames(result), "test") }) # =========================================================================== @@ -865,7 +865,7 @@ test_that("computeLdScores LdScore with annotations and ld_matrix_list returns c expect_equal(nrow(result), length(score_ref)) expect_equal(colnames(result), c("base_l2", "annot_A", "annot_B")) # First column should be the stored base LD scores - expect_equal(result[, 1], getLdScores(score_ref)[, 1]) + expect_equal(result[, 1], mcols(score_ref)$ldScores[, 1]) }) @@ -1009,16 +1009,16 @@ test_that("computeBaselineEnrichment uses jackknife blocks when provided", { tauSe <- c(0.002, 0.001) h2 <- 0.5 annot_names <- c("annot1", "base") - tauBlocks <- matrix(rep(tau, each = nBlocks), nrow = nBlocks, ncol = 2) + annotationJackknifeCoefs <- matrix(rep(tau, each = nBlocks), nrow = nBlocks, ncol = 2) res <- pecotmr:::computeBaselineEnrichment( tau, tauSe, - tauBlocks, + annotationJackknifeCoefs, baseline_mat, annot_names, h2 ) - # With constant tauBlocks, enrichmentSe should be 0 + # With constant annotationJackknifeCoefs, enrichmentSe should be 0 expect_equal(res$enrichmentSe, c(0, 0)) }) @@ -1032,8 +1032,8 @@ test_that("standardize_tau_star computes tauStar = tau * sd_annot * M_ref / h2g" M_ref <- 1000L h2g <- 0.4 nBlocks <- 5 - tauBlocks <- matrix(rep(tau, each = nBlocks), nrow = nBlocks, ncol = 2) - res <- pecotmr:::standardizeTauStar(tau, tauBlocks, sd_annot, M_ref, h2g) + annotationJackknifeCoefs <- matrix(rep(tau, each = nBlocks), nrow = nBlocks, ncol = 2) + res <- pecotmr:::standardizeTauStar(tau, annotationJackknifeCoefs, sd_annot, M_ref, h2g) expected <- tau * sd_annot * M_ref / h2g expect_equal(res$tauStar, expected) expect_length(res$tauStarSe, 2) @@ -1070,8 +1070,8 @@ test_that("standardize_tau_star returns list with tauStar and tauStarSe", { sd_annot <- c(0.5) M_ref <- 1000L h2g <- 0.4 - tauBlocks <- matrix(rnorm(5, mean = 0.01, sd = 0.001), nrow = 5, ncol = 1) - res <- pecotmr:::standardizeTauStar(tau, tauBlocks, sd_annot, M_ref, h2g) + annotationJackknifeCoefs <- matrix(rnorm(5, mean = 0.01, sd = 0.001), nrow = 5, ncol = 1) + res <- pecotmr:::standardizeTauStar(tau, annotationJackknifeCoefs, sd_annot, M_ref, h2g) expect_true(is.list(res)) expect_named(res, c("tauStar", "tauStarSe")) expect_length(res$tauStar, 1) @@ -1393,7 +1393,7 @@ simulateH2Data <- function( eigen_ref <- LdEigen( ldBlocks = ld_blocks, snpInfo = snp_info, - nRef = 500000L, + nSamples = 500000L, inSample = FALSE, genome = "hg19", eigenList = eigen_list, @@ -1411,7 +1411,7 @@ simulateH2Data <- function( ld_score_ref <- LdScore( ldBlocks = ld_blocks, snpInfo = snp_info, - nRef = 500000L, + nSamples = 500000L, inSample = FALSE, genome = "hg19", ldScores = matrix( @@ -1477,7 +1477,7 @@ test_that("lderUnivariate returns correct structure", { "interceptSe", "local", "enrichment", - "tauBlocks", + "annotationJackknifeCoefs", "scoreStats" ) %in% names(res) @@ -1531,7 +1531,7 @@ test_that("gldscUnivariate returns correct structure", { "interceptSe", "local", "enrichment", - "tauBlocks", + "annotationJackknifeCoefs", "scoreStats" ) %in% names(res) @@ -1577,7 +1577,7 @@ test_that("hdlUnivariate returns correct structure", { "interceptSe", "local", "enrichment", - "tauBlocks", + "annotationJackknifeCoefs", "scoreStats" ) %in% names(res) @@ -1640,7 +1640,7 @@ test_that("lder enrichment has correct columns", { expect_true(all(expected_cols %in% colnames(res$enrichment))) }) -test_that("lder with annotations returns tauBlocks matrix", { +test_that("lder with annotations returns annotationJackknifeCoefs matrix", { annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::lderUnivariate( dat_annot$z, @@ -1648,9 +1648,9 @@ test_that("lder with annotations returns tauBlocks matrix", { dat_annot$eigen_ref, annotations = annot ) - expect_true(is.matrix(res$tauBlocks)) + expect_true(is.matrix(res$annotationJackknifeCoefs)) # nBlocks rows (5 blocks in the annotation test data) - expect_equal(nrow(res$tauBlocks), 5L) + expect_equal(nrow(res$annotationJackknifeCoefs), 5L) }) test_that("lder with annotations returns scoreStats list", { @@ -1697,7 +1697,7 @@ test_that("hdlUnivariate with annotations returns enrichment data.frame with cor expect_true(all(is.finite(res$enrichment$enrichment))) }) -test_that("hdlUnivariate with annotations returns tauBlocks matrix", { +test_that("hdlUnivariate with annotations returns annotationJackknifeCoefs matrix", { set.seed(124) annot <- makeTestAnnotations(dat_annot$n_snps) res <- pecotmr:::hdlUnivariate( @@ -1706,13 +1706,13 @@ test_that("hdlUnivariate with annotations returns tauBlocks matrix", { dat_annot$eigen_ref, annotations = annot ) - expect_true(is.matrix(res$tauBlocks)) + expect_true(is.matrix(res$annotationJackknifeCoefs)) # nBlocks rows (5 blocks in dat_annot) - expect_equal(nrow(res$tauBlocks), 5L) + expect_equal(nrow(res$annotationJackknifeCoefs), 5L) # Number of columns matches baseline annotation count - expect_equal(ncol(res$tauBlocks), 1L) + expect_equal(ncol(res$annotationJackknifeCoefs), 1L) # Values should be finite - expect_true(all(is.finite(res$tauBlocks))) + expect_true(all(is.finite(res$annotationJackknifeCoefs))) }) test_that("hdlUnivariate with annotations and local = TRUE returns local data.frame", { @@ -1814,7 +1814,7 @@ test_that("gldscUnivariate with annotations returns enrichment data.frame", { expect_true(all(is.finite(res$enrichment$enrichment))) }) -test_that("gldscUnivariate with annotations returns tauBlocks matrix", { +test_that("gldscUnivariate with annotations returns annotationJackknifeCoefs matrix", { set.seed(201) annot <- makeGldscAnnotations(dat_annot$n_snps) res <- pecotmr:::gldscUnivariate( @@ -1823,14 +1823,14 @@ test_that("gldscUnivariate with annotations returns tauBlocks matrix", { dat_annot$ld_score_ref, annotations = annot ) - expect_true(is.matrix(res$tauBlocks)) + expect_true(is.matrix(res$annotationJackknifeCoefs)) # gldsc jackknife uses 200 blocks by default; with 500 SNPs the actual # number of unique blocks equals ceil(500/ceil(500/200)) = 200 - expect_true(nrow(res$tauBlocks) > 0) + expect_true(nrow(res$annotationJackknifeCoefs) > 0) # Number of columns matches baseline annotation count - expect_equal(ncol(res$tauBlocks), 1L) + expect_equal(ncol(res$annotationJackknifeCoefs), 1L) # Values should be finite (allow some NAs from edge blocks) - expect_true(any(is.finite(res$tauBlocks))) + expect_true(any(is.finite(res$annotationJackknifeCoefs))) }) test_that("gldscUnivariate with annotations returns scoreStats", { @@ -1865,7 +1865,7 @@ test_that("gldscUnivariate with annotations returns scoreStats", { # tau=NULL), .lderLocalH2 (small block + baseline path), .hdlSeFisher- # Stratified / .hdlJackknifeTau (lambda>0 + singular fallback), the # multi-candidate (cor) and no-candidate (NULL) paths of the stratified -# score-statistic helpers, h2EstimateToSldscTrait (unnamed tauBlocks), and +# score-statistic helpers, h2EstimateToSldscTrait (unnamed annotationJackknifeCoefs), and # the multi-study estimateH2 dispatch error. # =========================================================================== @@ -2068,16 +2068,16 @@ test_that("gldscUnivariate with baseline-only annotations yields NULL scoreStats }) # --------------------------------------------------------------------------- -# h2EstimateToSldscTrait — tauBlocks present but without column names +# h2EstimateToSldscTrait — annotationJackknifeCoefs present but without column names # --------------------------------------------------------------------------- -test_that("h2EstimateToSldscTrait assigns category names to unnamed tauBlocks", { +test_that("h2EstimateToSldscTrait assigns category names to unnamed annotationJackknifeCoefs", { h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) - tb <- getTauBlocks(h2_obj) + tb <- annotationJackknifeCoefs(h2_obj) colnames(tb) <- NULL - h2_obj@tauBlocks <- tb + h2_obj@annotationJackknifeCoefs <- tb result <- h2EstimateToSldscTrait(h2_obj) - expect_equal(colnames(result$tauBlocks), c("annot1", "annot2")) + expect_equal(colnames(result$annotationJackknifeCoefs), c("annot1", "annot2")) expect_equal(result$nBlocks, 10L) }) @@ -2105,7 +2105,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" ) gr <- .dfToGwasGr(df) ss2 <- GwasSumStats( - study = c("studyA", "studyB"), + studyName = c("studyA", "studyB"), entry = list(gr, gr), genome = "hg19", ldSketch = makeTestGwasGenotypeHandle(), @@ -2161,7 +2161,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" eigenRef <- LdEigen( ldBlocks = lb, snpInfo = snpInfo, - nRef = 500000L, + nSamples = 500000L, inSample = FALSE, genome = "hg19", eigenvalueTruncation = 1.0, @@ -2180,7 +2180,7 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" scoreRef <- LdScore( ldBlocks = lb, snpInfo = snpInfo, - nRef = 500000L, + nSamples = 500000L, inSample = FALSE, genome = "hg19", ldScores = matrix(lsv, ncol = 1, dimnames = list(NULL, "base_l2")), @@ -2278,7 +2278,7 @@ test_that("HDL uses the finite-reference correction (nRef changes h2)", { z <- d$simZ(rep(0.4 / d$M, d$M)) refBig <- d$eigenRef refSmall <- d$eigenRef - refSmall@nRef <- 2000L + refSmall@nSamples <- 2000L h2Big <- hdlUnivariate(z, d$N, refBig)$h2 # nRef = 2000 against this N is exactly the regime where the # finite-reference term dominates, so the fit lands on its bound and says @@ -2454,8 +2454,8 @@ test_that("univariate S-LDSC reproduces upstream ldsc to 1e-5", { data(ldScoreExample) ref <- ldScoreExample M <- length(ref) - scores <- matrix(as.vector(getLdScores(ref)[, 1]), ncol = 1) - baseScore <- as.vector(getLdScores(ref)[, 1]) + scores <- matrix(as.vector(mcols(ref)$ldScores[, 1]), ncol = 1) + baseScore <- as.vector(mcols(ref)$ldScores[, 1]) reference <- list( list( @@ -2544,7 +2544,7 @@ test_that("the two S-LDSC routes differ, as upstream's do", { ref <- ldScoreExample M <- length(ref) z <- .sldscUpstreamZ(ref, 0.4, 10000, 42) - scores <- matrix(as.vector(getLdScores(ref)[, 1]), ncol = 1) + scores <- matrix(as.vector(mcols(ref)$ldScores[, 1]), ncol = 1) uni <- pecotmr:::.sldscFit( z^2, scores, @@ -2586,14 +2586,14 @@ test_that("HDL reports when its fit lands on an optimiser bound", { z <- .sldscUpstreamZ(ldScoreExample, 0.4, 1e5, 2) small <- ldEigenExample - small@nRef <- 1000L + small@nSamples <- 1000L expect_warning( est <- pecotmr:::hdlUnivariate(z, 1e5, small)$h2, "sits at the top of its range" ) big <- ldEigenExample - big@nRef <- 20000L + big@nSamples <- 20000L expect_no_warning( ok <- pecotmr:::hdlUnivariate(z, 1e5, big)$h2, message = "sits at the top of its range" @@ -2608,7 +2608,7 @@ test_that("HDL reports when its fit lands on an optimiser bound", { test_that("HDL recovers a known h2 given an adequate reference", { data(ldEigenExample, ldScoreExample) ref <- ldEigenExample - ref@nRef <- 20000L + ref@nSamples <- 20000L ests <- map_dbl( 1:5, function(seed) { @@ -2656,7 +2656,7 @@ test_that("HDL reproduces upstream HDL", { ) for (g in reference) { ref <- ldEigenExample - ref@nRef <- g$nRef + ref@nSamples <- g$nRef z <- .sldscUpstreamZ(ldScoreExample, g$h2, g$n, g$seed) est <- suppressWarnings(pecotmr:::hdlUnivariate(z, g$n, ref)$h2) expect_equal(est, g$want, tolerance = 1e-6) @@ -2707,21 +2707,25 @@ test_that("an explicit study is used without inspecting the collection", { expect_equal(pecotmr:::.estimateH2ResolveStudy(NULL, "myStudy"), "myStudy") }) -test_that("the genome check reports NA, the build, or refuses a mixture", { +test_that("the genome check skips an unlabelled build and refuses a mixture", { gr <- GenomicRanges::GRanges( c("chr1", "chr2"), IRanges::IRanges(c(1L, 2L), width = 1L) ) - # No build recorded: NA rather than a guess. - expect_true(is.na(pecotmr:::.h2GenomeOfRanges(gr))) + # No build recorded: skipped rather than guessed at or rejected. + expect_true(pecotmr:::checkGenomeBuild(gr)) + # Two builds inside ONE object are as much a mismatch as two objects + # disagreeing, and report through the same path. GenomeInfoDb::genome(gr) <- c("hg19", "hg38") - # Mixed builds mean the parts were never comparable. expect_error( - pecotmr:::.h2GenomeOfRanges(gr), - "names 2 genome build" + pecotmr:::checkGenomeBuild(gr), + "Genome build mismatch" ) GenomeInfoDb::genome(gr) <- "hg38" - expect_equal(pecotmr:::.h2GenomeOfRanges(gr), "hg38") + expect_true(pecotmr:::checkGenomeBuild(gr)) + # An unlabelled object alongside a labelled one still passes. + bare <- GenomicRanges::GRanges("chr3", IRanges::IRanges(1L, width = 1L)) + expect_true(pecotmr:::checkGenomeBuild(gr, bare)) }) test_that("the chi2 filter is abandoned when too few variants survive it", { @@ -2831,7 +2835,7 @@ test_that(".h2BaselineMat is NULL when no annotation is baseline tier", { ) am <- AnnotationMatrix(mat, gr, meta, genome = "hg19") # The object has annotations, but none of them are baseline. - expect_equal(ncol(assay(getBaseline(am), "annotations")), 0L) + expect_equal(ncol(assay(baselineAnnotations(am), "annotations")), 0L) expect_null(pecotmr:::.h2BaselineMat(am)) expect_null(pecotmr:::.h2BaselineMat(NULL)) }) @@ -2874,7 +2878,7 @@ test_that(".h2Enrichment names unnamed annotation columns positionally", { baselineMat, tau = c(0.1, 0.2), tauSe = c(0.01, 0.02), - tauBlocks = matrix(c(0.1, 0.2, 0.1, 0.2), nrow = 2L), + annotationJackknifeCoefs = matrix(c(0.1, 0.2, 0.1, 0.2), nrow = 2L), h2 = 0.3 ) expect_equal(out$annotation, c("annot_1", "annot_2")) @@ -2896,7 +2900,7 @@ test_that(".sldscBlockIndex errors when no block covers a variant", { ldScores = matrix(1, nrow = n, ncol = 1L), ldScoreWeights = rep(1, n), ldBlocks = blocks, - nRef = 100L, + nSamples = 100L, genome = "hg19", ldMatrixList = list() ) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index 6432a76b..71e139ae 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -118,7 +118,7 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { pipe <- new( "FmJointPipeline", config = list( - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( includeAllCs = TRUE, perCsColumns = "full" ), @@ -140,7 +140,7 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { method, dataX, dataY, - credibleSetArgs, + credibleSetParam, fitRetention, csInput = NULL, af = NULL, @@ -148,17 +148,17 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { conditionIdx = NULL, ... ) { - captured$perCsColumns <- credibleSetArgs$perCsColumns - captured$includeAllCs <- credibleSetArgs$includeAllCs + captured$perCsColumns <- credibleSetParam$perCsColumns + captured$includeAllCs <- credibleSetParam$includeAllCs .je_mockPostprocess( fit, method, dataX, dataY, - credibleSetArgs$coverage, - credibleSetArgs$secondaryCoverage, - credibleSetArgs$signalCutoff, - credibleSetArgs$minAbsCorr, + credibleSetParam$coverage, + credibleSetParam$secondaryCoverage, + credibleSetParam$signalCutoff, + credibleSetParam$minAbsCorr, csInput = csInput, af = af, region = region, @@ -213,11 +213,11 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", twEntry <- twasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2), - fits = fp, + methodFits = fp, cvResult = cvPayload ) tw <- TwasWeights( - study = "S", + studyName = "S", context = "c1", trait = "G1", method = "mrmash", @@ -292,12 +292,12 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", X, Y, weightMethods, - study, + studyName, context, trait, fitRetention, - standardized, - dataType, + weightStandardized, + weightsDataType, verbose, ... ) { @@ -310,10 +310,10 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", e <- twasWeightsRow( variantIds = colnames(X), weights = W, - fits = .je_fakeMrmashFit() + methodFits = .je_fakeMrmashFit() ) TwasWeights( - study = study, + studyName = studyName, context = context, trait = trait, method = "mrmash", @@ -389,11 +389,11 @@ test_that(".runJointCell: cross-context twas expands to per-context weight vecto expect_equal(as.character(res$trait), c("G1", "G1")) expect_equal(as.character(res$jointContexts), c("c1;c2", "c1;c2")) # Each row carries that context's weight VECTOR (the matrix column). - w1 <- getWeights(pecotmr:::.collectionEntry(res, 1L)) + w1 <- weights(pecotmr:::.collectionEntry(res, 1L)) expect_false(is.matrix(w1)) expect_length(w1, 2L) # shared joint fit on each - expect_false(is.null(getFits(pecotmr:::.collectionEntry(res, 1L)))) + expect_false(is.null(methodFits(pecotmr:::.collectionEntry(res, 1L)))) }) test_that(".runJointCell: cross-context twas attaches per-condition CV slices", { @@ -420,12 +420,12 @@ test_that(".runJointCell: cross-context twas attaches per-condition CV slices", args = list(dataDrivenPriorMatricesCv = list(1, 2)) ) expect_equal(nrow(res), 2L) - cv <- getCvResult(pecotmr:::.collectionEntry(res, 1L)) + cv <- cvResult(pecotmr:::.collectionEntry(res, 1L)) expect_equal(names(cv$foldFits), c("fold_1", "fold_2")) # shared per-fold fits expect_false(is.null(cv$predictions)) # this context's slice expect_false(is.null(cv$samplePartition)) # per-context vector - expect_false(is.matrix(getWeights(pecotmr:::.collectionEntry(res, 1L)))) + expect_false(is.matrix(weights(pecotmr:::.collectionEntry(res, 1L)))) }) test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", { @@ -454,8 +454,8 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", expect_equal(nrow(res), 2L) e <- pecotmr:::.collectionEntry(res, 1L) expect_length(.twrPartsVariantIds(e), 0L) # placeholder weights - expect_null(getWeights(e)) - expect_equal(names(getCvResult(e)$foldFits), c("fold_1", "fold_2")) + expect_null(weights(e)) + expect_equal(names(cvResult(e)$foldFits), c("fold_1", "fold_2")) }) # ---- sumstats column (RSS; no sample folds) --------------------------------- @@ -574,8 +574,8 @@ test_that(".runJointCell: cross-context twas sumstats (mr.mash.rss) -> per-conte expect_equal(nrow(res), 2L) expect_equal(as.character(res$context), c("c1", "c2")) expect_equal(as.character(res$jointContexts), c("c1;c2", "c1;c2")) - expect_false(is.matrix(getWeights(pecotmr:::.collectionEntry(res, 1L)))) - expect_false(is.null(getFits(pecotmr:::.collectionEntry(res, 1L)))) + expect_false(is.matrix(weights(pecotmr:::.collectionEntry(res, 1L)))) + expect_false(is.null(methodFits(pecotmr:::.collectionEntry(res, 1L)))) }) test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regression)", { @@ -628,7 +628,7 @@ test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regressi fitJointGroup(group, pipe, "mrmash", list()) )) expect_length(entries, K) - w <- getWeights(entries[[1L]]) + w <- weights(entries[[1L]]) expect_length(w, p) expect_true(all(is.finite(w))) }) @@ -892,7 +892,7 @@ test_that(".runJointCell: cross-trait twas -> per-trait weight vectors", { expect_equal(as.character(res$context), c("brain", "brain")) expect_equal(as.character(res$trait), c("G1", "G2")) expect_equal(as.character(res$jointTraits), c("G1;G2", "G1;G2")) - expect_false(is.matrix(getWeights(pecotmr:::.collectionEntry(res, 1L)))) + expect_false(is.matrix(weights(pecotmr:::.collectionEntry(res, 1L)))) }) test_that("fitJointGroup(Individual, Fm): fsusie returns one entry per trait", { @@ -1038,7 +1038,7 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro expect_equal(as.character(res$trait), c("gA", "gB", "gA")) expect_equal(as.character(res$jointContexts), rep("c1;c2", 3L)) expect_equal(as.character(res$jointTraits), rep("gA;gB", 3L)) - expect_false(is.matrix(getWeights(pecotmr:::.collectionEntry(res, 1L)))) + expect_false(is.matrix(weights(pecotmr:::.collectionEntry(res, 1L)))) }) # ---- SR-TWAS ensemble layer (.twasEnsembleLayer) ---------------------------- @@ -1122,8 +1122,8 @@ test_that(".twasEnsembleLayer: >= 2 methods passing -> per-condition ensemble en ) expect_length(ens, 2L) expect_s4_class(ens[[1L]], "TwasWeightsRow") - expect_length(getWeights(ens[[1L]]), 3L) - coef <- getCvResult(ens[[1L]])$methodCoef + expect_length(weights(ens[[1L]]), 3L) + coef <- cvResult(ens[[1L]])$methodCoef expect_true(all(coef >= -1e-8)) expect_equal(sum(coef), 1, tolerance = 1e-6) }) @@ -1318,7 +1318,7 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand ) ) expect_false(cvCalled) # handoff used, no re-CV - expect_false(is.null(getCvResult(entries[[1L]])$predictions)) + expect_false(is.null(cvResult(entries[[1L]])$predictions)) }) # ============================================================================= @@ -1399,7 +1399,7 @@ test_that(".enumCrossContextIndividual: one group per trait in >= 2 contexts", { traits = list(S = c("G1", "G2")) ) local_mocked_bindings( - getStudy = function(data) "S", + studyName = function(data) "S", .buildIndividualCrossContextXy = function( data, tid, @@ -1440,7 +1440,7 @@ test_that(".enumCrossContextIndividual: one group per trait in >= 2 contexts", { }) test_that(".enumCrossContextIndividual: study not in scope / < 2 contexts -> empty", { - local_mocked_bindings(getStudy = function(data) "S", .package = "pecotmr") + local_mocked_bindings(studyName = function(data) "S", .package = "pecotmr") expect_length( pecotmr:::.enumCrossContextIndividual( NULL, @@ -1469,7 +1469,7 @@ test_that(".enumCrossContextSumstats: groups per (study, trait) with >= 2 contex traits = list(S = "t1") ) local_mocked_bindings( - getLdSketch = function(x) NULL, + ldSketch = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromSketch = .je_mockLd, .package = "pecotmr" @@ -1482,7 +1482,7 @@ test_that(".enumCrossContextSumstats: groups per (study, trait) with >= 2 contex test_that(".enumCrossContextSumstats: < 2 contexts and < 2 tuple rows skip", { local_mocked_bindings( - getLdSketch = function(x) NULL, + ldSketch = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromSketch = .je_mockLd, .package = "pecotmr" @@ -1511,7 +1511,7 @@ test_that(".enumCrossTraitIndividual: one group per context with >= 2 traits + p traits = list(S = c("G1", "G2")) ) local_mocked_bindings( - getStudy = function(data) "S", + studyName = function(data) "S", .buildIndividualCrossTraitXy = function( data, cx, @@ -1519,7 +1519,7 @@ test_that(".enumCrossTraitIndividual: one group per context with >= 2 traits + p cisWindow, verbose, label, - study, + studyName, region = NULL, ... ) { @@ -1554,7 +1554,7 @@ test_that(".enumCrossTraitIndividual: one group per context with >= 2 traits + p }) test_that(".enumCrossTraitIndividual: study not in scope -> empty", { - local_mocked_bindings(getStudy = function(data) "S", .package = "pecotmr") + local_mocked_bindings(studyName = function(data) "S", .package = "pecotmr") expect_length( pecotmr:::.enumCrossTraitIndividual( NULL, @@ -1572,7 +1572,7 @@ test_that(".enumCrossTraitSumstats: groups per (study, context) with >= 2 traits traits = list(S = c("t1", "t2")) ) local_mocked_bindings( - getLdSketch = function(x) NULL, + ldSketch = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromSketch = .je_mockLd, .package = "pecotmr" @@ -1593,7 +1593,7 @@ test_that(".enumCrossStudySumstats: group per (context, trait) in >= 2 studies", traits = list(S1 = "t1", S2 = "t1") ) local_mocked_bindings( - getLdSketch = function(x) NULL, + ldSketch = function(x) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromSketch = .je_mockLd, .package = "pecotmr" @@ -1617,11 +1617,11 @@ test_that(".enumComposedIndividual: one group joining every (context, trait) tup traits = list(S = c("gA", "gB")) ) local_mocked_bindings( - getStudy = function(data) "S", + studyName = function(data) "S", .buildComposedIndividualXy = function( data, scope, - study, + studyName, cisWindow, verbose, label, @@ -1661,7 +1661,7 @@ test_that(".enumComposedIndividual: one group joining every (context, trait) tup test_that(".enumComposedIndividual: study not in scope / NULL xy -> empty", { local_mocked_bindings( - getStudy = function(data) "S", + studyName = function(data) "S", .buildComposedIndividualXy = function(...) NULL, .package = "pecotmr" ) @@ -1693,8 +1693,8 @@ test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait) ) samp <- paste0("s", 1:5) local_mocked_bindings( - getStudy = function(data) "S", - getPhenotypes = function(data, contexts) .je_mkSe(c("G1", "G2")), + studyName = function(data) "S", + molecularTraits = function(data, contexts) .je_mkSe(c("G1", "G2")), .fmResidPheno = function( data, contexts, @@ -1735,8 +1735,8 @@ test_that(".enumUnivariateIndividual: too few shared samples skips the tuple", { traits = list(S = "G1") ) local_mocked_bindings( - getStudy = function(data) "S", - getPhenotypes = function(data, contexts) .je_mkSe("G1"), + studyName = function(data) "S", + molecularTraits = function(data, contexts) .je_mkSe("G1"), .fmResidPheno = function( data, contexts, @@ -1767,7 +1767,7 @@ test_that(".enumUnivariateIndividual: too few shared samples skips the tuple", { }) test_that(".enumUnivariateIndividual: study not in scope -> empty", { - local_mocked_bindings(getStudy = function(data) "S", .package = "pecotmr") + local_mocked_bindings(studyName = function(data) "S", .package = "pecotmr") expect_length( pecotmr:::.enumUnivariateIndividual( NULL, @@ -1785,7 +1785,7 @@ test_that(".enumComposedSumstats: one group per fixed-axis row block", { traits = list(S = "t1") ) local_mocked_bindings( - getLdSketch = function(x) NULL, + ldSketch = function(x) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) { list( groups = list(c(1L, 2L)), @@ -1809,7 +1809,7 @@ test_that(".enumComposedSumstats: one group per fixed-axis row block", { test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { local_mocked_bindings( - getLdSketch = function(x) NULL, + ldSketch = function(x) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) NULL, .package = "pecotmr" ) @@ -1821,7 +1821,7 @@ test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { 0L ) # gi NULL (646) local_mocked_bindings( - getLdSketch = function(x) NULL, + ldSketch = function(x) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) { list( groups = list(1L), @@ -2097,7 +2097,7 @@ test_that("fitJointGroup(SumStats, twas): a vector weight without rownames falls ) expect_s4_class(res, "TwasWeights") expect_equal( - getVariantIds(pecotmr:::.collectionEntry(res, 1L)), + variantIds(pecotmr:::.collectionEntry(res, 1L)), rownames(.jgZ(grp)) ) # fallback vids }) @@ -2264,7 +2264,7 @@ test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's ) ) expect_s4_class(ens[[1L]], "TwasWeightsRow") - expect_equal(getVariantIds(ens[[1L]]), colnames(.jgX(g))) # fallback ids + expect_equal(variantIds(ens[[1L]]), colnames(.jgX(g))) # fallback ids }) # ============================================================================= @@ -2366,7 +2366,7 @@ test_that(".twasGroupArgs: takes the CV partition from the fine-mapping CV when local_mocked_bindings( .twasFineMappingFits = function( fineMappingResult, - study, + studyName, context, trait ) { @@ -2402,7 +2402,7 @@ test_that(".runJointSpecs: region mode without traitId restricts scoped traits t traits = list(S = c("g1", "g2"), S2 = "g9") ) }, - getPhenotypes = function(data, contexts) .je_mkSe(c("g1", "g2")), + molecularTraits = function(data, contexts) .je_mkSe(c("g1", "g2")), .fmTraitsInRegion = function(se, traits, region) { captured <<- traits "g1" @@ -2450,7 +2450,7 @@ test_that(".runJointSpecs: region mode without traitId restricts scoped traits t # A QtlSumStats carrying a traitPos column, which no bundled fixture has. .je_ssWithTraitPos <- function() { QtlSumStats( - study = c("S", "S"), + studyName = c("S", "S"), context = c("brain", "brain"), trait = c("G1", "G2"), entry = list( @@ -2504,8 +2504,8 @@ test_that("the fit region of a QtlSumStats row is its variant span", { test_that("the fit region of a QtlDataset row is traitPos +/- the cis window", { data(qtlDatasetExample) qd <- qtlDatasetExample - cx <- getContexts(qd)[[1L]] - tr <- rownames(getPhenotypes(qd, contexts = cx))[[1L]] + cx <- contexts(qd)[[1L]] + tr <- rownames(molecularTraits(qd, contexts = cx))[[1L]] tp <- pecotmr:::.traitPosFor(qd, cx, tr) bare <- pecotmr:::.fitRegionFor(qd, cx, tr) wide <- pecotmr:::.fitRegionFor(qd, cx, tr, cisWindow = 1e5) @@ -2522,7 +2522,7 @@ test_that("the fit region of a QtlDataset row is traitPos +/- the cis window", { test_that("the anchors are NULL for a trait the dataset does not carry", { data(qtlDatasetExample) qd <- qtlDatasetExample - cx <- getContexts(qd)[[1L]] + cx <- contexts(qd)[[1L]] expect_null(pecotmr:::.traitPosFor(qd, cx, "absentTrait")) expect_null(pecotmr:::.traitPosFor(qd, "absentContext", "anything")) expect_null(pecotmr:::.fitRegionFor(qd, cx, "absentTrait")) @@ -2546,7 +2546,7 @@ test_that("a sumstats entry with no variants has no fit region", { n = integer(0) ) ss <- QtlSumStats( - study = "S", + studyName = "S", context = "brain", trait = "G0", entry = list(emptyEntry), @@ -2872,8 +2872,8 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { dimnames = list("t1", c("s1", "s2")) ) local_mocked_bindings( - getStudy = function(data) "S1", - getPhenotypes = function(data, contexts) phenotypes, + studyName = function(data) "S1", + molecularTraits = function(data, contexts) phenotypes, .fmResidPheno = function(data, contexts, traitId, naAction, ...) { matrix(1, 2L, 1L, dimnames = list(c("s1", "s2"), "t1")) }, diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index fba884e7..86d36a77 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -54,7 +54,7 @@ } .js_makeQtlDataset <- function( - study = "s1", + studyName = "s1", contexts = c("brain", "liver"), traits = c("ENSG1", "ENSG2") ) { @@ -63,7 +63,7 @@ contexts ) QtlDataset( - study = study, + studyName = studyName, genotypes = .js_makeGenotypeHandle(), phenotypes = phenos, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -96,7 +96,7 @@ gr }) QtlSumStats( - study = rows$study, + studyName = rows$study, context = rows$context, trait = rows$trait, entry = entries, @@ -111,14 +111,14 @@ test_that(".spListStudies / .spListContexts / .spListTraits: QtlDataset", { qd <- .js_makeQtlDataset( - study = "S1", + studyName = "S1", contexts = c("brain", "liver"), traits = c("ENSG_A", "ENSG_B") ) expect_equal(pecotmr:::.spListStudies(qd), "S1") expect_setequal(pecotmr:::.spListContexts(qd), c("brain", "liver")) expect_setequal( - pecotmr:::.spListTraits(qd, study = "S1", context = "brain"), + pecotmr:::.spListTraits(qd, studyName = "S1", context = "brain"), c("ENSG_A", "ENSG_B") ) expect_equal(pecotmr:::.spStudyDataForm(qd, "S1"), "individual") @@ -126,12 +126,12 @@ test_that(".spListStudies / .spListContexts / .spListTraits: QtlDataset", { test_that(".sp* helpers: MultiStudyQtlDataset combines individual + sumstats", { qd1 <- .js_makeQtlDataset( - study = "indA", + studyName = "indA", contexts = "brain", traits = "ENSG_A" ) qd2 <- .js_makeQtlDataset( - study = "indB", + studyName = "indB", contexts = "liver", traits = "ENSG_A" ) @@ -179,8 +179,8 @@ test_that("parseJointSpecification: accepts a list of specs", { }) test_that("parseJointSpecification: accepts scope-restricted spec", { - qd1 <- .js_makeQtlDataset(study = "A") - qd2 <- .js_makeQtlDataset(study = "B") + qd1 <- .js_makeQtlDataset(studyName = "A") + qd2 <- .js_makeQtlDataset(studyName = "B") mt <- MultiStudyQtlDataset(qtlDatasets = list(A = qd1, B = qd2)) out <- pecotmr:::parseJointSpecification( list(list(axes = "context", scope = list(study = c("A")))), @@ -217,7 +217,7 @@ test_that("parseJointSpecification: rejects unknown scope keys", { }) test_that("parseJointSpecification: rejects scope values absent from data", { - qd <- .js_makeQtlDataset(study = "S1") + qd <- .js_makeQtlDataset(studyName = "S1") expect_error( pecotmr:::parseJointSpecification( list(list(axes = "context", scope = list(study = "NotPresent"))), @@ -248,8 +248,8 @@ test_that("parseContexts: NULL passes through", { }) test_that("parseContexts: vector intersects with each study's contexts", { - qd1 <- .js_makeQtlDataset(study = "A", contexts = c("brain", "liver")) - qd2 <- .js_makeQtlDataset(study = "B", contexts = c("brain")) + qd1 <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) + qd2 <- .js_makeQtlDataset(studyName = "B", contexts = c("brain")) mt <- MultiStudyQtlDataset(qtlDatasets = list(A = qd1, B = qd2)) expect_warning( out <- pecotmr:::parseContexts(c("brain", "liver"), mt), @@ -260,7 +260,7 @@ test_that("parseContexts: vector intersects with each study's contexts", { }) test_that("parseContexts: named-list form requires valid studies", { - qd <- .js_makeQtlDataset(study = "A") + qd <- .js_makeQtlDataset(studyName = "A") expect_error( pecotmr:::parseContexts(list(B = "brain"), qd), "unknown studies" @@ -268,7 +268,7 @@ test_that("parseContexts: named-list form requires valid studies", { }) test_that("parseContexts: named-list rejects unknown contexts", { - qd <- .js_makeQtlDataset(study = "A", contexts = c("brain", "liver")) + qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) expect_error( pecotmr:::parseContexts(list(A = "bogus"), qd), "unknown contexts" @@ -276,8 +276,8 @@ test_that("parseContexts: named-list rejects unknown contexts", { }) test_that("parseContexts: list form fills unmentioned studies with defaults", { - qd1 <- .js_makeQtlDataset(study = "A", contexts = c("brain", "liver")) - qd2 <- .js_makeQtlDataset(study = "B", contexts = c("brain", "liver")) + qd1 <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) + qd2 <- .js_makeQtlDataset(studyName = "B", contexts = c("brain", "liver")) mt <- MultiStudyQtlDataset(qtlDatasets = list(A = qd1, B = qd2)) out <- pecotmr:::parseContexts(list(A = "brain"), mt) expect_equal(out$A, "brain") @@ -299,8 +299,8 @@ test_that("parseTraitIds: vector form returns the vector", { }) test_that("parseTraitIds: study-keyed list validates per study", { - qd1 <- .js_makeQtlDataset(study = "A", traits = c("ENSG_A")) - qd2 <- .js_makeQtlDataset(study = "B", traits = c("ENSG_B")) + qd1 <- .js_makeQtlDataset(studyName = "A", traits = c("ENSG_A")) + qd2 <- .js_makeQtlDataset(studyName = "B", traits = c("ENSG_B")) mt <- MultiStudyQtlDataset(qtlDatasets = list(A = qd1, B = qd2)) expect_error( pecotmr:::parseTraitIds(list(A = "ENSG_B"), mt), @@ -313,7 +313,7 @@ test_that("parseTraitIds: study-keyed list validates per study", { test_that("parseTraitIds: doubly-nested study->context validates per context", { qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = c("brain", "liver"), traits = c("ENSG_A", "ENSG_B") ) @@ -384,7 +384,7 @@ test_that("parseMethods: rejects unknown tokens", { }) test_that("parseMethods: rejects multi-axis methods at per-context level", { - qd <- .js_makeQtlDataset(study = "A", contexts = c("brain", "liver")) + qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) expect_error( pecotmr:::parseMethods( methods = list(A = list(brain = c("susie", "mvsusie"))), @@ -398,7 +398,7 @@ test_that("parseMethods: rejects multi-axis methods at per-context level", { test_that("parseMethods: rejects multi-axis methods at per-trait level", { qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = "brain", traits = c("ENSG_A", "ENSG_B") ) @@ -445,7 +445,7 @@ test_that("parseMethods: rejectedAtUser tokens are refused", { }) test_that("parseMethods: accepts per-context univariate methods", { - qd <- .js_makeQtlDataset(study = "A", contexts = c("brain", "liver")) + qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) out <- pecotmr:::parseMethods( methods = list(A = list(brain = "susie", liver = "susieInf")), data = qd, @@ -457,7 +457,7 @@ test_that("parseMethods: accepts per-context univariate methods", { test_that("parseMethods: validates per-(study, context, trait) leaf paths", { qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = "brain", traits = c("ENSG_A", "ENSG_B") ) @@ -477,8 +477,8 @@ test_that("parseMethods: validates per-(study, context, trait) leaf paths", { # ----------------------------------------------------------------------------- test_that("validateMethodsVsJointSpec: per-study methods + jointCrossStudy errors", { - qd1 <- .js_makeQtlDataset(study = "A") - qd2 <- .js_makeQtlDataset(study = "B") + qd1 <- .js_makeQtlDataset(studyName = "A") + qd2 <- .js_makeQtlDataset(studyName = "B") ss <- .js_makeQtlSumStats(studies = "C") mt <- MultiStudyQtlDataset( qtlDatasets = list(A = qd1, B = qd2), @@ -498,7 +498,7 @@ test_that("validateMethodsVsJointSpec: per-study methods + jointCrossStudy error }) test_that("validateMethodsVsJointSpec: per-context methods + jointCrossContext errors", { - qd <- .js_makeQtlDataset(study = "A", contexts = c("brain", "liver")) + qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) parsed <- pecotmr:::parseMethods( methods = list(A = list(brain = "susie", liver = "susie")), data = qd, @@ -513,7 +513,7 @@ test_that("validateMethodsVsJointSpec: per-context methods + jointCrossContext e }) test_that("validateMethodsVsJointSpec: vector methods + any joint flag OK", { - qd <- .js_makeQtlDataset(study = "A", contexts = c("brain", "liver")) + qd <- .js_makeQtlDataset(studyName = "A", contexts = c("brain", "liver")) parsed <- pecotmr:::parseMethods( methods = c("susie", "mvsusie"), data = qd, @@ -535,7 +535,7 @@ test_that("fineMappingPipeline(QtlDataset): trait-axis joint dispatcher is wired # the stub error), so we check that the error comes from the genotype # I/O layer rather than the jointSpec wiring. qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = "brain", traits = c("ENSG_A", "ENSG_B") ) @@ -556,7 +556,7 @@ test_that("fineMappingPipeline(QtlDataset): composed joint dispatcher is wired", # dispatcher reaches the extractor, which proves the dispatcher was # invoked (rather than the previous stub error). qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = c("brain", "liver"), traits = c("ENSG_A", "ENSG_B") ) @@ -573,7 +573,7 @@ test_that("fineMappingPipeline(QtlDataset): composed joint dispatcher is wired", test_that("fineMappingPipeline(QtlDataset): composed joint rejects axes with 'study'", { qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = c("brain", "liver"), traits = "ENSG_A" ) @@ -590,7 +590,7 @@ test_that("fineMappingPipeline(QtlDataset): composed joint rejects axes with 'st test_that("fineMappingPipeline(QtlDataset): study-axis on individual data errors", { qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = c("brain", "liver"), traits = "ENSG_A" ) @@ -606,14 +606,14 @@ test_that("fineMappingPipeline(QtlDataset): study-axis on individual data errors }) test_that("fineMappingPipeline(QtlDataset): NULL jointSpec is the default", { - qd <- .js_makeQtlDataset(study = "A", contexts = "brain", traits = "ENSG_A") + qd <- .js_makeQtlDataset(studyName = "A", contexts = "brain", traits = "ENSG_A") expect_silent( pecotmr:::parseJointSpecification(NULL, qd) ) }) test_that("fineMappingPipeline(QtlDataset): invalid jointSpec errors before fit", { - qd <- .js_makeQtlDataset(study = "A") + qd <- .js_makeQtlDataset(studyName = "A") expect_error( fineMappingPipeline( qd, @@ -627,7 +627,7 @@ test_that("fineMappingPipeline(QtlDataset): invalid jointSpec errors before fit" test_that("twasWeightsPipeline(QtlDataset): cross-trait joint dispatcher is wired", { qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = "brain", traits = c("ENSG_A", "ENSG_B") ) @@ -644,7 +644,7 @@ test_that("twasWeightsPipeline(QtlDataset): cross-trait joint dispatcher is wire test_that("twasWeightsPipeline(QtlDataset): study-axis on individual data errors", { qd <- .js_makeQtlDataset( - study = "A", + studyName = "A", contexts = c("brain", "liver"), traits = "ENSG_A" ) @@ -735,31 +735,31 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -800,7 +800,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") gr } QtlSumStats( - study = rows$study, + studyName = rows$study, context = rows$context, trait = rows$trait, entry = map(seq_len(nrow(rows)), function(.) makeGr()), @@ -1108,7 +1108,7 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", } .jd_makeQtlDataset <- function( - study = "Q1", + studyName = "Q1", contexts = c("c1", "c2"), traits = c("t1", "t2") ) { @@ -1117,7 +1117,7 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", contexts ) QtlDataset( - study = study, + studyName = studyName, genotypes = .jd_makeHandle(), phenotypes = phen, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -1126,7 +1126,7 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' fits mr.mash per trait", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = c("c1", "c2"), traits = "t1" ) @@ -1151,7 +1151,7 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' fits mr.mash per test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' with only one context skips", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = "c1", traits = c("t1", "t2") ) @@ -1175,7 +1175,7 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' with only one co test_that("twasWeightsPipeline(QtlDataset): jointSpec='trait' fits mr.mash per context", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = "c1", traits = c("t1", "t2") ) @@ -1200,7 +1200,7 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec='trait' fits mr.mash per c test_that("twasWeightsPipeline(QtlDataset): study-axis fails on individual data", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = c("c1", "c2"), traits = "t1" ) @@ -1217,7 +1217,7 @@ test_that("twasWeightsPipeline(QtlDataset): study-axis fails on individual data" test_that("twasWeightsPipeline(QtlDataset): composed jointSpec axes=c('context','trait') fits", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = c("c1", "c2"), traits = c("t1", "t2") ) @@ -1242,7 +1242,7 @@ test_that("twasWeightsPipeline(QtlDataset): composed jointSpec axes=c('context', test_that("twasWeightsPipeline(QtlDataset): composed jointSpec including 'study' errors", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = c("c1", "c2"), traits = "t1" ) @@ -1376,7 +1376,7 @@ test_that(".sp* helpers: QtlSumStats study/context/trait listing + dataForm", { expect_setequal(pecotmr:::.spListContexts(ss), c("c1", "c2")) # study=NULL expect_setequal(pecotmr:::.spListContexts(ss, "A"), c("c1", "c2")) expect_setequal( - pecotmr:::.spListTraits(ss, study = "A", context = "c1"), + pecotmr:::.spListTraits(ss, studyName = "A", context = "c1"), c("t1", "t2") ) expect_equal(pecotmr:::.spStudyDataForm(ss, "A"), "sumstats") @@ -1387,13 +1387,13 @@ test_that(".sp* helpers: QtlSumStats study/context/trait listing + dataForm", { }) test_that(".spStudyDataForm: QtlDataset wrong study errors", { - qd <- .js_makeQtlDataset(study = "S1") + qd <- .js_makeQtlDataset(studyName = "S1") expect_error(pecotmr:::.spStudyDataForm(qd, "wrong"), "not in QtlDataset") }) test_that(".sp* helpers: MultiStudy per-study context/trait routing", { qd1 <- .js_makeQtlDataset( - study = "indA", + studyName = "indA", contexts = "brain", traits = c("g1", "g2") ) @@ -1407,9 +1407,9 @@ test_that(".sp* helpers: MultiStudy per-study context/trait routing", { expect_setequal(pecotmr:::.spListContexts(mt, "indA"), "brain") expect_setequal(pecotmr:::.spListContexts(mt), c("brain", "DLPFC")) # all expect_equal(pecotmr:::.spListContexts(mt, "nope"), character(0)) - expect_setequal(pecotmr:::.spListTraits(mt, study = "ssC"), "g3") # ss branch - expect_setequal(pecotmr:::.spListTraits(mt, study = "indA"), c("g1", "g2")) - expect_equal(pecotmr:::.spListTraits(mt, study = "nope"), character(0)) + expect_setequal(pecotmr:::.spListTraits(mt, studyName = "ssC"), "g3") # ss branch + expect_setequal(pecotmr:::.spListTraits(mt, studyName = "indA"), c("g1", "g2")) + expect_equal(pecotmr:::.spListTraits(mt, studyName = "nope"), character(0)) # study = NULL aggregates ALL traits across individual + sumstats components # (regression guard: a present sumStats slot must not shadow the QtlDatasets). expect_setequal(pecotmr:::.spListTraits(mt), c("g1", "g2", "g3")) @@ -1417,11 +1417,11 @@ test_that(".sp* helpers: MultiStudy per-study context/trait routing", { test_that(".spListTraits: study=NULL on a sumstats-free MultiStudy aggregates traits", { qdA <- .js_makeQtlDataset( - study = "indA", + studyName = "indA", contexts = "brain", traits = c("g1", "g2") ) - qdB <- .js_makeQtlDataset(study = "indB", contexts = "liver", traits = "g3") + qdB <- .js_makeQtlDataset(studyName = "indB", contexts = "liver", traits = "g3") mt <- MultiStudyQtlDataset(qtlDatasets = list(indA = qdA, indB = qdB)) expect_setequal(pecotmr:::.spListTraits(mt), c("g1", "g2", "g3")) # aggregate }) @@ -1469,7 +1469,7 @@ test_that("parseJointSpecification: malformed inputs error", { }) test_that("parseContexts: malformed inputs error", { - qd <- .js_makeQtlDataset(study = "S1", contexts = c("brain", "liver")) + qd <- .js_makeQtlDataset(studyName = "S1", contexts = c("brain", "liver")) expect_error(pecotmr:::parseContexts(character(0), qd), "non-empty") expect_error( pecotmr:::parseContexts(list(brain = "x"), qd), @@ -1484,7 +1484,7 @@ test_that("parseContexts: malformed inputs error", { }) test_that("parseContexts: vector form warns on contexts missing from a study", { - qd <- .js_makeQtlDataset(study = "S1", contexts = c("brain", "liver")) + qd <- .js_makeQtlDataset(studyName = "S1", contexts = c("brain", "liver")) expect_warning( out <- pecotmr:::parseContexts(c("brain", "absent"), qd), "missing requested context" @@ -1494,7 +1494,7 @@ test_that("parseContexts: vector form warns on contexts missing from a study", { test_that("parseTraitIds: malformed inputs error", { qd <- .js_makeQtlDataset( - study = "S1", + studyName = "S1", contexts = "brain", traits = c("ENSG1", "ENSG2") ) @@ -1534,7 +1534,7 @@ test_that("parseTraitIds: malformed inputs error", { # ----------------------------------------------------------------------------- test_that(".spWalkMethods: structural errors via parseMethods", { - qd <- .js_makeQtlDataset(study = "S1", contexts = "brain", traits = "ENSG1") + qd <- .js_makeQtlDataset(studyName = "S1", contexts = "brain", traits = "ENSG1") caps <- list(lasso = list(multivariate = FALSE)) walk <- function(m) { pecotmr:::parseMethods( @@ -1559,7 +1559,7 @@ test_that(".spWalkMethods: structural errors via parseMethods", { }) test_that("parseMethods: split-form and leaf validation errors", { - qd <- .js_makeQtlDataset(study = "S1", contexts = "brain", traits = "ENSG1") + qd <- .js_makeQtlDataset(studyName = "S1", contexts = "brain", traits = "ENSG1") caps <- list( lasso = list(multivariate = FALSE), mrmash = list(multivariate = TRUE) @@ -1637,7 +1637,7 @@ test_that("validateMethodsVsJointSpec: empty spec is a no-op; per-trait nesting test_that(".fmResolveSpecScope: scope + contexts + traitIds filters intersect", { qd <- .js_makeQtlDataset( - study = "S1", + studyName = "S1", contexts = c("brain", "liver"), traits = c("ENSG1", "ENSG2") ) @@ -1670,7 +1670,7 @@ test_that(".buildJointSumstatZMatrix: a mismatched SNP order across entries erro ) calls <- 0L local_mocked_bindings( - getSumStatsDf = function(x, study, context, trait, require, ...) { + as.data.frame = function(x, studyName, context, trait, require, ...) { calls <<- calls + 1L vid <- if (calls == 1L) { c("chr1:100:A:G", "chr1:200:A:G") @@ -1705,7 +1705,7 @@ test_that(".buildIndividualCrossContextXy: skips when a trait spans < 2 contexts se1 <- .js_makeSe(traits = "g1") # g1 present se0 <- .js_makeSe(traits = "other") # g1 absent local_mocked_bindings( - getPhenotypes = function(data, contexts) { + molecularTraits = function(data, contexts) { if (identical(contexts, "c1")) se1 else se0 }, .package = "pecotmr" @@ -1725,7 +1725,7 @@ test_that(".buildIndividualCrossContextXy: region path + complete-case skip", { samp <- paste0("s", 1:6) region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 10000)) local_mocked_bindings( - getPhenotypes = function(data, contexts) se, + molecularTraits = function(data, contexts) se, .fmResidGeno = function( x, contexts, @@ -1764,7 +1764,7 @@ test_that(".buildIndividualCrossContextXy: region path + complete-case skip", { test_that(".buildIndividualCrossContextXy: too few shared samples skips", { se <- .js_makeSe(traits = "g1", samples = paste0("s", 1:6)) local_mocked_bindings( - getPhenotypes = function(data, contexts) se, + molecularTraits = function(data, contexts) se, .fmResidGeno = function( x, contexts, @@ -1813,7 +1813,7 @@ test_that(".buildIndividualCrossTraitXy: skip branches (< 2 traits, region, comp samp <- paste0("s", 1:6) # < 2 scoped traits in the context -> NULL. local_mocked_bindings( - getPhenotypes = function(data, contexts) se2, + molecularTraits = function(data, contexts) se2, .package = "pecotmr" ) expect_null(suppressMessages(pecotmr:::.buildIndividualCrossTraitXy( @@ -1823,11 +1823,11 @@ test_that(".buildIndividualCrossTraitXy: skip branches (< 2 traits, region, comp cisWindow = 1000L, verbose = 1, label = "X", - study = "S" + studyName = "S" ))) # region path + < 2 complete cases. local_mocked_bindings( - getPhenotypes = function(data, contexts) se2, + molecularTraits = function(data, contexts) se2, .fmResidGeno = function( x, contexts, @@ -1856,7 +1856,7 @@ test_that(".buildIndividualCrossTraitXy: skip branches (< 2 traits, region, comp cisWindow = NULL, verbose = 1, label = "X", - study = "S", + studyName = "S", region = GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 9999)) ))) }) @@ -1867,7 +1867,7 @@ test_that(".buildComposedIndividualXy: skip branches and single-context wrap", { scope <- list(contexts = list(S = "c1"), traits = list(S = c("g1", "g2"))) # Single context: YresList wrap branch, then a valid 2-tuple build. local_mocked_bindings( - getPhenotypes = function(data, contexts) se, + molecularTraits = function(data, contexts) se, .fmResidGeno = function( x, contexts, @@ -1901,7 +1901,7 @@ test_that(".buildComposedIndividualXy: skip branches and single-context wrap", { # < 2 tuples -> NULL. scope1 <- list(contexts = list(S = "c1"), traits = list(S = "g1")) local_mocked_bindings( - getPhenotypes = function(data, contexts) { + molecularTraits = function(data, contexts) { .js_makeSe(traits = "g1") }, .package = "pecotmr" @@ -1976,7 +1976,7 @@ test_that(".fmSynthesizeJointSpec: trait wins over context; single/single -> emp test_that(".fmMergeResultsByKey: merges per-region entries by (s,c,t,method)", { mk <- function() { QtlFineMappingResult( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "mvsusie", @@ -1992,7 +1992,7 @@ test_that(".fmMergeResultsByKey: merges per-region entries by (s,c,t,method)", { expect_equal(nrow(out), 1L) # n == 0 short-circuit returns the (empty) base unchanged. empty <- QtlFineMappingResult( - study = character(0), + studyName = character(0), context = character(0), trait = character(0), method = character(0), @@ -2004,7 +2004,7 @@ test_that(".fmMergeResultsByKey: merges per-region entries by (s,c,t,method)", { test_that(".twasMergeResultsByKey: merges per-region TwasWeights entries", { mk <- function() { TwasWeights( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "lasso", @@ -2018,7 +2018,7 @@ test_that(".twasMergeResultsByKey: merges per-region TwasWeights entries", { expect_s4_class(out, "TwasWeights") expect_equal(nrow(out), 1L) empty <- TwasWeights( - study = character(0), + studyName = character(0), context = character(0), trait = character(0), method = character(0), @@ -2045,7 +2045,7 @@ test_that(".twasDispatchJointSpecsQtlDataset: two region blocks are merged by ke parsed <- list(list(axes = "context", scope = NULL)) mkRegionRes <- function() { TwasWeights( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("mrmash", "mrmash"), @@ -2068,7 +2068,7 @@ test_that(".twasDispatchJointSpecsQtlDataset: two region blocks are merged by ke contexts = NULL, traitIds = NULL, cisWindow = NULL, - dataType = NULL, + weightsDataType = NULL, verbose = 0, xRegions = list(r1, r2) ) @@ -2083,7 +2083,7 @@ test_that(".twasDispatchJointSpecsQtlDataset: two region blocks are merged by ke test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components, study spec to sumstats", { qd <- .js_makeQtlDataset( - study = "indA", + studyName = "indA", contexts = c("c1", "c2"), traits = "t1" ) @@ -2094,14 +2094,14 @@ test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components list(axes = "study", scope = NULL) ) qdRes <- QtlFineMappingResult( - study = "indA", + studyName = "indA", context = "c1", trait = "t1", method = "mvsusie", entry = list(.js_fmEntry()) ) ssRes <- QtlFineMappingResult( - study = "ssC", + studyName = "ssC", context = "c1", trait = "t1", method = "mvsusie", @@ -2121,7 +2121,7 @@ test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components traitIds = NULL, cisWindow = NULL, verbose = 1, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = 0.5, signalCutoff = 0.1, @@ -2134,12 +2134,12 @@ test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot messages", { qdA <- .js_makeQtlDataset( - study = "indA", + studyName = "indA", contexts = c("c1", "c2"), traits = "t1" ) qdB <- .js_makeQtlDataset( - study = "indB", + studyName = "indB", contexts = c("c1", "c2"), traits = "t1" ) @@ -2154,7 +2154,7 @@ test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot mes traitIds = NULL, cisWindow = NULL, verbose = 1, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = 0.5, signalCutoff = 0.1, @@ -2168,7 +2168,7 @@ test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot mes test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and rbinds", { qd <- .jd_makeQtlDataset( - study = "indA", + studyName = "indA", contexts = c("c1", "c2"), traits = "t1" ) @@ -2179,7 +2179,7 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r list(axes = "study", scope = NULL) ) qdRes <- TwasWeights( - study = "indA", + studyName = "indA", context = "c1", trait = "t1", method = "mrmash", @@ -2189,7 +2189,7 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r )) ) ssRes <- TwasWeights( - study = "ssC", + studyName = "ssC", context = "c1", trait = "t1", method = "mrmash", @@ -2211,7 +2211,7 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r contexts = NULL, traitIds = NULL, cisWindow = NULL, - dataType = NULL, + weightsDataType = NULL, verbose = 1 )) expect_s4_class(out, "TwasWeights") @@ -2220,12 +2220,12 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r test_that(".twasDispatchJointSpecsMultiStudy: study spec, no sumStats -> message + NULL", { qdA <- .jd_makeQtlDataset( - study = "indA", + studyName = "indA", contexts = c("c1", "c2"), traits = "t1" ) qdB <- .jd_makeQtlDataset( - study = "indB", + studyName = "indB", contexts = c("c1", "c2"), traits = "t1" ) @@ -2239,7 +2239,7 @@ test_that(".twasDispatchJointSpecsMultiStudy: study spec, no sumStats -> message contexts = NULL, traitIds = NULL, cisWindow = NULL, - dataType = NULL, + weightsDataType = NULL, verbose = 1 ), "no sumStats slot" @@ -2254,12 +2254,12 @@ test_that(".twasDispatchJointSpecsMultiStudy: study spec, no sumStats -> message test_that(".sp* QtlDataset: mismatched study / absent context return empty", { qd <- .js_makeQtlDataset( - study = "S1", + studyName = "S1", contexts = "brain", traits = c("g1", "g2") ) expect_equal(pecotmr:::.spListContexts(qd, "wrong"), character(0)) # 59 - expect_equal(pecotmr:::.spListTraits(qd, study = "wrong"), character(0)) # 93 + expect_equal(pecotmr:::.spListTraits(qd, studyName = "wrong"), character(0)) # 93 expect_equal(pecotmr:::.spListTraits(qd, context = "nope"), character(0)) # 98 }) @@ -2274,7 +2274,7 @@ test_that("validateMethodsVsJointSpec: per-study methods with a context joint pa test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip the context", { se <- .js_makeSe(traits = c("g1", "g2"), samples = paste0("s", 1:6)) local_mocked_bindings( - getPhenotypes = function(data, contexts) se, + molecularTraits = function(data, contexts) se, .fmResidGeno = function( x, contexts, @@ -2302,7 +2302,7 @@ test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip the context", cisWindow = 1000L, verbose = 1, label = "X", - study = "S" + studyName = "S" ))) # 730 }) @@ -2315,7 +2315,7 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA ) # (a) disjoint X samples -> < 2 common -> NULL (774). local_mocked_bindings( - getPhenotypes = function(data, contexts) se, + molecularTraits = function(data, contexts) se, .fmResidGeno = function( x, contexts, @@ -2356,7 +2356,7 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA ))) # 774 # (b) one context's Y lacks the trait column -> tuple skipped -> < 2 yCols (779/785). local_mocked_bindings( - getPhenotypes = function(data, contexts) se, + molecularTraits = function(data, contexts) se, .fmResidGeno = function( x, contexts, @@ -2390,7 +2390,7 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA ))) # 779/785 # (c) two valid columns but < 2 complete rows (NA) -> NULL (788). local_mocked_bindings( - getPhenotypes = function(data, contexts) se, + molecularTraits = function(data, contexts) se, .fmResidGeno = function( x, contexts, @@ -2436,14 +2436,14 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA test_that(".fmMergeResultsByKey: a key missing from a later region contributes nothing", { twoRow <- QtlFineMappingResult( - study = c("S", "S"), + studyName = c("S", "S"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("mvsusie", "mvsusie"), entry = list(.js_fmEntry("chr1:100:A:G"), .js_fmEntry("chr1:200:A:G")) ) oneRow <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "mvsusie", @@ -2464,7 +2464,7 @@ test_that(".fmMergeResultsByKey: a key missing from a later region contributes n test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = c("c1", "c2"), traits = "t1" ) @@ -2472,7 +2472,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { r2 <- GenomicRanges::GRanges("chr1", IRanges::IRanges(300, 500)) mkRes <- function() { QtlFineMappingResult( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("mvsusie", "mvsusie"), @@ -2496,7 +2496,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { cisWindow = NULL, verbose = 0, xRegions = list(r1, r2), - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = 0.5, signalCutoff = 0.1, @@ -2509,12 +2509,12 @@ test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; all-NULL -> NULL", { qd <- .jd_makeQtlDataset( - study = "Q1", + studyName = "Q1", contexts = c("c1", "c2"), traits = "t1" ) res1 <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "mvsusie", @@ -2532,7 +2532,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al traitIds = NULL, cisWindow = 1000L, verbose = 0, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = 0.5, signalCutoff = 0.1, @@ -2552,7 +2552,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al traitIds = NULL, cisWindow = 1000L, verbose = 0, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = 0.5, signalCutoff = 0.1, @@ -2563,7 +2563,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al test_that(".twasMergeResultsByKey: a key absent from a later region contributes nothing", { twoRow <- TwasWeights( - study = c("S", "S"), + studyName = c("S", "S"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("lasso", "lasso"), @@ -2573,7 +2573,7 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes ) ) oneRow <- TwasWeights( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "lasso", @@ -2610,7 +2610,7 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes seq_len(nrow(ss)), as.character(ss$context), "probe", - ldSketch = getLdSketch(ss), + ldSketch = ldSketch(ss), cutoffs = .panelCutoffs(PanelFilterParam(...)) )) } @@ -2640,7 +2640,7 @@ test_that(".buildJointSumstatZMatrix agrees with .panelVariantFilter", { expect_equal( length(.bjz_build(ss, mafCutoff = cut)$variantIds), length(.panelVariantFilter( - getLdSketch(ss), + ldSketch(ss), ids, PanelFilterParam(mafCutoff = cut) )), diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index c0ec411e..898c44c2 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -126,7 +126,7 @@ test_that("Check that we correctly retrieve the names from the matrix", { ) ) expect_equal( - unlist(getVariantIds(res)), + unlist(variantIds(res)), variants ) file.remove(LD_meta_file_path) @@ -153,7 +153,7 @@ test_that("Check that the LD block contains the correct information", { ) ) # Check LD Block 1 - ld_block_one <- getCorrelation(res) + ld_block_one <- ldMatrix(res) ld_block_one_original <- as.matrix( read_delim( "test_data/LD_block_1.chr1_1000_1200.float16.txt.xz", @@ -190,16 +190,16 @@ test_that("partitionLdMatrix correctly partitions a single block", { expect_equal(length(partitioned$ldMatrices), 1) expect_equal( nrow(partitioned$variantIndices), - length(getVariantIds(ld_data)) + length(variantIds(ld_data)) ) expect_equal(unique(partitioned$variantIndices$blockId), 1) expect_identical( rownames(partitioned$ldMatrices[[1]]), - getVariantIds(ld_data) + variantIds(ld_data) ) expect_identical( colnames(partitioned$ldMatrices[[1]]), - getVariantIds(ld_data) + variantIds(ld_data) ) file.remove(LD_meta_file_path) @@ -229,7 +229,7 @@ test_that("partitionLdMatrix correctly partitions multiple blocks", { # Check if all variants are assigned to blocks expect_equal( nrow(partitioned$variantIndices), - length(getVariantIds(ld_data)) + length(variantIds(ld_data)) ) # Check if block IDs are correct @@ -271,14 +271,14 @@ test_that("partitionLdMatrix properly merges small blocks", { # Check if all variants are still assigned to blocks expect_equal( nrow(partitioned$variantIndices), - length(getVariantIds(ld_data)) + length(variantIds(ld_data)) ) # Check if merged blocks are larger than min_block_size block_sizes <- map_int(partitioned$ldMatrices, nrow) expect_true(all( block_sizes >= min_block_size | - block_sizes == length(getVariantIds(ld_data)) + block_sizes == length(variantIds(ld_data)) )) file.remove(LD_meta_file_path) @@ -351,9 +351,9 @@ test_that("partitionLdMatrix validates block structure properly", { ld_data <- loadLdMatrix(LD_meta_file_path, region) # Create an invalid block structure by modifying blockMetadata - bm <- getBlockMetadata(ld_data) - vids <- getVariantIds(ld_data) - ldmat <- getCorrelation(ld_data) + bm <- blockMetadata(ld_data) + vids <- variantIds(ld_data) + ldmat <- ldMatrix(ld_data) # Assuming we have at least 2 blocks: if (length(bm) >= 2) { @@ -375,10 +375,10 @@ test_that("partitionLdMatrix validates block structure properly", { # Rebuild LdData with modified matrix and block metadata invalid_ld_data <- new( "LdData", - getVariantInfo(ld_data), + variantInfo(ld_data), correlation = ldmat, genotypeHandle = NULL, - snpIdx = getSnpIdx(ld_data), + snpIdx = snpIdx(ld_data), blockMetadata = bm ) @@ -439,14 +439,14 @@ test_that("partitionLdMatrix handles row/column name mismatches", { ld_data <- loadLdMatrix(LD_meta_file_path, region) # Create an LdData with mismatched rownames and colnames on the correlation matrix - ldmat <- getCorrelation(ld_data) - vids <- getVariantIds(ld_data) + ldmat <- ldMatrix(ld_data) + vids <- variantIds(ld_data) rownames(ldmat) <- NULL colnames(ldmat) <- NULL mismatched_ld_data <- LdData( correlation = ldmat, - variants = getVariantInfo(ld_data), - blockMetadata = getBlockMetadata(ld_data) + variants = variantInfo(ld_data), + blockMetadata = blockMetadata(ld_data) ) # Should not error and should fix the names @@ -455,11 +455,11 @@ test_that("partitionLdMatrix handles row/column name mismatches", { # Check if names are fixed expect_identical( rownames(partitioned$ldMatrices[[1]]), - getVariantIds(ld_data) + variantIds(ld_data) ) expect_identical( colnames(partitioned$ldMatrices[[1]]), - getVariantIds(ld_data) + variantIds(ld_data) ) file.remove(LD_meta_file_path) @@ -482,8 +482,8 @@ test_that("partitionLdMatrix correctly extracts blocks based on metadata", { partitioned <- partitionLdMatrix(ld_data, mergeSmallBlocks = FALSE) # For each block, check if the extracted matrix matches the expected submatrix - ld_variants <- getVariantIds(ld_data) - ld_matrix <- getCorrelation(ld_data) + ld_variants <- variantIds(ld_data) + ld_matrix <- ldMatrix(ld_data) for (i in seq_along(partitioned$ldMatrices)) { block_info <- partitioned$blockMetadata[i, ] startIdx <- block_info$startIdx @@ -1425,19 +1425,19 @@ test_that("loadLdFromGenotype returns LD matrix with .afreq", { plink_prefix <- file.path(geno_test_data_dir, "test_variants") result <- pecotmr:::loadLdFromGenotype(plink_prefix, geno_region_all) expect_true(is(result, "LdData")) - expect_true(is.matrix(getCorrelation(result))) - expect_equal(nrow(getCorrelation(result)), 349L) - expect_true(isSymmetric(getCorrelation(result))) + expect_true(is.matrix(ldMatrix(result))) + expect_equal(nrow(ldMatrix(result)), 349L) + expect_true(isSymmetric(ldMatrix(result))) expect_false(hasGenotypes(result)) # ref_panel should have allele_freq from .afreq file expect_true( - "allele_freq" %in% names(S4Vectors::mcols(getVariantInfo(result))) + "allele_freq" %in% names(S4Vectors::mcols(variantInfo(result))) ) - expect_true(all(S4Vectors::mcols(getVariantInfo(result))$allele_freq > 0)) - expect_true(all(S4Vectors::mcols(getVariantInfo(result))$allele_freq < 1)) + expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq > 0)) + expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq < 1)) # blockMetadata - expect_true(is(getBlockMetadata(result), "GRanges")) - expect_equal(length(getBlockMetadata(result)), 1L) + expect_true(is(blockMetadata(result), "GRanges")) + expect_equal(length(blockMetadata(result)), 1L) }) test_that("loadLdFromGenotype returns genotype matrix when requested", { @@ -1449,7 +1449,7 @@ test_that("loadLdFromGenotype returns genotype matrix when requested", { returnGenotype = TRUE ) expect_true(hasGenotypes(result)) - X <- getGenotypes(result) + X <- genotypes(result) expect_equal(nrow(X), 100L) # samples expect_equal(ncol(X), 349L) # variants }) @@ -1462,10 +1462,10 @@ test_that("loadLdFromGenotype computes variance with n_sample", { geno_region_all, nSample = 100L ) - expect_true("variance" %in% names(S4Vectors::mcols(getVariantInfo(result)))) - expect_true("n_nomiss" %in% names(S4Vectors::mcols(getVariantInfo(result)))) - expect_equal(S4Vectors::mcols(getVariantInfo(result))$n_nomiss[1], 100L) - expect_true(all(S4Vectors::mcols(getVariantInfo(result))$variance > 0)) + expect_true("variance" %in% names(S4Vectors::mcols(variantInfo(result)))) + expect_true("n_nomiss" %in% names(S4Vectors::mcols(variantInfo(result)))) + expect_equal(S4Vectors::mcols(variantInfo(result))$n_nomiss[1], 100L) + expect_true(all(S4Vectors::mcols(variantInfo(result))$variance > 0)) }) test_that("loadLdFromGenotype falls back to computed AF without .afreq", { @@ -1474,15 +1474,15 @@ test_that("loadLdFromGenotype falls back to computed AF without .afreq", { result <- suppressWarnings( pecotmr:::loadLdFromGenotype(vcf_path, geno_region_all) ) - expect_true(is.matrix(getCorrelation(result))) - expect_equal(nrow(getCorrelation(result)), 349L) - expect_true(isSymmetric(getCorrelation(result))) + expect_true(is.matrix(ldMatrix(result))) + expect_equal(nrow(ldMatrix(result)), 349L) + expect_true(isSymmetric(ldMatrix(result))) # Allele frequencies computed from genotypes expect_true( - "allele_freq" %in% names(S4Vectors::mcols(getVariantInfo(result))) + "allele_freq" %in% names(S4Vectors::mcols(variantInfo(result))) ) - expect_true(all(S4Vectors::mcols(getVariantInfo(result))$allele_freq > 0)) - expect_true(all(S4Vectors::mcols(getVariantInfo(result))$allele_freq < 1)) + expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq > 0)) + expect_true(all(S4Vectors::mcols(variantInfo(result))$allele_freq < 1)) }) test_that("loadLdFromGenotype works with GDS files", { @@ -1490,9 +1490,9 @@ test_that("loadLdFromGenotype works with GDS files", { skip_if_not_installed("gdsfmt") gds_path <- file.path(geno_test_data_dir, "test_variants.gds") result <- pecotmr:::loadLdFromGenotype(gds_path, geno_region_all) - expect_true(is.matrix(getCorrelation(result))) - expect_equal(nrow(getCorrelation(result)), 349L) - expect_true(isSymmetric(getCorrelation(result))) + expect_true(is.matrix(ldMatrix(result))) + expect_equal(nrow(ldMatrix(result)), 349L) + expect_true(isSymmetric(ldMatrix(result))) }) test_that("loadLdFromGenotype .afreq and computed AF are consistent", { @@ -1506,8 +1506,8 @@ test_that("loadLdFromGenotype .afreq and computed AF are consistent", { # Allele frequencies should be close (same data, different source) expect_true( max(abs( - S4Vectors::mcols(getVariantInfo(res_afreq))$allele_freq - - S4Vectors::mcols(getVariantInfo(res_computed))$allele_freq + S4Vectors::mcols(variantInfo(res_afreq))$allele_freq - + S4Vectors::mcols(variantInfo(res_computed))$allele_freq )) < 0.01 ) @@ -1529,8 +1529,8 @@ test_that("loadLdMatrix dispatches to PLINK2 genotype source", { append = TRUE ) result <- loadLdMatrix(meta_file, geno_region_all) - expect_true(is.matrix(getCorrelation(result))) - expect_equal(nrow(getCorrelation(result)), 349L) + expect_true(is.matrix(ldMatrix(result))) + expect_equal(nrow(ldMatrix(result)), 349L) expect_false(hasGenotypes(result)) }) @@ -1546,8 +1546,8 @@ test_that("loadLdMatrix dispatches to VCF genotype source", { append = TRUE ) result <- suppressWarnings(loadLdMatrix(meta_file, geno_region_all)) - expect_true(is.matrix(getCorrelation(result))) - expect_equal(nrow(getCorrelation(result)), 349L) + expect_true(is.matrix(ldMatrix(result))) + expect_equal(nrow(ldMatrix(result)), 349L) }) test_that("loadLdMatrix dispatches to GDS genotype source", { @@ -1563,8 +1563,8 @@ test_that("loadLdMatrix dispatches to GDS genotype source", { append = TRUE ) result <- loadLdMatrix(meta_file, geno_region_all) - expect_true(is.matrix(getCorrelation(result))) - expect_equal(nrow(getCorrelation(result)), 349L) + expect_true(is.matrix(ldMatrix(result))) + expect_equal(nrow(ldMatrix(result)), 349L) }) test_that("loadLdMatrix return_genotype='auto' returns X for genotype source", { @@ -1580,7 +1580,7 @@ test_that("loadLdMatrix return_genotype='auto' returns X for genotype source", { ) result <- loadLdMatrix(meta_file, geno_region_all, returnGenotype = "auto") expect_true(hasGenotypes(result)) - X <- getGenotypes(result) + X <- genotypes(result) expect_equal(nrow(X), 100L) # samples expect_equal(ncol(X), 349L) # variants }) @@ -1649,16 +1649,16 @@ test_that("loadLdMatrix loads single precomputed block", { append = TRUE ) result <- loadLdMatrix(meta_file, "chr1:1000-1190") - expect_true(is.matrix(getCorrelation(result))) - expect_equal(nrow(getCorrelation(result)), 5L) - expect_true(isSymmetric(getCorrelation(result))) - expect_equal(length(getVariantIds(result)), 5L) - expect_true(all(grepl("^chr1:", getVariantIds(result)))) + expect_true(is.matrix(ldMatrix(result))) + expect_equal(nrow(ldMatrix(result)), 5L) + expect_true(isSymmetric(ldMatrix(result))) + expect_equal(length(variantIds(result)), 5L) + expect_true(all(grepl("^chr1:", variantIds(result)))) expect_false(hasGenotypes(result)) # blockMetadata should have one block - expect_equal(length(getBlockMetadata(result)), 1L) + expect_equal(length(blockMetadata(result)), 1L) # ref_panel (now GRanges) should have variant info via mcols - ref_mcols <- S4Vectors::mcols(getVariantInfo(result)) + ref_mcols <- S4Vectors::mcols(variantInfo(result)) expect_true("variant_id" %in% names(ref_mcols)) }) @@ -1691,11 +1691,11 @@ test_that("loadLdMatrix loads multiple precomputed blocks", { ) writeLines(lines, meta_file) result <- loadLdMatrix(meta_file, "chr1:1000-1500") - expect_true(is.matrix(getCorrelation(result))) + expect_true(is.matrix(ldMatrix(result))) # 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(length(getBlockMetadata(result)) >= 2) + expect_true(nrow(ldMatrix(result)) >= 10) + expect_true(isSymmetric(ldMatrix(result))) + expect_true(length(blockMetadata(result)) >= 2) }) test_that("loadLdMatrix with n_sample for precomputed blocks with freq data", { @@ -1719,7 +1719,7 @@ test_that("loadLdMatrix with n_sample for precomputed blocks with freq data", { ) result <- loadLdMatrix(meta_file, "chr1:1000-1190", nSample = 500L) # ref_panel (GRanges) should always have basic variant info in mcols - ref_mcols <- S4Vectors::mcols(getVariantInfo(result)) + ref_mcols <- S4Vectors::mcols(variantInfo(result)) expect_true(all(c("A2", "A1", "variant_id") %in% names(ref_mcols))) # 6-col bim lacks allele_freq so variance computation is skipped expect_false("variance" %in% names(ref_mcols)) @@ -1815,7 +1815,7 @@ test_that("loadLdMatrix propagates allele_freq/variance/n_nomiss from 9-col bim" ) result <- loadLdMatrix(meta_file, "chr1:1000-1190") # ref_panel (GRanges) should carry the extra columns from the 9-col bim - ref_mcols <- S4Vectors::mcols(getVariantInfo(result)) + ref_mcols <- S4Vectors::mcols(variantInfo(result)) expect_true("allele_freq" %in% names(ref_mcols)) expect_true("variance" %in% names(ref_mcols)) expect_true("n_nomiss" %in% names(ref_mcols)) @@ -1824,10 +1824,10 @@ test_that("loadLdMatrix propagates allele_freq/variance/n_nomiss from 9-col bim" }) # =========================================================================== -# getRegionalLdMeta: real .cor.xz fixtures +# regionalLdMeta: real .cor.xz fixtures # =========================================================================== -test_that("getRegionalLdMeta returns correct file paths for single block", { +test_that("regionalLdMeta returns correct file paths for single block", { meta_file <- file.path( geno_test_data_dir, "ld_meta_regional_single_tmp.tsv" @@ -1851,7 +1851,7 @@ test_that("getRegionalLdMeta returns correct file paths for single block", { ) ) writeLines(lines, meta_file) - result <- pecotmr:::getRegionalLdMeta(meta_file, "chr1:1050-1150") + result <- pecotmr:::regionalLdMeta(meta_file, "chr1:1050-1150") expect_true(is.list(result)) expect_true(length(result$intersections$LD_file_paths) >= 1) # All returned paths should exist @@ -1859,7 +1859,7 @@ test_that("getRegionalLdMeta returns correct file paths for single block", { expect_true(all(file.exists(result$intersections$bimFilePaths))) }) -test_that("getRegionalLdMeta spans multiple blocks for wide region", { +test_that("regionalLdMeta spans multiple blocks for wide region", { meta_file <- file.path(geno_test_data_dir, "ld_meta_regional_multi_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) lines <- c( @@ -1887,7 +1887,7 @@ test_that("getRegionalLdMeta spans multiple blocks for wide region", { ) ) writeLines(lines, meta_file) - result <- pecotmr:::getRegionalLdMeta(meta_file, "chr1:1000-1500") + result <- pecotmr:::regionalLdMeta(meta_file, "chr1:1000-1500") expect_true(length(result$intersections$LD_file_paths) >= 2) }) @@ -2875,7 +2875,7 @@ test_that("computeLd with shrinkage > 0", { # ============================================================================= -# Additional coverage: findIntersectionRows / getRegionalLdMeta edge cases +# Additional coverage: findIntersectionRows / regionalLdMeta edge cases # ============================================================================= test_that("findIntersectionRows errors when region falls in a coverage gap", { @@ -2888,7 +2888,7 @@ test_that("findIntersectionRows errors when region falls in a coverage gap", { ) }) -test_that("getRegionalLdMeta handles whole-chromosome 0:0 sentinel rows", { +test_that("regionalLdMeta handles whole-chromosome 0:0 sentinel rows", { meta_file <- file.path(geno_test_data_dir, "ld_meta_wholechrom_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) @@ -2904,14 +2904,14 @@ test_that("getRegionalLdMeta handles whole-chromosome 0:0 sentinel rows", { file = meta_file, append = TRUE ) - result <- pecotmr:::getRegionalLdMeta(meta_file, "chr1:1000-1190") + result <- pecotmr:::regionalLdMeta(meta_file, "chr1:1000-1190") expect_true(length(result$intersections$LD_file_paths) >= 1) expect_true(all(file.exists(result$intersections$LD_file_paths))) # 0:0 sentinel row should have had its end set to Inf internally (line 103) expect_true(is.infinite(max(result$ldMetaData$end))) }) -test_that("getRegionalLdMeta validates complete coverage when required", { +test_that("regionalLdMeta validates complete coverage when required", { meta_file <- file.path(geno_test_data_dir, "ld_meta_complete_tmp.tsv") on.exit(unlink(meta_file), add = TRUE) lines <- c( @@ -2926,7 +2926,7 @@ test_that("getRegionalLdMeta validates complete coverage when required", { ) writeLines(lines, meta_file) # Region fully inside block 1 -> validateSelectedRegion passes (line 122) - result <- pecotmr:::getRegionalLdMeta( + result <- pecotmr:::regionalLdMeta( meta_file, "chr1:1050-1150", completeCoverageRequired = TRUE @@ -3076,10 +3076,10 @@ test_that("loadLdMatrix removes duplicate variants from the backend result", { .package = "pecotmr" ) result <- loadLdMatrix(meta_file, "chr1:100-200") - ids <- getVariantIds(result) + ids <- variantIds(result) expect_equal(length(ids), 2L) expect_false(any(duplicated(ids))) - expect_equal(dim(getCorrelation(result)), c(2L, 2L)) + expect_equal(dim(ldMatrix(result)), c(2L, 2L)) }) # ============================================================================= @@ -3132,7 +3132,7 @@ test_that(".ldFromSketch drops variants absent from the panel when onMissing='dr file.path(geno_test_data_dir, "test_variants"), format = "plink2" ) - si <- getSnpInfo(h) + si <- snpInfo(h) ids <- c(as.character(si$SNP[1]), "bogus:999:A:G", as.character(si$SNP[3])) m <- pecotmr:::.ldFromSketch(h, ids, onMissing = "drop") expect_equal(dim(m), c(2L, 2L)) @@ -3153,7 +3153,7 @@ test_that(".ldFromSketch resolves chr-prefixed request ids against a non-prefixe file.path(geno_test_data_dir, "test_variants"), format = "plink2" ) - pid <- as.character(getSnpInfo(h)$SNP) # chr-prefixed (chr21_..._C_G) + pid <- as.character(snpInfo(h)$SNP) # chr-prefixed (chr21_..._C_G) h@snpInfo$SNP <- sub("^chr", "", pid) # panel now lacks the prefix m <- pecotmr:::.ldFromSketch(h, pid[1:3]) # request keeps the prefix expect_equal(dim(m), c(3L, 3L)) @@ -3167,7 +3167,7 @@ test_that(".ldFromSketch resolves non-prefixed request ids against a chr-prefixe file.path(geno_test_data_dir, "test_variants"), format = "plink2" ) - pid <- as.character(getSnpInfo(h)$SNP) + pid <- as.character(snpInfo(h)$SNP) req <- sub("^chr", "", pid[1:3]) # request drops the prefix m <- pecotmr:::.ldFromSketch(h, req) expect_equal(dim(m), c(3L, 3L)) @@ -3180,7 +3180,7 @@ test_that(".ldFromSketch is unchanged when request and panel share a convention" file.path(geno_test_data_dir, "test_variants"), format = "plink2" ) - pid <- as.character(getSnpInfo(h)$SNP) + pid <- as.character(snpInfo(h)$SNP) m <- pecotmr:::.ldFromSketch(h, pid[1:3]) expect_equal(dim(m), c(3L, 3L)) expect_equal(rownames(m), pid[1:3]) @@ -3192,7 +3192,7 @@ test_that(".ldFromSketch still errors on a genuinely-absent variant after reconc file.path(geno_test_data_dir, "test_variants"), format = "plink2" ) - pid <- as.character(getSnpInfo(h)$SNP) + pid <- as.character(snpInfo(h)$SNP) # request the prefix-stripped form (forces reconciliation) plus one truly-absent variant req <- c(sub("^chr", "", pid[1]), "21_99999999_A_G") expect_error( @@ -3237,36 +3237,36 @@ test_that(".ldFromSketch rejects an ldSketch that is not a genotype panel", { .lds_mockExtractor <- function(seed = 7, nSamples = 30L) { function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) - nSnp <- nrow(getSnpInfo(handle)) + nSnp <- nrow(snpInfo(handle)) panel <- matrix( rbinom(nSamples * nSnp, 2, 0.3), nrow = nSamples, ncol = nSnp, - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) rr <- GenomicRanges::GRanges( - seqnames = str_c("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = str_c("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) dosage <- t(panel[, snpIdx, drop = FALSE]) dimnames(dosage) <- list( - getSnpInfo(handle)$SNP[snpIdx], - getSampleIds(handle) + snpInfo(handle)$SNP[snpIdx], + sampleIds(handle) ) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, colData = S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) ) } @@ -3354,17 +3354,17 @@ test_that(".requireMatchingLdSketches errors on swapped alleles", { file.path(geno_test_data_dir, "test_variants"), format = "plink2" ) - si <- getSnpInfo(h) + si <- snpInfo(h) si2 <- si si2$A1[1] <- si$A2[1] # swap the coding of one shared variant si2$A2[1] <- si$A1[1] h2 <- new( "GenotypeHandle", - path = getPath(h), - format = getFormat(h), + path = path(h), + format = genotypeFormat(h), snpInfo = si2, - nSamples = getNSamples(h), - sampleIds = getSampleIds(h), + nSamples = nSamples(h), + sampleIds = sampleIds(h), pgenPtr = NULL, chromPaths = character(0) ) @@ -3534,7 +3534,7 @@ test_that("loadLdFromBlocks drops empty blocks and keeps non-empty ones", { result <- pecotmr:::loadLdFromBlocks(meta_file, "chr1:1180-1260"), "Removing 1 empty LD block" ) - ids <- getVariantIds(result) + ids <- variantIds(result) expect_true(length(ids) >= 1) expect_true(all(grepl("^chr1:12", ids))) }) @@ -3591,7 +3591,7 @@ test_that("loadLdFromBlocks derives variance from allele_freq + nSample when var ) result <- loadLdMatrix(meta_file, "chr1:1000-1190", nSample = 500L) - ref_mcols <- S4Vectors::mcols(getVariantInfo(result)) + ref_mcols <- S4Vectors::mcols(variantInfo(result)) expect_true("variance" %in% names(ref_mcols)) expect_true(all(!is.na(ref_mcols$variance))) expect_true(all(ref_mcols$variance > 0)) @@ -4122,16 +4122,16 @@ test_that(".panelVariantStats reports NA MAF for an all-missing variant", { test_that(".panelVariantFilter is a no-op at its defaults", { data(qtlDatasetExample) - gh <- getGenotypes(qtlDatasetExample) - handle <- getGenotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(getSnpInfo(handle)$SNP) + gh <- genotypes(qtlDatasetExample) + handle <- genotypeHandle(qtlDatasetExample) + ids <- normalizeVariantId(snpInfo(handle)$SNP) expect_identical(.panelVariantFilter(handle, ids), ids) }) test_that(".panelVariantFilter drops panel-rare variants", { data(qtlDatasetExample) - handle <- getGenotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(getSnpInfo(handle)$SNP) + handle <- genotypeHandle(qtlDatasetExample) + ids <- normalizeVariantId(snpInfo(handle)$SNP) loose <- .panelVariantFilter( handle, ids, @@ -4151,9 +4151,9 @@ test_that(".panelVariantFilter drops panel-rare variants", { test_that(".panelVariantFilter treats MAC as a MAF equivalent", { data(qtlDatasetExample) - handle <- getGenotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(getSnpInfo(handle)$SNP) - nSamp <- getNSamples(handle) + handle <- genotypeHandle(qtlDatasetExample) + ids <- normalizeVariantId(snpInfo(handle)$SNP) + nSamp <- nSamples(handle) # macCutoff / (2 * nSamples) is the same threshold as mafCutoff. byMac <- .panelVariantFilter( handle, @@ -4179,8 +4179,8 @@ test_that(".panelVariantFilter treats MAC as a MAF equivalent", { test_that(".panelVariantFilter drops high-missingness variants", { data(qtlDatasetExample) - handle <- getGenotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(getSnpInfo(handle)$SNP) + handle <- genotypeHandle(qtlDatasetExample) + ids <- normalizeVariantId(snpInfo(handle)$SNP) strict <- .panelVariantFilter( handle, ids, @@ -4199,8 +4199,8 @@ test_that(".panelVariantFilter passes through ids absent from the panel", { # .ldFromSketch's `onMissing`; deciding it here too would let the two # disagree about the same variant. data(qtlDatasetExample) - handle <- getGenotypeHandle(qtlDatasetExample) - ids <- normalizeVariantId(getSnpInfo(handle)$SNP)[1:3] + handle <- genotypeHandle(qtlDatasetExample) + ids <- normalizeVariantId(snpInfo(handle)$SNP)[1:3] withGhost <- c("chr9:999:A:G", ids) expect_true(is_in( "chr9:999:A:G", @@ -4214,7 +4214,7 @@ test_that(".panelVariantFilter passes through ids absent from the panel", { test_that(".panelVariantFilter handles empty and NULL input", { data(qtlDatasetExample) - handle <- getGenotypeHandle(qtlDatasetExample) + handle <- genotypeHandle(qtlDatasetExample) expect_length( .panelVariantFilter( handle, @@ -4271,7 +4271,7 @@ test_that(".panelCutoffs short-circuits when no cutoff is set", { test_that(".panelAfreqMaf reads panel MAF from the .afreq sidecar", { skip_if_not_installed("pgenlibr") handle <- .pvfAfreqHandle() - ids <- as.character(getSnpInfo(handle)$SNP) + ids <- as.character(snpInfo(handle)$SNP) maf <- .panelAfreqMaf(handle, ids) afreq <- readAfreq(test_path("test_data/test_variants")) altFreq <- afreq$alt_freq[match(ids, afreq$id)] @@ -4281,7 +4281,7 @@ test_that(".panelAfreqMaf reads panel MAF from the .afreq sidecar", { test_that(".panelAfreqMaf refuses a partial or non-plink2 sidecar", { skip_if_not_installed("pgenlibr") handle <- .pvfAfreqHandle() - ids <- as.character(getSnpInfo(handle)$SNP) + ids <- as.character(snpInfo(handle)$SNP) # One id the sidecar cannot answer for is enough: a partial answer would # disagree with the dosage path about that variant, so NULL sends the # caller down the dosage path for all of them. @@ -4290,13 +4290,13 @@ test_that(".panelAfreqMaf refuses a partial or non-plink2 sidecar", { test_path("test_data/test_variants"), format = "plink1" ) - expect_null(.panelAfreqMaf(bed, as.character(getSnpInfo(bed)$SNP))) + expect_null(.panelAfreqMaf(bed, as.character(snpInfo(bed)$SNP))) }) test_that(".panelVariantFilter: .afreq and dosage agree on what to drop", { skip_if_not_installed("pgenlibr") handle <- .pvfAfreqHandle() - ids <- as.character(getSnpInfo(handle)$SNP) + ids <- as.character(snpInfo(handle)$SNP) viaAfreq <- .panelVariantFilter( handle, ids, @@ -4321,7 +4321,7 @@ test_that(".panelVariantFilter uses dosage whenever missingness is capped", { # Missingness is not derivable from the sidecar, so an imissCutoff must # never be silently answered by it. handle <- .pvfAfreqHandle() - ids <- as.character(getSnpInfo(handle)$SNP) + ids <- as.character(snpInfo(handle)$SNP) local_mocked_bindings( .panelAfreqMaf = function(handle, variantIds) { abort("the .afreq fast path must not run here") @@ -4348,11 +4348,11 @@ test_that(".panelAfreqPrefixes reads only the chromosomes the panel spans", { # read -- the cost per-chromosome sketch trimming exists to avoid. sharded <- handle sharded@chromPaths <- c( - "22" = getPath(handle), + "22" = path(handle), "21" = "/nonexistent/chr21" ) - sharded@snpInfo$CHR <- rep("22", nrow(getSnpInfo(handle))) - expect_identical(.panelAfreqPrefixes(sharded), getPath(handle)) + sharded@snpInfo$CHR <- rep("22", nrow(snpInfo(handle))) + expect_identical(.panelAfreqPrefixes(sharded), path(handle)) }) @@ -4379,9 +4379,9 @@ test_that("loadLdMatrix requires exactly one addressing mode", { test_that("loadLdMatrix loads an in-memory correlation matrix by block", { R1 <- matrix(c(1, 0.3, 0.3, 1), 2, 2) R2 <- matrix(c(1, 0.8, 0.8, 1), 2, 2) - expect_equal(unname(getCorrelation(loadLdMatrix(R1, block = 1))), R1) + expect_equal(unname(ldMatrix(loadLdMatrix(R1, block = 1))), R1) expect_equal( - unname(getCorrelation(loadLdMatrix(list(R1, R2), block = 2))), + unname(ldMatrix(loadLdMatrix(list(R1, R2), block = 2))), R2 ) }) @@ -4398,10 +4398,10 @@ test_that("loadLdMatrix subsamples oversized blocks reproducibly", { diag(R) <- 1 small <- loadLdMatrix(R, block = 1, maxVariants = 5, seed = 42) expect_equal(length(small), 5L) - expect_equal(dim(getCorrelation(small)), c(5L, 5L)) + expect_equal(dim(ldMatrix(small)), c(5L, 5L)) # Same seed, same draw. again <- loadLdMatrix(R, block = 1, maxVariants = 5, seed = 42) - expect_equal(getVariantIds(small), getVariantIds(again)) + expect_equal(variantIds(small), variantIds(again)) # A cap above the block size is a no-op. expect_equal(length(loadLdMatrix(R, block = 1, maxVariants = 100)), 10L) }) @@ -4454,9 +4454,9 @@ test_that("loadLdMatrix can materialize genotypes onto the object", { materializeGenotypes = TRUE ) # Same data; the difference is whether later access re-reads the file. - expect_s4_class(getGenotypeHandle(lazy), "GenotypeHandle") - expect_true(is.matrix(getGenotypeHandle(eager))) - expect_equal(getGenotypes(lazy), getGenotypes(eager)) + expect_s4_class(genotypeHandle(lazy), "GenotypeHandle") + expect_true(is.matrix(genotypeHandle(eager))) + expect_equal(genotypes(lazy), genotypes(eager)) }) test_that("loadLdMatrix can drop monomorphic variants", { @@ -4477,7 +4477,7 @@ test_that("loadLdMatrix can drop monomorphic variants", { # This panel has no monomorphic variants, so the filter is a no-op here; # what matters is that it does not drop polymorphic ones. expect_lte(length(kept), length(full)) - af <- getRefPanel(kept)$allele_freq + af <- refPanel(kept)$allele_freq expect_true(all(af > 0 & af < 1)) }) @@ -4489,7 +4489,7 @@ test_that("loadLdMatrix can drop monomorphic variants", { # ctwas's whole-panel assembler, RAiSS's coordinate window, and the bare # accessors. They used to disagree on what a bad sketch looked like -- the # shared path said so plainly while the others surfaced "unable to find an -# inherited method for 'getSnpInfo'" from whichever accessor touched it +# inherited method for 'snpInfo'" from whichever accessor touched it # first. The guard now sits at `.ldSketchRanges()` / `.ldSketchDosage()`, the # two primitives everything funnels through. # ============================================================================= @@ -4504,7 +4504,7 @@ test_that("every panel access route rejects a NULL sketch the same way", { shared = function() { pecotmr:::.ldFromSketch(NULL, "chr22:1:A:G", label = "demo") }, - ctwas = function() pecotmr:::.ctwasComputeFullPanelLd(NULL), + ctwas = function() pecotmr:::.ctwasPanelFor(NULL), raiss = function() pecotmr:::.qcRaissWindowIdx(df, NULL, 0L), matchIds = function() pecotmr:::.ldSketchMatchIds(NULL), dosage = function() pecotmr:::.ldSketchDosage(NULL, 1L), @@ -4521,7 +4521,7 @@ test_that("a non-panel sketch is rejected by every route", { "must be a genotype panel" ) expect_error( - pecotmr:::.ctwasComputeFullPanelLd("not a panel"), + pecotmr:::.ctwasPanelFor("not a panel"), "must be a genotype panel" ) expect_error( @@ -4538,7 +4538,7 @@ test_that("callers that validate first keep their own label", { ) expect_match(shared, "^fineMappingPipeline:") ctwas <- tryCatch( - pecotmr:::.ctwasComputeFullPanelLd(NULL), + pecotmr:::.ctwasPanelFor(NULL), error = conditionMessage ) expect_match(ctwas, "^ctwasPipeline:") @@ -4640,8 +4640,8 @@ test_that("emptying a sketch clears both axes", { pgenPtr = NULL ) e <- pecotmr:::.emptySketch(h) - expect_equal(nrow(pecotmr:::getSnpInfo(e)), 0L) - expect_equal(length(pecotmr:::getSampleIds(e)), 0L) + expect_equal(nrow(pecotmr:::snpInfo(e)), 0L) + expect_equal(length(pecotmr:::sampleIds(e)), 0L) }) test_that("a missing or malformed afreq sidecar degrades to no frequencies", { @@ -4735,7 +4735,7 @@ test_that("subsetting an LdData narrows the correlation on both axes", { ld <- pecotmr:::.ldDataFromMatrix(R, isGenotype = FALSE) out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) expect_equal(length(out), 2L) - expect_equal(dim(getCorrelation(out)), c(2L, 2L)) + expect_equal(dim(ldMatrix(out)), c(2L, 2L)) }) # --------------------------------------------------------------------------- @@ -4779,7 +4779,7 @@ test_that("subsetting an LdData narrows the correlation on both axes", { } test_that(".loadLdDedup passes through when there are no variant ids", { - # A GRanges with no variant_id column: getVariantIds() is NULL, so there + # A GRanges with no variant_id column: variantIds() is NULL, so there # is nothing to deduplicate against. bare <- GenomicRanges::GRanges( "chr1", @@ -4790,7 +4790,7 @@ test_that(".loadLdDedup passes through when there are no variant ids", { variants = bare, blockMetadata = .ldcov_bm(3L) ) - expect_null(getVariantIds(ld)) + expect_null(variantIds(ld)) expect_identical(pecotmr:::.loadLdDedup(ld), ld) }) @@ -4814,7 +4814,7 @@ test_that(".ldApplyMonomorphic needs an allele_freq column to act", { ) # No frequencies to judge monomorphism by, so the request is a no-op # rather than an error -- distinct from the all-polymorphic case. - expect_false(is_in("allele_freq", colnames(getRefPanel(ld)))) + expect_false(is_in("allele_freq", colnames(refPanel(ld)))) expect_identical(pecotmr:::.ldApplyMonomorphic(ld, TRUE), ld) }) @@ -4826,8 +4826,8 @@ test_that(".ldApplyMonomorphic drops monomorphic variants", { blockMetadata = .ldcov_bm(3L) ) out <- pecotmr:::.ldApplyMonomorphic(ld, TRUE) - expect_equal(getVariantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) - expect_equal(dim(getCorrelation(out)), c(2L, 2L)) + expect_equal(variantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) + expect_equal(dim(ldMatrix(out)), c(2L, 2L)) }) test_that(".ldApplyMaterialize leaves a mixture list alone", { @@ -4841,9 +4841,9 @@ test_that(".ldApplyMaterialize leaves a mixture list alone", { variants = .ldcov_gr(v), blockMetadata = .ldcov_bm(3L) ) - # getGenotypes() on a mixture returns a LIST of dosage matrices; there is + # genotypes() on a mixture returns a LIST of dosage matrices; there is # no single matrix to fold into the object. - expect_false(is.matrix(getGenotypes(ld))) + expect_false(is.matrix(genotypes(ld))) expect_identical(pecotmr:::.ldApplyMaterialize(ld, TRUE), ld) }) @@ -4858,8 +4858,8 @@ test_that(".ldSubsetData narrows a dosage matrix by column", { blockMetadata = .ldcov_bm(3L) ) out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) - expect_equal(dim(pecotmr:::getGenotypeHandle(out)), c(4L, 2L)) - expect_equal(getVariantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) + expect_equal(dim(pecotmr:::genotypeHandle(out)), c(4L, 2L)) + expect_equal(variantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) }) test_that(".ldSubsetData narrows a handle through snpIdx", { @@ -4874,8 +4874,8 @@ test_that(".ldSubsetData narrows a handle through snpIdx", { out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) # The handle is untouched; snpIdx selects into its full snpInfo, so # subsetting picks positions 1 and 3 OF THE INDEX, not of the file. - expect_equal(pecotmr:::getSnpIdx(out), c(5L, 7L)) - expect_equal(getVariantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) + expect_equal(pecotmr:::snpIdx(out), c(5L, 7L)) + expect_equal(variantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) }) test_that(".ldSketchMatchIds returns bare ids when alleles are absent", { @@ -5041,9 +5041,9 @@ test_that("computeLd(onDisk) defaults to every variant in the panel", { format = "gds" ) R <- computeLd(handle, backend = "snprelate", onDisk = TRUE) - n <- nrow(pecotmr:::getSnpInfo(handle)) + n <- nrow(pecotmr:::snpInfo(handle)) expect_equal(dim(R), c(n, n)) - expect_identical(rownames(R), pecotmr:::getSnpInfo(handle)$SNP) + expect_identical(rownames(R), pecotmr:::snpInfo(handle)$SNP) }) test_that("computeLd(onDisk) applies shrinkage toward the identity", { @@ -5099,14 +5099,14 @@ test_that(".ldInfoBlock reads a block with an explicit SNP_file", { # Both ldInfo sources return an LdData, so the post-load chain does not # have to branch on which kind of LD_file it was given. expect_s4_class(out, "LdData") - expect_equal(dim(getCorrelation(out)), c(5L, 5L)) + expect_equal(dim(ldMatrix(out)), c(5L, 5L)) expect_equal( - head(getVariantIds(out), 3L), + head(variantIds(out), 3L), c("chr1:1000:A:G", "chr1:1040:A:G", "chr1:1080:A:G") ) # The .bim coordinates are carried through rather than replaced with the # chrNA:1..n placeholders a bare matrix would get. - refPanel <- getRefPanel(out) + refPanel <- refPanel(out) expect_equal(as.character(refPanel$chrom[[1L]]), "chr1") expect_equal(as.integer(refPanel$pos[[1L]]), 1000L) }) @@ -5127,8 +5127,8 @@ test_that("loadLdMatrix reads an ldInfo table of precomputed LD", { # materialize) runs against a precomputed block, not just a genotype one. out <- loadLdMatrix(info, block = 1L) expect_s4_class(out, "LdData") - expect_equal(length(getVariantIds(out)), 5L) - expect_equal(unname(diag(getCorrelation(out))), rep(1, 5L)) + expect_equal(length(variantIds(out)), 5L) + expect_equal(unname(diag(ldMatrix(out))), rep(1, 5L)) }) test_that(".ldInfoBlock auto-detects the variant file beside the matrix", { @@ -5165,7 +5165,7 @@ test_that(".ldInfoBlock auto-detects the variant file beside the matrix", { ) expect_identical(auto, explicit) expect_s4_class(auto, "LdData") - expect_equal(dim(getCorrelation(auto)), c(5L, 5L)) + expect_equal(dim(ldMatrix(auto)), c(5L, 5L)) }) test_that(".ldInfoBlock requires an LD_file column", { @@ -5183,11 +5183,11 @@ test_that(".panelAfreqMaf returns NULL when no sidecar exists at all", { test_path("test_data/test_variants_chr22"), format = "plink2" ) - expect_equal(pecotmr:::getFormat(handle), "plink2") + expect_equal(pecotmr:::genotypeFormat(handle), "plink2") expect_null( pecotmr:::.panelAfreqMaf( handle, - as.character(pecotmr:::getSnpInfo(handle)$SNP) + as.character(pecotmr:::snpInfo(handle)$SNP) ) ) }) diff --git a/tests/testthat/test_ldData.R b/tests/testthat/test_ldData.R index ef8b7994..d59377d0 100644 --- a/tests/testthat/test_ldData.R +++ b/tests/testthat/test_ldData.R @@ -61,31 +61,31 @@ context("LdData accessors") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -95,20 +95,20 @@ context("LdData accessors") } # =========================================================================== -# getCorrelation +# ldMatrix # =========================================================================== -test_that("getCorrelation: returns the stored correlation matrix when set", { +test_that("ldMatrix: returns the stored correlation matrix when set", { R <- diag(4) ld <- LdData( correlation = R, variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1) ) - expect_identical(getCorrelation(ld), R) + expect_identical(ldMatrix(ld), R) }) -test_that("getCorrelation: computes from a single GenotypeHandle via extractBlockGenotypes", { +test_that("ldMatrix: computes from a single GenotypeHandle via extractBlockGenotypes", { ld <- LdData( correlation = NULL, genotypeHandle = .ld_makeHandle(), @@ -120,18 +120,18 @@ test_that("getCorrelation: computes from a single GenotypeHandle via extractBloc extractBlockGenotypes = .ld_mockExtractor(seed = 7), .package = "pecotmr" ) - R <- getCorrelation(ld) + R <- ldMatrix(ld) expect_true(is.matrix(R)) expect_equal(dim(R), c(4L, 4L)) expect_equal(unname(diag(R)), c(1, 1, 1, 1), tolerance = 1e-12) }) -# NB: The "neither correlation nor genotypeHandle" branch in getCorrelation +# NB: The "neither correlation nor genotypeHandle" branch in ldMatrix # is defensive — LdData validity rejects that state at construction time, so # the only way to hit the runtime stop() is to mutate the slot post-hoc. # Skipping that test in favor of paths the validity actually permits. -test_that("getCorrelation: mixture handles produce a weighted-average R", { +test_that("ldMatrix: mixture handles produce a weighted-average R", { gh1 <- .ld_makeHandle(path = "/tmp/h1.gds") gh2 <- .ld_makeHandle(path = "/tmp/h2.gds") ld <- LdData( @@ -156,7 +156,7 @@ test_that("getCorrelation: mixture handles produce a weighted-average R", { }, .package = "pecotmr" ) - R_mix <- getCorrelation(ld) + R_mix <- ldMatrix(ld) expect_equal(dim(R_mix), c(4L, 4L)) # Recompute per-panel R independently and check weighted-average property. call_n <- 0 @@ -180,7 +180,7 @@ test_that("getCorrelation: mixture handles produce a weighted-average R", { expect_equal(R_mix, expected, tolerance = 1e-12) }) -test_that("getCorrelation: mixture handles without mixtureWeights errors", { +test_that("ldMatrix: mixture handles without mixtureWeights errors", { gh <- .ld_makeHandle() # Build via new() to skip the constructor's mixtureWeights validity check. ld <- new( @@ -190,16 +190,16 @@ test_that("getCorrelation: mixture handles without mixtureWeights errors", { genotypeHandle = list(gh, gh), snpIdx = 1:4, blockMetadata = .ld_makeBlockMetadata(), - nRef = 0L, + nSamples = 0L, mixtureWeights = NULL ) expect_error( - getCorrelation(ld), + ldMatrix(ld), "Cannot compute mixture LD: `mixtureWeights` is NULL" ) }) -test_that("getCorrelation: mixture panels of differing dim error", { +test_that("ldMatrix: mixture panels of differing dim error", { gh_small <- .ld_makeHandle(snp_n = 3L) gh <- .ld_makeHandle(snp_n = 4L) ld <- new( @@ -209,7 +209,7 @@ test_that("getCorrelation: mixture panels of differing dim error", { genotypeHandle = list(gh_small, gh), snpIdx = 1:3, blockMetadata = .ld_makeBlockMetadata(), - nRef = 0L, + nSamples = 0L, mixtureWeights = c(0.5, 0.5) ) # The first call sees snpIdx 1:3 against gh_small (3 variants); the second @@ -230,25 +230,25 @@ test_that("getCorrelation: mixture panels of differing dim error", { .package = "pecotmr" ) expect_error( - getCorrelation(ld), + ldMatrix(ld), "panels yielded LD matrices of differing dimensions" ) }) # =========================================================================== -# getGenotypes +# genotypes # =========================================================================== -test_that("getGenotypes: NULL handle returns NULL", { +test_that("genotypes: NULL handle returns NULL", { ld <- LdData( correlation = diag(4), variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1) ) - expect_null(getGenotypes(ld)) + expect_null(genotypes(ld)) }) -test_that("getGenotypes: matrix handle is returned unchanged", { +test_that("genotypes: matrix handle is returned unchanged", { X <- matrix( 0, nrow = 10, @@ -262,13 +262,13 @@ test_that("getGenotypes: matrix handle is returned unchanged", { genotypeHandle = X, snpIdx = NULL, blockMetadata = .ld_makeBlockMetadata(), - nRef = 0L, + nSamples = 0L, mixtureWeights = NULL ) - expect_identical(getGenotypes(ld), X) + expect_identical(genotypes(ld), X) }) -test_that("getGenotypes: single handle returns samples x variants dosage", { +test_that("genotypes: single handle returns samples x variants dosage", { ld <- LdData( correlation = NULL, genotypeHandle = .ld_makeHandle(), @@ -280,12 +280,12 @@ test_that("getGenotypes: single handle returns samples x variants dosage", { extractBlockGenotypes = .ld_mockExtractor(seed = 7), .package = "pecotmr" ) - G <- getGenotypes(ld) + G <- genotypes(ld) expect_equal(dim(G), c(30L, 4L)) expect_equal(colnames(G), sprintf("chr1:%d:A:G", 100L * (1:4))) }) -test_that("getGenotypes: list of handles returns a list of dosage matrices", { +test_that("genotypes: list of handles returns a list of dosage matrices", { gh1 <- .ld_makeHandle(path = "/tmp/h1.gds") gh2 <- .ld_makeHandle(path = "/tmp/h2.gds") ld <- LdData( @@ -308,7 +308,7 @@ test_that("getGenotypes: list of handles returns a list of dosage matrices", { }, .package = "pecotmr" ) - G <- getGenotypes(ld) + G <- genotypes(ld) expect_true(is.list(G)) expect_equal(length(G), 2L) expect_equal(dim(G[[1L]]), c(30L, 4L)) @@ -336,23 +336,23 @@ test_that("hasGenotypes: TRUE when handle present, FALSE otherwise", { expect_true(hasGenotypes(ld_gh)) }) -test_that("getVariantIds returns the variant_id mcol", { +test_that("variantIds returns the variant_id mcol", { ld <- LdData( correlation = diag(4), variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1) ) - expect_equal(getVariantIds(ld), sprintf("chr1:%d:A:G", 100L * (1:4))) + expect_equal(variantIds(ld), sprintf("chr1:%d:A:G", 100L * (1:4))) }) -test_that("getVariantInfo returns the variants verbatim", { +test_that("variantInfo 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(variantInfo(ld), vars) # blockMetadata is NOT verbatim: the constructor normalises it to the # columns consumers read. A column the caller added is carried through. - got <- getBlockMetadata(ld) + got <- blockMetadata(ld) expect_s4_class(got, "GRanges") expect_true(all( c("blockId", "size", "startIdx", "endIdx") %in% @@ -361,13 +361,13 @@ test_that("getVariantInfo returns the variants verbatim", { expect_equal(got$region, "chr1:100-400") }) -test_that("getRefPanel: assembles the chrom/pos/A1/A2/variant_id data.frame", { +test_that("refPanel: assembles the chrom/pos/A1/A2/variant_id data.frame", { ld <- LdData( correlation = diag(4), variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1) ) - rp <- getRefPanel(ld) + rp <- refPanel(ld) expect_s3_class(rp, "data.frame") expect_setequal(colnames(rp), c("A1", "A2", "variant_id", "chrom", "pos")) expect_equal(rp$variant_id, sprintf("chr1:%d:A:G", 100L * (1:4))) @@ -403,10 +403,10 @@ test_that("LdData constructor works with correlation matrix", { ld <- LdData(correlation = R, variants = gr, blockMetadata = bm) expect_s4_class(ld, "LdData") 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(length(getBlockMetadata(ld)), 1L) - expect_null(getGenotypes(ld)) + expect_true(is.matrix(ldMatrix(ld))) + expect_equal(variantIds(ld), c("chr1:100:A:G", "chr1:200:C:T")) + expect_equal(length(blockMetadata(ld)), 1L) + expect_null(genotypes(ld)) }) @@ -475,7 +475,7 @@ test_that("LdData supports block-diagonal correlation", { variants = gr, blockMetadata = data.frame() ) - corr <- getCorrelation(ld) + corr <- ldMatrix(ld) expect_true(is.list(corr)) expect_equal(length(corr), 2) }) @@ -497,10 +497,10 @@ test_that("LdData S4 accessors return correct data", { variants = gr, blockMetadata = data.frame(blockId = 1L) ) - expect_equal(getCorrelation(ld), R) - expect_equal(getVariantIds(ld), c("chr1:100:A:G", "chr1:200:A:G")) + expect_equal(ldMatrix(ld), R) + expect_equal(variantIds(ld), c("chr1:100:A:G", "chr1:200:A:G")) expect_false(hasGenotypes(ld)) - rp <- getRefPanel(ld) + rp <- refPanel(ld) expect_true(is.data.frame(rp)) expect_true("variant_id" %in% names(rp)) expect_equal(rp$variant_id, c("chr1:100:A:G", "chr1:200:A:G")) @@ -527,12 +527,12 @@ test_that(".refPanelToGranges builds GRanges from data.frame", { expect_equal(S4Vectors::mcols(gr)$allele_freq, c(0.3, 0.7)) }) # ============================================================================= -# getTopLoci(type = "GRanges") +# topLoci() ranges # ============================================================================= # === Tests migrated from test_s4Constructors.R (LdData) === -test_that("LdData: pre-computed correlation matrix is returned by getCorrelation", { +test_that("LdData: pre-computed correlation matrix is returned by ldMatrix", { gr <- GenomicRanges::GRanges( seqnames = rep("chr1", 3), ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) @@ -549,10 +549,10 @@ test_that("LdData: pre-computed correlation matrix is returned by getCorrelation snpIdx = NULL, variants = gr, blockMetadata = block_meta, - nRef = 100L + nSamples = 100L ) expect_s4_class(ld, "LdData") - expect_equal(getCorrelation(ld), R) + expect_equal(ldMatrix(ld), R) }) @@ -656,10 +656,10 @@ test_that("LdData: mixtureWeights must be non-negative and sum to 1", { # =========================================================================== -# getGenotypeHandle / getMixtureWeights / getSnpIdx accessors +# genotypeHandle / mixtureWeights / snpIdx accessors # =========================================================================== -test_that("LdData: getGenotypeHandle / getMixtureWeights / getSnpIdx return their slots", { +test_that("LdData: genotypeHandle / mixtureWeights / snpIdx return their slots", { gh1 <- .ld_makeHandle(path = "/tmp/h1.gds") gh2 <- .ld_makeHandle(path = "/tmp/h2.gds") ld <- LdData( @@ -670,12 +670,12 @@ test_that("LdData: getGenotypeHandle / getMixtureWeights / getSnpIdx return thei blockMetadata = S4Vectors::DataFrame(x = 1), mixtureWeights = c(0.3, 0.7) ) - expect_identical(getGenotypeHandle(ld), list(gh1, gh2)) - expect_equal(getMixtureWeights(ld), c(0.3, 0.7)) - expect_equal(getSnpIdx(ld), 1:4) + expect_identical(genotypeHandle(ld), list(gh1, gh2)) + expect_equal(mixtureWeights(ld), c(0.3, 0.7)) + expect_equal(snpIdx(ld), 1:4) }) -test_that("getCorrelation: errors when neither correlation nor genotypeHandle is set", { +test_that("ldMatrix: errors when neither correlation nor genotypeHandle is set", { # LdData validity forbids this state at construction, so build a valid # object and drop the correlation slot post-hoc to reach the defensive # runtime stop(). @@ -686,7 +686,7 @@ test_that("getCorrelation: errors when neither correlation nor genotypeHandle is ) ld@correlation <- NULL expect_error( - getCorrelation(ld), + ldMatrix(ld), "No correlation matrix or genotype handle available" ) }) @@ -695,11 +695,11 @@ test_that("getCorrelation: errors when neither correlation nor genotypeHandle is # genotypeHandle: what the slot admits # =========================================================================== -test_that("getCorrelation works when the source is a dosage matrix", { +test_that("ldMatrix works when the source is a dosage matrix", { # .loadLdFromBlocks stores extracted, filtered dosages in genotypeHandle - # with snpIdx NULL (the matrix IS the subset). getGenotypes() always had a - # branch for that shape; getCorrelation() did not, and died inside the - # file readers with a dispatch error on getSampleIds(). + # with snpIdx NULL (the matrix IS the subset). genotypes() always had a + # branch for that shape; ldMatrix() did not, and died inside the + # file readers with a dispatch error on sampleIds(). set.seed(3) X <- matrix( rbinom(40, 2, 0.3), @@ -713,9 +713,9 @@ test_that("getCorrelation works when the source is a dosage matrix", { snpIdx = NULL, variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1), - nRef = 10L + nSamples = 10L ) - R <- getCorrelation(ld) + R <- ldMatrix(ld) expect_equal(dim(R), c(4L, 4L)) expect_equal(unname(R), unname(cor(X)), tolerance = 1e-8) }) @@ -726,7 +726,7 @@ test_that("the genotypeHandle slot refuses a source LD cannot be read from", { snpIdx = NULL, variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1), - nRef = 0L + nSamples = 0L ) for (bad in list("a path", 42L, sum)) { expect_error( @@ -744,7 +744,7 @@ test_that("a mixture list must hold sources, not arbitrary values", { snpIdx = 1:4, variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1), - nRef = 0L, + nSamples = 0L, mixtureWeights = c(0.5, 0.5) ), "must each be a genotype panel or a dosage matrix" @@ -765,10 +765,10 @@ test_that("the constructor unwraps a genotype panel to its handle", { snpIdx = 1:4, variants = .ld_makeVariants(), blockMetadata = S4Vectors::DataFrame(x = 1), - nRef = 0L + nSamples = 0L ) - expect_s4_class(getGenotypeHandle(ld), "GenotypeHandle") - expect_equal(dim(getCorrelation(ld)), c(4L, 4L)) + expect_s4_class(genotypeHandle(ld), "GenotypeHandle") + expect_equal(dim(ldMatrix(ld)), c(4L, 4L)) }) test_that("a DelayedMatrix is refused with the panel route named", { @@ -811,7 +811,7 @@ test_that("snpIdx accepts doubles and stores them as integer", { genotypeHandle = .ld_makeHandle(), snpIdx = c(1, 2, 3, 4) ) - expect_identical(getSnpIdx(ld), 1:4) + expect_identical(snpIdx(ld), 1:4) }) test_that("correlation takes a matrix, a per-block list, or NULL", { @@ -919,7 +919,7 @@ test_that("blockMetadata: a bare genomic span is completed from variants", { end = 400L ) ) - bm <- getBlockMetadata(ld) + bm <- blockMetadata(ld) expect_s4_class(bm, "GRanges") expect_true(all(.ld_bmMcols %in% names(S4Vectors::mcols(bm)))) expect_equal(length(bm), 1L) @@ -939,7 +939,7 @@ test_that("blockMetadata: a placeholder table means one block, not none", { variants = .ld_makeVariants(), blockMetadata = data.frame() ) - bm <- getBlockMetadata(ld) + bm <- blockMetadata(ld) expect_equal(length(bm), 1L) expect_true(all(.ld_bmMcols %in% names(S4Vectors::mcols(bm)))) expect_equal(bm$size, 4L) @@ -963,7 +963,7 @@ test_that("blockMetadata: a GRanges keeps its mcols over its ranges", { variants = .ld_makeVariants(), blockMetadata = gr ) - bm <- getBlockMetadata(ld) + bm <- blockMetadata(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. @@ -979,7 +979,7 @@ test_that("blockMetadata: several blocks take their ranges from size", { variants = .ld_makeVariants(), blockMetadata = tibble(blockId = 1:2, size = c(3L, 1L)) ) - bm <- getBlockMetadata(ld) + bm <- blockMetadata(ld) expect_equal(bm$startIdx, c(1L, 4L)) expect_equal(bm$endIdx, c(3L, 4L)) expect_equal( @@ -1023,7 +1023,7 @@ test_that("blockMetadata: supplied indices are never replaced", { endIdx = 20L ) ) - bm <- getBlockMetadata(ld) + bm <- blockMetadata(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 @@ -1038,7 +1038,7 @@ test_that("blockMetadata: a caller's own columns are carried through", { variants = .ld_makeVariants(), blockMetadata = tibble(region = "chr1:100-400", note = "kept") ) - bm <- getBlockMetadata(ld) + bm <- blockMetadata(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 diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index bf271b0c..7c4772da 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -122,7 +122,7 @@ test_that(".reconcileScalar resolves arg/column and flags conflicts", { test_that(".detectGenotypeFormat builds a PLINK1 handle from a prefix", { h <- pecotmr:::.detectGenotypeFormat(.toyRefPrefix()) expect_s4_class(h, "GenotypeHandle") - expect_equal(getFormat(h), "plink1") + expect_equal(genotypeFormat(h), "plink1") }) test_that("BCF sumstats are rejected", { @@ -191,13 +191,13 @@ test_that("loadGwasSumStatsFromManifest builds from a data.frame manifest", { expect_s4_class(obj, "GwasSumStats") expect_true(methods::validObject(obj)) expect_equal(as.character(obj$study), "study1") - expect_equal(getGenome(obj), "hg38") + expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") expect_equal(length(obj[[1L]]), 5L) expect_true(all( c("SNP", "A1", "A2", "Z", "N") %in% colnames(S4Vectors::mcols(obj[[1L]])) )) - expect_equal(length(getQcInfo(obj)), 0L) # loaders run no QC + expect_equal(length(qcInfo(obj)), 0L) # loaders run no QC }) test_that("loadGwasSumStatsFromManifest reads a file and reconciles genome", { @@ -219,7 +219,7 @@ test_that("loadGwasSumStatsFromManifest reads a file and reconciles genome", { genome = "hg38", ldSketch = .toyLdSketch() ) - expect_equal(getGenome(obj), "hg38") + expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") # conflicting arg errors. expect_error( loadGwasSumStatsFromManifest( @@ -748,8 +748,8 @@ test_that("loadQtlDatasetFromManifest builds a single-study dataset", { qd <- loadQtlDatasetFromManifest(manifest) expect_s4_class(qd, "QtlDataset") expect_true(methods::validObject(qd)) - expect_equal(getStudy(qd), "studyX") - expect_equal(getContexts(qd), "ctxA") + expect_equal(studyName(qd), "studyX") + expect_equal(contexts(qd), "ctxA") }) test_that("loadQtlDatasetFromManifest accepts study/genotypes as arguments", { @@ -762,10 +762,10 @@ test_that("loadQtlDatasetFromManifest accepts study/genotypes as arguments", { ) qd <- loadQtlDatasetFromManifest( manifest, - study = "studyY", + studyName = "studyY", genotypes = .toyLdSketch() ) - expect_equal(getStudy(qd), "studyY") + expect_equal(studyName(qd), "studyY") }) # --------------------------------------------------------------------------- @@ -786,7 +786,7 @@ test_that("loadMultiStudyQtlDatasetFromManifest builds from >=2 studies", { msd <- loadMultiStudyQtlDatasetFromManifest(manifest) expect_s4_class(msd, "MultiStudyQtlDataset") expect_true(methods::validObject(msd)) - expect_equal(sort(names(getQtlDatasets(msd))), c("study1", "study2")) + expect_equal(sort(names(qtlDatasets(msd))), c("study1", "study2")) }) test_that("loadMultiStudyQtlDatasetFromManifest attaches a summary study", { @@ -815,7 +815,7 @@ test_that("loadMultiStudyQtlDatasetFromManifest attaches a summary study", { ) expect_true(methods::validObject(msd)) expect_s4_class(msd@sumStats, "QtlSumStats") - expect_equal(names(getQtlDatasets(msd)), "study1") + expect_equal(names(qtlDatasets(msd)), "study1") }) # =========================================================================== @@ -879,13 +879,13 @@ test_that(".detectGenotypeFormat dispatches by extension", { "Could not determine genotype format" ) h <- pecotmr:::.detectGenotypeFormat(paste0(.toyRefPrefix(), ".bed")) - expect_equal(getFormat(h), "plink1") + expect_equal(genotypeFormat(h), "plink1") }) test_that(".resolveLdSketch accepts a genoMeta vector or path, rejects junk", { sharded <- pecotmr:::.resolveLdSketch(c("22" = .toyRefPrefix())) expect_s4_class(sharded, "GenotypeHandle") - expect_true("22" %in% names(getChromPaths(sharded))) + expect_true("22" %in% names(chromPaths(sharded))) expect_s4_class( pecotmr:::.resolveLdSketch(.toyRefPrefix()), "GenotypeHandle" @@ -934,7 +934,7 @@ test_that(".materializeLdSketch passes a handle through, restricts shards", { spec <- c("22" = .toyRefPrefix(), "21" = "/no/such/chr21/prefix") restricted <- pecotmr:::.materializeLdSketch(spec, "22") expect_s4_class(restricted, "GenotypeHandle") - expect_equal(names(getChromPaths(restricted)), "22") + expect_equal(names(chromPaths(restricted)), "22") expect_error(pecotmr:::.materializeLdSketch(spec, c("22", "21"))) }) @@ -1151,8 +1151,8 @@ test_that("loadQtlDatasetFromManifest attaches context/genotype covariates", { stringsAsFactors = FALSE ) qd <- loadQtlDatasetFromManifest(manifest) - expect_equal(ncol(getPhenotypeCovariates(qd, "ctx")[["ctx"]]), 3L) - expect_equal(ncol(getGenotypeCovariates(qd)), 2L) + expect_equal(ncol(phenotypeCovariates(qd, "ctx")[["ctx"]]), 3L) + expect_equal(ncol(genotypeCovariates(qd)), 2L) }) test_that("loadQtlDatasetFromManifest reads transposed (QTLtools) covariates", { @@ -1174,7 +1174,7 @@ test_that("loadQtlDatasetFromManifest reads transposed (QTLtools) covariates", { stringsAsFactors = FALSE ) qd <- loadQtlDatasetFromManifest(manifest, transposeCovariates = TRUE) - expect_equal(ncol(getPhenotypeCovariates(qd, "ctx")[["ctx"]]), 4L) + expect_equal(ncol(phenotypeCovariates(qd, "ctx")[["ctx"]]), 4L) }) test_that("loadQtlDatasetFromManifest accepts a prefix and matrix covariates", { @@ -1193,7 +1193,7 @@ test_that("loadQtlDatasetFromManifest accepts a prefix and matrix covariates", { genotypes = .toyRefPrefix(), genotypeCovariates = gmat ) - expect_equal(ncol(getGenotypeCovariates(qd)), 2L) + expect_equal(ncol(genotypeCovariates(qd)), 2L) }) test_that("QtlDataset builder errors on inconsistent per-context paths", { @@ -1553,7 +1553,7 @@ test_that("genotypeCovariates accepts a path string", { stringsAsFactors = FALSE ) qd <- loadQtlDatasetFromManifest(manifest, genotypeCovariates = gcov) - expect_equal(ncol(getGenotypeCovariates(qd)), 2L) + expect_equal(ncol(genotypeCovariates(qd)), 2L) }) test_that("QtlSumStats manifest resolves a per-row columnMapping", { @@ -1771,14 +1771,14 @@ test_that("manifest loaders guard the QtlDataset pass-through arguments", { expect_error( loadQtlDatasetFromManifest( data.frame(), - genotypeFilterArgs = GenotypeFilterParam(mafCutoff = -1) + genotypeFilterParam = GenotypeFilterParam(mafCutoff = -1) ), "mafCutoff.*is not >= 0" ) expect_error( loadQtlDatasetFromManifest( data.frame(), - genotypeFilterArgs = GenotypeFilterParam(keepIndel = NA) + genotypeFilterParam = GenotypeFilterParam(keepIndel = NA) ), "keepIndel.*May not be NA" ) @@ -1786,7 +1786,7 @@ test_that("manifest loaders guard the QtlDataset pass-through arguments", { expect_error( loadQtlDatasetFromManifest( data.frame(), - genotypeFilterArgs = list(mafCutoff = 0.01) + genotypeFilterParam = list(mafCutoff = 0.01) ), "must be built with GenotypeFilterParam" ) @@ -1798,8 +1798,8 @@ test_that("manifest loaders guard the QtlDataset pass-through arguments", { "scaleResiduals.*Must have length 1" ) expect_error( - loadQtlDatasetFromManifest(data.frame(), study = 1L), - "study.*Must be of type 'string'" + loadQtlDatasetFromManifest(data.frame(), studyName = 1L), + "studyName.*Must be of type 'string'" ) expect_error( loadMultiStudyQtlDatasetFromManifest( @@ -1811,7 +1811,7 @@ test_that("manifest loaders guard the QtlDataset pass-through arguments", { expect_error( loadMultiStudyQtlDatasetFromManifest( data.frame(), - genotypeFilterArgs = GenotypeFilterParam(xvarCutoff = -1) + genotypeFilterParam = GenotypeFilterParam(xvarCutoff = -1) ), "xvarCutoff.*is not >= 0" ) diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index 3daf8df2..36387d83 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -43,7 +43,7 @@ gr }) QtlSumStats( - study = rep("s1", length(contexts)), + studyName = rep("s1", length(contexts)), context = contexts, trait = rep("g1", length(contexts)), entry = entries, @@ -134,7 +134,7 @@ topLoci = mkTL(c(-0.4, 0.7, 0.1, 5.0, -1.2, 0.6), c(4, 5)) ) QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("brain", "blood"), trait = c("t1", "t1"), method = c("susie", "susie"), @@ -3003,7 +3003,7 @@ test_that(".mashSumStatsToMatrices: inputScale='z' errors when Z missing", { test_that(".mashObjectMatrices errors when marginal effects lack the required columns", { res <- QtlFineMappingResult( - study = "s", + studyName = "s", context = "brain", trait = "t", method = "susie", @@ -3012,7 +3012,7 @@ test_that(".mashObjectMatrices errors when marginal effects lack the required co # 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, ...) { + marginalEffects = function(x, ...) { data.frame(variant_id = "v", beta = 1, se = 1) }, .package = "pecotmr" @@ -3029,7 +3029,7 @@ test_that(".mashObjectMatrices errors when marginal effects lack the required co test_that(".mashObjectMatrices warns and pins the first method on a multi-method result", { res <- QtlFineMappingResult( - study = c("s", "s"), + studyName = c("s", "s"), context = c("brain", "liver"), trait = c("t", "t"), method = c("susie", "mvsusie"), @@ -3155,7 +3155,7 @@ test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=10 } # ctx1 has all 5 variants; ctx2 has only the first 3 ss <- QtlSumStats( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("ctx1", "ctx2"), trait = c("g1", "g1"), entry = list( @@ -3216,7 +3216,7 @@ test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) # 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"), + studyName = c("s1", "s1"), context = c("ctx1", "ctx1"), trait = c("g1", "g2"), entry = list( @@ -3270,7 +3270,7 @@ test_that(".mashSumStatsToMatrices errors when entry lacks SNP mcol", { SE = rep(0.05, 3) ) ss <- QtlSumStats( - study = "s1", + studyName = "s1", context = "ctx1", trait = "g1", entry = list(gr), @@ -3323,7 +3323,7 @@ test_that(".mashSumStatsToMatrices on GwasSumStats: studies become columns", { # 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"), + studyName = c("studyA", "studyB"), entry = list( mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))), mkGr(sprintf("chr1:%d:A:G", 100L * (1:3))) @@ -3389,7 +3389,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { SE = rep(0.05, 3) ) ss <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "g1", entry = list(gr), @@ -3421,7 +3421,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has zero entries", { pgenPtr = NULL ) ss <- QtlSumStats( - study = character(0), + studyName = character(0), context = character(0), trait = character(0), entry = list(), @@ -3455,7 +3455,7 @@ test_that("qtlSumStatsFromZMatrix: one row per context, Z preserved verbatim", { c("brain", "liver") ) ) - qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) + qss <- qtlSumStatsFromZMatrix(z, studyName = "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. @@ -3463,11 +3463,11 @@ test_that("qtlSumStatsFromZMatrix: one row per context, Z preserved verbatim", { 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 + # sumStats 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") + brain <- sumStats(qss, studyName = "s1", context = "brain", trait = "mash") + liver <- sumStats(qss, studyName = "s1", context = "liver", trait = "mash") expect_equal(S4Vectors::mcols(brain)$Z, unname(z[, 1])) expect_equal(S4Vectors::mcols(liver)$Z, unname(z[, 2])) }) @@ -3478,10 +3478,10 @@ test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when ncol = 1, dimnames = list(c("chr1:250:A:G", "not_a_variant"), "ctx") ) - qss <- qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()) + qss <- qtlSumStatsFromZMatrix(z, studyName = "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") + e <- sumStats(qss, studyName = "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) @@ -3492,7 +3492,7 @@ test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when 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()) + qss <- qtlSumStatsFromZMatrix(z, studyName = "s1", ldSketch = .qszm_gh()) expect_equal(S4Vectors::mcols(qss[[1]])$SNP, c("var1", "var2")) }) @@ -3500,7 +3500,7 @@ 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", + studyName = "s1", ldSketch = .qszm_gh(), n = 500L, a1 = "T", @@ -3511,8 +3511,8 @@ test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcInfo are set" 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 + expect_equal(qcInfo(qss)$role, "strong") + expect_equal(length(qcInfo(qss)$entryAudit), 2L) # one slot per context }) test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait pairs", { @@ -3520,7 +3520,7 @@ test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait # columns as traits: constant context, one trait per column qss <- qtlSumStatsFromZMatrix( z, - study = "s1", + studyName = "s1", ldSketch = .qszm_gh(), context = "brain", trait = colnames(z) @@ -3530,7 +3530,7 @@ test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait # columns as (context, trait) pairs qss2 <- qtlSumStatsFromZMatrix( z, - study = "s1", + studyName = "s1", ldSketch = .qszm_gh(), context = c("brain", "liver"), trait = c("geneA", "geneA") @@ -3544,7 +3544,7 @@ test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors" expect_error( qtlSumStatsFromZMatrix( z, - study = "s1", + studyName = "s1", ldSketch = .qszm_gh(), trait = c("t1", "t2", "t3") ), @@ -3554,13 +3554,13 @@ test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors" test_that("qtlSumStatsFromZMatrix: rejects non-matrix input and unlabelled conditions", { expect_error( - qtlSumStatsFromZMatrix(1:5, study = "s1", ldSketch = .qszm_gh()), + qtlSumStatsFromZMatrix(1:5, studyName = "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()), + qtlSumStatsFromZMatrix(z, studyName = "s1", ldSketch = .qszm_gh()), "column names" ) }) @@ -3570,15 +3570,15 @@ test_that("qtlSumStatsFromBetaMatrix: one entry per context, BETA/SE/Z mcols set qss <- qtlSumStatsFromBetaMatrix( d$bhat, d$shat, - study = "s1", + studyName = "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 + # One element per (context, chromosome); sumStats stitches a context # back into the single GRanges matching the matrix column. mc <- S4Vectors::mcols( - getSumStats(qss, study = "s1", context = "brain", trait = "mash") + sumStats(qss, studyName = "s1", context = "brain", trait = "mash") ) expect_true(all(c("BETA", "SE", "Z") %in% colnames(mc))) expect_equal(mc$BETA, unname(d$bhat[, 1])) @@ -3591,7 +3591,7 @@ test_that("qtlSumStatsFromBetaMatrix: feeds .mashSumStatsToMatrices on both scal qss <- qtlSumStatsFromBetaMatrix( d$bhat, d$shat, - study = "s1", + studyName = "s1", ldSketch = .qszm_gh() ) mb <- .mashSumStatsToMatrices(qss, "strong", inputScale = "beta") @@ -3627,7 +3627,7 @@ test_that("qtlSumStatsFromBetaMatrix: NULL rownames -> synthetic ids; placeholde qss <- qtlSumStatsFromBetaMatrix( bhat, shat, - study = "s1", + studyName = "s1", ldSketch = .qszm_gh(), n = 500L, a1 = "T", @@ -3638,7 +3638,7 @@ test_that("qtlSumStatsFromBetaMatrix: NULL rownames -> synthetic ids; placeholde 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") + expect_equal(qcInfo(qss)$role, "strong") }) test_that("mashInput: QtlSumStats path returns the flat b/s/z + XtX contract", { @@ -3719,7 +3719,7 @@ test_that("mashInput: a FineMappingResult with no credible set yields no strong" topLoci = noCsTL(rnorm(6)) ) fmr <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("brain", "blood"), trait = c("t1", "t1"), method = c("susie", "susie"), @@ -3851,7 +3851,7 @@ test_that(".qtlSumStatsFromMatrix synthesises coords for unparseable ids", { out <- pecotmr:::.qtlSumStatsFromMatrix( vids = c("weird1", "weird2"), nCond = 1L, - study = "s1", + studyName = "s1", ldSketch = NULL, context = "cA", trait = "g1", diff --git a/tests/testthat/test_overlapTopLoci.R b/tests/testthat/test_overlapTopLoci.R index 59e809ce..cd3c5e2b 100644 --- a/tests/testthat/test_overlapTopLoci.R +++ b/tests/testthat/test_overlapTopLoci.R @@ -49,7 +49,7 @@ test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-fli af = c(0.3, 0.4) )) qtl <- QtlFineMappingResult( - study = c("s", "s"), + studyName = c("s", "s"), context = c("ctx1", "ctx2"), trait = c("t", "t"), method = c("susie", "susie"), @@ -64,7 +64,7 @@ test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-fli af = c(0.2, 0.7) )) gwas <- GwasFineMappingResult( - study = "gwas", + studyName = "gwas", method = "susie", entry = list(g1) ) @@ -72,13 +72,12 @@ test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-fli ov <- overlapTopLoci(qtl, gwas, signalCutoff = 0) # variant key kept once; every other column prefixed qtl_ / gwas_ - expect_true(all(c("variant_id", "chrom", "pos", "A1", "A2") %in% names(ov))) - expect_true( - any(grepl("^qtl_", names(ov))) && any(grepl("^gwas_", names(ov))) - ) - expect_false(any(grepl("^qtl_(chrom|pos|A1|A2)$", names(ov)))) + cols <- names(S4Vectors::mcols(ov)) + expect_true(all(c("variant_id", "chrom", "pos", "A1", "A2") %in% cols)) + expect_true(any(grepl("^qtl_", cols)) && any(grepl("^gwas_", cols))) + expect_false(any(grepl("^qtl_(chrom|pos|A1|A2)$", cols))) # 2 shared variants x 2 QTL contexts x 1 GWAS study = 4 rows (wide cross-product) - expect_equal(nrow(ov), 4L) + expect_equal(length(ov), 4L) expect_setequal(unique(ov$variant_id), c("chr1:100:A:G", "chr1:200:A:G")) # per-context QTL rows preserved expect_setequal(unique(ov$qtl_context), c("ctx1", "ctx2")) @@ -109,25 +108,24 @@ test_that("overlapTopLoci returns zero rows when no variants overlap", { af = 0.2 )) qtl <- QtlFineMappingResult( - study = "s", + studyName = "s", context = "c", trait = "t", method = "susie", entry = list(q) ) gwas <- GwasFineMappingResult( - study = "g", + studyName = "g", method = "susie", entry = list(g) ) ov <- overlapTopLoci(qtl, gwas, signalCutoff = 0) - expect_equal(nrow(ov), 0L) - expect_true( - any(grepl("^qtl_", names(ov))) && any(grepl("^gwas_", names(ov))) - ) + expect_equal(length(ov), 0L) + cols <- names(S4Vectors::mcols(ov)) + expect_true(any(grepl("^qtl_", cols)) && any(grepl("^gwas_", cols))) }) -test_that("overlapTopLoci returns an empty merge when a side has no signal (df + GRanges)", { +test_that("overlapTopLoci returns an empty merge when a side has no signal", { q <- .ot_entry(.ot_tl( "chr1:100:A:G", A1 = "G", @@ -143,30 +141,27 @@ test_that("overlapTopLoci returns an empty merge when a side has no signal (df + af = 0.2 )) qtl <- QtlFineMappingResult( - study = "s", + studyName = "s", context = "c", trait = "t", method = "susie", entry = list(q) ) gwas <- GwasFineMappingResult( - study = "g", + studyName = "g", method = "susie", entry = list(g) ) # signalCutoff above every pip (0.9) -> both top-loci tables empty -> emptyMerge. df <- overlapTopLoci(qtl, gwas, signalCutoff = 0.99) - expect_equal(nrow(df), 0L) - expect_true( - any(grepl("^qtl_", names(df))) && any(grepl("^gwas_", names(df))) - ) - # same empty result routed through the GRanges branch (.overlapToGRanges empty guard). - gr <- overlapTopLoci(qtl, gwas, signalCutoff = 0.99, type = "GRanges") - expect_s4_class(gr, "GRanges") - expect_equal(length(gr), 0L) + expect_equal(length(df), 0L) + cols <- names(S4Vectors::mcols(df)) + expect_true(any(grepl("^qtl_", cols)) && any(grepl("^gwas_", cols))) + # the empty result is still ranges (.overlapToGRanges empty guard) + expect_s4_class(df, "GRanges") }) -test_that("overlapTopLoci type='GRanges' returns a GRanges of the shared variants", { +test_that("overlapTopLoci returns a GRanges of the shared variants", { q <- .ot_entry(.ot_tl( c("chr1:100:A:G", "chr1:200:A:G"), A1 = c("G", "G"), @@ -182,18 +177,18 @@ test_that("overlapTopLoci type='GRanges' returns a GRanges of the shared variant af = 0.2 )) qtl <- QtlFineMappingResult( - study = "s", + studyName = "s", context = "c", trait = "t", method = "susie", entry = list(q) ) gwas <- GwasFineMappingResult( - study = "g", + studyName = "g", method = "susie", entry = list(g) ) - gr <- overlapTopLoci(qtl, gwas, signalCutoff = 0, type = "GRanges") + gr <- overlapTopLoci(qtl, gwas, signalCutoff = 0) expect_s4_class(gr, "GRanges") expect_equal(length(gr), 1L) expect_true("gwas_beta" %in% names(S4Vectors::mcols(gr))) diff --git a/tests/testthat/test_qtlAssociationPostprocess.R b/tests/testthat/test_qtlAssociationPostprocess.R index bb00ebbe..24eabd86 100644 --- a/tests/testthat/test_qtlAssociationPostprocess.R +++ b/tests/testthat/test_qtlAssociationPostprocess.R @@ -90,7 +90,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { ) expect_s4_class(r, "QtlSumStats") - expect_false(is.null(getQcInfo(r)$associationPostprocess)) # recipe stashed + expect_false(is.null(qcInfo(r)$associationPostprocess)) # recipe stashed # Bonferroni original == min over variants of p.adjust(P, "bonferroni", n). expP <- map_dbl( @@ -157,10 +157,10 @@ test_that("permutation nominal threshold == stats::qbeta of the empirical cutoff ) }) -test_that("getSignificantQtls (bonferroni) matches the derived threshold rule", { +test_that("significantQtls (bonferroni) matches the derived threshold rule", { x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, mafCutoff = 0.01, cisWindow = 1e6) - sig <- getSignificantQtls(r, "bonferroni_original", threshold = 0.5) + sig <- significantQtls(r, "bonferroni_original", threshold = 0.5) expect_s4_class(sig, "GRanges") expect_true("trait" %in% names(S4Vectors::mcols(sig))) @@ -178,12 +178,12 @@ test_that("getSignificantQtls (bonferroni) matches the derived threshold rule", expect_equal(length(sig), expN) }) -test_that("getSumStats(annotateSignificance=) adds a derived logical mcol", { +test_that("sumStats(annotateSignificance=) adds a derived logical mcol", { x <- .qapDefaultFixture r <- qtlAssociationPostprocess(x, methods = "permutation") - gr <- getSumStats( + gr <- sumStats( r, - study = "s", + studyName = "s", context = "brain", trait = "g1", annotateSignificance = "permutation" @@ -203,7 +203,7 @@ test_that("getSumStats(annotateSignificance=) adds a derived logical mcol", { test_that("significance accessors require a postprocessed object", { x <- .qapDefaultFixture # not postprocessed expect_error( - getSignificantQtls(x, "bonferroni_original"), + significantQtls(x, "bonferroni_original"), "qtlAssociationPostprocess" ) }) @@ -267,15 +267,15 @@ test_that("permutation nominal threshold is NA for every gene when none pass FDR expect_true(all(is.na(as.numeric(r$p_nominal_threshold)))) }) -# ---- getSignificantQtls: one branch of the significance mask per method ------- +# ---- significantQtls: one branch of the significance mask per method ------- -test_that("getSignificantQtls (permutation) uses each gene's nominal threshold", { +test_that("significantQtls (permutation) uses each gene's nominal threshold", { r <- qtlAssociationPostprocess( .qapDefaultFixture, fdrThreshold = 0.1, methods = "permutation" ) - sig <- getSignificantQtls(r, "permutation") # threshold defaults to recipe + sig <- significantQtls(r, "permutation") # threshold defaults to recipe expect_s4_class(sig, "GRanges") expect_true("trait" %in% names(S4Vectors::mcols(sig))) # Reproduce: per gene, variants with P < p_nominal_threshold[gene]. @@ -293,7 +293,7 @@ test_that("getSignificantQtls (permutation) uses each gene's nominal threshold", expect_equal(length(sig), expN) }) -test_that("getSignificantQtls (permutation) skips genes with an NA threshold", { +test_that("significantQtls (permutation) skips genes with an NA threshold", { # Gene 1's NA beta_shape1 makes its qbeta nominal threshold NA, so the mask # loop must `next` past it while still processing the non-NA genes. r <- qtlAssociationPostprocess( @@ -304,7 +304,7 @@ test_that("getSignificantQtls (permutation) skips genes with an NA threshold", { thr <- as.numeric(r$p_nominal_threshold) expect_true(is.na(thr[1])) # NA-threshold gene present ... expect_true(any(!is.na(thr))) # ... alongside non-NA genes - sig <- getSignificantQtls(r, "permutation") + sig <- significantQtls(r, "permutation") expect_s4_class(sig, "GRanges") # Gene 1 contributes nothing; total is the sum over the non-NA-threshold genes. expN <- sum(map_int( @@ -319,23 +319,23 @@ test_that("getSignificantQtls (permutation) skips genes with an NA threshold", { expect_equal(length(sig), expN) }) -test_that("getSignificantQtls (permutation) errors without a nominal threshold", { +test_that("significantQtls (permutation) errors without a nominal threshold", { # No beta shapes -> postprocess produces no p_nominal_threshold column. r <- qtlAssociationPostprocess( .qapFixture(drop = c("beta_shape1", "beta_shape2")), methods = "permutation" ) expect_null(r$p_nominal_threshold) - expect_error(getSignificantQtls(r, "permutation"), "p_nominal_threshold") + expect_error(significantQtls(r, "permutation"), "p_nominal_threshold") }) -test_that("getSignificantQtls (bonferroni_filtered) applies the MAF/cis keep filter", { +test_that("significantQtls (bonferroni_filtered) applies the MAF/cis keep filter", { r <- qtlAssociationPostprocess( .qapDefaultFixture, mafCutoff = 0.01, cisWindow = 1e6 ) - sig <- getSignificantQtls(r, "bonferroni_filtered", threshold = 0.5) + sig <- significantQtls(r, "bonferroni_filtered", threshold = 0.5) expect_s4_class(sig, "GRanges") expect_gt(length(sig), 0) # Every returned variant must satisfy the filtered keep rule (MAF & cis window). @@ -347,19 +347,19 @@ test_that("getSignificantQtls (bonferroni_filtered) applies the MAF/cis keep fil )) }) -test_that("getSignificantQtls (bonferroni) errors when its columns are absent", { +test_that("significantQtls (bonferroni) errors when its columns are absent", { r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") # no bonferroni - expect_error(getSignificantQtls(r, "bonferroni_original"), "columns absent") + expect_error(significantQtls(r, "bonferroni_original"), "columns absent") }) -test_that("getSignificantQtls (qvalue) selects variants by their qvalue mcol", { +test_that("significantQtls (qvalue) selects variants by their qvalue mcol", { skip_if_not_installed("qvalue") r <- qtlAssociationPostprocess( .qapFixture(withQvalue = TRUE), fdrThreshold = 0.1, methods = "permutation" ) - sig <- getSignificantQtls(r, "qvalue", threshold = 0.1) + sig <- significantQtls(r, "qvalue", threshold = 0.1) expect_s4_class(sig, "GRanges") # Reproduce: within genes whose event q_beta < 0.1, variants with qvalue < 0.1. qb <- as.numeric(r$q_beta) @@ -375,7 +375,7 @@ test_that("getSignificantQtls (qvalue) selects variants by their qvalue mcol", { expect_equal(length(sig), expN) }) -test_that("getSignificantQtls (qvalue) errors when no event q column exists", { +test_that("significantQtls (qvalue) errors when no event q column exists", { # Drop p_beta so permutation adds no q_beta, and skip bonferroni so there is # no q_bonferroni_min_original either -- yet the object is still postprocessed. r <- qtlAssociationPostprocess( @@ -384,16 +384,16 @@ test_that("getSignificantQtls (qvalue) errors when no event q column exists", { ) expect_null(r$q_beta) expect_null(r$q_bonferroni_min_original) - expect_error(getSignificantQtls(r, "qvalue"), "event q-value column") + expect_error(significantQtls(r, "qvalue"), "event q-value column") }) -test_that("getSignificantQtls returns an empty GRanges when nothing is significant", { +test_that("significantQtls returns an empty GRanges when nothing is significant", { r <- qtlAssociationPostprocess( .qapDefaultFixture, mafCutoff = 0.01, cisWindow = 1e6 ) - sig <- getSignificantQtls(r, "bonferroni_original", threshold = 1e-300) + sig <- significantQtls(r, "bonferroni_original", threshold = 1e-300) expect_s4_class(sig, "GRanges") expect_length(sig, 0) }) @@ -453,7 +453,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", { +test_that("significantQtls(bonferroni_filtered) applies the derived rule on the filtered set", { x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, @@ -461,7 +461,7 @@ test_that("getSignificantQtls(bonferroni_filtered) applies the derived rule on t cisWindow = 1e6, methods = "bonferroni" ) - sig <- getSignificantQtls(r, "bonferroni_filtered", threshold = 0.5) + sig <- significantQtls(r, "bonferroni_filtered", threshold = 0.5) expect_s4_class(sig, "GRanges") fdr <- as.numeric(r$fdr_bonferroni_min_filtered) sigGenes <- which(!is.na(fdr) & fdr < 0.5) @@ -491,14 +491,14 @@ 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", + studyName = "s1", context = "c1", trait = "g1", entry = list(g), genome = "hg19" ) local_mocked_bindings( - getQcInfo = function(x) { + qcInfo = function(x) { list( associationPostprocess = list( fdrThreshold = 0.05, diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index bde52cb0..29f1b701 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -8,15 +8,15 @@ context("qtlEnrichmentPipeline") # The internal builders take an identity list keyed by the collection's own # columns; the axes a GWAS collection lacks are NA. .qep_gwasIdent <- function( - study, + studyName, context = NA_character_, trait = NA_character_ ) { - list(study = study, context = context, trait = trait) + list(study = studyName, context = context, trait = trait) } -.qep_qtlIdent <- function(study, context) { - list(study = study, context = context) +.qep_qtlIdent <- function(studyName, context) { + list(study = studyName, context = context) } .qep_makeHandle <- function( @@ -82,7 +82,7 @@ context("qtlEnrichmentPipeline") methodVec <- c(methodVec, "susie") } GwasFineMappingResult( - study = studyVec, + studyName = studyVec, method = methodVec, entry = entries, ldSketch = if (with_sketch) .qep_makeHandle() else NULL @@ -105,7 +105,7 @@ context("qtlEnrichmentPipeline") simplify = FALSE ) QtlFineMappingResult( - study = studies, + studyName = studies, context = ctx, trait = trs, method = methods, @@ -159,7 +159,7 @@ test_that("qtlEnrichmentPipeline: the real estimator fills the value columns", { alpha <- alpha / rowSums(alpha) sketch <- .qep_makeHandle() gfmr <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(fineMappingRow( variantIds = ids, @@ -173,7 +173,7 @@ test_that("qtlEnrichmentPipeline: the real estimator fills the value columns", { ldSketch = sketch ) qfmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -213,7 +213,7 @@ test_that("qtlEnrichmentPipeline: keys a QTL outcome side by its trait", { # study alone they collide -- the pipeline would abort on conflicting PIPs # -- and one estimate would stand in for both traits. outcome <- QtlFineMappingResult( - study = c("Q1", "Q1"), + studyName = c("Q1", "Q1"), context = c("c1", "c1"), trait = c("t1", "t2"), method = c("susie", "susie"), @@ -313,9 +313,9 @@ test_that("qtlEnrichmentPipeline: ldSketch mismatch errors", { # Build the QTL with a sketch carrying a different sample set. gfmr <- .qep_makeGwasFmr() qSketch <- .qep_makeHandle() - qSketch@sampleIds <- paste0("z", seq_len(getNSamples(qSketch))) + qSketch@sampleIds <- paste0("z", seq_len(nSamples(qSketch))) qfmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -362,7 +362,7 @@ test_that("qtlEnrichmentPipeline: distinguishes two QTL studies that share a con e1 <- .qep_makeFmEntry(variant_ids = sprintf("chr1:%d:A:G", 100L * (1:5))) e2 <- .qep_makeFmEntry(variant_ids = sprintf("chr1:%d:A:G", 100L * (1:5))) qfmr <- QtlFineMappingResult( - study = c("Q1", "Q2"), + studyName = c("Q1", "Q2"), context = c("shared_ctx", "shared_ctx"), trait = c("t1", "t1"), method = c("susie", "susie"), @@ -419,7 +419,7 @@ test_that("qtlEnrichmentPipeline: empty input collections yield the empty schema ) ) gfmr <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(emptyEntry), ldSketch = .qep_makeHandle() @@ -472,7 +472,7 @@ test_that(".enrBuildGwasPipVector: deduplicates identical PIPs across blocks", { pip = c(0.5, 0.4) ) g <- GwasFineMappingResult( - study = c("G1", "G1"), + studyName = c("G1", "G1"), method = c("susie", "susie"), entry = list(e1, e2), ldSketch = .qep_makeHandle() @@ -501,7 +501,7 @@ test_that(".enrBuildGwasPipVector: conflicting PIPs across blocks errors", { alpha = matrix(c(0.8, 0.1), nrow = 1) ) g <- GwasFineMappingResult( - study = c("G1", "G1"), + studyName = c("G1", "G1"), method = c("susie", "susie"), entry = list(e1, e2), ldSketch = .qep_makeHandle() @@ -559,7 +559,7 @@ test_that(".enrBuildQtlRegionsList: returns empty list when the (study, context) # 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 + maxNumSingleEffects = 2L ) { set.seed(seed) variantNames <- paste0("1:", seq_len(nSnps), ":A:G") @@ -567,7 +567,7 @@ test_that(".enrBuildQtlRegionsList: returns empty list when the (study, context) gwasPip[causalIdx] <- causalPips names(gwasPip) <- variantNames - alpha <- matrix(1 / nSnps, nrow = L, ncol = nSnps) + alpha <- matrix(1 / nSnps, nrow = maxNumSingleEffects, ncol = nSnps) alpha[1, ] <- 0.001 alpha[1, causalIdx[1]] <- 0.95 alpha[1, ] <- alpha[1, ] / sum(alpha[1, ]) @@ -859,7 +859,7 @@ test_that(".enrBuildGwasPipVector: unknown study yields numeric(0)", { test_that(".enrBuildGwasPipVector: skips a block whose pip length disagrees with variantIds", { # Unnamed pip of length 2 against 3 variant ids -> ids come from - # getVariantIds and length(ids) != length(pip) -> the block is skipped, + # variantIds and length(ids) != length(pip) -> the block is skipped, # leaving no pieces -> numeric(0). badEntry <- fineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), @@ -871,7 +871,7 @@ test_that(".enrBuildGwasPipVector: skips a block whose pip length disagrees with ) ) g <- GwasFineMappingResult( - study = "G1", + studyName = "G1", method = "susie", entry = list(badEntry), ldSketch = .qep_makeHandle() @@ -898,7 +898,7 @@ test_that(".enrBuildQtlRegionsList: skips an entry whose fit lacks alpha/pip", { ) ) qfmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -929,7 +929,7 @@ test_that(".enrBuildQtlRegionsList: skips a fit with no V and no prior_variance" ) ) qfmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -948,7 +948,7 @@ test_that(".enrBuildQtlRegionsList: skips a fit with no V and no prior_variance" test_that(".enrBuildQtlRegionsList: names an unnamed pip from the entry's variant ids", { unnamedPipFit <- list( alpha = matrix(c(0.6, 0.4), nrow = 1), - pip = c(0.6, 0.4), # unnamed -> names assigned from getVariantIds + pip = c(0.6, 0.4), # unnamed -> names assigned from variantIds V = 0.1 ) entry <- fineMappingRow( @@ -961,7 +961,7 @@ test_that(".enrBuildQtlRegionsList: names an unnamed pip from the entry's varian ) ) qfmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -983,7 +983,7 @@ test_that(".enrBuildQtlRegionsList: names an unnamed pip from the entry's varian test_that("qtlEnrichmentPipeline: empty QTL collection errors with the no-triples message", { gfmr <- .qep_makeGwasFmr() qfmrEmpty <- QtlFineMappingResult( - study = character(0), + studyName = character(0), context = character(0), trait = character(0), method = character(0), @@ -1012,7 +1012,7 @@ test_that("qtlEnrichmentPipeline: alignTuple cache is reused across GWAS studies pip = c(0.4, 0.3, 0.2) ) gfmr <- GwasFineMappingResult( - study = c("G1", "G2"), + studyName = c("G1", "G2"), method = c("susie", "susie"), entry = list(e1, e2), ldSketch = .qep_makeHandle() @@ -1042,7 +1042,7 @@ test_that("qtlEnrichmentPipeline: a tuple with no usable QTL regions warns and i ) ) qfmr <- QtlFineMappingResult( - study = "Q1", + studyName = "Q1", context = "c1", trait = "t1", method = "susie", @@ -1091,7 +1091,7 @@ test_that(".enrBuildQtlRegionsList reads prior variance under either name", { local_mocked_bindings( .enrMatchRows = function(qtlFmr, ident) 1L, .fmrRowParts = function(qtlFmr, i) "parts", - getSusieFit = function(parts) fit, + susieFit = function(parts) fit, .package = "pecotmr" ) pecotmr:::.enrBuildQtlRegionsList("fmr", "ident") diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index b6ee724c..85744ad9 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -45,7 +45,7 @@ context("qtlSumStats") } .qtlMakeOne <- function( - study = "study1", + studyName = "study1", context = "Cortex", trait = "ENSG001", n = 5, @@ -55,7 +55,7 @@ context("qtlSumStats") genome = "hg19" ) { QtlSumStats( - study = study, + studyName = studyName, context = context, trait = trait, entry = list(.qtlMakeEntryGr(n, with_maf = with_maf)), @@ -79,7 +79,7 @@ test_that("QtlSumStats: minimal single-tuple object builds and validates", { test_that("QtlSumStats: multi-tuple object is keyed by (study, context, trait)", { obj <- QtlSumStats( - study = c("s1", "s1", "s2"), + studyName = c("s1", "s1", "s2"), context = c("c1", "c2", "c1"), trait = c("t1", "t1", "t1"), entry = list( @@ -91,22 +91,22 @@ test_that("QtlSumStats: multi-tuple object is keyed by (study, context, trait)", ldSketch = .qtlMakeGenotypeHandle() ) expect_equal(nrow(obj), 3L) - expect_setequal(getContexts(obj), c("c1", "c2")) - expect_equal(getTraits(obj), "t1") + expect_setequal(contexts(obj), c("c1", "c2")) + expect_equal(traitNames(obj), "t1") }) -test_that("QtlSumStats: getTraitPosition returns NA when no trait position supplied", { +test_that("QtlSumStats: traitPosition returns NA when no trait position supplied", { obj <- .qtlMakeOne(trait = "ENSG001") # traitPos cannot be inferred from summary statistics, so an unsupplied # position reports NA rather than a fabricated range. - expect_identical(getTraitPosition(obj), NA) - expect_identical(getTraitPosition(obj, "ENSG001"), NA) + expect_identical(traitPosition(obj), NA) + expect_identical(traitPosition(obj, "ENSG001"), NA) }) -test_that("QtlSumStats: getTraitPosition returns the supplied trait position", { +test_that("QtlSumStats: traitPosition returns the supplied trait position", { tpos <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1000L, 1500L)) obj <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "ENSGX", entry = list(.qtlMakeEntryGr(5)), @@ -114,23 +114,23 @@ test_that("QtlSumStats: getTraitPosition returns the supplied trait position", { ldSketch = .qtlMakeGenotypeHandle(), traitPos = tpos ) - tp <- getTraitPosition(obj) + tp <- traitPosition(obj) expect_s4_class(tp, "GRanges") expect_equal(GenomicRanges::start(tp), 1000L) expect_equal(GenomicRanges::end(tp), 1500L) - expect_equal(GenomicRanges::start(getTraitPosition(obj, "ENSGX")), 1000L) + expect_equal(GenomicRanges::start(traitPosition(obj, "ENSGX")), 1000L) # a trait not in the collection -> NA - expect_identical(getTraitPosition(obj, "nope"), NA) + expect_identical(traitPosition(obj, "nope"), NA) }) test_that("QtlSumStats: errors when required args are missing", { - expect_error(QtlSumStats(study = "s1", context = "c1"), "all required") + expect_error(QtlSumStats(studyName = "s1", context = "c1"), "all required") }) test_that("QtlSumStats: errors on length mismatch among study/context/trait/entry", { expect_error( QtlSumStats( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1"), trait = c("t1"), entry = list(.qtlMakeEntryGr(1)), @@ -144,7 +144,7 @@ test_that("QtlSumStats: errors on length mismatch among study/context/trait/entr test_that("QtlSumStats: errors when entry is not a list", { expect_error( QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = "not_a_list", @@ -158,7 +158,7 @@ test_that("QtlSumStats: errors when entry is not a list", { test_that("QtlSumStats: errors on non-singleton genome", { expect_error( QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(.qtlMakeEntryGr(1)), @@ -172,7 +172,7 @@ test_that("QtlSumStats: errors on non-singleton genome", { test_that("QtlSumStats: errors on duplicate (study, context, trait) tuple", { expect_error( QtlSumStats( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(1), .qtlMakeEntryGr(1)), @@ -186,7 +186,7 @@ test_that("QtlSumStats: errors on duplicate (study, context, trait) tuple", { test_that("QtlSumStats: errors when entry list contains non-GRanges", { expect_error( QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list("not_a_granges"), @@ -199,7 +199,7 @@ test_that("QtlSumStats: errors when entry list contains non-GRanges", { test_that("QtlSumStats: scalar varY is recycled across tuples", { obj <- QtlSumStats( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c1"), trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), @@ -213,7 +213,7 @@ test_that("QtlSumStats: scalar varY is recycled across tuples", { test_that("QtlSumStats: errors when varY length is neither 1 nor n", { expect_error( QtlSumStats( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c1"), trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), @@ -229,7 +229,7 @@ test_that("QtlSumStats: optional nSample column is absent by default, attached a bare <- .qtlMakeOne() expect_false("nSample" %in% names(bare)) # schema unchanged by default obj <- QtlSumStats( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c1"), trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), @@ -244,7 +244,7 @@ test_that("QtlSumStats: optional nSample column is absent by default, attached a test_that("QtlSumStats: errors when nSample length is neither 1 nor n", { expect_error( QtlSumStats( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c1"), trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), @@ -259,7 +259,7 @@ test_that("QtlSumStats: errors when nSample length is neither 1 nor n", { test_that("QtlSumStats: subsetChr preserves the nSample column", { gr <- .qtlMakeEntryGr(4, chr = "chr1") obj <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(gr), @@ -273,7 +273,7 @@ test_that("QtlSumStats: subsetChr preserves the nSample column", { test_that("QtlSumStats: accepts and stores extra per-tuple columns via ...", { obj <- QtlSumStats( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c1"), trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), @@ -286,7 +286,7 @@ test_that("QtlSumStats: accepts and stores extra per-tuple columns via ...", { # so a bare `cohort =` here would read as adding an entry. expect_error( QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(), @@ -301,20 +301,20 @@ test_that("QtlSumStats: accepts and stores extra per-tuple columns via ...", { # Accessors # =========================================================================== -test_that("getSumStats / getZ / getN return values from the single-tuple entry", { +test_that("sumStats / z / nSamples return values from the single-tuple entry", { obj <- .qtlMakeOne(n = 4) - expect_s4_class(getSumStats(obj), "GRanges") - expect_equal(length(getSumStats(obj)), 4L) - expect_equal(getZ(obj), seq(1.0, by = 0.5, length.out = 4)) - expect_equal(getN(obj), rep(1000L, 4)) + expect_s4_class(sumStats(obj), "GRanges") + expect_equal(length(sumStats(obj)), 4L) + expect_equal(z(obj), seq(1.0, by = 0.5, length.out = 4)) + expect_equal(nSamples(obj), rep(1000L, 4)) }) -test_that("getMaf returns NULL when MAF column is absent, vector when present", { +test_that("maf returns NULL when MAF column is absent, vector when present", { obj_no_maf <- .qtlMakeOne(with_maf = FALSE) - expect_null(getMaf(obj_no_maf)) + expect_null(maf(obj_no_maf)) obj_maf <- .qtlMakeOne(n = 4, with_maf = TRUE) - expect_equal(length(getMaf(obj_maf)), 4L) + expect_equal(length(maf(obj_maf)), 4L) }) test_that("nSnps reports the number of variants in the selected entry", { @@ -322,17 +322,17 @@ test_that("nSnps reports the number of variants in the selected entry", { expect_equal(nSnps(obj), 7L) }) -test_that("getVarY returns numeric value or NULL when NA", { +test_that("varY returns numeric value or NULL when NA", { obj_na <- .qtlMakeOne(varY = NA_real_) - expect_null(getVarY(obj_na)) + expect_null(varY(obj_na)) obj_v <- .qtlMakeOne(varY = 2.5) - expect_equal(getVarY(obj_v), 2.5) + expect_equal(varY(obj_v), 2.5) }) -test_that("getContexts / getTraits return unique values across tuples", { +test_that("contexts / traitNames return unique values across tuples", { obj <- QtlSumStats( - study = c("s1", "s1", "s2"), + studyName = c("s1", "s1", "s2"), context = c("c1", "c2", "c1"), trait = c("t1", "t1", "t2"), entry = list( @@ -343,13 +343,13 @@ test_that("getContexts / getTraits return unique values across tuples", { genome = "hg19", ldSketch = .qtlMakeGenotypeHandle() ) - expect_setequal(getContexts(obj), c("c1", "c2")) - expect_setequal(getTraits(obj), c("t1", "t2")) + expect_setequal(contexts(obj), c("c1", "c2")) + expect_setequal(traitNames(obj), c("t1", "t2")) }) test_that("accessors require (study, context, trait) when collection has >1 entry", { obj <- QtlSumStats( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c1"), trait = c("t1", "t1"), entry = list(.qtlMakeEntryGr(1), .qtlMakeEntryGr(1)), @@ -357,20 +357,20 @@ test_that("accessors require (study, context, trait) when collection has >1 entr ldSketch = .qtlMakeGenotypeHandle() ) expect_error( - getSumStats(obj), + sumStats(obj), "Pass `study`, `context`, and `trait` to select one" ) expect_s4_class( - getSumStats(obj, study = "s1", context = "c1", trait = "t1"), + sumStats(obj, studyName = "s1", context = "c1", trait = "t1"), "GRanges" ) }) test_that("accessors error on unknown tuple", { - obj <- .qtlMakeOne(study = "s1", context = "c1", trait = "t1") + obj <- .qtlMakeOne(studyName = "s1", context = "c1", trait = "t1") expect_error( - getSumStats(obj, study = "ghost", context = "c1", trait = "t1"), + sumStats(obj, studyName = "ghost", context = "c1", trait = "t1"), "No entry" ) }) @@ -378,7 +378,7 @@ test_that("accessors error on unknown tuple", { test_that("accessors require length-1 selection args", { obj <- .qtlMakeOne() expect_error( - getSumStats(obj, study = c("s1", "s2"), context = "c1", trait = "t1"), + sumStats(obj, studyName = c("s1", "s2"), context = "c1", trait = "t1"), "Must have length 1" ) }) @@ -405,7 +405,7 @@ test_that("subsetChr keeps only variants on the requested chromosome", { N = rep(1000L, length(gr)) ) obj <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(gr), @@ -431,16 +431,22 @@ test_that("subsetChr drops the element when no variants on that chromosome", { expect_equal(nrow(empty), 0L) expect_equal(length(empty), 0L) # The collection-level state survives even when nothing is left. - expect_equal(getGenome(empty), getGenome(obj)) - expect_identical(getLdSketch(empty), getLdSketch(obj)) + expect_equal( + unname(GenomeInfoDb::genome(empty)), + unname(GenomeInfoDb::genome(obj)) + ) + expect_identical(ldSketch(empty), ldSketch(obj)) }) test_that("subsetChr preserves class-level slots (genome, ldSketch, qcInfo)", { obj <- .qtlMakeOne(qcInfo = list(step1 = "ok")) res <- subsetChr(obj, "1") - expect_equal(getGenome(res), getGenome(obj)) - expect_equal(getQcInfo(res), getQcInfo(obj)) - expect_identical(getLdSketch(res), getLdSketch(obj)) + expect_equal( + unname(GenomeInfoDb::genome(res)), + unname(GenomeInfoDb::genome(obj)) + ) + expect_equal(qcInfo(res), qcInfo(obj)) + expect_identical(ldSketch(res), ldSketch(obj)) }) # =========================================================================== @@ -456,9 +462,9 @@ test_that("show prints entry count and genome build", { # Empty-collection + duplicate-tuple selector error branches # =========================================================================== -test_that("getSumStats errors on an empty QtlSumStats collection", { +test_that("sumStats errors on an empty QtlSumStats collection", { empty <- QtlSumStats( - study = character(0), + studyName = character(0), context = character(0), trait = character(0), entry = list(), @@ -467,25 +473,25 @@ test_that("getSumStats errors on an empty QtlSumStats collection", { varY = numeric(0) ) expect_equal(nrow(empty), 0L) - expect_error(getSumStats(empty), "has no rows") + expect_error(sumStats(empty), "has no rows") }) test_that("QtlSumStats: ldSketch is optional (NULL for LD-free workflows)", { obj <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(.qtlMakeEntryGr(1)), genome = "hg19" ) # ldSketch omitted - expect_null(getLdSketch(obj)) + expect_null(ldSketch(obj)) expect_output(show(obj), "none \\(LD-free\\)") }) test_that("QtlSumStats: a non-GenotypeHandle ldSketch is rejected", { expect_error( QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(.qtlMakeEntryGr(1)), @@ -497,32 +503,32 @@ test_that("QtlSumStats: a non-GenotypeHandle ldSketch is rejected", { }) # =========================================================================== -# First-class summary-statistic accessors: getP / getBeta / getSe +# First-class summary-statistic accessors: pval / coef / se # =========================================================================== -test_that("getP / getBeta / getSe read the optional P/BETA/SE mcols", { +test_that("pval / coef / se read the optional P/BETA/SE mcols", { gr <- .qtlMakeEntryGr(4) S4Vectors::mcols(gr)$P <- c(0.1, 0.01, 1e-4, 0.5) S4Vectors::mcols(gr)$BETA <- c(0.2, -0.3, 0.4, 0.05) S4Vectors::mcols(gr)$SE <- rep(0.1, 4) x <- QtlSumStats( - study = "s", + studyName = "s", context = "c", trait = "g", entry = list(gr), genome = "hg19" ) - expect_equal(getP(x), c(0.1, 0.01, 1e-4, 0.5)) - expect_equal(getBeta(x), c(0.2, -0.3, 0.4, 0.05)) - expect_equal(getSe(x), rep(0.1, 4)) + expect_equal(pval(x), c(0.1, 0.01, 1e-4, 0.5)) + expect_equal(coef(x), c(0.2, -0.3, 0.4, 0.05)) + expect_equal(se(x), rep(0.1, 4)) }) -test_that("getP / getBeta / getSe return NULL when the entry omits them", { +test_that("pval / coef / se return NULL when the entry omits them", { y <- .qtlMakeOne(n = 4) # Z/N-only entry - expect_null(getP(y)) - expect_null(getBeta(y)) - expect_null(getSe(y)) - expect_equal(getZ(y), seq(1.0, by = 0.5, length.out = 4)) # Z still works + expect_null(pval(y)) + expect_null(coef(y)) + expect_null(se(y)) + expect_equal(z(y), seq(1.0, by = 0.5, length.out = 4)) # Z still works }) # =========================================================================== @@ -533,14 +539,14 @@ test_that("constructor derives tss/tes distance from a point trait position", { gr <- .qtlMakeEntryGr(5, start_at = 100L, step = 100L) # 100..500 tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(250L, width = 1L)) x <- QtlSumStats( - study = "s", + studyName = "s", context = "c", trait = "g", entry = list(gr), genome = "hg19", traitPos = tp ) - mc <- S4Vectors::mcols(getSumStats(x)) + mc <- S4Vectors::mcols(sumStats(x)) expect_equal(mc$tss_distance, c(100, 200, 300, 400, 500) - 250) # 1bp trait -> tss and tes distance are identical expect_equal(mc$tss_distance, mc$tes_distance) @@ -550,26 +556,26 @@ test_that("constructor derives distinct tss/tes distance for a multi-base trait" gr <- .qtlMakeEntryGr(3, start_at = 100L, step = 100L) # 100,200,300 tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(200L, 400L)) # TSS 200, TES 400 x <- QtlSumStats( - study = "s", + studyName = "s", context = "c", trait = "g", entry = list(gr), genome = "hg19", traitPos = tp ) - mc <- S4Vectors::mcols(getSumStats(x)) + mc <- S4Vectors::mcols(sumStats(x)) expect_equal(mc$tss_distance, c(100, 200, 300) - 200) expect_equal(mc$tes_distance, c(100, 200, 300) - 400) }) test_that("no traitPos -> no distance columns; existing distance is preserved", { z <- .qtlMakeOne(n = 3) - expect_null(S4Vectors::mcols(getSumStats(z))$tss_distance) + expect_null(S4Vectors::mcols(sumStats(z))$tss_distance) gr <- .qtlMakeEntryGr(2, start_at = 100L, step = 100L) S4Vectors::mcols(gr)$tss_distance <- c(-999L, -888L) # pre-existing w <- QtlSumStats( - study = "s", + studyName = "s", context = "c", trait = "g", entry = list(gr), @@ -579,7 +585,7 @@ test_that("no traitPos -> no distance columns; existing distance is preserved", IRanges::IRanges(250L, width = 1L) ) ) - mc <- S4Vectors::mcols(getSumStats(w)) + mc <- S4Vectors::mcols(sumStats(w)) expect_equal(mc$tss_distance, c(-999L, -888L)) # not clobbered expect_equal(mc$tes_distance, c(100, 200) - 250) # absent -> filled }) @@ -597,13 +603,16 @@ test_that("combineQtlSumStats() row-binds collections and keeps NULL sketches", expect_s4_class(out, "QtlSumStats") expect_equal(nrow(out), nrow(a) + nrow(b)) expect_identical(as.list(out), c(as.list(a), as.list(b))) - expect_equal(getGenome(out), getGenome(a)) + expect_equal( + unname(GenomeInfoDb::genome(out)), + unname(GenomeInfoDb::genome(a)) + ) a2 <- a a2@ldSketch <- NULL b2 <- b b2@ldSketch <- NULL - expect_null(getLdSketch(combineQtlSumStats(a2, b2))) + expect_null(ldSketch(combineQtlSumStats(a2, b2))) }) diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index d3882f14..c9f60288 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -6,8 +6,8 @@ context("SS-TWAS: weights, pipeline, and omnibus combination") # context, trait, method, entry) columns where each entry is a # `TwasWeightsRow` S4 object carrying weights / fits / cvResult. # Class-shape tests for the new collection should live alongside the -# pipeline tests and assert via accessors (`getWeights`, `getStudy`, -# `getCvResult`, etc.) — not against legacy slot shapes. +# pipeline tests and assert via accessors (`weights`, `studyName`, +# `cvResult`, etc.) — not against legacy slot shapes. # # `twasAnalysis()` was collapsed into the unified `twasZ()` dispatcher # (task #37); its tests are removed here. @@ -71,7 +71,7 @@ test_that("fitSusieInfThenSusieRss returns two fits", { n <- 500 R <- diag(p) z <- rnorm(p) - fits <- fitSusieInfThenSusieRss(z, R, n, args = SusieOptions(L = 5)) + fits <- fitSusieInfThenSusieRss(z, R, n, args = SusieOptions(max_iter = 5)) expect_true(is.list(fits)) expect_true("susie" %in% names(fits)) expect_true("susieInf" %in% names(fits)) @@ -467,7 +467,7 @@ 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(methodArgs = QggOptions(nit = 200, nburn = 20, nthin = 1)) + mc <- list(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) @@ -1055,7 +1055,7 @@ test_that("mrmashWrapper refuses to let methodArgs override derived values", { dataDrivenPriorMatrices = list(U = list(diag(2))), methodArgs = MrmashOptions(S0 = list(diag(2))) ), - "derived by the wrapper" + "supplied by pecotmr" ) }) diff --git a/tests/testthat/test_rrBayesAlphabet.R b/tests/testthat/test_rrBayesAlphabet.R index 79a0d875..27bfedc4 100644 --- a/tests/testthat/test_rrBayesAlphabet.R +++ b/tests/testthat/test_rrBayesAlphabet.R @@ -74,7 +74,8 @@ test_that("bayesNWeights dispatches to bayesAlphabetWeights with bayesN", { result <- bayesNWeights( X, y, - methodArgs = QggOptions(nit = 50, nburn = 10) + nit = 50, + nburn = 10 ) expect_equal(length(result), p) expect_true(is.numeric(result)) diff --git a/tests/testthat/test_sldscPostprocessingPipeline.R b/tests/testthat/test_sldscPostprocessingPipeline.R index 855ccada..d2f4f89a 100644 --- a/tests/testthat/test_sldscPostprocessingPipeline.R +++ b/tests/testthat/test_sldscPostprocessingPipeline.R @@ -35,7 +35,7 @@ test_that("pipeline runs end-to-end on a single + joint SldscData", { }) # The shape assertions above pass even when every meta row is NA, which is -# what a degenerate per-block tau (constant tauBlocks -> jackknife SE of 0) +# what a degenerate per-block tau (constant annotationJackknifeCoefs -> jackknife SE of 0) # produces: metafor gets zero-variance inputs and DerSimonian-Laird drops # every trait, leaving nTraits == 0. Assert on the values, not just the # columns. @@ -51,7 +51,7 @@ test_that("meta tables pool every trait rather than dropping them", { expect_true(all(meta$singleSe > 0), info = tbl) } # tau* is the one pooled from the jackknife blocks, so it is the column - # a zero-variance tauBlocks silently empties. + # a zero-variance annotationJackknifeCoefs silently empties. expect_true(all(res$meta$tauStar$singleMean > 0)) expect_false(any(is.na(res$meta$tauStar$jointMean))) }) @@ -100,7 +100,7 @@ test_that("pipeline errors on non-SldscData input", { }) test_that("pipeline errors when the SldscData has no traits", { - sd <- SldscData(annot = data.frame(CHR = 1, SNP = "rs1", annot_A = 1)) + sd <- SldscData(annotData = data.frame(CHR = 1, SNP = "rs1", annot_A = 1)) expect_error(suppressMessages(sldscPostprocessingPipeline(sd)), "no traits") }) @@ -302,7 +302,7 @@ test_that(".sldscCollectSingle returns empty parts for no standardizations", { test_that(".sldscTraitSingle tolerates a trait with no single-mode runs", { local_mocked_bindings( - getTraitRun = function(...) NULL, + sldscResults = function(...) NULL, .package = "pecotmr" ) ctx <- list(sldscData = NULL, targetCategories = c("t1", "t2")) diff --git a/tests/testthat/test_sldscWrapper.R b/tests/testthat/test_sldscWrapper.R index ef8353a9..86fbc9b1 100644 --- a/tests/testthat/test_sldscWrapper.R +++ b/tests/testthat/test_sldscWrapper.R @@ -41,9 +41,9 @@ test_that("readSldscTrait reads polyfun outputs correctly", { expect_equal(result$nBlocks, 5L) expect_equal(length(result$tau), 3L) expect_true("myannot_0" %in% names(result$tau)) - expect_true(is.matrix(result$tauBlocks)) - expect_equal(nrow(result$tauBlocks), 5L) - expect_equal(ncol(result$tauBlocks), 3L) + expect_true(is.matrix(result$annotationJackknifeCoefs)) + expect_equal(nrow(result$annotationJackknifeCoefs), 5L) + expect_equal(ncol(result$annotationJackknifeCoefs), 3L) }) test_that("readSldscTrait errors on missing files", { @@ -344,7 +344,7 @@ test_that("isBinarySldscAnnot errors on non-SldscData input", { # ============================================================================= -# standardizeSldscTrait (operates on SldscData via getTraitRun) +# standardizeSldscTrait (operates on SldscData via sldscResults) # ============================================================================= # Build a readSldscTrait-shaped run with specific values the tests assert on. @@ -367,7 +367,7 @@ test_that("isBinarySldscAnnot errors on non-SldscData input", { propH2 = setNames(rep(0.15, n), cats), propSnps = setNames(rep(0.06, n), cats), h2g = h2g, - tauBlocks = blocks, + annotationJackknifeCoefs = blocks, nBlocks = nBlocks ) } @@ -376,7 +376,7 @@ test_that("isBinarySldscAnnot errors on non-SldscData input", { # standardizeSldscTrait(sldscData, trait, mode, idx, ...) API can reach it. .wrapRun <- function(run, joint = run) { SldscData( - annot = data.frame( + annotData = data.frame( CHR = 1, SNP = "rs1", A = 1, diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index fb797093..2952b66f 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -8,7 +8,7 @@ context("sumstats_qc") # pair # * `QcResult` and the accessors `getRssInput()`, `getLdData()`, # `getOutlierNumber()` have been removed; QC audit lives on -# `getQcInfo()` +# `qcInfo()` # Integration coverage of `summaryStatsQc()` lives in the # pipeline test files (test_colocboostPipeline.R, etc.). # @@ -40,6 +40,44 @@ context("sumstats_qc") } } +test_that(".entryToSumstatDf: derives maf from a directional af", { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:3), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), + A1 = "A", + A2 = "G", + Z = c(2, -1.5, 1.8), + N = 1000L, + AF = c(0.3, 0.8, 0.5) + ) + df <- pecotmr:::.entryToSumstatDf(gr) + # af is directional, maf is not: 0.8 folds to 0.2. + expect_equal(df$af, c(0.3, 0.8, 0.5)) + expect_equal(df$maf, c(0.3, 0.2, 0.5)) + # ... which is what takes the MR ratio off the z-scale fallback. + expect_true(pecotmr:::.cipGwasHasScale(df$maf, df$N)) +}) + +test_that(".entryToSumstatDf: a declared MAF is not overwritten by af", { + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 1L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = "chr1:100:A:G", + A1 = "A", + A2 = "G", + Z = 2, + N = 1000L, + AF = 0.8, + MAF = 0.45 + ) + df <- pecotmr:::.entryToSumstatDf(gr) + # The study asserted 0.45; af is only another route to the same thing. + expect_equal(df$maf, 0.45) + expect_equal(df$af, 0.8) +}) + test_that("ldMismatchQc dentist returns a data frame with an outlier column", { set.seed(42) p <- 20 @@ -3037,10 +3075,10 @@ context("summaryStatsQc") .ssQ_makeGwasSumStats <- function( snp_ids = paste0("rs", 1:4), positions = c(100L, 200L, 300L, 400L), - study = "g1" + studyName = "g1" ) { GwasSumStats( - study = study, + studyName = studyName, entry = list(.ssQ_makeEntryGr(snp_ids, positions)), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -3051,31 +3089,31 @@ context("summaryStatsQc") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -3109,7 +3147,7 @@ test_that("mafCutoff > 0 with no frequency skips the filter, not the run", { expect_warning( res <- summaryStatsQc( ss, - panelFilterArgs = PanelFilterParam(mafCutoff = 0.05) + panelFilterParam = PanelFilterParam(mafCutoff = 0.05) ), "skipping the MAF filter" ) @@ -3142,7 +3180,7 @@ test_that("summaryStatsQc: PIP screen runs AFTER allele harmonization", { mc$Z <- c(0.2, 0.3, 0.1, 12) # only the off-panel rsX carries signal S4Vectors::mcols(gr) <- mc ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -3169,7 +3207,7 @@ test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { mc$Z <- c(0.2, 0.3, 0.1, 12) S4Vectors::mcols(gr) <- mc ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -3190,7 +3228,7 @@ test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { # as real genotype LD sketches do, so a re-keyed entry SNP resolves against it. .ssQ_makeHandleVid <- function(snp_n = 8L, n_samples = 60L) { h <- .ssQ_makeHandle(snp_n, n_samples) - h@snpInfo$SNP <- paste0("chr1:", getSnpInfo(h)$BP, ":G:A") + h@snpInfo$SNP <- paste0("chr1:", snpInfo(h)$BP, ":G:A") h } @@ -3216,7 +3254,7 @@ test_that("summaryStatsQc: harmonization re-keys SNP and sign-flips Z", { # the SNP must be re-keyed to the panel-orientation id (chr1:200:G:A), not # left at the input-orientation chr1:200:A:G. Exact matches are unchanged. ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeFlipEntryGr()), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -3295,7 +3333,7 @@ test_that("a tag-named panel entry survives the end-to-end sketch subset", { h <- .ssQ_makeHandleVid() h@snpInfo$SNP[h@snpInfo$BP == 200L] <- "chr1:200:INS:A" ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr()), genome = "hg19", ldSketch = h @@ -3309,7 +3347,7 @@ test_that("a tag-named panel entry survives the end-to-end sketch subset", { expect_true("chr1:200:G:A" %in% snp) # the retained sketch keeps the panel row the QC'd entry still refers to expect_true( - "chr1:200:G:A" %in% pecotmr:::.ldSketchMatchIds(getLdSketch(out)) + "chr1:200:G:A" %in% pecotmr:::.ldSketchMatchIds(ldSketch(out)) ) }) @@ -3322,10 +3360,10 @@ test_that("the sketch survives a chr:pos:A1:A2 panel (PLINK .bim order)", { # .subsetSketchToIds() silently emptied the sketch and RSS fine-mapping / # TWAS weights aborted later with "not present in the LD sketch panel". h <- .ssQ_makeHandleVid() - si <- getSnpInfo(h) + si <- snpInfo(h) h@snpInfo$SNP <- paste0("chr1:", si$BP, ":", si$A1, ":", si$A2) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr( snp_ids = paste0("chr1:", c(100L, 200L, 300L, 400L), ":G:A") )), @@ -3337,7 +3375,7 @@ test_that("the sketch survives a chr:pos:A1:A2 panel (PLINK .bim order)", { signalScreenArgs = SignalScreenParam(pip = 0), sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) - kept <- pecotmr:::.ldSketchMatchIds(getLdSketch(out)) + kept <- pecotmr:::.ldSketchMatchIds(ldSketch(out)) expect_length(kept, 4L) expect_setequal( pecotmr:::parseVariantId(kept)$pos, @@ -3351,7 +3389,7 @@ test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants", { # "absent from the ldSketch panel". After the harmonization re-key the SNP # matches the panel and slalom QC runs to completion. ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeFlipEntryGr()), genome = "hg19", ldSketch = .ssQ_makeHandleVid() @@ -3393,9 +3431,9 @@ test_that("summaryStatsQc: ldMismatchQc reconciles a chr-prefix difference", { # canonical chr-prefixed form, so the opt-in z-mismatch panel match must # reconcile the prefix (previously errored "absent from the ldSketch panel"). h <- .ssQ_makeHandle() - h@snpInfo$SNP <- paste0("1:", getSnpInfo(h)$BP, ":G:A") # non-chr-prefixed + h@snpInfo$SNP <- paste0("1:", snpInfo(h)$BP, ":G:A") # non-chr-prefixed ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr()), genome = "hg19", ldSketch = h @@ -3483,7 +3521,7 @@ test_that("summaryStatsQc: vanilla run fills qcInfo, returns GwasSumStats", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc(ss) expect_s4_class(res, "GwasSumStats") - qc <- getQcInfo(res) + qc <- qcInfo(res) expect_true(length(qc) > 0L) expect_true("options" %in% names(qc)) expect_true("entryAudit" %in% names(qc)) @@ -3496,7 +3534,7 @@ test_that("summaryStatsQc: vanilla run fills qcInfo, returns GwasSumStats", { test_that("summaryStatsQc: keepVariants subsets entries, records the drop", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc(ss, keepVariants = c("rs1", "rs3")) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$keepVariantsDropped, 2L) expect_equal(ea$variantsOut, 2L) }) @@ -3504,7 +3542,7 @@ test_that("summaryStatsQc: keepVariants subsets entries, records the drop", { test_that("summaryStatsQc: skipRegion drops overlapping variants", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc(ss, skipRegion = "chr1:50-150") - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$skipRegionDropped, 1L) # rs1 at pos 100 is dropped }) @@ -3514,13 +3552,13 @@ test_that("summaryStatsQc: PIP screen triggers when no variant has signal", { gr <- .ssQ_makeEntryGr() S4Vectors::mcols(gr)$Z <- rep(0.1, length(gr)) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() ) res <- summaryStatsQc(ss, signalScreenArgs = SignalScreenParam(pip = 0.99)) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) expect_match(ea$pipScreenReason, "no signals above PIP threshold") expect_equal(length(res[[1L]]), 0L) @@ -3529,7 +3567,7 @@ test_that("summaryStatsQc: PIP screen triggers when no variant has signal", { test_that("summaryStatsQc: harmonized variants count is recorded", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc(ss) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$matchedAgainstSketch, 4L) }) @@ -3543,7 +3581,7 @@ test_that("summaryStatsQc: options block records the curated knobs", { nCutoff = 10 ) ) - opts <- getQcInfo(res)$options + opts <- qcInfo(res)$options expect_true(opts$removeIndels) expect_false(opts$removeStrandAmbiguous) expect_equal(opts$nCutoff, 10) @@ -3552,7 +3590,7 @@ test_that("summaryStatsQc: options block records the curated knobs", { test_that("summaryStatsQc: round-trips QtlSumStats inputs", { gr <- .ssQ_makeEntryGr() ss <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(gr), @@ -3561,7 +3599,7 @@ test_that("summaryStatsQc: round-trips QtlSumStats inputs", { ) res <- summaryStatsQc(ss) expect_s4_class(res, "QtlSumStats") - expect_equal(length(getQcInfo(res)$entryAudit), 1L) + expect_equal(length(qcInfo(res)$entryAudit), 1L) }) # =========================================================================== @@ -3628,7 +3666,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts, no N -> N == N_eff", { nControl = c(900, 800, 850, 750) ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -3636,7 +3674,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts, no N -> N == N_eff", { res <- summaryStatsQc(ss) # 4*case*control/(case+control) per variant. expect_equal(.ssQ_entryNByPos(res[[1L]]), c(360, 640, 510, 750)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "effective") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "effective") }) test_that("summaryStatsQc(effectiveN=TRUE): counts + N -> counts win", { @@ -3646,7 +3684,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts + N -> counts win", { includeN = TRUE ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -3655,14 +3693,14 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts + N -> counts win", { res <- summaryStatsQc(ss) # N (was 1000) is replaced by the per-variant N_eff. expect_equal(.ssQ_entryNByPos(res[[1L]]), c(360, 640, 510, 750)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "effective") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "effective") }) test_that("summaryStatsQc(effectiveN=TRUE): N only, no counts -> used as-is", { ss <- .ssQ_makeGwasSumStats() # entry carries N = 1000, no counts res <- summaryStatsQc(ss) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "column") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "column") }) test_that("summaryStatsQc(effectiveN=FALSE): counts + N -> raw N", { @@ -3672,14 +3710,14 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts + N -> raw N", { includeN = TRUE ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() ) res <- summaryStatsQc(ss, effectiveN = FALSE) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "column") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "column") }) test_that("summaryStatsQc(effectiveN=FALSE): counts -> raw total", { @@ -3688,7 +3726,7 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts -> raw total", { nControl = c(900, 800, 850, 750) ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -3696,14 +3734,14 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts -> raw total", { res <- summaryStatsQc(ss, effectiveN = FALSE) # Raw total n_case + n_control per variant. expect_equal(.ssQ_entryNByPos(res[[1L]]), c(1000, 1000, 1000, 1000)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "total") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "total") }) test_that("summaryStatsQc(effectiveN=TRUE): study scalars fill all variants", { # Entry has an N column but NO per-variant N_CASE/N_CONTROL; the scalars win. gr <- .ssQ_makeEntryGr() ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle(), @@ -3714,7 +3752,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): study scalars fill all variants", { res <- summaryStatsQc(ss) # 4*100*900/1000 = 360 for every variant. expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 360)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "effective") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "effective") }) test_that("summaryStatsQc: study nSample is the level-4 fallback", { @@ -3724,7 +3762,7 @@ test_that("summaryStatsQc: study nSample is the level-4 fallback", { mc$N <- NULL # remove per-variant N S4Vectors::mcols(gr) <- mc ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle(), @@ -3732,7 +3770,7 @@ test_that("summaryStatsQc: study nSample is the level-4 fallback", { ) res <- summaryStatsQc(ss) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 4321)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "study-n") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "study-n") }) test_that("summaryStatsQc: QtlSumStats tuple nSample falls back too", { @@ -3744,7 +3782,7 @@ test_that("summaryStatsQc: QtlSumStats tuple nSample falls back too", { mc$N <- NULL # remove per-variant N S4Vectors::mcols(gr) <- mc ss <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(gr), @@ -3755,7 +3793,7 @@ test_that("summaryStatsQc: QtlSumStats tuple nSample falls back too", { res <- summaryStatsQc(ss) expect_s4_class(res, "QtlSumStats") expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 838)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "study-n") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "study-n") expect_equal(as.numeric(res$nSample), 838) # slot preserved through QC }) @@ -3766,7 +3804,7 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { nControl = c(900, 800, 850, 750) ) ss1 <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr1), genome = "hg19", ldSketch = .ssQ_makeHandle(), @@ -3774,10 +3812,10 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { ) res1 <- summaryStatsQc(ss1) expect_equal(.ssQ_entryNByPos(res1[[1L]]), c(360, 640, 510, 750)) - expect_identical(getQcInfo(res1)$entryAudit[[1L]]$nSource, "effective") + expect_identical(qcInfo(res1)$entryAudit[[1L]]$nSource, "effective") # per-variant N column present alongside nSample (no counts) -> N wins (column). ss2 <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr()), genome = "hg19", ldSketch = .ssQ_makeHandle(), @@ -3785,14 +3823,14 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { ) res2 <- summaryStatsQc(ss2) # .ssQ_makeEntryGr carries N = 1000 expect_true(all(.ssQ_entryNByPos(res2[[1L]]) == 1000)) - expect_identical(getQcInfo(res2)$entryAudit[[1L]]$nSource, "column") + expect_identical(qcInfo(res2)$entryAudit[[1L]]$nSource, "column") }) test_that("summaryStatsQc: effectiveN recorded in qcInfo options", { ss <- .ssQ_makeGwasSumStats() - expect_true(getQcInfo(summaryStatsQc(ss))$options$effectiveN) + expect_true(qcInfo(summaryStatsQc(ss))$options$effectiveN) expect_false( - getQcInfo(summaryStatsQc(ss, effectiveN = FALSE))$options$effectiveN + qcInfo(summaryStatsQc(ss, effectiveN = FALSE))$options$effectiveN ) }) @@ -3801,7 +3839,7 @@ test_that("summaryStatsQc: quantitative QtlSumStats: no effective N", { # "column"), N untouched. gr <- .ssQ_makeEntryGr() ss <- QtlSumStats( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", entry = list(gr), @@ -3810,7 +3848,7 @@ test_that("summaryStatsQc: quantitative QtlSumStats: no effective N", { ) res <- summaryStatsQc(ss) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) - expect_identical(getQcInfo(res)$entryAudit[[1L]]$nSource, "column") + expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "column") }) # =========================================================================== @@ -3821,7 +3859,7 @@ 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( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr( snp_ids = paste0("rs", 1:8), positions = seq(100L, by = 100L, length.out = 8L) @@ -3834,7 +3872,7 @@ test_that("summaryStatsQc: ldMismatchQcMethod 'dentist' walks the LD branch", { .package = "pecotmr" ) res <- suppressWarnings(summaryStatsQc(ss, ldMismatchQcMethod = "dentist")) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$ldMismatchMethod, "dentist") expect_true("ldMismatchOutliersDropped" %in% names(ea)) }) @@ -3849,7 +3887,7 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { full_snp_ids <- paste0("rs", 1:8) full_positions <- seq(100L, by = 100L, length.out = 8L) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr( snp_ids = full_snp_ids[1:4], positions = full_positions[1:4] @@ -3881,7 +3919,7 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { impute = TRUE, imputeArgs = RaissParam(flank = 500) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) expect_equal(ea$raissImputedVariants, 2L) }) @@ -3900,7 +3938,7 @@ test_that("summaryStatsQc: impute scopes panel/dosage to the region", { cap <- new.env(parent = emptyenv()) cap$idx <- list() ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr( paste0("rs", 1:4), c(100L, 200L, 300L, 400L) @@ -3932,7 +3970,7 @@ test_that("summaryStatsQc: impute with a NULL raiss records 0 imputed", { full_snp_ids <- paste0("rs", 1:8) full_positions <- seq(100L, by = 100L, length.out = 8L) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr( snp_ids = full_snp_ids[1:4], positions = full_positions[1:4] @@ -3947,7 +3985,7 @@ test_that("summaryStatsQc: impute with a NULL raiss records 0 imputed", { .package = "pecotmr" ) res <- summaryStatsQc(ss, impute = TRUE) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$raissImputedVariants, 0L) }) @@ -4036,7 +4074,7 @@ test_that("summaryStatsQc: skipped steps are omitted from the rollup", { test_that("summaryStatsQc: QtlSumStats log lines carry the tuple label", { # Reuse the QtlSumStats fixture from the round-trip test. qss <- QtlSumStats( - study = "qstudy", + studyName = "qstudy", context = "qctx", trait = "qtrait", entry = list(.ssQ_makeEntryGr()), @@ -4109,31 +4147,31 @@ context("sumstatsQc internal helpers") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -4380,20 +4418,20 @@ test_that("summaryStatsQc: surfaces the sanity audit, honours the knobs", { S4Vectors::mcols(gr)$SE <- c(0.1, 0.1, 0.1, 0.1) S4Vectors::mcols(gr)$P <- c(0.5, 0.5, 0.5, 0.5) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() ) res <- summaryStatsQc(ss) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$sanityChecks$zeroEffectDropped, 2L) # Disable the knob: zero-effect rows should remain. res2 <- summaryStatsQc( ss, sumstatsCleaningArgs = SumstatsCleaningParam(dropZeroEffect = FALSE) ) - ea2 <- getQcInfo(res2)$entryAudit[[1L]] + ea2 <- qcInfo(res2)$entryAudit[[1L]] expect_null(ea2$sanityChecks$zeroEffectDropped) }) @@ -4718,7 +4756,7 @@ test_that(".applyLdMismatchQcToEntry: NA slalom outlier flags are kept", { # treating it as FALSE (current behavior) keeps them and yields a # finite outlier count. handle <- .ssh_makeHandle() - panel_ids <- as.character(getSnpInfo(handle)$SNP) + panel_ids <- as.character(snpInfo(handle)$SNP) vids <- panel_ids[seq_len(min(4L, length(panel_ids)))] df <- data.frame( SNP = vids, @@ -4836,7 +4874,7 @@ test_that("summaryStatsQc: absZ / bf / logBf screens skip a no-signal entry", { gr <- .ssQ_makeEntryGr() S4Vectors::mcols(gr)$Z <- rep(0.1, length(gr)) GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -4853,7 +4891,7 @@ test_that("summaryStatsQc: absZ / bf / logBf screens skip a no-signal entry", { !!!arg, sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) expect_equal(length(res[[1L]]), 0L) } @@ -4865,7 +4903,7 @@ test_that("summaryStatsQc: absZ screen keeps a strong marginal Z", { z[1] <- 8 S4Vectors::mcols(gr)$Z <- z ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -4875,7 +4913,7 @@ test_that("summaryStatsQc: absZ screen keeps a strong marginal Z", { signalScreenArgs = SignalScreenParam(absZ = 5), sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_false(isTRUE(ea$pipScreenSkipped)) expect_gt(length(res[[1L]]), 0L) }) @@ -5813,7 +5851,7 @@ test_that("autoDecision assigns SER for single CS", { test_that("summaryStatsQc: preserves nCase/nControl columns through QC", { gr <- .ssQ_makeEntryGr(paste0("rs", 1:4), c(100L, 200L, 300L, 400L)) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle(), @@ -6791,7 +6829,7 @@ test_that("summaryStatsQc: emit() drops the label for an empty study id", { # An empty study id resolves the per-entry label to NA, exercising the # unlabeled emit() branch. ss <- GwasSumStats( - study = "", + studyName = "", entry = list(.ssQ_makeEntryGr()), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -6810,7 +6848,7 @@ test_that("summaryStatsQc: the N filter emits its message and rollup", { gr <- .ssQ_makeEntryGr() S4Vectors::mcols(gr)$N <- c(1000L, 1010L, 1005L, 100000L) # last is an N outlier ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -6824,7 +6862,7 @@ test_that("summaryStatsQc: the N filter emits its message and rollup", { joined <- paste(msgs, collapse = "") expect_match(joined, "MAF/INFO/N filters kept") expect_match(joined, "nCutoff 1") - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$contentFilters$nDropped, 1L) }) @@ -6842,7 +6880,7 @@ test_that("summaryStatsQc: derives BETA/SE from Z+MAF+N, records it", { MAF = c(0.2, 0.3, 0.4, 0.25) ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -6851,7 +6889,7 @@ test_that("summaryStatsQc: derives BETA/SE from Z+MAF+N, records it", { ss, sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$betaSeFromZ$nDerived, 4L) }) @@ -6859,7 +6897,7 @@ test_that("summaryStatsQc: clamps tiny Z-derived P and audits it", { gr <- .ssQ_makeEntryGr() S4Vectors::mcols(gr)$Z <- c(50, 1, 2, 3) # |Z| = 50 underflows P to 0 ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -6868,7 +6906,7 @@ test_that("summaryStatsQc: clamps tiny Z-derived P and audits it", { ss, sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_true(!is.null(ea$sanityChecks$smallPClamped)) expect_gte(ea$sanityChecks$smallPClamped, 1L) }) @@ -6876,7 +6914,7 @@ test_that("summaryStatsQc: clamps tiny Z-derived P and audits it", { test_that("summaryStatsQc: early-exits below two pre-harmonization variants", { gr <- .ssQ_makeEntryGr(snp_ids = "rs1", positions = 100L) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -6885,7 +6923,7 @@ test_that("summaryStatsQc: early-exits below two pre-harmonization variants", { ss, sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_match(ea$earlyExit, "fewer than two variants") expect_equal(length(res[[1L]]), 1L) }) @@ -6896,7 +6934,7 @@ test_that("summaryStatsQc: kriging QC records its audit and rollup", { "installed susieR has no kriging_rss" ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(.ssQ_makeEntryGr( snp_ids = paste0("rs", 1:8), positions = seq(100L, by = 100L, length.out = 8L) @@ -6919,7 +6957,7 @@ test_that("summaryStatsQc: kriging QC records its audit and rollup", { joined <- paste(msgs, collapse = "") expect_match(joined, "kriging sign-flipped") expect_match(joined, "kriging-flip ") - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_true("krigingFlipped" %in% names(ea)) expect_true("krigingDiagnostics" %in% names(ea)) kd <- ea$krigingDiagnostics @@ -6946,7 +6984,7 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { SE = rep(0.1, 4) ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) @@ -6973,7 +7011,7 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { impute = TRUE, imputeArgs = RaissParam(flank = 500) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) expect_equal(ea$raissImputedVariants, 2L) mc <- S4Vectors::mcols(res[[1L]]) @@ -7094,7 +7132,7 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { SE = df$SE ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandle() @@ -7113,14 +7151,14 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { infoCutoff = 0.5, nCutoff = 3 ), - panelFilterArgs = PanelFilterParam(mafCutoff = 0.01) + panelFilterParam = PanelFilterParam(mafCutoff = 0.01) ) ) joined <- paste(msgs, collapse = "") # The chr99 variant lands in its own ELEMENT (entries are split by seqname # at construction), so the audit is now per (study, chromosome) and the # drop counts are summed across entries rather than read off entry 1. - audits <- getQcInfo(res)$entryAudit + audits <- qcInfo(res)$entryAudit tally <- function(section, field) { sum(unlist(map(map(audits, section), field))) } @@ -7312,7 +7350,7 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { # the row. corrExtractor <- function(handle, snpIdx, meanImpute = TRUE) { set.seed(42) - n <- length(getSampleIds(handle)) + n <- length(sampleIds(handle)) k <- length(snpIdx) f <- rnorm(n) # shared latent factor M <- exec( @@ -7322,26 +7360,26 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { }) ) rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) dosage <- t(M) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, colData = S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) ) } @@ -7356,7 +7394,7 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { mc$N <- rep(3000L, 8) S4Vectors::mcols(gr) <- mc ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = .ssQ_makeHandleVid(snp_n = 8L, n_samples = 300L) @@ -7373,7 +7411,7 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0) ) ) - ea <- getQcInfo(res)$entryAudit[[1L]] + ea <- qcInfo(res)$entryAudit[[1L]] expect_gte(ea$krigingFlipped, 1L) # at least one flipped expect_equal(length(res[[1L]]), 8L) # retained, not dropped # rs4's -15 flips to +15; its neighbours were +4, so every retained Z is now @@ -7391,7 +7429,7 @@ test_that(".subsetSketchToRange keeps panel variants in the entry span", { test_path("test_data/test_variants"), format = "plink2" ) - si <- getSnpInfo(h) + si <- snpInfo(h) ch <- names(sort(table(si$CHR), decreasing = TRUE))[1] # busiest chromosome chIdx <- which(si$CHR == ch) slice <- si[chIdx[seq_len(min(30L, length(chIdx)))], , drop = FALSE] @@ -7400,7 +7438,7 @@ test_that(".subsetSketchToRange keeps panel variants in the entry span", { IRanges::IRanges(as.integer(slice$BP), width = 1L) ) S4Vectors::mcols(gr)$SNP <- slice$SNP - sub <- getSnpInfo(pecotmr:::.subsetSketchToRange(h, list(gr))) + sub <- snpInfo(pecotmr:::.subsetSketchToRange(h, list(gr))) lo <- min(slice$BP) hi <- max(slice$BP) expected <- si$SNP[ @@ -7417,14 +7455,14 @@ test_that(".subsetSketchToIds keeps exactly the entries' variants", { test_path("test_data/test_variants"), format = "plink2" ) - si <- getSnpInfo(h) + si <- snpInfo(h) sel <- c(3L, 10L, 40L, 200L) gr <- GenomicRanges::GRanges( paste0("chr", si$CHR[sel]), IRanges::IRanges(as.integer(si$BP[sel]), width = 1L) ) S4Vectors::mcols(gr)$SNP <- si$SNP[sel] - sub <- getSnpInfo(pecotmr:::.subsetSketchToIds(h, list(gr))) + sub <- snpInfo(pecotmr:::.subsetSketchToIds(h, list(gr))) expect_setequal( normalizeVariantId(sub$SNP), normalizeVariantId(si$SNP[sel]) @@ -7454,7 +7492,7 @@ test_that(".subsetSketchToRange / .subsetSketchToIds are NULL-safe", { # order -- the ground truth the filter is checked against. .ssqcPanelMaf <- function(handle) { afreq <- readAfreq(.ssqcPanelStem()) - ids <- as.character(getSnpInfo(handle)$SNP) + ids <- as.character(snpInfo(handle)$SNP) altFreq <- afreq$alt_freq[match(ids, afreq$id)] pmin(altFreq, 1 - altFreq) } @@ -7463,7 +7501,7 @@ test_that(".subsetSketchToRange / .subsetSketchToIds are NULL-safe", { # common in the study whatever the panel says, so only a panel-side filter can # remove it. .ssqcPanelSumStats <- function(handle) { - si <- getSnpInfo(handle) + si <- snpInfo(handle) gr <- GenomicRanges::GRanges( seqnames = paste0("chr", si$CHR), ranges = IRanges::IRanges(start = as.integer(si$BP), width = 1L) @@ -7478,7 +7516,7 @@ test_that(".subsetSketchToRange / .subsetSketchToIds are NULL-safe", { AF = rep(0.30, nrow(si)) ) GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = handle @@ -7488,7 +7526,7 @@ test_that(".subsetSketchToRange / .subsetSketchToIds are NULL-safe", { test_that(".ssqcPrunePanel drops exactly the sub-cutoff panel variants", { skip_if_not_installed("pgenlibr") h <- .ssqcPanelHandle() - ids <- as.character(getSnpInfo(h)$SNP) + ids <- as.character(snpInfo(h)$SNP) maf <- .ssqcPanelMaf(h) cutoff <- stats::median(maf, na.rm = TRUE) pruned <- expect_message( @@ -7499,7 +7537,7 @@ test_that(".ssqcPrunePanel drops exactly the sub-cutoff panel variants", { ), "below the LD-panel MAF / MAC / missingness cutoffs" ) - keptIds <- as.character(getSnpInfo(pruned)$SNP) + keptIds <- as.character(snpInfo(pruned)$SNP) expect_lt(length(keptIds), length(ids)) expect_setequal(keptIds, ids[!is.na(maf) & maf >= cutoff]) }) @@ -7521,7 +7559,7 @@ test_that(".ssqcPrunePanel prunes the RSE sketch's seed handle, not the view", { # the seed -- the real-flow shape the bare-handle tests do not exercise. h <- .ssqcPanelHandle() maf <- .ssqcPanelMaf(h) - ids <- as.character(getSnpInfo(h)$SNP) + ids <- as.character(snpInfo(h)$SNP) cutoff <- stats::median(maf, na.rm = TRUE) rse <- pecotmr:::.genotypeExperiment(h) expect_s4_class(rse, "RangedSummarizedExperiment") @@ -7532,7 +7570,7 @@ test_that(".ssqcPrunePanel prunes the RSE sketch's seed handle, not the view", { )) seed <- pecotmr:::.ldSketchHandle(pruned) expect_setequal( - as.character(getSnpInfo(seed)$SNP), + as.character(snpInfo(seed)$SNP), ids[!is.na(maf) & maf >= cutoff] ) }) @@ -7549,16 +7587,16 @@ test_that("summaryStatsQc: mafCutoff drops panel-rare observed variants", { out <- suppressMessages(summaryStatsQc( ss, sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0), - panelFilterArgs = PanelFilterParam(mafCutoff = cutoff) + panelFilterParam = 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 # read keys off, not just the row view -- holds no sub-cutoff variant. - seed <- pecotmr:::.ldSketchHandle(getLdSketch(out)) + seed <- pecotmr:::.ldSketchHandle(ldSketch(out)) keptMaf <- maf[match( - as.character(getSnpInfo(seed)$SNP), - as.character(getSnpInfo(h)$SNP) + as.character(snpInfo(seed)$SNP), + as.character(snpInfo(h)$SNP) )] expect_true(all(keptMaf >= cutoff)) }) @@ -7570,14 +7608,14 @@ test_that("summaryStatsQc: macCutoff is the stricter of MAF / MAC", { ss <- .ssqcPanelSumStats(h) # MAC expressed per panel sample: 2 * nSamples * mafEquivalent. cutoff <- stats::median(maf, na.rm = TRUE) - mac <- ceiling(cutoff * 2 * getNSamples(h)) + mac <- ceiling(cutoff * 2 * nSamples(h)) out <- suppressMessages(summaryStatsQc( ss, sumstatsFilterArgs = SumstatsFilterParam(nCutoff = 0), - panelFilterArgs = PanelFilterParam(macCutoff = mac) + panelFilterParam = PanelFilterParam(macCutoff = mac) )) entry <- pecotmr:::.collectionEntry(out, 1) - expected <- sum(!is.na(maf) & maf >= mac / (2 * getNSamples(h))) + expected <- sum(!is.na(maf) & maf >= mac / (2 * nSamples(h))) expect_equal(length(entry), expected) }) @@ -7591,7 +7629,7 @@ test_that("summaryStatsQc: the panel filter is off by default", { )) expect_equal( length(pecotmr:::.collectionEntry(out, 1)), - nrow(getSnpInfo(h)) + nrow(snpInfo(h)) ) }) @@ -7600,28 +7638,28 @@ test_that("summaryStatsQc validates the panel cutoffs before any panel read", { expect_error( summaryStatsQc( ss, - panelFilterArgs = PanelFilterParam(mafCutoff = -1) + panelFilterParam = PanelFilterParam(mafCutoff = -1) ), "mafCutoff" ) expect_error( summaryStatsQc( ss, - panelFilterArgs = PanelFilterParam(macCutoff = c(1, 2)) + panelFilterParam = PanelFilterParam(macCutoff = c(1, 2)) ), "macCutoff" ) expect_error( summaryStatsQc( ss, - panelFilterArgs = PanelFilterParam(imissCutoff = NA_real_) + panelFilterParam = PanelFilterParam(imissCutoff = NA_real_) ), "imissCutoff" ) expect_error( summaryStatsQc( ss, - panelFilterArgs = PanelFilterParam(macCutoff = Inf) + panelFilterParam = PanelFilterParam(macCutoff = Inf) ), "macCutoff" ) @@ -7765,10 +7803,10 @@ test_that("summaryStatsQc imputeArgs cutoffs bound what RAISS imputes", { gss <- gwasSumStatsS4Example variants <- unlist(gss) thin <- GwasSumStats( - study = getStudy(gss), + studyName = studyName(gss), entry = list(variants[seq(1L, length(variants), by = 4L)]), - genome = getGenome(gss), - ldSketch = getLdSketch(gss) + genome = unique(unname(GenomeInfoDb::genome(gss))), + ldSketch = ldSketch(gss) ) nObserved <- sum(lengths(thin)) # The bundled toy panel imputes poorly, so the R2 gate would otherwise @@ -8069,8 +8107,8 @@ test_that("emptying drops both axes but keeps the panel's identity", { expect_equal(ncol(e), 0L) hh <- .ldSketchHandle(h) eh <- .ldSketchHandle(e) - expect_equal(getFormat(eh), getFormat(hh)) - expect_equal(getPath(eh), getPath(hh)) + expect_equal(genotypeFormat(eh), genotypeFormat(hh)) + expect_equal(path(eh), path(hh)) }) test_that(".emptySketch drops the seed's variants, not just the rows", { @@ -8080,7 +8118,7 @@ test_that(".emptySketch drops the seed's variants, not just the rows", { h <- .sk_panel() e <- .emptySketch(h) expect_equal(nrow(e), 0L) - expect_equal(nrow(getSnpInfo(.ldSketchHandle(e))), 0L) + expect_equal(nrow(snpInfo(.ldSketchHandle(e))), 0L) expect_lt( length(serialize(e, NULL)), length(serialize(h, NULL)) / 2 diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 28a5e931..5c41bc0d 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -63,7 +63,7 @@ test_that(".tupleSelectRow: zero-row input errors with the class label", { expect_error( pecotmr:::.tupleSelectRow( empty, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -109,7 +109,7 @@ test_that(".tupleSelectRow: non-scalar selectors error", { expect_error( pecotmr:::.tupleSelectRow( multi, - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = "c1", trait = "t1", method = "susie" @@ -129,7 +129,7 @@ test_that(".tupleSelectRow: matching tuple returns first row index", { expect_equal( pecotmr:::.tupleSelectRow( multi, - study = "s1", + studyName = "s1", context = "c2", trait = "t1", method = "susie" @@ -149,7 +149,7 @@ test_that(".tupleSelectRow: missing tuple errors with the 4-tuple in the message expect_error( pecotmr:::.tupleSelectRow( multi, - study = "ghost", + studyName = "ghost", context = "c1", trait = "t1", method = "susie" @@ -170,7 +170,7 @@ test_that(".tupleSelectRowGwasFmr: zero-row input errors", { stringsAsFactors = FALSE ) expect_error( - pecotmr:::.tupleSelectRowGwasFmr(empty, study = "g1", method = "susie"), + pecotmr:::.tupleSelectRowGwasFmr(empty, studyName = "g1", method = "susie"), "GwasFineMappingResult has no rows" ) }) @@ -208,7 +208,7 @@ test_that(".tupleSelectRowGwasFmr: non-scalar region errors", { expect_error( pecotmr:::.tupleSelectRowGwasFmr( multi, - study = "g1", + studyName = "g1", method = "susie", region = c("r1", "r2") ), @@ -227,7 +227,7 @@ test_that(".tupleSelectRowGwasFmr: region disambiguates per-block rows", { expect_equal( pecotmr:::.tupleSelectRowGwasFmr( multi, - study = "g1", + studyName = "g1", method = "susie", region = "chr22_500_600" ), @@ -245,7 +245,7 @@ test_that(".tupleSelectRowGwasFmr: missing tuple errors and includes region in m expect_error( pecotmr:::.tupleSelectRowGwasFmr( one, - study = "g1", + studyName = "g1", method = "susie", region = "ghost" ), @@ -263,7 +263,7 @@ test_that(".tupleSelectRowGwasFmr: ambiguous multi-match (no region) lists candi stringsAsFactors = FALSE ) expect_error( - pecotmr:::.tupleSelectRowGwasFmr(multi, study = "g1", method = "susie"), + pecotmr:::.tupleSelectRowGwasFmr(multi, studyName = "g1", method = "susie"), "pass `region` to disambiguate" ) }) @@ -291,7 +291,7 @@ test_that(".fmrRowsMatching: matches a subset without erroring on ambiguity", { method = c("susie", "susie", "susie"), stringsAsFactors = FALSE ) - expect_equal(pecotmr:::.fmrRowsMatching(df, study = "s1"), c(1L, 2L)) + expect_equal(pecotmr:::.fmrRowsMatching(df, studyName = "s1"), c(1L, 2L)) expect_equal(pecotmr:::.fmrRowsMatching(df, context = "c1"), c(1L, 3L)) }) @@ -326,7 +326,7 @@ test_that(".fmrRowsMatching: a vector selector matches any listed value", { stringsAsFactors = FALSE ) expect_equal( - pecotmr:::.fmrRowsMatching(df, study = c("s1", "s3")), + pecotmr:::.fmrRowsMatching(df, studyName = c("s1", "s3")), c(1L, 3L) ) }) @@ -555,7 +555,7 @@ test_that("chromosome paths union when they agree and abort when they clash", { # =========================================================================== test_that("an empty collection coerces to itself, not to a row", { - # getFineMappingResult() hands over a single-row COLLECTION, so the + # fineMappingResult() hands over a single-row COLLECTION, so the # coercion has to accept that shape -- but an empty one has no row to # extract and must come back untouched. data(qtlFineMappingExample, twasWeightsExample) diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index 7225b2e0..19c952c0 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -26,14 +26,14 @@ makeData <- function(n = 50, p = 10, seed = 42, add_zero_var_col = FALSE) { list(X = X, Y = Y, beta = beta) } -makeFakeSusieFit <- function(p = 10, L = 3, inf = FALSE) { +makeFakeSusieFit <- function(p = 10, maxNumSingleEffects = 3, inf = FALSE) { fit <- list( - alpha = matrix(1 / p, nrow = L, ncol = p), - mu = matrix(0, nrow = L, ncol = p), - lbf_variable = matrix(0, nrow = L, ncol = p), + alpha = matrix(1 / p, nrow = maxNumSingleEffects, ncol = p), + mu = matrix(0, nrow = maxNumSingleEffects, ncol = p), + lbf_variable = matrix(0, nrow = maxNumSingleEffects, ncol = p), X_column_scale_factors = rep(1, p), pip = rep(0.1, p), - V = rep(0.5, L), + V = rep(0.5, maxNumSingleEffects), sets = list(cs = NULL, purity = NULL) ) if (inf) { @@ -47,7 +47,7 @@ mockSusie <- function(...) { L <- if (is.null(args$L)) 3 else args$L makeFakeSusieFit( ncol(args$X), - L = L, + maxNumSingleEffects = L, inf = identical(args$unmappable_effects, "inf") ) } @@ -66,15 +66,15 @@ mockSusie <- function(...) { } # The entry is a derived view now: ask the collection for it rather than # reaching into a stored `entry` column that no longer exists. - entry <- getTwasWeights( + entry <- twasWeights( tw, - study = as.character(tw$study)[[idx[[1L]]]], + studyName = as.character(tw$study)[[idx[[1L]]]], context = as.character(tw$context)[[idx[[1L]]]], trait = as.character(tw$trait)[[idx[[1L]]]], method = shortName ) - w <- getWeights(entry) - vids <- getVariantIds(entry) + w <- weights(entry) + vids <- variantIds(entry) if (is.numeric(w) && is.null(dim(w))) { nm <- names(w) if (is.null(nm) && length(vids) == length(w)) { @@ -331,7 +331,7 @@ test_that("twasWeights: Y as vector gets converted to matrix internally", { weightMethods = list(lasso_weights = list()) ) expect_true(is(result, "TwasWeights")) - expect_equal(length(getMethodNames(result)), 1) + expect_equal(length(methodNames(result)), 1) expect_equal(nrow(.weightsByMethod(result, "lassoWeights")), ncol(d$X)) # Weight vector length must equal number of predictors and be numeric/finite w <- .weightsByMethod(result, "lassoWeights")[, 1] @@ -357,7 +357,7 @@ test_that("twasWeights: character weight_methods input is accepted", { # Short name should be resolved via .twas_method_lookup result <- learnTwasWeights(d$X, d$Y, weightMethods = c("lasso")) expect_true(is(result, "TwasWeights")) - expect_equal(getMethodNames(result), "lasso") + expect_equal(methodNames(result), "lasso") }) test_that("twasWeights: zero variance columns are filtered and padded back with zeros", { @@ -429,9 +429,9 @@ test_that("twasWeights: multiple methods return named list with one entry per me d$Y, weightMethods = list(lasso_weights = list(), enetWeights = list()) ) - expect_equal(length(getMethodNames(result)), 2) - expect_true("lasso" %in% getMethodNames(result)) - expect_true("enet" %in% getMethodNames(result)) + expect_equal(length(methodNames(result)), 2) + expect_true("lasso" %in% methodNames(result)) + expect_true("enet" %in% methodNames(result)) }) # =========================================================================== @@ -450,7 +450,7 @@ test_that("twasWeights: lassoWeights produces correct structure with real glmnet ) expect_true(is(result, "TwasWeights")) - expect_equal(getMethodNames(result), "lasso") + expect_equal(methodNames(result), "lasso") expect_equal(nrow(.weightsByMethod(result, "lassoWeights")), ncol(d$X)) expect_equal(ncol(.weightsByMethod(result, "lassoWeights")), 1) # At least some weights should be non-zero for this strong signal @@ -467,7 +467,7 @@ test_that("twasWeights: enetWeights produces correct structure with real glmnet" ) expect_true(is(result, "TwasWeights")) - expect_equal(getMethodNames(result), "enet") + expect_equal(methodNames(result), "enet") expect_equal(nrow(.weightsByMethod(result, "enetWeights")), ncol(d$X)) }) @@ -656,7 +656,7 @@ test_that("learnTwasWeights resolves fits under camelCase method names", { d$X, as.numeric(d$Y), weightMethods = list(susie_weights = list()), - fittedModels = list(susie = makeFakeSusieFit(p = 10, L = 5)) + fittedModels = list(susie = makeFakeSusieFit(p = 10, maxNumSingleEffects = 5)) ) expect_true("susie" %in% class(seen)) }) @@ -676,11 +676,11 @@ test_that("learnTwasWeights runs susie + susieInf from supplied fits", { susie_inf_weights = list() ), fittedModels = list( - susie = makeFakeSusieFit(p = 10, L = 5), - susieInf = makeFakeSusieFit(p = 10, L = 7, inf = TRUE) + susie = makeFakeSusieFit(p = 10, maxNumSingleEffects = 5), + susieInf = makeFakeSusieFit(p = 10, maxNumSingleEffects = 7, inf = TRUE) ) ) - expect_equal(getMethodNames(result), c("susie", "susie_inf")) + expect_equal(methodNames(result), c("susie", "susie_inf")) }) @@ -948,7 +948,7 @@ test_that("TwasWeights: builds a collection keyed by 4-tuple", { e1 <- .sc_makeTwasWeightsRow() e2 <- .sc_makeTwasWeightsRow() tw <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "enet"), @@ -956,22 +956,22 @@ test_that("TwasWeights: builds a collection keyed by 4-tuple", { ) expect_s4_class(tw, "TwasWeights") expect_equal(nrow(tw), 2L) - expect_setequal(getMethodNames(tw), c("lasso", "enet")) + expect_setequal(methodNames(tw), c("lasso", "enet")) }) -test_that("TwasWeights: getStudy / getContexts / getTraits / getMethodNames", { +test_that("TwasWeights: studyName / contexts / traitNames / methodNames", { e <- .sc_makeTwasWeightsRow() tw <- TwasWeights( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("lasso", "lasso"), entry = list(e, e) ) - expect_setequal(getContexts(tw), c("c1", "c2")) - expect_equal(getTraits(tw), "t1") - expect_equal(getMethodNames(tw), "lasso") + expect_setequal(contexts(tw), c("c1", "c2")) + expect_equal(traitNames(tw), "t1") + expect_equal(methodNames(tw), "lasso") }) @@ -979,7 +979,7 @@ test_that("TwasWeights: rejects duplicate 4-tuples", { e <- .sc_makeTwasWeightsRow() expect_error( TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "lasso"), @@ -994,7 +994,7 @@ test_that("TwasWeights: joint columns work the same as on the FMR class", { e <- .sc_makeTwasWeightsRow() # Univariate lasso at c1 + the c1 slice of an mr.mash joint over (c1, c2). tw <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "mrmash"), @@ -1006,7 +1006,7 @@ test_that("TwasWeights: joint columns work the same as on the FMR class", { # uniqueness: same (s1, c1, t1, mrmash) tuple from two joint fits over # (c1, c2) and (c1, c3) -> distinct rows via jointContexts. tw2 <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("mrmash", "mrmash"), @@ -1017,21 +1017,21 @@ test_that("TwasWeights: joint columns work the same as on the FMR class", { }) -test_that("TwasWeights: getTwasWeights extracts the entry for a tuple", { +test_that("TwasWeights: twasWeights extracts the entry for a tuple", { e1 <- .sc_makeTwasWeightsRow() e2 <- .sc_makeTwasWeightsRow() tw <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "enet"), entry = list(e1, e2) ) - # getTwasWeights() returns the single-row COLLECTION for that tuple, not a + # twasWeights() returns the single-row COLLECTION for that tuple, not a # detached entry object, so compare what the row carries. - picked <- getTwasWeights( + picked <- twasWeights( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "enet" @@ -1039,8 +1039,8 @@ test_that("TwasWeights: getTwasWeights extracts the entry for a tuple", { expect_s4_class(picked, "TwasWeights") expect_equal(nrow(picked), 1L) expect_equal(as.character(picked$method), "enet") - expect_identical(getVariantIds(picked), .twrPartsVariantIds(e2)) - expect_equal(unname(getWeights(picked)), unname(getWeights(e2))) + expect_identical(variantIds(picked), .twrPartsVariantIds(e2)) + expect_equal(unname(weights(picked)), unname(weights(e2))) }) # =========================================================================== @@ -1052,7 +1052,7 @@ test_that("TwasWeights: getTwasWeights extracts the entry for a tuple", { test_that("show.TwasWeights prints entry/study/context/trait/method counts", { e <- .sh_makeTwEntry() tw <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("lasso", "enet"), @@ -1067,7 +1067,7 @@ test_that("show.TwasWeights prints entry/study/context/trait/method counts", { test_that("show.TwasWeights reports ldSketch when present", { e <- .sh_makeTwEntry() tw <- TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso", @@ -1223,7 +1223,7 @@ test_that("TwasWeights: mismatched core-vector lengths error", { e <- .sc_makeTwasWeightsRow() expect_error( TwasWeights( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = "c1", trait = "t1", method = "lasso", @@ -1237,7 +1237,7 @@ test_that("TwasWeights: joint* column length must match study", { e <- .sc_makeTwasWeightsRow() expect_error( TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso", @@ -1248,45 +1248,45 @@ test_that("TwasWeights: joint* column length must match study", { ) }) -test_that("TwasWeights: getStandardized/getDataType/getVariantIds delegate to the entry", { +test_that("TwasWeights: weightStandardized/weightsDataType/variantIds delegate to the entry", { e1 <- twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rnorm(4), - standardized = TRUE, - dataType = "expression" + weightStandardized = TRUE, + weightsDataType = "expression" ) e2 <- twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rnorm(4), - standardized = FALSE, - dataType = "splicing" + weightStandardized = FALSE, + weightsDataType = "splicing" ) tw <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "enet"), entry = list(e1, e2) ) - expect_true(getStandardized( + expect_true(weightStandardized( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso" )) - expect_false(getStandardized( + expect_false(weightStandardized( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "enet" )) expect_equal( - getDataType( + weightsDataType( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "enet" @@ -1294,9 +1294,9 @@ test_that("TwasWeights: getStandardized/getDataType/getVariantIds delegate to th "splicing" ) expect_equal( - getVariantIds( + variantIds( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso" @@ -1305,24 +1305,24 @@ test_that("TwasWeights: getStandardized/getDataType/getVariantIds delegate to th ) }) -test_that("TwasWeights: getStudy returns unique study labels", { +test_that("TwasWeights: studyName returns unique study labels", { e <- .sc_makeTwasWeightsRow() tw <- TwasWeights( - study = c("s1", "s2"), + studyName = c("s1", "s2"), context = c("c1", "c2"), trait = c("t1", "t1"), method = c("lasso", "lasso"), entry = list(e, e) ) - expect_setequal(getStudy(tw), c("s1", "s2")) + expect_setequal(studyName(tw), c("s1", "s2")) }) -test_that("TwasWeights: getWeights/getCvResult/getFits/getLdSketch delegate per tuple", { +test_that("TwasWeights: weights/cvResult/methodFits/ldSketch delegate per tuple", { w1 <- rnorm(4) e1 <- twasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = w1, - fits = list(tag = "fitA"), + methodFits = list(tag = "fitA"), cvResult = list(rsq = 0.42) ) e2 <- twasWeightsRow( @@ -1330,7 +1330,7 @@ test_that("TwasWeights: getWeights/getCvResult/getFits/getLdSketch delegate per weights = rnorm(4) ) tw <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "enet"), @@ -1339,9 +1339,9 @@ test_that("TwasWeights: getWeights/getCvResult/getFits/getLdSketch delegate per ) expect_equal( - getWeights( + weights( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso" @@ -1349,9 +1349,9 @@ test_that("TwasWeights: getWeights/getCvResult/getFits/getLdSketch delegate per w1 ) expect_equal( - getCvResult( + cvResult( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso" @@ -1359,16 +1359,16 @@ test_that("TwasWeights: getWeights/getCvResult/getFits/getLdSketch delegate per 0.42 ) expect_equal( - getFits( + methodFits( tw, - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso" )$tag, "fitA" ) - expect_s4_class(getLdSketch(tw), "RangedSummarizedExperiment") + expect_s4_class(ldSketch(tw), "RangedSummarizedExperiment") }) # =========================================================================== @@ -1391,8 +1391,8 @@ test_that(".resolveMethodFunction: unresolvable key falls back to the key itself # =========================================================================== test_that(".prepareSusieWeightMethods writes supplied fits onto the method args", { - infFit <- makeFakeSusieFit(p = 8, L = 3, inf = TRUE) - susieFit <- makeFakeSusieFit(p = 8, L = 5) + infFit <- makeFakeSusieFit(p = 8, maxNumSingleEffects = 3, inf = TRUE) + susieFit <- makeFakeSusieFit(p = 8, maxNumSingleEffects = 5) wm <- pecotmr:::.prepareSusieWeightMethods( weightMethods = list( @@ -1628,7 +1628,7 @@ test_that("learnTwasWeights: parallel weights path (numThreads = 2)", { numThreads = 2 )) expect_true(is(result, "TwasWeights")) - expect_setequal(getMethodNames(result), c("lasso", "enet")) + expect_setequal(methodNames(result), c("lasso", "enet")) }) # =========================================================================== @@ -1651,7 +1651,7 @@ test_that("twasPredict: accepts a TwasWeights S4 collection", { weights = w2 ) tw <- TwasWeights( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("lasso", "enet"), @@ -1806,8 +1806,11 @@ 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'" + exec( + learnTwasWeights, + !!!list_modify(base, !!!list(studyName = 1L)) + ), + "studyName.*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. @@ -1816,13 +1819,16 @@ test_that("learnTwasWeights: argument guards fire", { d$X, d$Y, weightMethods = list(), - standardized = NULL + weightStandardized = NULL ), - "standardized.*Must be of type 'logical flag'" + "weightStandardized.*Must be of type 'logical flag'" ) expect_error( - exec(learnTwasWeights, !!!list_modify(base, !!!list(dataType = 1L))), - "dataType.*Must be of type 'string'" + exec( + learnTwasWeights, + !!!list_modify(base, !!!list(weightsDataType = 1L)) + ), + "weightsDataType.*Must be of type 'string'" ) expect_error( exec( diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index e638f6bb..cb10da74 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -84,7 +84,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") contexts ) QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = phen, genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -95,31 +95,31 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) panel <- matrix( - rbinom(n_samples * nrow(getSnpInfo(handle)), 2, 0.3), + rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(getSnpInfo(handle)), - dimnames = list(getSampleIds(handle), getSnpInfo(handle)$SNP) + ncol = nrow(snpInfo(handle)), + dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) ) sub <- panel[, snpIdx, drop = FALSE] rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", getSnpInfo(handle)$CHR[snpIdx]), + seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), ranges = IRanges::IRanges( - start = getSnpInfo(handle)$BP[snpIdx], + start = snpInfo(handle)$BP[snpIdx], width = 1L ) ) S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = getSnpInfo(handle)$SNP[snpIdx], - A1 = getSnpInfo(handle)$A1[snpIdx], - A2 = getSnpInfo(handle)$A2[snpIdx] + SNP = snpInfo(handle)$SNP[snpIdx], + A1 = snpInfo(handle)$A1[snpIdx], + A2 = snpInfo(handle)$A2[snpIdx] ) cd <- S4Vectors::DataFrame( - sampleId = getSampleIds(handle), - row.names = getSampleIds(handle) + sampleId = sampleIds(handle), + row.names = sampleIds(handle) ) dosage <- t(sub) - rownames(dosage) <- getSnpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- getSampleIds(handle) + rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] + colnames(dosage) <- sampleIds(handle) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), rowRanges = rr, @@ -133,14 +133,14 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") # loop pulls these via .twasFineMappingFits() and threads them into the # corresponding *Weights wrapper as susieFit / susieInfFit / mvsusieFit / etc. .tp_makeStubFineMappingResult <- function( - study = "study1", + studyName = "study1", contexts = "brain", traits = "ENSG_A", method = "susie", fitPayload = NULL ) { rows <- expand.grid( - study = study, + study = studyName, context = contexts, trait = traits, method = method, @@ -167,7 +167,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") }) if ("brain" %in% rows$context || any(rows$context != "")) { QtlFineMappingResult( - study = rows$study, + studyName = rows$study, context = rows$context, trait = rows$trait, method = rows$method, @@ -175,7 +175,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") ) } else { GwasFineMappingResult( - study = rows$study, + studyName = rows$study, method = rows$method, entry = entries ) @@ -232,14 +232,14 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" expect_s4_class(res, "TwasWeights") # 1 context x 2 traits x 2 methods = 4 rows. expect_equal(nrow(res), 4L) - expect_setequal(getMethodNames(res), c("lasso", "enet")) - expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) + expect_setequal(methodNames(res), c("lasso", "enet")) + expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) # Provenance, aligned per row (.tp_makeSe: ENSG_A -> chr1:1000-1499, # ENSG_B -> chr1:2000-2499). traitPos = the bare trait position (no # cis-window); region = that position expanded by cisWindow (1000), start # clamped at 1. - reg <- getRegion(res) - tp <- getTraitPosition(res) + reg <- genomicRegion(res) + tp <- traitPosition(res) expect_s4_class(reg, "GRanges") expect_s4_class(tp, "GRanges") expect_equal(length(reg), 4L) @@ -281,9 +281,9 @@ test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tight )) } vcount <- function(res) { - length(getWeights( + length(weights( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "lasso" @@ -295,14 +295,14 @@ test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tight # 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( - genotypeFilterArgs = GenotypeFilterParam(mafCutoff = 0.25) + genotypeFilterParam = 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(genotypeFilterArgs = GenotypeFilterParam(xvarCutoff = 0)), + call(genotypeFilterParam = GenotypeFilterParam(xvarCutoff = 0)), "TwasWeights" ) }) @@ -326,7 +326,7 @@ test_that("twasWeightsPipeline(QtlDataset): contexts filter restricts the per-co ensembleArgs = EnsembleParam() ) ) - expect_setequal(getContexts(res), "brain") + expect_setequal(contexts(res), "brain") expect_equal(nrow(res), 1L) }) @@ -393,7 +393,7 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { traits <- rep("t1", n_entries) entries <- map(seq_len(n_entries), function(.) .tp_makeSumstatsEntry()) QtlSumStats( - study = studies, + studyName = studies, context = contexts, trait = traits, entry = entries, @@ -430,7 +430,7 @@ test_that("twasWeightsPipeline(QtlSumStats): runs end-to-end with mocked solvers )) expect_s4_class(res, "TwasWeights") expect_equal(nrow(res), 2L) - expect_setequal(getMethodNames(res), c("mrash", "lasso")) + expect_setequal(methodNames(res), c("mrash", "lasso")) }) test_that("twasWeightsPipeline(QtlSumStats): un-QCd input is rejected", { @@ -486,7 +486,7 @@ test_that("twasWeightsPipeline( # Provide a stub FineMappingResult so the gate passes; the multivariate # guard is what we want to exercise here. fmr <- .tp_makeStubFineMappingResult( - study = "s1", + studyName = "s1", contexts = "c1", traits = "t1", method = "mvsusie" @@ -548,7 +548,7 @@ test_that("gate: mvsusie without fineMappingResult errors (QtlDataset)", { test_that("gate: fsusie now has a TWAS-weight extractor (accepted with FMR)", { fmr <- .tp_makeStubFineMappingResult( - study = "study1", + studyName = "study1", contexts = c("brain", "liver"), traits = "ENSG_A", method = "fsusie" @@ -569,7 +569,7 @@ test_that("gate: fsusie now has a TWAS-weight extractor (accepted with FMR)", { test_that("gate: fsusie on QtlSumStats delegates to .fmCheckMethodCapabilities", { ss <- .tp_makeQtlSumStats() fmr <- .tp_makeStubFineMappingResult( - study = "s1", + studyName = "s1", contexts = "c1", traits = "t1", method = "fsusie" @@ -608,7 +608,7 @@ test_that("gate: unknown method tokens still error with full menu", { test_that("gate: QtlDataset + susie + fineMappingResult threads the susieFit", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") fmr <- .tp_makeStubFineMappingResult( - study = "study1", + studyName = "study1", contexts = "brain", traits = "ENSG_A", method = "susie" @@ -636,14 +636,14 @@ test_that("gate: QtlDataset + susie + fineMappingResult threads the susieFit", { )) expect_s4_class(res, "TwasWeights") expect_equal(nrow(res), 1L) - expect_setequal(getMethodNames(res), "susie") + expect_setequal(methodNames(res), "susie") expect_true(sawFit) }) test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit", { ss <- .tp_makeQtlSumStats() fmr <- .tp_makeStubFineMappingResult( - study = "s1", + studyName = "s1", contexts = "c1", traits = "t1", method = "susie" @@ -669,14 +669,14 @@ test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit )) expect_s4_class(res, "TwasWeights") expect_equal(nrow(res), 1L) - expect_setequal(getMethodNames(res), "susie") + expect_setequal(methodNames(res), "susie") expect_equal(fitsSeen, 1L) }) test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAshRssFit", { ss <- .tp_makeQtlSumStats() fmr <- .tp_makeStubFineMappingResult( - study = "s1", + studyName = "s1", contexts = "c1", traits = "t1", method = "susieAsh" @@ -700,7 +700,7 @@ test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAsh )) expect_s4_class(res, "TwasWeights") expect_equal(nrow(res), 1L) - expect_setequal(getMethodNames(res), "susieAsh") + expect_setequal(methodNames(res), "susieAsh") expect_true(sawFit) }) @@ -710,7 +710,7 @@ test_that("gate: missing matching tuple in fineMappingResult warns and skips", { # the gate passes (any fine-mapping fit present satisfies the object # check), but the per-tuple lookup finds nothing and warns. fmr <- .tp_makeStubFineMappingResult( - study = "other_study", + studyName = "other_study", contexts = "other_ctx", traits = "other_trait", method = "susie" @@ -747,7 +747,7 @@ test_that("twasWeightsPipeline( )", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") fmr <- .tp_makeStubFineMappingResult( - study = "study1", + studyName = "study1", contexts = c("brain", "liver"), traits = "ENSG_A", method = "mvsusie" @@ -783,9 +783,9 @@ test_that("twasWeightsPipeline( expect_s4_class(res, "TwasWeights") # Joint fit on 2 contexts x 1 trait -> 2 rows back, one per (context, trait). expect_equal(nrow(res), 2L) - expect_setequal(getContexts(res), c("brain", "liver")) - expect_setequal(getTraits(res), "ENSG_A") - expect_setequal(getMethodNames(res), "mvsusie") + expect_setequal(contexts(res), c("brain", "liver")) + expect_setequal(traitNames(res), "ENSG_A") + expect_setequal(methodNames(res), "mvsusie") expect_gte(mvCalls, 1L) }) @@ -820,9 +820,9 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 tra expect_s4_class(res, "TwasWeights") # 2 contexts x 2 traits = 4 output rows. expect_equal(nrow(res), 4L) - expect_setequal(getContexts(res), c("brain", "liver")) - expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) - expect_setequal(getMethodNames(res), "mrmash") + expect_setequal(contexts(res), c("brain", "liver")) + expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) + expect_setequal(methodNames(res), "mrmash") }) test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the fits slot", { @@ -880,9 +880,9 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the ensembleArgs = EnsembleParam() ) )) - fit <- getFits( + fit <- methodFits( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "mrmash" @@ -910,7 +910,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the .tp_makeSumstatsEntry(snp_ids = snp_ids, positions = positions) }) QtlSumStats( - study = rep("s1", n), + studyName = rep("s1", n), context = contexts, trait = rep("t1", n), entry = entries, @@ -923,7 +923,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns one row per context", { ss <- .tp_makeMultiCtxQtlSumStats(contexts = c("c1", "c2")) fmr <- .tp_makeStubFineMappingResult( - study = "s1", + studyName = "s1", contexts = c("c1", "c2"), traits = "t1", method = "mvsusie" @@ -958,9 +958,9 @@ test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns o expect_s4_class(res, "TwasWeights") # 1 (study, trait) group with 2 contexts -> 2 output rows. expect_equal(nrow(res), 2L) - expect_setequal(getContexts(res), c("c1", "c2")) - expect_setequal(getTraits(res), "t1") - expect_setequal(getMethodNames(res), "mvsusie") + expect_setequal(contexts(res), c("c1", "c2")) + expect_setequal(traitNames(res), "t1") + expect_setequal(methodNames(res), "mvsusie") # The solver was called once with a (variants x 2) Z matrix and was # handed the precomputed fit from fineMappingResult. expect_length(shapesSeen, 1L) @@ -999,14 +999,14 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash multivariate solver failure twasWeightsRow( variantIds = variant_ids, weights = weights, - standardized = FALSE + weightStandardized = FALSE ) } test_that("twasWeightsPipeline(QtlDataset): full cache hit avoids all weight fitting", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") cached <- TwasWeights( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "lasso", @@ -1042,7 +1042,7 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") # Cache covers `lasso` but `enet` is missing -> only enetWeights is called. cached <- TwasWeights( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "lasso", @@ -1079,7 +1079,7 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing ensembleArgs = EnsembleParam() ) ) - expect_setequal(getMethodNames(res), c("lasso", "enet")) + expect_setequal(methodNames(res), c("lasso", "enet")) expect_equal(nrow(res), 2L) expect_equal(lassoCalls, 0L) # cache hit expect_equal(enetCalls, 1L) # cache miss -> fit @@ -1088,7 +1088,7 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing test_that("twasWeightsPipeline(QtlSumStats): cache hit on a per-tuple basis", { ss <- .tp_makeQtlSumStats() cached <- TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso", @@ -1134,7 +1134,7 @@ test_that(".twasCacheLookup: non-TwasWeights input returns NULL", { test_that(".twasCacheLookup: returns matching entry by 4-tuple", { e <- twasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5) tw <- TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso", @@ -1174,7 +1174,7 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { traits = c("ENSG_A", "ENSG_B") ) fmr <- .tp_makeStubFineMappingResult( - study = "study1", + studyName = "study1", contexts = c("brain", "liver"), traits = c("ENSG_A", "ENSG_B"), method = "mvsusie" @@ -1217,9 +1217,9 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { # Both solvers ran, and each contributes its own rows. expect_gte(mvCalls, 1L) expect_gte(mrCalls, 1L) - expect_setequal(getMethodNames(res), c("mrmash", "mvsusie")) - expect_setequal(getContexts(res), c("brain", "liver")) - expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) + expect_setequal(methodNames(res), c("mrmash", "mvsusie")) + expect_setequal(contexts(res), c("brain", "liver")) + expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) # 2 contexts x 2 traits x 2 methods, with no method overwriting the other. expect_equal(nrow(res), 8L) }) @@ -1914,7 +1914,7 @@ test_that(".twasCheckMultivariateY: mvsusie/mrmash error with single trait, sing sampleIds = character(), pgenPtr = NULL ) - GwasSumStats(study = "g1", entry = list(gr), genome = "hg19", ldSketch = gh) + GwasSumStats(studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = gh) } test_that(".twasAssertQcd: errors when qcInfo is empty", { @@ -1947,7 +1947,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { pgenPtr = NULL ) ss <- GwasSumStats( - study = "g1", + studyName = "g1", entry = list(gr), genome = "hg19", ldSketch = gh, @@ -1957,7 +1957,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { }) # =========================================================================== -# getSumStatsDf (public method on GwasSumStats / QtlSumStats; replaces +# as.data.frame (public method on GwasSumStats / QtlSumStats; replaces # the now-deleted `.twasSumstatsEntryToDf` shim) # =========================================================================== @@ -1990,7 +1990,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { ) S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcolsDf) GwasSumStats( - study = "G1", + studyName = "G1", entry = list(gr), genome = "hg19", ldSketch = .gsd_makeHandle(snp_n), @@ -1998,7 +1998,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { ) } -test_that("getSumStatsDf: returns the canonical column layout", { +test_that("as.data.frame: returns the canonical column layout", { ss <- .gsd_makeGwasSumStats(data.frame( SNP = c("rs1", "rs2"), A1 = c("A", "A"), @@ -2007,7 +2007,7 @@ test_that("getSumStatsDf: returns the canonical column layout", { N = c(1000L, 1500L), MAF = c(0.1, 0.3) )) - df <- getSumStatsDf(ss) + df <- as.data.frame(ss) expect_s3_class(df, "data.frame") expect_equal(df$variant_id, c("rs1", "rs2")) expect_equal(df$chrom, c("chr1", "chr1")) @@ -2017,7 +2017,7 @@ test_that("getSumStatsDf: returns the canonical column layout", { expect_equal(df$maf, c(0.1, 0.3)) }) -test_that("getSumStatsDf: derives z from beta/se when derive='zFromBetaSe'", { +test_that("as.data.frame: derives z from beta/se when derive='zFromBetaSe'", { ss <- .gsd_makeGwasSumStats( data.frame( SNP = "rs1", @@ -2029,13 +2029,13 @@ test_that("getSumStatsDf: derives z from beta/se when derive='zFromBetaSe'", { ), snp_n = 1L ) - df <- getSumStatsDf(ss, derive = "zFromBetaSe") + df <- as.data.frame(ss, derive = "zFromBetaSe") expect_equal(df$beta, 0.5) expect_equal(df$se, 0.1) expect_equal(df$z, 0.5 / 0.1) }) -test_that("getSumStatsDf: omits optional columns when absent", { +test_that("as.data.frame: omits optional columns when absent", { ss <- .gsd_makeGwasSumStats( data.frame( SNP = "rs1", @@ -2044,7 +2044,7 @@ test_that("getSumStatsDf: omits optional columns when absent", { ), snp_n = 1L ) - df <- getSumStatsDf(ss) + df <- as.data.frame(ss) expect_false("z" %in% names(df)) expect_false("beta" %in% names(df)) expect_false("se" %in% names(df)) @@ -2052,7 +2052,7 @@ test_that("getSumStatsDf: omits optional columns when absent", { expect_false("maf" %in% names(df)) }) -test_that("getSumStatsDf: require=c('Z','N') errors when columns missing", { +test_that("as.data.frame: require=c('Z','N') errors when columns missing", { ss <- .gsd_makeGwasSumStats( data.frame( SNP = "rs1", @@ -2062,7 +2062,7 @@ test_that("getSumStatsDf: require=c('Z','N') errors when columns missing", { ), snp_n = 1L ) - expect_error(getSumStatsDf(ss, require = c("Z", "N")), "no N mcol") + expect_error(as.data.frame(ss, require = c("Z", "N")), "no N mcol") }) # =========================================================================== @@ -2082,11 +2082,11 @@ test_that("estimateSparsity: TwasWeights collection input reads from the mrash e entry <- twasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), weights = c(0.1, 0, 0.3), - fits = list(pi = c(0.7, 0.2, 0.1)), - standardized = FALSE + methodFits = list(pi = c(0.7, 0.2, 0.1)), + weightStandardized = FALSE ) tw <- TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "mrash", @@ -2098,7 +2098,7 @@ test_that("estimateSparsity: TwasWeights collection input reads from the mrash e test_that("estimateSparsity: TwasWeights without mrash entry errors", { entry <- twasWeightsRow(variantIds = c("chr1:100:A:G"), weights = c(0.1)) tw <- TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso", @@ -2114,10 +2114,10 @@ test_that("estimateSparsity: TwasWeights with mrash entry but no fit$pi errors", entry <- twasWeightsRow( variantIds = c("chr1:100:A:G"), weights = c(0.1), - fits = list(other = 1) + methodFits = list(other = 1) ) tw <- TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "mrash", @@ -2165,7 +2165,7 @@ context("twasWeights internal helpers (extra)") test_that(".twasFineMappingFits: NULL input returns an empty list", { out <- pecotmr:::.twasFineMappingFits( NULL, - study = "s1", + studyName = "s1", context = "c1", trait = "t1" ) @@ -2176,7 +2176,7 @@ test_that(".twasFineMappingFits: non-FineMappingResult input errors", { expect_error( pecotmr:::.twasFineMappingFits( "not_a_result", - study = "s1", + studyName = "s1", context = "c1", trait = "t1" ), @@ -2188,7 +2188,7 @@ test_that(".twasFineMappingFits: pulls matching (study,context,trait) susie fit" e_susie <- .tw_makeFmEntry("susie") e_susieInf <- .tw_makeFmEntry("susieInf") res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("susie", "susieInf"), @@ -2196,7 +2196,7 @@ test_that(".twasFineMappingFits: pulls matching (study,context,trait) susie fit" ) out <- pecotmr:::.twasFineMappingFits( res, - study = "s1", + studyName = "s1", context = "c1", trait = "t1" ) @@ -2208,7 +2208,7 @@ test_that(".twasFineMappingFits: pulls matching (study,context,trait) susie fit" test_that(".twasFineMappingFits: returns empty list when no tuple matches", { res <- QtlFineMappingResult( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "susie", @@ -2216,7 +2216,7 @@ test_that(".twasFineMappingFits: returns empty list when no tuple matches", { ) out <- pecotmr:::.twasFineMappingFits( res, - study = "ghost", + studyName = "ghost", context = "c1", trait = "t1" ) @@ -2227,7 +2227,7 @@ test_that(".twasFineMappingFits: ignores non-susie methods (e.g. lasso)", { e <- .tw_makeFmEntry("susie") e_lasso <- .tw_makeFmEntry("lasso") res <- QtlFineMappingResult( - study = c("s1", "s1"), + studyName = c("s1", "s1"), context = c("c1", "c1"), trait = c("t1", "t1"), method = c("susie", "lasso"), @@ -2235,7 +2235,7 @@ test_that(".twasFineMappingFits: ignores non-susie methods (e.g. lasso)", { ) out <- pecotmr:::.twasFineMappingFits( res, - study = "s1", + studyName = "s1", context = "c1", trait = "t1" ) @@ -2299,12 +2299,12 @@ test_that(".twasMergeRegionEntries stacks weights and builds a flat per-region C pecotmr:::.twrPartsVariantIds(m), c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G", "chr1:400:A:G") ) - expect_equal(unname(getWeights(m)), c(0.1, 0.2, 0.3, 0.4)) - cv <- getCvResult(m) + expect_equal(unname(weights(m)), c(0.1, 0.2, 0.3, 0.4)) + cv <- cvResult(m) expect_s3_class(cv, "data.frame") expect_equal(cv$region, c("chr1:1-100", "chr1:200-300")) expect_equal(cv$rsq, c(0.3, 0.5)) - expect_equal(names(getFits(m)), c("chr1:1-100", "chr1:200-300")) + expect_equal(names(methodFits(m)), c("chr1:1-100", "chr1:200-300")) }) test_that(".twasMergeRegionEntries returns a single entry unchanged", { @@ -2333,7 +2333,7 @@ test_that(".twasMergeRegionEntries rbinds matrix weights across regions", { list(mk(rownames(m1), m1), mk(rownames(m2), m2)), c("r1", "r2") ) - w <- getWeights(m) + w <- weights(m) # Matrix weights stack by ROW -- one row per variant, contexts preserved # as columns. The vector branch would have flattened this to length 8. expect_true(is.matrix(w)) @@ -2350,7 +2350,7 @@ test_that(".twasMergeRegionEntries rbinds matrix weights across regions", { ) 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")) + expect_equal(names(methodFits(m)), c("r1", "r2")) }) test_that(".twasNormalizeCharMethods: fine-mapping-only tokens skip lookup", { @@ -2378,7 +2378,7 @@ test_that(".twasMergedEntryForRow gathers one key across regions", { ) m <- pecotmr:::.twasMergedEntryForRow(1L, base, list(tw, tw), c("rA", "rB")) expect_s4_class(m, "TwasWeightsRow") - expect_equal(names(getFits(m)), c("rA", "rB")) + expect_equal(names(methodFits(m)), c("rA", "rB")) # Same table twice: the merged entry carries both regions' variants. one <- pecotmr:::.twasMergedEntryForRow(1L, base, list(tw), "rA") expect_equal( @@ -2447,9 +2447,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per- expect_s4_class(res, "TwasWeights") # 1 ctx x 1 trait x 1 method -> a single merged row. expect_equal(nrow(res), 1L) - w <- getWeights( + w <- weights( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "lasso" @@ -2484,9 +2484,9 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=TRUE fits one concatena ensembleArgs = EnsembleParam() )) expect_equal(nrow(res), 1L) - w <- getWeights( + w <- weights( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "lasso" @@ -2534,9 +2534,9 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatena expect_s4_class(res, "TwasWeights") # 2 contexts x 2 traits = 4 rows, each with weights concatenated over regions. expect_equal(nrow(res), 4L) - w <- getWeights( + w <- weights( res, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "mrmash" @@ -2584,7 +2584,7 @@ test_that(".twasCvResultFor merges per-method cvResult across a tuple's entries" cvResult = mkCv("susie_inf") ) fmr <- QtlFineMappingResult( - study = c("S", "S"), + studyName = c("S", "S"), context = c("C", "C"), trait = c("T", "T"), method = c("susie", "susieInf"), @@ -2610,7 +2610,7 @@ test_that(".twasCvResultFor returns NULL when no entry carries CV", { ) e <- fineMappingRow("chr1:100:A:G", list(), tl) fmr <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "C", trait = "T", method = "susie", @@ -2667,7 +2667,7 @@ test_that(".unpackMashPrior routes a MashPrior into the internal CV arguments", # =========================================================================== .tp_tw <- function( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "lasso", @@ -2675,7 +2675,7 @@ test_that(".unpackMashPrior routes a MashPrior into the internal CV arguments", w = 0.5 ) { TwasWeights( - study = study, + studyName = studyName, context = context, trait = trait, method = method, @@ -2771,7 +2771,7 @@ test_that(".twasCvResultFor: NULL / non-FMR / no-match all return NULL", { expect_null(pecotmr:::.twasCvResultFor(NULL, "S", "c1", "t1")) expect_null(pecotmr:::.twasCvResultFor(list(a = 1), "S", "c1", "t1")) fmr <- .tp_makeStubFineMappingResult( - study = "study1", + studyName = "study1", contexts = "brain", traits = "ENSG_A", method = "susie" @@ -2806,7 +2806,7 @@ test_that(".twasCvResultFor: a multi-region (per-region list) cvResult is unwrap cvResult = nested ) fmr <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "susie", @@ -3074,7 +3074,7 @@ test_that("twasWeightsPipeline(QtlDataset): mashPrior full prior is threaded int test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso both run", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") jointRes <- .tp_tw( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "mrmash" @@ -3125,7 +3125,7 @@ test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", crossValidationArgs = CrossValidationParam(folds = 0), ensembleArgs = EnsembleParam() ))) - expect_setequal(getTraits(res), "ENSG_A") # only the overlapping gene + expect_setequal(traitNames(res), "ENSG_A") # only the overlapping gene }) # ----------------------------------------------------------------------------- @@ -3153,7 +3153,7 @@ test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS p twasWeightsPipeline(ss, methods = NULL, verbose = 0) )) expect_s4_class(res, "TwasWeights") - expect_setequal(getMethodNames(res), c("lasso", "prsCs", "dprGibbs")) + expect_setequal(methodNames(res), c("lasso", "prsCs", "dprGibbs")) }) test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type", { @@ -3173,7 +3173,7 @@ test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type verbose = 0 ) )) - expect_setequal(getMethodNames(res), "lasso") + expect_setequal(methodNames(res), "lasso") expect_error( twasWeightsPipeline(ss, methods = 42), "must be NULL, a character vector, a named list" @@ -3193,7 +3193,7 @@ test_that("twasWeightsPipeline(QtlSumStats): traitId filter selects matching row res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = "lasso", traitId = "t1", verbose = 0) )) - expect_setequal(getTraits(res), "t1") + expect_setequal(traitNames(res), "t1") expect_error( twasWeightsPipeline(ss, methods = "lasso", traitId = "absent"), "no entries matched" @@ -3227,7 +3227,7 @@ test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fin ss <- .tp_makeQtlSumStats(n_entries = 2L) # FineMappingResult that does NOT contain an mvsusie fit (only susie). fmr <- .tp_makeStubFineMappingResult( - study = "s1", + studyName = "s1", contexts = "c1", traits = "t1", method = "susie" @@ -3345,7 +3345,7 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): region + cisWindow is reje test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec-only mr.mash returns the joint result", { mt <- .tp_makeMultiStudy() jointRes <- .tp_tw( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "mrmash" @@ -3368,7 +3368,7 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec-only mr.mash ret test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univariate lasso are combined", { mt <- .tp_makeMultiStudy() jointRes <- .tp_tw( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "mrmash" @@ -3426,7 +3426,7 @@ test_that(".twasCvResultFor: an entry whose nested CV carries no partition is sk cvResult = nested ) fmr <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "c1", trait = "t1", method = "susie", @@ -3454,7 +3454,7 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash-only with no fits test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lasso combine", { ss <- .tp_makeQtlSumStats() jointRes <- .tp_tw( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "mrmash" @@ -3487,7 +3487,7 @@ test_that("twasWeightsPipeline( # t1 has 2 contexts (processed); t2 has 1 context (skipped at the < 2 guard). entries <- map(1:3, function(.) .tp_makeSumstatsEntry()) ss <- QtlSumStats( - study = rep("s1", 3), + studyName = rep("s1", 3), context = c("c1", "c2", "c1"), trait = c("t1", "t1", "t2"), entry = entries, @@ -3506,14 +3506,14 @@ test_that("twasWeightsPipeline( res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = "mrmash", verbose = 0) )) - expect_setequal(getTraits(res), "t1") # only t1 (1189) + expect_setequal(traitNames(res), "t1") # only t1 (1189) }) test_that("twasWeightsPipeline(QtlSumStats): a mismatched SNP order in a multivariate group errors", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # (s1, t1) x 2 ctx calls <- 0L local_mocked_bindings( - getSumStatsDf = function(x, study, context, trait, require, ...) { + as.data.frame = function(x, studyName, context, trait, require, ...) { calls <<- calls + 1L vid <- if (calls == 1L) { c("chr1:100:A:G", "chr1:200:A:G") @@ -3542,7 +3542,7 @@ test_that("twasWeightsPipeline(QtlSumStats): a mismatched SNP order in a multiva test_that("twasWeightsPipeline(MultiStudyQtlDataset): list-form methods, joint mr.mash only", { mt <- .tp_makeMultiStudy() jointRes <- .tp_tw( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "mrmash" @@ -3767,7 +3767,7 @@ test_that(".ensembleAccumulateWeights skips a dim-mismatched member", { twasWeightsPipeline( ss, methods = "lasso", - panelFilterArgs = PanelFilterParam(...) + panelFilterParam = PanelFilterParam(...) ) )))) } @@ -3790,9 +3790,9 @@ test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { # Exactly the variants the shared filter names: no more (something else is # filtering) and no fewer (the cutoff silently did nothing). ss <- .twrssf_qcd() - ids <- getSumStatsDf( + ids <- as.data.frame( ss, - study = ss$study[[1L]], + studyName = ss$study[[1L]], context = ss$context[[1L]], trait = ss$trait[[1L]], require = c("Z", "N"), @@ -3802,7 +3802,7 @@ test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { expect_equal( .twrssf_n(ss, mafCutoff = cut), length(.panelVariantFilter( - getLdSketch(ss), + ldSketch(ss), ids, PanelFilterParam(mafCutoff = cut) )), @@ -3813,7 +3813,7 @@ test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { test_that("twasWeightsPipeline RSS treats MAC as a MAF equivalent", { ss <- .twrssf_qcd() - nSamp <- ncol(getLdSketch(ss)) + nSamp <- ncol(ldSketch(ss)) expect_equal( .twrssf_n(ss, macCutoff = 0.1 * 2 * nSamp), .twrssf_n(ss, mafCutoff = 0.1) @@ -3828,7 +3828,7 @@ test_that("twasWeightsPipeline RSS honours a missingness cutoff", { test_that(".twasQssUnivariateFitCtx keeps z, ids and LD aligned", { ss <- .twrssf_qcd() - sketch <- getLdSketch(ss) + sketch <- ldSketch(ss) args <- list(ss, ss$study[[1L]], ss$context[[1L]], ss$trait[[1L]], sketch) plain <- exec(pecotmr:::.twasQssUnivariateFitCtx, !!!args) cut <- suppressMessages(exec( @@ -4008,7 +4008,7 @@ test_that(".twasQssMultivariateFitOne returns no rows when the fit is absent", { methodArgs = list(), fitRetention = "none", fineMappingResult = NULL, - dataType = NULL + weightsDataType = NULL ), "no 'mvsusie' fit found" ) @@ -4035,11 +4035,11 @@ test_that(".twasQssMultivariateFitOne promotes vector weights to a matrix", { methodArgs = list(), fitRetention = "none", fineMappingResult = NULL, - dataType = "rnaseq" + weightsDataType = "rnaseq" ) expect_length(rows, 1L) expect_equal(rows[[1L]]$context, "cA") - expect_equal(unname(getWeights(rows[[1L]]$entry)), c(0.5, 0.25)) + expect_equal(unname(weights(rows[[1L]]$entry)), c(0.5, 0.25)) }) test_that(".twasQssAssemble passes the joint result through alone", { @@ -4103,7 +4103,7 @@ test_that(".fmrAnyCvResult reports whether any row carries cross-validation", { ) bare <- fineMappingRow("chr1:100:A:G", list(), tl) noCv <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "C", trait = "T", method = "susie", @@ -4111,7 +4111,7 @@ test_that(".fmrAnyCvResult reports whether any row carries cross-validation", { ) expect_false(pecotmr:::.fmrAnyCvResult(noCv)) withCv <- QtlFineMappingResult( - study = "S", + studyName = "S", context = "C", trait = "T", method = "susie", @@ -4352,8 +4352,8 @@ test_that("twasWeightsPipeline(QtlDataset): usePCA adds top-PC rows", { } plain <- run(FALSE) withPc <- run(TRUE) - expect_false(any(str_detect(as.character(getTraits(plain)), "^topPC"))) - pcs <- unique(as.character(getTraits(withPc))) + expect_false(any(str_detect(as.character(traitNames(plain)), "^topPC"))) + pcs <- unique(as.character(traitNames(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))) @@ -4405,7 +4405,7 @@ test_that("a multivariate group resumes from the cache only in full", { # 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") + w <- .tp_tw(studyName = "s1", context = "c1", trait = "t1", method = "mrmash") # One context cached out of two -> no reuse. expect_null(pecotmr:::.twasMvCacheHits( diff --git a/tests/testthat/test_twasWeightsRow.R b/tests/testthat/test_twasWeightsRow.R index bd36ec1f..a02b2b54 100644 --- a/tests/testthat/test_twasWeightsRow.R +++ b/tests/testthat/test_twasWeightsRow.R @@ -6,21 +6,21 @@ test_that("TwasWeightsRow: constructor and accessors round-trip", { e <- twasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), weights = c(0.1, -0.2, 0.05), - fits = list(model = "lasso"), + methodFits = list(model = "lasso"), cvResult = list(rsq = 0.4), - standardized = TRUE, - dataType = "expression" + weightStandardized = TRUE, + weightsDataType = "expression" ) expect_s4_class(e, "TwasWeightsRow") expect_equal( .twrPartsVariantIds(e), c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") ) - expect_equal(getWeights(e), c(0.1, -0.2, 0.05)) - expect_equal(getFits(e), list(model = "lasso")) - expect_equal(getCvResult(e), list(rsq = 0.4)) - expect_true(isTRUE(getStandardized(e))) - expect_equal(getDataType(e), "expression") + expect_equal(weights(e), c(0.1, -0.2, 0.05)) + expect_equal(methodFits(e), list(model = "lasso")) + expect_equal(cvResult(e), list(rsq = 0.4)) + expect_true(isTRUE(weightStandardized(e))) + expect_equal(weightsDataType(e), "expression") }) test_that("TwasWeightsRow: resolveWeights returns the aligned (variantIds, weights) pair", { @@ -50,16 +50,16 @@ test_that("TwasWeightsRow: standardized is coerced via isTRUE() semantics", { e_logical <- twasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.1, - standardized = TRUE + weightStandardized = TRUE ) - expect_true(isTRUE(getStandardized(e_logical))) + expect_true(isTRUE(weightStandardized(e_logical))) e_default <- twasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.1, - standardized = "yes-please" + weightStandardized = "yes-please" ) - expect_false(isTRUE(getStandardized(e_default))) + expect_false(isTRUE(weightStandardized(e_default))) }) @@ -80,7 +80,7 @@ test_that("TwasWeightsRow: validity rejects matrix weights with wrong nrow", { test_that("TwasWeights: rejects non-TwasWeightsRow rows", { expect_error( TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso", @@ -97,7 +97,7 @@ test_that("TwasWeights: validity does not recurse on key subset (#546)", { # S4Vectors revalidates that intermediate and fails with "missing columns". e <- .sc_makeTwasWeightsRow(p = 5L) res <- TwasWeights( - study = "s1", + studyName = "s1", context = "c1", trait = "t1", method = "lasso", @@ -111,7 +111,7 @@ test_that("TwasWeights: validity does not recurse on key subset (#546)", { # === Tests migrated from test_showMethods.R (TwasWeightsRow) === test_that("show.TwasWeightsRow reports standardized flag and CV availability", { - e <- .sh_makeTwEntry(p = 5, standardized = TRUE) + e <- .sh_makeTwEntry(p = 5, weightStandardized = TRUE) out <- capture.output(show(e)) expect_true(any(grepl( "TwasWeightsRow: 5 variants.*standardized=TRUE", @@ -142,10 +142,10 @@ test_that("variantIds that encode no coordinates are rejected", { twasWeightsRow( variantIds = c("chr1:100:A:G", "v1", "v2"), weights = c(0.1, -0.2, 0.05), - fits = list(model = "lasso"), + methodFits = list(model = "lasso"), cvResult = list(rsq = 0.4), - standardized = TRUE, - dataType = "expression" + weightStandardized = TRUE, + weightsDataType = "expression" ), "do not encode coordinates" ) @@ -156,10 +156,10 @@ test_that("the identity message names the offenders", { twasWeightsRow( variantIds = c("rsX", "rsY"), weights = c(0.1, -0.2), - fits = list(), + methodFits = list(), cvResult = list(), - standardized = TRUE, - dataType = "expression" + weightStandardized = TRUE, + weightsDataType = "expression" ), error = function(e) conditionMessage(e) ) @@ -173,10 +173,10 @@ test_that("an empty variant set is allowed", { e <- twasWeightsRow( variantIds = character(0), weights = numeric(0), - fits = list(), + methodFits = list(), cvResult = list(), - standardized = TRUE, - dataType = "expression" + weightStandardized = TRUE, + weightsDataType = "expression" ) expect_s4_class(e, "TwasWeightsRow") expect_equal(length(.twrPartsVariantIds(e)), 0L) diff --git a/tests/testthat/test_vcfWriter.R b/tests/testthat/test_vcfWriter.R index 810e3aea..ceb8b70f 100644 --- a/tests/testthat/test_vcfWriter.R +++ b/tests/testthat/test_vcfWriter.R @@ -29,7 +29,7 @@ makeTestGwasSumStats <- function(n = 5) { N = rep(1000L, n) ) GwasSumStats( - study = "test_trait", + studyName = "test_trait", entry = list(gr), genome = "hg38", ldSketch = makeTestGenotypeHandle() @@ -69,7 +69,7 @@ makeTestFineMappingResult <- function(n = 5) { topLoci = tl ) GwasFineMappingResult( - study = "test_study", + studyName = "test_study", method = "susie", entry = list(entry) ) @@ -241,7 +241,7 @@ test_that("writeSumStatsVcf errors on empty FineMappingResult", { topLoci = empty_tl ) fm_empty <- GwasFineMappingResult( - study = "test_study", + studyName = "test_study", method = "susie", entry = list(entry) ) @@ -282,7 +282,7 @@ test_that("writeSumStatsVcf errors on empty FineMappingResult", { fineMappingRow(variantIds = ids, susieFit = list(), topLoci = tl) }) QtlFineMappingResult( - study = rep("study1", 2), + studyName = rep("study1", 2), context = contexts, trait = traits, method = rep("susie", 2), @@ -391,7 +391,7 @@ test_that("writeSumStatsVcf(FineMappingResult): multi-row without split flags re gr } GwasSumStats( - study = c("studyA", "studyB"), + studyName = c("studyA", "studyB"), entry = list(mkGr(), mkGr()), genome = "hg38", ldSketch = makeTestGenotypeHandle() @@ -411,7 +411,7 @@ test_that("writeSumStatsVcf(GwasSumStats): `study` selector writes the chosen st ss2 <- .makeTwoStudyGwasSumStats() out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - res <- writeSumStatsVcf(ss2, out, study = "studyB") + res <- writeSumStatsVcf(ss2, out, studyName = "studyB") expect_equal(res, out) expect_true(file.exists(out)) }) @@ -420,7 +420,7 @@ test_that("writeSumStatsVcf(GwasSumStats): emits the AF genotype field when MAF skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") ss <- GwasSumStats( - study = "t", + studyName = "t", entry = list(local({ gr <- GenomicRanges::GRanges( "chr1", @@ -473,7 +473,7 @@ test_that("writeSumStatsVcf(FineMappingResult): explicit selectors pick a single res <- writeSumStatsVcf( fmr, out, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_A", method = "susie" @@ -488,7 +488,7 @@ test_that("writeSumStatsVcf(FineMappingResult): no matching rows errors", { fmr <- .makeMultiTupleQtlFmr() out <- tempfile(fileext = ".vcf") expect_error( - writeSumStatsVcf(fmr, out, study = "does_not_exist"), + writeSumStatsVcf(fmr, out, studyName = "does_not_exist"), "no rows match" ) }) @@ -562,7 +562,7 @@ test_that("writeSumStatsVcf(FineMappingResult): emits AF from the topLoci `af` c topLoci = tl ) fm <- GwasFineMappingResult( - study = "s", + studyName = "s", method = "susie", entry = list(entry) ) @@ -609,7 +609,7 @@ test_that("writeSumStatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit topLoci = tl ) fm <- GwasFineMappingResult( - study = "s", + studyName = "s", method = "susie", entry = list(entry) ) @@ -633,10 +633,10 @@ test_that("writeSumStatsVcf(FineMappingResult): falls back to marginal sumstats skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fm <- makeTestFineMappingResult(5) - # Simulate an entry whose posterior table is unavailable (empty getTopLoci) so + # Simulate an entry whose posterior table is unavailable (empty topLoci) so # the marginal univariate sumstats alone drive the VCF body (the else-if branch). testthat::local_mocked_bindings( - getTopLoci = function(x, ...) data.frame(), + topLoci = function(x, ...) GenomicRanges::GRanges(), .package = "pecotmr" ) out <- tempfile(fileext = ".vcf") @@ -693,10 +693,23 @@ test_that("BCF output explains itself when Rsamtools cannot convert", { test_that(".vcfResolveBody uses posterior rows when no marginals exist", { local_mocked_bindings( - getTopLoci = function(entry, signalCutoff) { - data.frame(variant_id = c("v1", "v2"), pip = c(0.9, 0.1)) + topLoci = function(entry, signalCutoff) { + # topLoci() returns ranges carrying the per-variant columns in + # mcols(); these ids are deliberately not coordinate-shaped, so + # the ranges are built directly rather than parsed from them. + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = c(1L, 2L), width = 1L) + ) + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame( + variant_id = c("v1", "v2"), + pip = c(0.9, 0.1) + ) + ) }, - getMarginalEffects = function(entry) stop("none"), + marginalEffects = function(entry) stop("none"), .package = "pecotmr" ) out <- pecotmr:::.vcfResolveBody("e", "S1") diff --git a/vignettes/coloc-pipeline.Rmd b/vignettes/coloc-pipeline.Rmd index e23153bc..6ed6231e 100644 --- a/vignettes/coloc-pipeline.Rmd +++ b/vignettes/coloc-pipeline.Rmd @@ -207,7 +207,7 @@ colocPipeline( 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) + credibleSetParam = CredibleSetParam(coverage = 0.95) ), returnGwasFineMapping = FALSE, enrichment = NULL, # data.frame for enloc mode @@ -228,7 +228,7 @@ pair is reported verbatim, including both halves of a credible set that straddles a block boundary. ```{r read-pairs} -pairs <- getColocPairs(res) +pairs <- colocPairs(res) head(pairs[order(pairs$PP.H4.abf, decreasing = TRUE), ]) ``` @@ -245,7 +245,7 @@ The per-variant layer: `colocPp` is `PP.H4.abf * SNP.PP.H4`, the posterior that this particular variant is the shared causal one. ```{r read-variants} -variants <- getColocVariants(res) +variants <- colocVariants(res) head(variants[order(variants$colocPp, decreasing = TRUE), ]) ``` @@ -258,7 +258,7 @@ rather than inherited. Filtering happens before any LD extraction, so a stricter threshold costs strictly less. ```{r read-cs} -head(getColocCredibleSets(res, coverage = 0.95, minPp4 = 0.1)) +head(colocCredibleSets(res, coverage = 0.95, minPp4 = 0.1)) ``` ### Genes @@ -269,7 +269,7 @@ variant is in one block or the other — so they are summed; distinct QTL credible sets are independent signals and combine as `1 - prod(1 - p)`. ```{r read-genes} -getColocGenes(res) +colocGenes(res) ``` The warning above is the diagnostic that rule produces: a within-credible-set diff --git a/vignettes/colocboost-pipeline.Rmd b/vignettes/colocboost-pipeline.Rmd index 8d12b4fc..69b8fe26 100644 --- a/vignettes/colocboost-pipeline.Rmd +++ b/vignettes/colocboost-pipeline.Rmd @@ -178,12 +178,12 @@ are the per-call refinements. - **Individual-level (`QtlDataset` / `MultiStudyQtlDataset`)**: QC (MAF / MAC / X-variance / per-sample missingness, sample / variant restrictions) lives on the `QtlDataset` constructor and is applied lazily inside - `getGenotypes()` / `getResidualizedGenotypes()`. The pipeline does not run + `genotypes()` / `residualizedGenotypes()`. The pipeline does not run a separate pass. - **Summary statistics (`QtlSumStats` / `GwasSumStats`)**: all variant filters, panel harmonization, LD-mismatch detection, and RAISS imputation live in [`summaryStatsQc()`](rss-qc.html). The pipeline rejects inputs - whose `getQcInfo()` is empty. + whose `qcInfo()` is empty. # Session info diff --git a/vignettes/constructing-qtl-datasets.Rmd b/vignettes/constructing-qtl-datasets.Rmd index 8cff984c..38341d6f 100644 --- a/vignettes/constructing-qtl-datasets.Rmd +++ b/vignettes/constructing-qtl-datasets.Rmd @@ -181,7 +181,7 @@ applied at load), for example: ```{r qtl-manifest-qc} qdFiltered <- loadQtlDatasetFromManifest( manifest, - genotypeFilterArgs = GenotypeFilterParam( + genotypeFilterParam = GenotypeFilterParam( mafCutoff = 0.01, imissCutoff = 0.05, keepIndel = FALSE @@ -231,7 +231,7 @@ phenotypes <- list(Muscle = buildSE(muscleBed), Blood = buildSE(bloodBed)) genotypes <- readGenotypes(plink1Prefix = genoPrefix) qdManual <- QtlDataset( - study = "GTEx_toy", + studyName = "GTEx_toy", genotypes = genotypes, phenotypes = phenotypes ) @@ -272,7 +272,7 @@ A MultiStudyQtlDataset can be manually constructed by building a named list of msdManual <- MultiStudyQtlDataset( qtlDatasets = list(StudyA = qd, StudyB = qdManual) ) -names(getQtlDatasets(msdManual)) +names(qtlDatasets(msdManual)) ``` To attach a summary-only study, pass a `QtlSumStats` object to the `sumStats` @@ -341,12 +341,12 @@ Once built, the accessors extract data lazily, applying the stored QC filters at extraction time: ```{r accessors} -getStudy(qd) -getContexts(qd) +studyName(qd) +contexts(qd) # Cis genotypes around a trait (+/- a window), QC applied on the fly: -dim(getGenotypes(qd, traitId = "GENE1", cisWindow = 1e6)) +dim(genotypes(qd, traitId = "GENE1", cisWindow = 1e6)) # Phenotype matrix for one context: -dim(SummarizedExperiment::assay(getPhenotypes(qd, contexts = "Muscle"))) +dim(SummarizedExperiment::assay(molecularTraits(qd, contexts = "Muscle"))) ``` `QtlDataset` and `MultiStudyQtlDataset` are direct inputs to diff --git a/vignettes/constructing-sumstats.Rmd b/vignettes/constructing-sumstats.Rmd index d4e704f5..cf913147 100644 --- a/vignettes/constructing-sumstats.Rmd +++ b/vignettes/constructing-sumstats.Rmd @@ -155,7 +155,7 @@ S4Vectors::mcols(entry) <- S4Vectors::DataFrame( ) gwsManual <- GwasSumStats( - study = "MyGWAS", + studyName = "MyGWAS", entry = list(entry), genome = "GRCh38", ldSketch = ldSketch @@ -201,7 +201,7 @@ qts ```{r qtl-manual} qtsManual <- QtlSumStats( - study = "MyQTL", + studyName = "MyQTL", context = "Blood", trait = "ENSG00000001", entry = list(entry), @@ -229,7 +229,7 @@ contexts as column names: data(mashInputExample) z <- mashInputExample$strong.z[1:6, 1:3] rownames(z) <- paste0("chr1:", seq(1000, by = 100, length.out = 6), ":A:G") -qtlSumStatsFromZMatrix(z, study = "demo") +qtlSumStatsFromZMatrix(z, studyName = "demo") ``` `qtlSumStatsFromBetaMatrix()` is the effect-size counterpart, taking `bhat` @@ -239,7 +239,7 @@ and `shat`: b <- mashInputExample$strong.b[1:6, 1:3] shat <- mashInputExample$strong.s[1:6, 1:3] rownames(b) <- rownames(shat) <- rownames(z) -getContexts(qtlSumStatsFromBetaMatrix(b, shat, study = "demo")) +contexts(qtlSumStatsFromBetaMatrix(b, shat, studyName = "demo")) ``` Both default `ldSketch = NULL`, giving an LD-free collection. That is fine @@ -404,9 +404,9 @@ weights with pecotmr* and *Multi-trait colocalization with ColocBoost* vignettes. ```{r accessors} -getGenome(gws) +unname(GenomeInfoDb::genome(gws)) as.character(gws$study) -length(getSumStats(gws)) # variants in the first entry +length(sumStats(gws)) # variants in the first entry ``` ```{r session-info} diff --git a/vignettes/ctwas-pipeline.Rmd b/vignettes/ctwas-pipeline.Rmd index 9ffaf103..a30d7f05 100644 --- a/vignettes/ctwas-pipeline.Rmd +++ b/vignettes/ctwas-pipeline.Rmd @@ -101,7 +101,7 @@ gwasSumStats <- loadGwasSumStatsFromManifest( ) gwasByRegion <- summaryStatsQc( gwasSumStats, - panelFilterArgs = PanelFilterParam(mafCutoff = 0.0025) + panelFilterParam = PanelFilterParam(mafCutoff = 0.0025) ) data(ctwasWeightsExample) @@ -120,9 +120,12 @@ res <- ctwasPipeline( fallbackToPrefit = TRUE ), methodArgs = CtwasOptions( - min_group_size = 1, - min_p_single_effect = 0, - min_nonSNP_PIP = 0 + regionData = CtwasRegionDataOptions(min_group_size = 1), + estParam = CtwasEstParamOptions( + min_group_size = 1, + min_p_single_effect = 0 + ), + screen = CtwasScreenOptions(min_nonSNP_PIP = 0) ) ) res @@ -192,15 +195,15 @@ ctwasPipeline( `(gwasStudy, study, context, method)` run. ```{r ctwas-identity} -getMethodNames(res) -getStudy(res) -getContexts(res) +methodNames(res) +studyName(res) +contexts(res) ``` -The per-gene posteriors live in `getFinemap()`: +The per-gene posteriors live in `ctwasPosteriors()`: ```{r ctwas-finemap} -fm <- getFinemap(res) +fm <- ctwasPosteriors(res) as.data.frame(fm)[, c( "molecular_id", "context", @@ -216,11 +219,11 @@ gene is causal given the SNPs it competes with. Here it is low (the toy GWAS has no real signal) and `cs` is `NA` because the gene falls in no credible set. -`getSusieAlpha()` returns the per-single-effect alpha matrix behind those +`susieAlpha()` returns the per-single-effect alpha matrix behind those PIPs, and the EM group priors sit on each row's entry: ```{r ctwas-param} -param <- getCtwasGroupPriors(res$entry[[1]]) +param <- ctwasGroupPriors(res$entry[[1]]) param$group_prior param$group_prior_var param$converged @@ -251,20 +254,31 @@ est <- estCtwasGroupPriors( niter = 10, fallbackToPrefit = TRUE ), - methodArgs = CtwasOptions(min_group_size = 1, min_p_single_effect = 0) + methodArgs = CtwasOptions( + regionData = CtwasRegionDataOptions(min_group_size = 1), + estParam = CtwasEstParamOptions( + min_group_size = 1, + min_p_single_effect = 0 + ) + ) +) +screened <- screenCtwasRegions( + est, + methodArgs = CtwasOptions( + screen = CtwasScreenOptions(min_nonSNP_PIP = 0) + ) ) -screened <- screenCtwasRegions(est, methodArgs = CtwasOptions(min_nonSNP_PIP = 0)) finemapped <- finemapCtwasRegions(screened) nrow(finemapped$finemap_res) ``` -`finemap_res` here has more rows than `getFinemap(res)` above: it still +`finemap_res` here has more rows than `ctwasPosteriors(res)` above: it still carries the SNP rows. `asCtwasResult()` is the step that structures the payload and drops them. ```{r ctwas-as-result} -nrow(getFinemap(asCtwasResult(finemapped))) -nrow(getFinemap(asCtwasResult(finemapped, keepSnps = TRUE))) +nrow(ctwasPosteriors(asCtwasResult(finemapped))) +nrow(ctwasPosteriors(asCtwasResult(finemapped, keepSnps = TRUE))) ``` Each step's payload is also bundled, so you can enter anywhere: @@ -308,7 +322,7 @@ ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), method = NULL, # NULL: "ensemble" if present, else every method - L = 5, + maxNumSingleEffects = 5, ncore = 1, keepSnps = FALSE, ctwasPriorArgs = CtwasPriorParam( diff --git a/vignettes/fine-mapping.Rmd b/vignettes/fine-mapping.Rmd index 1fafd934..7d9fa1e1 100644 --- a/vignettes/fine-mapping.Rmd +++ b/vignettes/fine-mapping.Rmd @@ -80,22 +80,22 @@ fmr Per-tuple PIPs: ```{r individual-pips} -pip <- getPip( +pipAll <- pip( fmr, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_example", method = "susie" ) -head(sort(pip, decreasing = TRUE), 5) +head(sort(pipAll, decreasing = TRUE), 5) ``` Credible sets: ```{r individual-cs} -getCs( +credibleSets( fmr, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_example", method = "susie", @@ -108,9 +108,9 @@ sumstats into one long-format data.frame: ```{r individual-toploci} head( - getTopLoci( + topLoci( fmr, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_example", method = "susie" @@ -161,27 +161,27 @@ fineMappingPipeline( contexts = "brain", traitId = "ENSG_example", cisWindow = 5e5, - credibleSetArgs = CredibleSetParam( + credibleSetParam = CredibleSetParam( coverage = 0.95, secondaryCoverage = c(0.7, 0.5), signalCutoff = 0.025, minAbsCorr = 0.8, - L = 10L + maxNumSingleEffects = 10L ), - addSusieInf = TRUE, + initializeWithSusieInf = TRUE, naAction = "drop", # "drop" (default) or "impute" verbose = 1 ) ``` - `naAction` controls how phenotype NAs are handled by - `getResidualizedPhenotypes()`: `"drop"` removes samples with any NA across + `residualizedPhenotypes()`: `"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. -- `CredibleSetParam(L = ...)` bounds how many single effects the fit may - carry, and so how many credible sets can exist. +- `initializeWithSusieInf = 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(maxNumSingleEffects = ...)` 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. @@ -217,13 +217,14 @@ colnames(fmr) lengths(fmr) # variants per tuple ``` -Rather than reaching into the payload, use the view accessors. Each returns a -tidy table over the whole collection, with the tuple columns carried along: +Rather than reaching into the payload, use the view accessors. `topLoci()` +returns a `GRanges` over the whole collection with the tuple columns carried +in `mcols()`; the others return tidy tables: ```{r fm-views} -head(getTopLoci(fmr), 3) # per-variant posterior summary -head(getCs(fmr), 3) # credible-set membership -head(getCredibleSetSummary(fmr), 3) # one row per credible set +head(topLoci(fmr), 3) # per-variant posterior summary +head(credibleSets(fmr), 3) # credible-set membership +head(credibleSetSummary(fmr), 3) # one row per credible set ``` Passing a tuple selects a single fit and returns that tuple's values on their @@ -231,17 +232,17 @@ own — a bare vector rather than a table: ```{r fm-one-tuple} key <- list( - study = fmr$study[[1L]], + studyName = fmr$study[[1L]], context = fmr$context[[1L]], trait = fmr$trait[[1L]], method = fmr$method[[1L]] ) -pip <- do.call(getPip, c(list(fmr), key)) -length(pip) +pipOne <- do.call(pip, c(list(fmr), key)) +length(pipOne) ``` -The underlying SuSiE fit is available with `getSusieFit()` and the -cross-validation record with `getCvResult()`, both keyed the same way. +The underlying SuSiE fit is available with `susieFit()` and the +cross-validation record with `cvResult()`, both keyed the same way. Range-based subsetting works directly: ```{r fm-range} diff --git a/vignettes/finemapping-postprocessing.Rmd b/vignettes/finemapping-postprocessing.Rmd index f568effc..b8ff2818 100644 --- a/vignettes/finemapping-postprocessing.Rmd +++ b/vignettes/finemapping-postprocessing.Rmd @@ -42,13 +42,14 @@ qtlFineMappingExample A fine-mapping result carries two flat summaries, and which one you want depends on whether your unit of interest is a variant or a credible set. -**`getTopLoci()`** is one row per retained variant, with its PIP, effect -size, and credible-set membership at each coverage level: +**`topLoci()`** is one range per retained variant, with its PIP, effect +size, and credible-set membership at each coverage level carried in +`mcols()`. Take a table with `as.data.frame()`: ```{r top-loci} -topLoci <- getTopLoci(qtlFineMappingExample) -dim(topLoci) -head(as.data.frame(topLoci)[, c( +loci <- topLoci(qtlFineMappingExample) +length(loci) +head(as.data.frame(loci)[, c( "variant_id", "pip", "cs_95", @@ -62,10 +63,10 @@ head(as.data.frame(topLoci)[, c( belongs to none. The `cs_70` / `cs_50` columns give the same membership at looser coverage, so a variant can be in a 95% set but not a 50% one. -**`getCredibleSetSummary()`** is one row per credible set instead: +**`credibleSetSummary()`** is one row per credible set instead: ```{r cs-summary} -as.data.frame(getCredibleSetSummary(qtlFineMappingExample))[, c( +as.data.frame(credibleSetSummary(qtlFineMappingExample))[, c( "cs", "coverage", "n_variants", @@ -192,11 +193,11 @@ When the flat tables are not enough — you want the per-effect posterior, or to re-derive PIPs under a different assumption — the underlying fit is available. -`getLbf()` returns the log Bayes factors, one row per variant and one +`lbf()` returns the log Bayes factors, one row per variant and one column per single effect: ```{r lbf} -lbf <- getLbf(qtlFineMappingLbfExample) +lbf <- lbf(qtlFineMappingLbfExample) unit <- lbf[lbf$trait == lbf$trait[1] & lbf$context == lbf$context[1], ] lbfMatrix <- as.matrix(unit[, grep("^lbf_L", names(unit))]) dim(lbfMatrix) @@ -220,11 +221,11 @@ The LBF matrix is also what `colocPipeline()` consumes, which is why `fineMappingPipeline(..., keepLbf = TRUE)` is required before colocalization. -`getSusieFit()` returns the raw per-unit SuSiE object when you need +`susieFit()` returns the raw per-unit SuSiE object when you need something the accessors do not expose: ```{r susie-fit} -fit <- getSusieFit(qtlFineMappingExample) +fit <- susieFit(qtlFineMappingExample) class(fit) names(fit) ``` @@ -252,7 +253,7 @@ threshold are applied, so re-running it with a different `coverage` gives a different `top_loci` without refitting anything. Two smaller extractors sit at the row level and are what -`getCredibleSetSummary()` is assembled from: +`credibleSetSummary()` is assembled from: - `extractCsInfo(fmRow, csNames, topLociTable, ldSource)` — per-credible-set detail for one result row, including the between-variant correlations that @@ -260,7 +261,7 @@ Two smaller extractors sit at the row level and are what - `extractTopPipInfo(fmRow, sumstats)` — the lead variant and its statistics, joined against summary statistics. -`getSusieResult()` unwraps a per-condition fit list into the single SuSiE +`susieResult()` unwraps a per-condition fit list into the single SuSiE object the other helpers expect. ## Writing results out diff --git a/vignettes/heritability.Rmd b/vignettes/heritability.Rmd index dddc5042..a2834e56 100644 --- a/vignettes/heritability.Rmd +++ b/vignettes/heritability.Rmd @@ -72,7 +72,7 @@ perSnpVar <- rep(h2True / M, M) set.seed(1) z <- numeric(M) -for (block in getLdMatrixList(ldScoreExample)) { +for (block in ldMatrixList(ldScoreExample)) { idx <- block$snpIdx p <- length(idx) sigma <- nGwas * (block$R %*% diag(perSnpVar[idx], p) %*% block$R) + @@ -90,9 +90,9 @@ S4Vectors::mcols(gr) <- S4Vectors::DataFrame( N = as.integer(nGwas) ) gwas <- GwasSumStats( - study = "trait1", + studyName = "trait1", entry = list(gr), - genome = getGenome(ldScoreExample), + genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), ldSketch = readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) @@ -111,8 +111,8 @@ names(estimates) <- methods data.frame( method = methods, - h2 = round(vapply(estimates, getH2, numeric(1)), 3), - se = round(vapply(estimates, getH2Se, numeric(1)), 3), + h2 = round(vapply(estimates, heritabilityEstimate, numeric(1)), 3), + se = round(vapply(estimates, heritabilityEstimateSe, numeric(1)), 3), row.names = NULL ) ``` @@ -154,10 +154,10 @@ outgrows the signal, the modelled variance is driven to its floor across most eigen-directions, and the optimiser walks the intercept out to the top of its range — returning a number that reflects that bound rather than the data. At `N = 1e5` against this reference (`nRef` = -`r getNRef(ldEigenExample)`) it drifts to about 0.56 for a true 0.4 and +`r ldPanelNSamples(ldEigenExample)`) it drifts to about 0.56 for a true 0.4 and warns that the fit sits on a bound. At the `N = 1e4` used here it is comfortably inside its range. If HDL disagrees sharply with the others, -check for that warning and compare `getN()` against `getNRef()`. +check for that warning and compare `nSamples()` against `ldPanelNSamples()`. A standard error of zero, or an estimate pinned at a boundary, almost always means the reference is too small rather than that the trait has no @@ -202,7 +202,7 @@ perSnpVarStrat <- ifelse(inA, 0.225 / sum(inA), 0.075 / sum(!inA)) set.seed(1) zStrat <- numeric(M) -for (block in getLdMatrixList(ldScoreExample)) { +for (block in ldMatrixList(ldScoreExample)) { idx <- block$snpIdx p <- length(idx) sigma <- nGwas * @@ -215,9 +215,9 @@ for (block in getLdMatrixList(ldScoreExample)) { } S4Vectors::mcols(gr)$Z <- zStrat gwasStrat <- GwasSumStats( - study = "trait1", + studyName = "trait1", entry = list(gr), - genome = getGenome(ldScoreExample), + genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), ldSketch = readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) @@ -227,7 +227,7 @@ annot <- AnnotationMatrix( matrix(as.integer(inA), ncol = 1, dimnames = list(NULL, "annotA")), as(ldScoreExample, "GRanges"), data.frame(name = "annotA", tier = "baseline", type = "binary"), - genome = getGenome(ldScoreExample) + genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))) ) ``` @@ -238,7 +238,7 @@ strat <- estimateH2( method = "gldsc", annotations = annot ) -as.data.frame(getEnrichment(strat))[, c( +as.data.frame(stratifiedHeritabilityEnrichment(strat))[, c( "annotation", "tau", "enrichment", @@ -268,7 +268,7 @@ annot <- readAnnotations( The `tier` column decides how each annotation is used: `"baseline"` annotations enter the model and get an enrichment estimate, while `"candidate"` annotations are scored against the fitted baseline (the sHDL -score test, via `getScoreStats()`). +score test, via `scoreStats()`). One structural caveat: a set of baseline annotations that exactly partitions the variants is rank-deficient by construction, because the model's implicit @@ -303,8 +303,8 @@ test. ```{r sldsc-pipeline} sldscData <- SldscData( - annot = annotTable, - frq = frq, + annotData = annotTable, + frqData = frq, traits = lapply(runs, function(r) list(single = list(r))) ) result <- sldscPostprocessingPipeline( @@ -344,7 +344,7 @@ standardisation for one trait's run, and `metaSldscRandom()` is the DerSimonian-Laird pooling across traits. Running them yourself is the way to see which of the three a strange tau\* came from. -`getAnnotData()`, `getFrqData()`, `getAnnotCols()` and `getTraitRuns()` read +`annotData()`, `frqData()`, `annotCols()` and `sldscResults()` read the corresponding parts of an `SldscData` back out. ### LD scores from an existing reference diff --git a/vignettes/ld-infrastructure.Rmd b/vignettes/ld-infrastructure.Rmd index ee588f4a..b835208f 100644 --- a/vignettes/ld-infrastructure.Rmd +++ b/vignettes/ld-infrastructure.Rmd @@ -58,7 +58,7 @@ correlation matrix, or the genotypes to compute it from: region <- "chr22:10000000-19000000" ld <- loadLdMatrix(ldMeta, region = region) ld -R <- getCorrelation(ld) +R <- ldMatrix(ld) dim(R) ``` @@ -67,11 +67,11 @@ source. `returnGenotype = "auto"` (the default for genotype sources) returns dosages and computes `R` on demand, which matters because a dense matrix for a large region is far bigger than the genotypes it came from. -`getVariantInfo()` gives the variants as a plain `GRanges`, which is what you +`variantInfo()` gives the variants as a plain `GRanges`, which is what you need to align summary statistics against the panel: ```{r variant-info} -head(getVariantInfo(ld), 3) +head(variantInfo(ld), 3) ``` **A region is not a block.** Loading a whole region returns one dense matrix diff --git a/vignettes/rss-qc.Rmd b/vignettes/rss-qc.Rmd index 3ceb6dff..682ec0a8 100644 --- a/vignettes/rss-qc.Rmd +++ b/vignettes/rss-qc.Rmd @@ -63,7 +63,7 @@ gws_qcd <- summaryStatsQc( infoCutoff = 0, # 0 = off; > 0 requires INFO column nCutoff = 5 ), - panelFilterArgs = PanelFilterParam( + panelFilterParam = PanelFilterParam( mafCutoff = 0 # 0 = off; > 0 requires MAF column ), skipRegion = NULL, # e.g. MHC "chr6:25000000-35000000" @@ -76,10 +76,10 @@ gws_qcd <- summaryStatsQc( `gws_qc` is a new `GwasSumStats` of the same class, with cleaned entries and a populated `qcInfo` slot. The per-entry audit record is -accessible via `getQcInfo()`: +accessible via `qcInfo()`: ```{r inspect-qcinfo, eval=FALSE} -qc <- getQcInfo(gws_qcd) +qc <- qcInfo(gws_qcd) str(qc$entryAudit[[1]]) # per-entry counts: variantsIn, mungeSumstatsDropped, # keepVariantsDropped, skipRegionDropped, matchedAgainstSketch, # krigingOutliersDropped, ldMismatchOutliersDropped, ... diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index c0fa7786..4addaaeb 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -68,27 +68,27 @@ tw Extract the per-variant weights for one tuple: ```{r individual-weights} -entry <- getTwasWeights( +entry <- twasWeights( tw, - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_example", method = "lasso" ) -head(getWeights(entry)) +head(weights(entry)) ``` CV performance: ```{r individual-cv} -getCvResult(entry) +cvResult(entry) ``` The entry's `variantIds` slot lists the LD-aligned variant set the weights are defined on: ```{r individual-vids} -length(getVariantIds(entry)) +length(variantIds(entry)) ``` ## Including a fine-mapping susie fit in the TWAS ensemble @@ -312,7 +312,7 @@ twasWeightsPipeline( phenotypeCovariates = NULL, genotypeCovariates = NULL ), - dataType = NULL, + weightsDataType = NULL, naAction = "drop" ) ``` @@ -320,7 +320,7 @@ twasWeightsPipeline( - `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 +- `naAction` is forwarded to `residualizedPhenotypes()` (see the [fine-mapping vignette](fine-mapping.html#common-parameters) for semantics). @@ -348,21 +348,21 @@ To pull one method's weights, pass the tuple to the accessor: ```{r tw-one-tuple} key <- list( - study = tw$study[[1L]], + studyName = tw$study[[1L]], context = tw$context[[1L]], trait = tw$trait[[1L]], method = tw$method[[1L]] ) -w <- do.call(getWeights, c(list(tw), key)) +w <- do.call(weights, c(list(tw), key)) length(w) -do.call(getStandardized, c(list(tw), key)) # standardized or original scale -do.call(getDataType, c(list(tw), key)) # tag carried through for reporting +do.call(weightStandardized, c(list(tw), key)) # standardized or original scale +do.call(weightsDataType, c(list(tw), key)) # tag carried through for reporting ``` -`getWeights()` returns a named numeric vector for univariate methods and a +`weights()` returns a named numeric vector for univariate methods and a 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 +`variantIds()` for the aligned variant set, `cvResult()` for the +cross-validation record (`rsq`, `r`, predicted values), and `methodFits()` for 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 d64aaa2b..e028dd2b 100644 --- a/vignettes/twas-zscore.Rmd +++ b/vignettes/twas-zscore.Rmd @@ -34,7 +34,7 @@ Three valid input combinations: | What you supply | TWAS-Z source | MR? | |---|---|---| | `twasWeights` only | per-tuple weights from `TwasWeights` | no | -| `fineMappingResult` only | SuSiE coefficients from `getTopLoci()` | yes | +| `fineMappingResult` only | SuSiE coefficients from `topLoci()` | yes | | both | weights from `TwasWeights` | yes (MR uses the FMR) | ```{r load-packages} diff --git a/vignettes/xqtl-enrichment.Rmd b/vignettes/xqtl-enrichment.Rmd index 40508b54..16f42b2a 100644 --- a/vignettes/xqtl-enrichment.Rmd +++ b/vignettes/xqtl-enrichment.Rmd @@ -44,21 +44,21 @@ qtlFineMappingExample ## Input data Each object is a `GRangesList`-backed collection, one element per tuple; -use the accessors rather than reaching into slots. `getTopLoci()` returns the -per-variant posterior table (identity columns, `pip`, and credible-set -membership): +use the accessors rather than reaching into slots. `topLoci()` returns the +per-variant posterior summary as a `GRanges`, with the identity columns, +`pip`, and credible-set membership in `mcols()`: ```{r toploci} -head(getTopLoci(gwasFineMappingExample)) -head(getTopLoci(qtlFineMappingExample)) +head(topLoci(gwasFineMappingExample)) +head(topLoci(qtlFineMappingExample)) ``` Posterior inclusion probabilities across all variants in each region, taken from the underlying SuSiE fit: ```{r pip-plots, fig.width = 7, fig.height = 3.2} -gwas_pip <- getSusieFit(gwasFineMappingExample)$pip -qtl_pip <- getSusieFit(qtlFineMappingExample)$pip +gwas_pip <- susieFit(gwasFineMappingExample)$pip +qtl_pip <- susieFit(qtlFineMappingExample)$pip op <- par(mfrow = c(1, 2)) plot( gwas_pip,