From 87f8217d0569c5fbffb58843b45ade6d8dfa8e06 Mon Sep 17 00:00:00 2001 From: Daniel Nachun Date: Sun, 1 Nov 2026 12:13:58 -0800 Subject: [PATCH 1/5] expand and improve RSS TWAS functions --- .Rbuildignore | 1 + .github/recipe/recipe.yaml | 6 +- DESCRIPTION | 10 +- LICENSE | 676 ++- NAMESPACE | 37 +- R/AllClasses.R | 463 +- R/AllGenerics.R | 250 +- R/AnnotationMatrix.R | 5 + R/ColocBoostResult.R | 13 +- R/ColocResult.R | 490 +- R/CtwasResult.R | 100 +- R/GenotypeDosageSeed.R | 14 +- R/GenotypeHandle.R | 46 +- R/GenotypeMixture.R | 25 +- R/GwasFineMappingResult.R | 21 +- R/H2Estimate.R | 381 +- R/LdMatrix.R | 178 +- R/LdScore.R | 47 +- R/LdStatistic.R | 11 +- R/MethodOptions.R | 13 +- R/MethodParam.R | 62 +- R/QtlDataset.R | 7 +- R/QtlFineMappingResult.R | 2 +- R/RangedTupleList.R | 292 +- R/causalInferencePipeline.R | 57 +- R/colocPipeline.R | 30 +- R/colocboostPipeline.R | 2 +- R/cpp11.R | 28 +- R/crossValidation.R | 256 +- R/ctwasPipeline.R | 549 +- R/exampleData.R | 28 +- R/fineMappingPipeline.R | 319 +- R/fineMappingRow.R | 342 +- R/fineMappingWrappers.R | 306 +- R/genotypeIo.R | 437 +- R/gwasSumStats.R | 6 +- R/h2Annotations.R | 47 +- R/h2EstimationWrappers.R | 892 +++- R/jointEngine.R | 330 +- R/jointSpecification.R | 135 +- R/ld.R | 489 +- R/manifestLoaders.R | 8 +- R/qtlAssociationPostprocess.R | 39 +- R/qtlSumStats.R | 28 +- R/regularizedRegressionWrappers.R | 4542 +++++++++++++---- R/resultWriters.R | 344 +- R/sumstatsQc.R | 361 +- R/tupleSelectors.R | 596 ++- R/twasWeights.R | 2031 ++++++-- R/twasWeightsPipeline.R | 475 +- R/twasWeightsRow.R | 136 +- R/variantId.R | 124 +- _pkgdown.yml | 11 +- data/ctwasEstExample.rda | Bin 247640 -> 105532 bytes data/ctwasFinemapExample.rda | Bin 248272 -> 106348 bytes data/ctwasInputsExample.rda | Bin 246876 -> 104956 bytes data/ctwasWeightsExample.rda | Bin 6668 -> 6624 bytes data/fsusieFineMappingExample.rda | Bin 22204 -> 22224 bytes data/gwasFineMappingExample.rda | Bin 650684 -> 661732 bytes data/gwasFineMappingLbfExample.rda | Bin 41316 -> 40636 bytes data/gwasSumStatsS4Example.rda | Bin 7444 -> 7388 bytes data/h2EstimateExample.rda | Bin 700 -> 1092 bytes data/ldScoreExample.rda | Bin 583572 -> 474796 bytes data/multiStudyQtlDatasetExample.rda | Bin 7068 -> 7016 bytes data/mvsusieFineMappingExample.rda | Bin 116952 -> 113516 bytes data/qtlDatasetExample.rda | Bin 5572 -> 5540 bytes data/qtlFineMappingExample.rda | Bin 212468 -> 199404 bytes data/qtlFineMappingLbfExample.rda | Bin 78172 -> 76508 bytes data/qtlFineMappingPairedExample.rda | Bin 19352 -> 17984 bytes data/qtlSumStatsExample.rda | Bin 8400 -> 8336 bytes data/qtlSumStatsMulticontextExample.rda | Bin 16512 -> 16432 bytes data/twasWeightsExample.rda | Bin 10324 -> 8940 bytes inst/COPYRIGHTS | 239 + inst/scripts/build_ctwas_examples.R | 13 +- inst/scripts/build_h2_estimate_example.R | 77 + man/AnnotationMatrix-class.Rd | 5 + man/ColocResult-class.Rd | 21 +- man/ColocResult.Rd | 8 +- man/CtwasResult-class.Rd | 6 +- man/FineMappingResultBase-class.Rd | 13 + man/GenotypeDosageSeed-class.Rd | 3 +- man/GhSeed-class.Rd | 8 +- man/H2Estimate-class.Rd | 89 +- man/LdMatrix-class.Rd | 18 +- man/LdScore-class.Rd | 8 +- man/SumStatsBase-class.Rd | 37 + man/TwasWeights-class.Rd | 61 +- man/TwasWeights.Rd | 51 +- man/TwasWeightsRow-class.Rd | 6 - man/annotationJackknifeCoefs.Rd | 7 +- man/assembleCtwasInputs.Rd | 9 +- man/bLassoWeights.Rd | 52 - man/bayesARssWeights.Rd | 86 + man/bayesAWeights.Rd | 54 +- man/bayesAlphabetRss.Rd | 106 + man/bayesAlphabetRssWeights.Rd | 134 + man/bayesAlphabetWeights.Rd | 100 +- man/bayesBRssWeights.Rd | 89 + man/bayesBWeights.Rd | 62 +- man/bayesCRssWeights.Rd | 90 + man/bayesCWeights.Rd | 58 +- man/bayesLRssWeights.Rd | 86 + man/bayesLWeights.Rd | 57 +- man/bayesNRssWeights.Rd | 87 + man/bayesNWeights.Rd | 55 +- man/bayesRRssWeights.Rd | 86 + man/bayesRWeights.Rd | 55 +- man/bglrWeights.Rd | 11 +- man/causalInferencePipeline.Rd | 6 +- man/colocPipeline.Rd | 10 +- man/colocViews.Rd | 8 +- man/ctwasGroupPriors.Rd | 33 +- man/ctwasPipeline.Rd | 9 +- man/dot-penalizedRssWeights.Rd | 6 +- man/dprWeights.Rd | 6 +- man/enetRssWeights.Rd | 19 +- man/enetWeights.Rd | 21 +- man/estimateH2.Rd | 145 +- man/estimateSparsity.Rd | 4 +- man/fitMvsusie.Rd | 11 + man/fitMvsusieRss.Rd | 11 + man/flattenTupleRanges.Rd | 6 + man/fsusieWeights.Rd | 11 +- man/glmnetWeights.Rd | 21 +- man/h2EstimateExample.Rd | 18 +- man/h2EstimateToSldscTrait.Rd | 6 +- man/heritabilityEstimate.Rd | 8 +- man/heritabilityEstimateSe.Rd | 6 +- man/heritabilityIntercept.Rd | 9 +- man/heritabilityInterceptSe.Rd | 6 +- man/l0learnRssWeights.Rd | 16 +- man/l0learnWeights.Rd | 22 +- man/lassoWeights.Rd | 20 +- man/lassosumRssWeights.Rd | 100 +- man/ldpred2AutoWeights.Rd | 112 + man/ldpred2GridWeights.Rd | 114 + man/learnTwasWeights.Rd | 13 +- man/localH2Blocks.Rd | 24 - man/mcpRssWeights.Rd | 17 +- man/mcpWeights.Rd | 21 +- man/methodNames.Rd | 4 +- man/mrashWeights.Rd | 7 +- man/mrmashWrapper.Rd | 10 +- man/mvsusieWeights.Rd | 23 +- man/nSnps.Rd | 6 +- man/ncvregWeights.Rd | 22 +- man/nestTupleRanges.Rd | 3 + man/pecotmr-h2-lder.Rd | 4 +- man/penalizedRss.Rd | 10 +- man/prsCs.Rd | 23 +- man/qtlAssociationPostprocess.Rd | 7 +- man/readAfreq.Rd | 6 +- man/readAnnotations.Rd | 9 +- man/resolveWeights.Rd | 2 + man/ridgeRssWeights.Rd | 25 +- man/ridgeWeights.Rd | 20 +- man/scadRssWeights.Rd | 17 +- man/scadWeights.Rd | 21 +- man/scoreStats.Rd | 8 +- man/sdpr.Rd | 21 +- man/stratifiedHeritabilityEnrichment.Rd | 17 +- man/studyName.Rd | 14 +- man/traitNames.Rd | 8 +- man/twasEngineOptions.Rd | 32 +- man/twasWeightsCv.Rd | 35 +- man/twasWeightsEntry.Rd | 13 +- man/twasWeightsExample.Rd | 8 +- man/twasWeightsPipeline.Rd | 77 +- man/updateObject-methods.Rd | 38 +- pixi.toml | 2 + src/cpp11.cpp | 64 +- src/dentist_iterative_impute.cpp | 4 + src/function_pool.cpp | 60 - src/function_pool.h | 26 - src/penalized_rss.cpp | 6 + src/prscs_mcmc.cpp | 111 - src/prscs_mcmc.h | 393 -- src/qtl_enrichment.cpp | 7 + src/qtl_enrichment.h | 7 + src/rss_mcmc.cpp | 1138 +++++ src/rss_mcmc.h | 1449 ++++++ src/sdpr.cpp | 139 - src/sdpr_mcmc.cpp | 739 --- src/sdpr_mcmc.h | 262 - tests/testthat/helper-fineMapping.R | 15 +- tests/testthat/helper-h2Classes.R | 37 +- tests/testthat/helper-rrwFixtures.R | 47 +- tests/testthat/helper-s4Constructors.R | 2 +- tests/testthat/helper-savedObjects.R | 111 +- tests/testthat/test_AllClasses.R | 390 +- tests/testthat/test_ColocBoostResult.R | 9 +- tests/testthat/test_ColocResult.R | 174 +- tests/testthat/test_CtwasResult.R | 136 + tests/testthat/test_GenotypeMixture.R | 23 + tests/testthat/test_H2Estimate.R | 284 +- tests/testthat/test_LdMatrix.R | 70 +- tests/testthat/test_LdScore.R | 19 + tests/testthat/test_QtlDataset.R | 247 +- tests/testthat/test_QtlFineMappingResult.R | 8 +- tests/testthat/test_RangedTupleList.R | 91 +- tests/testthat/test_causalInferencePipeline.R | 109 +- tests/testthat/test_colocPipeline.R | 78 +- tests/testthat/test_colocboostPipeline.R | 77 +- tests/testthat/test_cpp11.R | 3 + tests/testthat/test_crossValidation.R | 211 + tests/testthat/test_ctwasPipeline.R | 354 +- tests/testthat/test_data/h2EstimateSaved.rds | Bin 0 -> 1136 bytes tests/testthat/test_fineMappingPipeline.R | 332 +- tests/testthat/test_fineMappingRow.R | 295 +- tests/testthat/test_fineMappingWrappers.R | 227 +- tests/testthat/test_genotypeHandle.R | 33 +- tests/testthat/test_genotypeIo.R | 84 +- tests/testthat/test_h2Annotations.R | 54 +- tests/testthat/test_h2EstimationWrappers.R | 491 +- tests/testthat/test_jointEngine.R | 327 +- tests/testthat/test_jointSpecification.R | 291 +- tests/testthat/test_ld.R | 290 +- .../testthat/test_qtlAssociationPostprocess.R | 28 +- .../test_regularizedRegressionWrappers.R | 249 +- tests/testthat/test_resultReaders.R | 29 +- tests/testthat/test_resultWriters.R | 98 +- tests/testthat/test_rrBayesAlphabet.R | 818 ++- tests/testthat/test_rrBglr.R | 59 +- tests/testthat/test_rrDispatch.R | 39 +- tests/testthat/test_rrDpr.R | 20 + tests/testthat/test_rrE2eSolvers.R | 29 +- tests/testthat/test_rrGlmnet.R | 31 + tests/testthat/test_rrL0learn.R | 31 + tests/testthat/test_rrLassosum.R | 128 +- tests/testthat/test_rrLdpred2.R | 290 ++ tests/testthat/test_rrMrash.R | 19 + tests/testthat/test_rrNcvreg.R | 25 + tests/testthat/test_rrPenalizedRss.R | 162 +- tests/testthat/test_rrPrsCs.R | 236 +- tests/testthat/test_rrSdpr.R | 140 + tests/testthat/test_rrSignalRecovery.R | 2 +- tests/testthat/test_sumstatsQc.R | 351 +- tests/testthat/test_tupleSelectors.R | 153 +- tests/testthat/test_twasWeights.R | 756 ++- tests/testthat/test_twasWeightsPipeline.R | 563 +- tests/testthat/test_twasWeightsRow.R | 94 +- tests/testthat/test_variantId.R | 66 +- tests/testthat/testthat-problems.rds | Bin 0 -> 33442 bytes vignettes/coloc-pipeline.Rmd | 7 +- vignettes/ctwas-pipeline.Rmd | 18 +- vignettes/heritability.Rmd | 43 +- vignettes/twas-weights.Rmd | 117 +- 247 files changed, 25552 insertions(+), 7749 deletions(-) create mode 100644 inst/COPYRIGHTS create mode 100644 inst/scripts/build_h2_estimate_example.R delete mode 100644 man/bLassoWeights.Rd create mode 100644 man/bayesARssWeights.Rd create mode 100644 man/bayesAlphabetRss.Rd create mode 100644 man/bayesAlphabetRssWeights.Rd create mode 100644 man/bayesBRssWeights.Rd create mode 100644 man/bayesCRssWeights.Rd create mode 100644 man/bayesLRssWeights.Rd create mode 100644 man/bayesNRssWeights.Rd create mode 100644 man/bayesRRssWeights.Rd create mode 100644 man/ldpred2AutoWeights.Rd create mode 100644 man/ldpred2GridWeights.Rd delete mode 100644 man/localH2Blocks.Rd delete mode 100644 src/function_pool.cpp delete mode 100644 src/function_pool.h delete mode 100644 src/prscs_mcmc.cpp delete mode 100644 src/prscs_mcmc.h create mode 100644 src/rss_mcmc.cpp create mode 100644 src/rss_mcmc.h delete mode 100644 src/sdpr.cpp delete mode 100644 src/sdpr_mcmc.cpp delete mode 100644 src/sdpr_mcmc.h create mode 100644 tests/testthat/test_data/h2EstimateSaved.rds create mode 100644 tests/testthat/test_rrLdpred2.R create mode 100644 tests/testthat/testthat-problems.rds diff --git a/.Rbuildignore b/.Rbuildignore index ed2d16c7a..2449e5f69 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,3 +13,4 @@ ^dev$ ^air.toml ^inst/prototype +^LICENSE$ diff --git a/.github/recipe/recipe.yaml b/.github/recipe/recipe.yaml index bc8891b77..a8886eb77 100644 --- a/.github/recipe/recipe.yaml +++ b/.github/recipe/recipe.yaml @@ -55,12 +55,14 @@ requirements: - r-ctwas - r-dbi - r-dplyr + - r-fdrtool - r-flashier - r-fsusier - r-gbj - r-glmnet - r-glue - r-harmonicmeanp + - r-hibayes - r-igraph - r-l0learn - r-magrittr @@ -129,12 +131,14 @@ requirements: - r-ctwas - r-dbi - r-dplyr + - r-fdrtool - r-flashier - r-fsusier - r-gbj - r-glmnet - r-glue - r-harmonicmeanp + - r-hibayes - r-igraph - r-l0learn - r-magrittr @@ -176,7 +180,7 @@ tests: - R -e "library('pecotmr')" about: - license: MIT + license: GPL-3.0-only license_file: LICENSE summary: pecotmr implements pair-wise enrichment, colocalization, TWAS and Mendelian Randomization to integrate QTL and GWAS analysis based on a fine-mapped single effects model. homepage: https://github.com/StatFunGen/pecotmr diff --git a/DESCRIPTION b/DESCRIPTION index f70cb96b1..44421403f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,7 +12,8 @@ Authors@R: c(person("Gao Wang",role = c("cre","aut"), person("Daniel Nachun", role = "aut", email = "dnachun@stanford.edu"), person("StatFunGen Lab", role = "ctb")) -License: MIT + file LICENSE +License: GPL-3 +Copyright: See the file inst/COPYRIGHTS for code included from other projects. biocViews: StatisticalMethod, GenomeWideAssociation, @@ -51,6 +52,7 @@ Imports: Rsamtools, S4Arrays, S4Vectors, + SparseArray, stringr, SummarizedExperiment, susieR (>= 0.16.4), @@ -74,6 +76,7 @@ Suggests: ctwas, DBI, ebnm, + fdrtool, flashier, fsusieR, GBJ, @@ -81,6 +84,7 @@ Suggests: gdsfmt, glmnet, harmonicmeanp, + hibayes, igraph, knitr, L0Learn, @@ -138,8 +142,6 @@ Collate: 'CtwasResult.R' 'GenotypeDosageSeed.R' 'GwasFineMappingResult.R' - 'MethodOptions.R' - 'MethodParam.R' 'H2Estimate.R' 'JointGroup.R' 'LdBlocks.R' @@ -147,6 +149,8 @@ Collate: 'LdEigen.R' 'LdScore.R' 'MashPrior.R' + 'MethodOptions.R' + 'MethodParam.R' 'qtlSumStats.R' 'QtlDataset.R' 'MultiStudyQtlDataset.R' diff --git a/LICENSE b/LICENSE index 22d6bc3f6..f288702d2 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,674 @@ -YEAR: 2023 -COPYRIGHT HOLDER: Gao Wang + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/NAMESPACE b/NAMESPACE index a1ffad9a9..d7e6c64ef 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,7 +17,9 @@ export("maf<-") export("sampleSize<-") export(AnnotationMatrix) export(AspuOptions) +export(BayesAlphabetRssOptions) export(BglrOptions) +export(BigsnprOptions) export(BoundaryMergeParam) export(ColocBoostResult) export(ColocLbfFilterParam) @@ -60,6 +62,8 @@ export(GlmnetOptions) export(GwasFineMappingParam) export(GwasFineMappingResult) export(GwasSumStats) +export(HibayesOptions) +export(HibayesRssOptions) export(KrigingOptions) export(L0learnOptions) export(LassosumOptions) @@ -135,14 +139,20 @@ export(annotationJackknifeCoefs) export(asCtwasResult) export(assembleCtwasInputs) export(autoDecision) -export(bLassoWeights) export(baselineAnnotations) +export(bayesARssWeights) export(bayesAWeights) +export(bayesAlphabetRssWeights) export(bayesAlphabetWeights) +export(bayesBRssWeights) export(bayesBWeights) +export(bayesCRssWeights) export(bayesCWeights) +export(bayesLRssWeights) export(bayesLWeights) +export(bayesNRssWeights) export(bayesNWeights) +export(bayesRRssWeights) export(bayesRWeights) export(blockId) export(buildLdEigen) @@ -260,13 +270,14 @@ export(ldMismatchQc) export(ldPanelNSamples) export(ldPruneByCorrelation) export(ldReference) +export(ldpred2AutoWeights) +export(ldpred2GridWeights) export(learnTwasWeights) export(loadGenotypeRegion) export(loadGwasSumStatsFromManifest) export(loadMultiStudyQtlDatasetFromManifest) export(loadQtlDatasetFromManifest) export(loadQtlSumStatsFromManifest) -export(localH2Blocks) export(maf) export(makePairwiseContrastCol) export(marginalEffects) @@ -503,12 +514,14 @@ exportMethods(fullFit) exportMethods(genomicRegion) exportMethods(genotypeCovariates) exportMethods(genotypes) +exportMethods(getListElement) exportMethods(heritabilityEstimate) exportMethods(heritabilityEstimateSe) exportMethods(heritabilityIntercept) exportMethods(heritabilityInterceptSe) exportMethods(inSample) exportMethods(intersectVariants) +exportMethods(lapply) exportMethods(lbf) exportMethods(ldBlocks) exportMethods(ldMatrix) @@ -516,7 +529,6 @@ exportMethods(ldMatrixList) exportMethods(ldPanelNSamples) exportMethods(ldReference) exportMethods(length) -exportMethods(localH2Blocks) exportMethods(longForm) exportMethods(maf) exportMethods(marginalEffects) @@ -575,15 +587,18 @@ exportMethods(writeGwasVcf) exportMethods(z) importClassesFrom(BiocParallel,BiocParallelParam) importClassesFrom(GenomicRanges,GRanges) +importClassesFrom(Matrix,dspMatrix) importClassesFrom(MultiAssayExperiment,MultiAssayExperiment) importClassesFrom(S4Vectors,DataFrame) importClassesFrom(S4Vectors,List) importClassesFrom(S4Vectors,SimpleList) importClassesFrom(S4Vectors,Vector) importClassesFrom(S4Vectors,character_OR_NULL) +importClassesFrom(SparseArray,SVT_SparseArray) importClassesFrom(SummarizedExperiment,RangedSummarizedExperiment) importFrom(BiocGenerics, colnames, + lapply, ncol, nrow, path, @@ -620,6 +635,10 @@ importFrom(IRanges, trim ) importFrom(MASS,ginv) +importFrom(Matrix, + colSums, + rowSums +) importFrom(MultiAssayExperiment, ExperimentList, MultiAssayExperiment, @@ -648,8 +667,10 @@ importFrom(S4Vectors, DataFrame, SimpleList, bindROWS, + elementNROWS, endoapply, extractROWS, + getListElement, mcols, metadata, normalizeSingleBracketSubscript, @@ -760,7 +781,9 @@ importFrom(purrr, list_rbind, map, map2, + map2_chr, map2_dbl, + map2_int, map2_lgl, map_chr, map_dbl, @@ -768,6 +791,7 @@ importFrom(purrr, map_int, map_lgl, partial, + pluck, pmap, possibly, pwalk, @@ -789,6 +813,7 @@ importFrom(readr, importFrom(rlang, "!!!", .data, + .env, abort, arg_match, arg_match0, @@ -817,11 +842,13 @@ importFrom(stats, optimize, pcauchy, pchisq, + pf, pnorm, predict, pt, qnorm, quantile, + rnorm, sd, setNames, var @@ -874,7 +901,9 @@ importFrom(tidyselect,all_of) importFrom(tools,file_ext) importFrom(utils, combn, - head + head, + removeSource, + tail ) importFrom(vctrs, vec_chop, diff --git a/R/AllClasses.R b/R/AllClasses.R index 5149c2232..b3a69d25b 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -65,6 +65,16 @@ setClassUnion( #' \code{x[[i]]} is that tuple's summary statistics and the identity columns #' live in \code{mcols(x)}. There is no \code{entry} column: what used to be #' \code{x$entry[[i]]} is now simply \code{x[[i]]}. +#' @details The rows are stored compactly: a column recomputed exactly from +#' the others (\code{SNP} from the variant's position and alleles, +#' \code{BETA} and \code{SE} from \code{Z}, \code{MAF} and \code{N}, +#' \code{P} from \code{Z}) is left out, and the stored variants' metadata +#' (\code{derivedColumns}) names those they leave out; \code{N}, +#' \code{N_CASE}, \code{N_CONTROL} and \code{z_supplied} are run-length +#' encoded where that is smaller. \code{x[[i]]}, \code{as.list()}, +#' \code{lapply()}, \code{\link{sumStats}} and the per-variant accessors +#' hand the rows out with every column back. \code{unlist()} hands them out +#' as stored, and a collection built from them puts the columns back. #' @slot ldReference A named list of the LD references the rows were #' harmonized against and every pipeline reads LD from, each a genotype #' panel (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} @@ -92,7 +102,9 @@ setClass( ) methods::setValidity("SumStatsBase", function(object) { - .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) %||% TRUE + .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) %||% + .ssDerivedProblems(object) %||% + TRUE }) # TRUE when two elements share both their identity tuple AND their span. @@ -164,6 +176,267 @@ methods::setValidity("SumStatsBase", function(object) { gr[onWindowChrom & IRanges::overlapsAny(gr, win)] } +# ============================================================================= +# Summary statistics stored compactly +# ----------------------------------------------------------------------------- +# A summary-statistic collection stores its variants' columns compactly and +# hands them out plain, so a reader sees the columns the rows were given: +# - SNP is left out when every label is the id rendered from its variant's +# position and alleles, as every QC'd collection's is; +# - BETA, SE and P are left out when recomputing them as QC derives them -- +# BETA and SE from Z, MAF and N, P from Z -- gives them back exactly; +# - MAF and AF keep no names, which only repeated the variant ids; +# - N, N_CASE, N_CONTROL and z_supplied are run-length encoded where that is +# smaller. +# The stored variants record the columns they leave out in their metadata +# (`derivedColumns`), so a column the source never had is not taken for one +# left out, and the record goes wherever the stored variants go: unlist(x), +# and any piece of it, carries it, and a collection built from them puts the +# columns back. x[[i]], as.list(), lapply(), sumStats() and the readers built +# on them hand out every column (.ssPlainElement()). +# ============================================================================= + +# Variant columns in the order a row holds them (.dfToEntryGranges()). +# @noRd +.SS_COLUMNS <- c( + "SNP", + "A1", + "A2", + "Z", + "N", + "AF", + "MAF", + "INFO", + "BETA", + "SE", + "P", + "N_CASE", + "N_CONTROL", + "z_supplied" +) + +# The columns a row may leave out, in the order they are put back, each +# with the columns it is recomputed from. +# @noRd +.SS_DERIVED <- list( + SNP = c("A1", "A2"), + BETA = c("Z", "MAF", "N"), + SE = c("Z", "MAF", "N"), + P = "Z" +) + +# The columns stored run-length encoded where that is smaller. +# @noRd +.SS_RLE <- c("N", "N_CASE", "N_CONTROL", "z_supplied") + +# `grl` as a summary-statistic collection stores it (see above). Columns its +# variants leave out already are put back first, so storing a stored +# collection again changes nothing. +# @noRd +.ssStored <- function(grl) { + flat <- .ssPlainElement(unlist(grl, use.names = FALSE)) + md <- .ssUnnamedFrequencies(mcols(flat, use.names = FALSE)) + left <- .ssLeftOutColumns(flat, md) + kept <- md[, setdiff(colnames(md), left), drop = FALSE] + stored <- .ssWithLeftOut( + S4Vectors::`mcols<-`(flat, value = .rtlRleWhereSmaller(kept, .SS_RLE)), + left + ) + S4Vectors::`mcols<-`( + IRanges::relist( + stored, + IRanges::PartitioningByEnd( + cumsum(lengths(grl)), + names = names(grl) + ) + ), + value = mcols(grl, use.names = FALSE) + ) +} + +# `x`'s rows as a bare GRangesList, every column back (.ssPlainFlat()). +# @noRd +.ssPlainRows <- function(x) { + IRanges::relist( + .rtlGatherElements(x, seq_along(x)), + IRanges::PartitioningByEnd(cumsum(lengths(x)), names = names(x)) + ) +} + +# The columns stored variants `gr` leave out, as their metadata records. +# @noRd +.ssLeftOut <- function(gr) { + as.character(S4Vectors::metadata(gr)$derivedColumns) +} + +# `gr` recording that it leaves out columns `left` (none: no record). +# @noRd +.ssWithLeftOut <- function(gr, left) { + md <- S4Vectors::metadata(gr) + md$derivedColumns <- if (length(left) > 0L) left + S4Vectors::`metadata<-`(gr, value = md) +} + +# Variants as a summary-statistic collection stores them, `gr` -- a row, a +# piece of one, or unlist() of a collection -- with every column back +# (.ssPlainFlat()) and no record left of any it left out. Anything but +# ranges passes through. +# @noRd +.ssPlainElement <- function(gr) { + if (!methods::is(gr, "GenomicRanges")) { + return(gr) + } + .ssWithLeftOut(.ssPlainFlat(gr, .ssLeftOut(gr)), character(0)) +} + +# A constructor's entries with every column back (.ssPlainElement()), in +# the canonical seqname and allele styles (.canonEntries()). +# @noRd +.ssEntries <- function(entry) { + .canonEntries(map(as.list(entry), .ssPlainElement)) +} + +# The variants of rows as stored, `flat`, with every column back: those run- +# length encoded decoded, and those in `left` that it lacks recomputed, each +# put in its place. +# @noRd +.ssPlainFlat <- function(flat, left) { + plain <- .rtlPlainMcols(flat) + md <- mcols(plain, use.names = FALSE) + missing <- setdiff(intersect(names(.SS_DERIVED), left), colnames(md)) + if (length(missing) == 0L) { + return(plain) + } + S4Vectors::`mcols<-`( + plain, + value = reduce(missing, .ssPutBack, .init = md, flat = plain) + ) +} + +# `md` with column `col` recomputed and put where a row holds it. +# @noRd +.ssPutBack <- function(md, col, flat) { + cn <- colnames(md) + md[[col]] <- .ssDerive(col, flat, md) + md[, append(cn, col, after = .ssPlaceOf(col, cn)), drop = FALSE] +} + +# Column `col` recomputed from the others: the id rendered from the variant's +# position and alleles, or BETA, SE or P as QC derives them +# (.zToBetaSe(), .zToPvalue()). +# @noRd +.ssDerive <- function(col, flat, md) { + if (col == "SNP") { + return(.grVariantIds(flat)) + } + if (col == "P") { + return(.zToPvalue(md$Z)) + } + .zToBetaSe(md$Z, md$MAF, md$N)[[str_to_lower(col)]] +} + +# The columns of `md` (the variants of `flat`) a collection leaves out: each +# recomputes to exactly what it holds, and putting them back puts each in its +# place again. +# @noRd +.ssLeftOutColumns <- function(flat, md) { + left <- keep(names(.SS_DERIVED), .ssReproduces, flat = flat, md = md) + restored <- reduce( + left, + .ssPlaceName, + .init = setdiff(colnames(md), left) + ) + if (!identical(restored, colnames(md))) { + return(character(0)) + } + left +} + +# TRUE when `md` holds column `col` and the columns it is recomputed from, +# and recomputing it gives back exactly what it holds. +# @noRd +.ssReproduces <- function(col, flat, md) { + needed <- c(col, .SS_DERIVED[[col]]) + if (nrow(md) == 0L || !all(is_in(needed, colnames(md)))) { + return(FALSE) + } + identical(md[[col]], .ssDerive(col, flat, md)) +} + +# Column names `cn` with `col` put in its place among them. +# @noRd +.ssPlaceName <- function(cn, col) { + append(cn, col, after = .ssPlaceOf(col, cn)) +} + +# Where column `col` goes among columns `cn`: after the last of them a row +# holds before it (.SS_COLUMNS), or first. +# @noRd +.ssPlaceOf <- function(col, cn) { + before <- .SS_COLUMNS[seq_len(match(col, .SS_COLUMNS) - 1L)] + max(c(0L, match(before, cn)), na.rm = TRUE) +} + +# `md` with the names of its MAF and AF columns dropped. +# @noRd +.ssUnnamedFrequencies <- function(md) { + reduce( + intersect(c("MAF", "AF"), colnames(md)), + .ssUnnameColumn, + .init = md + ) +} + +# @noRd +.ssUnnameColumn <- function(md, cn) { + md[[cn]] <- unname(md[[cn]]) + md +} + +# What is wrong with the record of the columns `object`'s variants leave +# out, or NULL: it names only columns they may leave out, and none they hold. +# @noRd +.ssDerivedProblems <- function(object) { + flat <- unlist(object, use.names = FALSE) + left <- .ssLeftOut(flat) + held <- colnames(mcols(flat)) + bad <- union(setdiff(left, names(.SS_DERIVED)), intersect(left, held)) + if (length(bad) == 0L) { + return(NULL) + } + str_c( + "derivedColumns names columns the variants cannot leave out: ", + str_flatten(bad, ", ") + ) +} + +#' @rdname SumStatsBase-class +#' @param x A summary-statistics collection. +#' @param i The row: a position or an element name. +#' @param exact Passed on to the element lookup. +#' @importFrom S4Vectors getListElement +#' @export +setMethod("getListElement", "SumStatsBase", function(x, i, exact = TRUE) { + .ssPlainElement(methods::callNextMethod()) +}) + +#' @rdname SumStatsBase-class +#' @param use.names Whether the list keeps the element names. +#' @export +setMethod("as.list", "SumStatsBase", function(x, use.names = TRUE) { + as.list(.ssPlainRows(x), use.names = use.names) +}) + +#' @rdname SumStatsBase-class +#' @param X A summary-statistics collection. +#' @param FUN The function applied to each row's variants. +#' @param ... Passed on to \code{FUN}. +#' @importFrom BiocGenerics lapply +#' @export +setMethod("lapply", "SumStatsBase", function(X, FUN, ...) { + lapply(as.list(X), FUN, ...) +}) + # The build recorded in seqinfo must be exactly one non-NA value. A missing # build is an error rather than a default: every downstream liftover / LD # join keys on it, and silently guessing hg38 is how a mismatched panel gets @@ -399,7 +672,8 @@ setMethod( # that slot as an attribute; it is split into the `qcOptions` slot and the # `qcAudit` column. An object older still held its genome build in a # `genome` slot (.ssMigrateGenome()). An object that old needs the updates -# every collection shares too, so the inherited update runs either way. +# every collection shares too, so the inherited update runs either way. Its +# rows are then stored as they are today (.ssRestored()). #' @rdname updateObject-methods #' @export setMethod( @@ -413,14 +687,23 @@ setMethod( if (!is.null(old)) { object <- .ssMigrateQcInfo(object, old) } - methods::callNextMethod( + .ssRestored(methods::callNextMethod( .ssMigrateGenome(object), ..., verbose = verbose - ) + )) } ) +# `x` with its rows stored as a collection stores them today (.ssStored()): +# an object saved before held every column in full. `x` itself when they +# are stored so already. +# @noRd +.ssRestored <- function(x) { + restored <- .rtlFinish(x, .ssPlainRows(x), seq_along(x)) + if (identical(restored, x)) x else restored +} + # Before the genome build moved into seqinfo(), summary statistics held it # in a `genome` slot; an object saved then still carries it as an # attribute, and it becomes the build seqinfo() names (none, when the slot @@ -910,6 +1193,17 @@ setMethod( #' \code{mcols} names the entry each row used (\code{NA} for a fit derived #' from individual-level data). Used downstream to check that the rows a #' pipeline combines share an LD reference. +#' @slot cvPartition A named list of the cross-validation fold partitions the +#' rows' results share, each with the order of the samples its out-of-fold +#' predictions are held for, stored once apiece; the \code{cvPartition} +#' column of \code{mcols} names the entry each row's result used +#' (\code{NA} for a row without one). \code{cvResult()} returns a row's +#' result with its partition and sample names in place. +#' @slot fits A named list of the rows' fits, stored once apiece: the rows of +#' a joint fit, one per condition, all name one entry. The +#' \code{susieFit} column of \code{mcols} names each row's entry +#' (\code{NA} for a row without a fit); \code{susieFit()} returns it in +#' place. #' @section Narrowed rows: A row is built from its fit, holding the fit's #' variables in the fit's order, so its fit is read off it by position. A #' row narrowed since -- by \code{endoapply()} or \code{[[<-} -- keeps its @@ -933,12 +1227,15 @@ setMethod( setClass( "FineMappingResultBase", contains = c("VIRTUAL", "RangedTupleList"), - representation(ldReference = "list"), - prototype(ldReference = list()) + representation(ldReference = "list", cvPartition = "list", fits = "list"), + prototype(ldReference = list(), cvPartition = list(), fits = list()) ) methods::setValidity("FineMappingResultBase", function(object) { - .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) %||% TRUE + .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) %||% + .cvPartitionProblems(object) %||% + .fitProblems(object, "susieFit") %||% + TRUE }) #' @rdname studyName @@ -1009,42 +1306,57 @@ setMethod( } ) -# The collection's identity columns plus the per-entry payload columns. +# The collection's identity columns plus the per-entry payload columns, with +# the CV as `cv` (.cvStoredColumn()) stores it and each fit as its key into +# the fits dictionary (`fitKeys`). # @noRd -.withEntryPayload <- function(md, entries) { +.withEntryPayload <- function(md, entries, cv, fitKeys) { # `[[<-` not cbind(): the collection may already carry these columns, and # they must be REPLACED -- cbind would append a second copy of each, which # every reader then shadows with the stale one. - withFit <- `[[<-`( - md, - "susieFit", - value = S4Vectors::SimpleList(map(entries, susieFit)) - ) - withCv <- `[[<-`( - withFit, - "cvResult", - value = S4Vectors::SimpleList(map(entries, cvResult)) - ) + withFit <- `[[<-`(md, "susieFit", value = fitKeys) + withCv <- `[[<-`(withFit, "cvResult", value = cv$cvResult) + withKeys <- `[[<-`(withCv, "cvPartition", value = cv$keys) `[[<-`( - withCv, + withKeys, "derivedColumns", value = IRanges::CharacterList(map(entries, .fmRowDerivedColumns)) ) } # Rebuild a fine-mapping collection from adjusted entries, keeping every -# identity column and collection-level slot. +# identity column, row name and collection-level slot. # @noRd .fmrFromEntries <- function(x, entries) { - # .rtlRebuild() carries the names, seqinfo (the genome build) and every - # slot -- the rows keep their keys in mcols, so the references go across - # as is -- and only the payload columns are new. - rebuilt <- .rtlRebuild(x, map(entries, variants), seq_len(length(x))) - withPayload <- `mcols<-`( - rebuilt, - value = .withEntryPayload(mcols(rebuilt, use.names = FALSE), entries) + # The stored CV, not cvResult()'s view of it: that names the fold weights, + # whose ids the rows hold once. + cv <- .cvStoredColumn(map(entries, .fmRowCvStored)) + fitted <- .dictBuild(map(entries, susieFit), .FIT_DICT_PREFIX) + # seqinfo carries the genome build, which elements rebuilt bare lose. + grl <- `mcols<-`( + .rtlRestoreSeqinfo(.rtlBindElements(map(entries, variants)), x), + value = .withEntryPayload( + mcols(x, use.names = FALSE), + entries, + cv, + fitted$keys + ) + ) + # Every slot goes across -- the rows keep their keys in mcols, so the LD + # references go as they are -- but the dictionaries the entries now fill. + ownSlots <- .rtlOwnSlots(x) + slotArgs <- list_assign( + set_names(map(ownSlots, .rtlGetSlot, x = x), ownSlots), + cvPartition = cv$entries, + fits = fitted$entries ) - S4Vectors::`metadata<-`(withPayload, value = S4Vectors::metadata(x)) + rebuilt <- exec( + methods::new, + class(x), + .rtlStored(class(x), .rtlNamedLike(grl, x, seq_along(x))), + !!!slotArgs + ) + S4Vectors::`metadata<-`(rebuilt, value = S4Vectors::metadata(x)) } # TRUE when an entry shares at least one variant with `keepVariants`, matched @@ -1199,7 +1511,8 @@ trimFineMappingResult <- function(x, role = NULL) { # The alpha rows and prior variances of the fit's effects of positive prior # variance, named by effect id, and alpha's columns by `fitIds` when given. -# An already trimmed fit's names are its ids. +# An already trimmed fit's names are its ids; a fit trimmed when it was stored +# records its effects (.fitEffectIndex()). # @noRd .trimEffects <- function(fit, fitIds = NULL) { priorVariance <- fit[["V"]] %||% fit[["prior_variance"]] @@ -1210,7 +1523,7 @@ trimFineMappingResult <- function(x, role = NULL) { ids <- if (.namedByEffect(alpha)) { rownames(alpha) } else { - str_c("L", seq_len(nrow(alpha))) + str_c("L", .fitEffectIndex(fit, nrow(alpha))) } keep <- which(as.numeric(priorVariance) > 0) list( @@ -1345,7 +1658,7 @@ setMethod( # and carried on the fit. # @noRd .rcMassForRow <- function(i, x) { - fit <- mcols(x)$susieFit[[i]] + fit <- .fitEntry(mcols(x)$susieFit[[i]], x) mass <- .rcFitRetainedMass(fit) if (is.null(mass)) { return(NULL) @@ -1629,10 +1942,94 @@ setMethod( } else { object } - methods::callNextMethod(current, ..., verbose = verbose) + # The storage steps rebuild the collection, so they run once the + # inherited update has brought its slots up to date. + updated <- methods::callNextMethod( + .fmrFoldFitsToWeights(current), + ..., + verbose = verbose + ) + .fmrStoreTopLoci(.fmrShareFits(.cvSharePartitions(updated))) } ) +# A collection saved before rows shared their fits holds each row's fit in +# its `susieFit` cell. They move to the fits dictionary, where the rows of a +# joint fit share one entry. +# @noRd +#' @importFrom methods slot<- +.fmrShareFits <- function(object) { + md <- mcols(object, use.names = FALSE) + if (is.character(md$susieFit)) { + return(object) + } + fitted <- .dictBuild(as.list(md$susieFit), .FIT_DICT_PREFIX) + md$susieFit <- fitted$keys + methods::slot(object, "fits", check = FALSE) <- fitted$entries + S4Vectors::`mcols<-`(object, value = md) +} + +# A saved collection's topLoci as collections now store them, compact +# (.fmrCompactTopLoci()): rebuilding its elements stores them so. +# @noRd +.fmrStoreTopLoci <- function(object) { + flat <- unlist(object, use.names = FALSE) + .rtlWithVariantMcols(object, mcols(flat, use.names = FALSE)) +} + +# A saved collection whose CV kept per-fold fits, with each turned into the +# per-fold weights rows now keep (.cvFoldFitsToWeights()). +# @noRd +.fmrFoldFitsToWeights <- function(object) { + cvs <- as.list(mcols(object, use.names = FALSE)$cvResult) + if (!any(map_lgl(cvs, .cvHasFoldFits))) { + return(object) + } + ids <- map(seq_along(object), .fmrRowVariantIdsAt, x = object) + `$<-`( + object, + "cvResult", + S4Vectors::SimpleList(map2(cvs, ids, .cvFoldFitsToWeights)) + ) +} + +# Whether a saved row's CV (one payload, or one per region) has fold fits. +# @noRd +.cvHasFoldFits <- function(cv) { + if (.cvIsPerRegion(cv)) { + return(any(map_lgl(cv, .cvPayloadHasFoldFits))) + } + .cvPayloadHasFoldFits(cv) +} + +# @noRd +.cvPayloadHasFoldFits <- function(cv) { + !is.null(cv$foldFits) +} + +# @noRd +.fmrRowVariantIdsAt <- function(i, x) { + .grVariantIds(x[[i]]) +} + +# The variant names a fine-mapping fit carries: its PIPs' names, else the +# columns of its effect matrices (SuSiE, mvSuSiE) or of csd_X (fSuSiE); none +# for an unnamed fit. A null_weight fit gives its effect matrices one more +# column, which susieR names "null"; that is no variant. +# @noRd +.fitNamedVariants <- function(fit) { + if (!is.list(fit)) { + return(character(0)) + } + named <- as.character( + names(fit[["pip"]]) %||% + colnames(fit[["alpha"]]) %||% + colnames(fit[["lbf_variable"]]) %||% + names(fit[["csd_X"]]) + ) + named[named != "null"] +} + #' @rdname traitPosition #' @examples #' data(qtlDatasetExample) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index e1ab22773..45d66a9e4 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -23,16 +23,64 @@ NULL # ============================================================================= #' @title Estimate SNP Heritability -#' @description Estimate SNP heritability from GWAS summary statistics using -#' one of four methods: S-LDSC, g-LDSC, LDER, or HDL/sHDL. Supplying -#' \code{annotations} makes any of them stratified. -#' @param sumstats A \code{GwasSumStats} object. -#' @param ldRef An \code{LdStatistic} object (method-appropriate subclass): -#' an \code{\link{LdScore}} for \code{"sldsc"} / \code{"gldsc"}, an -#' \code{\link{LdEigen}} for \code{"lder"} / \code{"hdl"}. Build either -#' from loaded LD with \code{\link{buildLdScore}} / -#' \code{\link{buildLdEigen}}. -#' @param method Character, one of \code{"lder"} (the default), +#' @description Estimate SNP heritability, genome-wide from GWAS summary +#' statistics or per trait in its cis window from QTL summary statistics. +#' From a \code{GwasSumStats} and an LD reference, one of four methods +#' (S-LDSC, g-LDSC, LDER, or HDL/sHDL) gives one genome-wide estimate; +#' supplying \code{annotations} makes any of them stratified. From a +#' \code{QtlSumStats}, one of three methods (LAVA, HDL-L or FastHer) gives +#' one estimate per selected (study, context, trait) row, each from the +#' row's own statistics and LD reference. +#' @details Each per-trait method is written from its authors' published +#' estimator and reports what they report: +#' \describe{ +#' \item{\code{"lava"}}{(default) LAVA's univariate estimator (Werme et +#' al. 2022): the adjusted \eqn{R^2} of the trait on the standardized +#' LD components that hold 99\% of the LD variance (at least 2, at +#' most 0.75 times the sample size), with the F test of no +#' heritability. The estimate is scaled by \eqn{(N_{ref} - K - 1) / +#' (N_{ref} - 1)} for a reference of \eqn{N_{ref}} samples and +#' \eqn{K} components, a correction LAVA describes but leaves off. +#' LAVA itself withholds the estimate where \eqn{K} exceeds a tenth of +#' the sample size, which a cis window's components usually do at QTL +#' sample sizes; it is reported here at any \eqn{K}. On real genotypes +#' its error past that point was about twice that below it, still +#' below HDL-L's. The estimate can be negative.} +#' \item{\code{"hdlL"}}{HDL-L (Li et al. 2025): the likelihood of the +#' statistics rotated onto the LD eigenvectors that cover 99\% of the +#' trace, in the heritability and an intercept, with a term for the +#' reference's sampling noise. Its p-value is the likelihood ratio +#' against no heritability; \code{intercept} is the fitted intercept. +#' \code{NA} where no fit converges and beats that null.} +#' \item{\code{"fastHer"}}{FastHer (Svishcheva 2025): the maximum +#' likelihood of an infinitesimal model for the study samples, +#' computed in the LD eigenbasis, with a standard error from the +#' expected information; \code{scale} is the fitted phenotypic +#' variance relative to its standardized value, about 1 when the model +#' fits. HEELS (Li, Mazumder and Lin 2023) maximizes the same +#' likelihood by iteration. The likelihood assumes in-sample LD and is +#' undefined when the reference's rank, or the statistics' squared +#' norm in the LD's metric, reaches the sample size, as it can with an +#' external reference larger than the study; such traits are +#' \code{NA}, with a warning.} +#' } +#' Every per-trait method assumes the LD reference matches the population +#' of the statistics, as the QC step (\code{\link{summaryStatsQc}}) +#' checks. LAVA and HDL-L read the reference's sample size, so an +#' \code{\link{LdMatrix}} reference must record \code{nSamples}. A trait +#' whose window holds no variants is \code{NA}, with a warning. +#' @param sumstats A \code{GwasSumStats}, or a \code{QtlSumStats} that has +#' been through \code{\link{summaryStatsQc}}, each row with an LD +#' reference. +#' @param ldRef For a \code{GwasSumStats}, an \code{LdStatistic} object +#' (method-appropriate subclass): an \code{\link{LdScore}} for +#' \code{"sldsc"} / \code{"gldsc"}, an \code{\link{LdEigen}} for +#' \code{"lder"} / \code{"hdl"}. Build either from loaded LD with +#' \code{\link{buildLdScore}} / \code{\link{buildLdEigen}}. Omitted for a +#' \code{QtlSumStats}, whose rows carry their own. +#' @param method Character. For a \code{QtlSumStats}, one of \code{"lava"} +#' (the default), \code{"hdlL"} or \code{"fastHer"} (see Details). For a +#' \code{GwasSumStats}, one of \code{"lder"} (the default), #' \code{"sldsc"}, \code{"gldsc"} or \code{"hdl"}: #' \describe{ #' \item{\code{"sldsc"}}{Stratified LD score regression (Finucane et al. @@ -47,15 +95,31 @@ NULL #' stratified as sHDL. Models reference-panel noise explicitly, so it #' shrinks hard when \code{nRef} is small.} #' } -#' @param annotations An \code{AnnotationMatrix} object, or NULL for -#' unstratified estimation. -#' @param local Logical, whether to compute per-block local estimates. -#' @param estimatorArgs Optional named list of estimator-specific options -#' (\code{lambda} for lder / gldsc / hdl, \code{nIter} for sldsc). +#' @param annotations For a \code{GwasSumStats}, an \code{AnnotationMatrix} +#' object, or NULL for unstratified estimation. +#' @param estimatorArgs For a \code{GwasSumStats}, an optional named list of +#' estimator-specific options (\code{nIter} for sldsc). #' @param ... Additional method-specific arguments. -#' @param studyName Character (length 1) or \code{NULL}. Restrict the selection -#' to this study; \code{NULL} matches all studies. -#' @return An \code{H2Estimate} object. +#' @param studyName For a \code{GwasSumStats}, the study to estimate (length +#' 1), or \code{NULL} when it holds one. +#' @return An \code{\linkS4class{H2Estimate}}. From a \code{GwasSumStats}, +#' one row: the study's genome-wide estimate, whose element holds no +#' ranges. From a \code{QtlSumStats}, one row per selected (study, +#' context, trait), whose element is the window it covers. +#' @references Werme J, van der Sluis S, Posthuma D, de Leeuw CA (2022). An +#' integrated framework for local genetic correlation analysis. Nature +#' Genetics 54, 274-282. +#' +#' Li Y, Pawitan Y, Shen X (2025). An enhanced framework for local genetic +#' correlation analysis. Nature Genetics. doi:10.1038/s41588-025-02123-3. +#' +#' Svishcheva GR (2025). FastHer: a fast and accurate estimator of local +#' heritability from GWAS summary statistics. bioRxiv. +#' doi:10.64898/2025.12.24.696369. +#' +#' Li H, Mazumder R, Lin X (2023). Accurate and efficient estimation of +#' local heritability using summary statistics and the linkage +#' disequilibrium matrix. Nature Communications 14, 7954. #' @examples #' data(ldScoreExample) #' # The estimators index the z-scores by the reference's own variant order, @@ -75,6 +139,10 @@ NULL #' genome = unique(unname(GenomeInfoDb::genome(ldScoreExample))), #' ldReference = panel) #' estimateH2(ss, ldScoreExample, method = "sldsc") +#' +#' # Per-trait cis heritability, each row against its own LD reference. +#' data(qtlSumStatsExample) +#' estimateH2(qtlSumStatsExample) #' @export setGeneric( "estimateH2", @@ -83,7 +151,6 @@ setGeneric( ldRef, method = "lder", annotations = NULL, - local = FALSE, ... ) { standardGeneric("estimateH2") @@ -219,10 +286,15 @@ setGeneric("readGenotypes", function(path, format = NULL, ...) { #' objects. Names become annotation names. #' @param snpRanges A \code{GRanges} object defining SNP positions. #' @param annotationMeta A \code{data.frame} with annotation metadata (name, -#' tier, type). If NULL, auto-detected from file format. +#' tier, type). If NULL, every annotation is a candidate, and its type is +#' continuous for a BigWig signal, binary for BED intervals, and for an +#' S-LDSC \code{.annot} column binary when its values are 0 and 1, +#' continuous otherwise. #' @param genome Character, genome build. #' @param ... Additional arguments. -#' @return An \code{AnnotationMatrix} object. +#' @return An \code{AnnotationMatrix} object. Its annotation matrix is stored +#' sparse (a \code{dgCMatrix}) when that is smaller than dense, as for +#' mostly-zero binary annotations. #' @examples #' bedFile <- tempfile(fileext = ".bed") #' writeLines("chr1\t100\t500\tregion1", bedFile) @@ -241,20 +313,23 @@ setGeneric( # Accessor generics # ============================================================================= -#' @title Get Local Estimates -#' @description Extract per-block local estimates from a result object. -#' @param object An \code{H2Estimate} object. -#' @return A \code{data.frame} of local estimates, or NULL. -#' @examples -#' data(h2EstimateExample) -#' localH2Blocks(h2EstimateExample) -#' @export -setGeneric("localH2Blocks", function(object) standardGeneric("localH2Blocks")) - #' @title Get Enrichment Estimates -#' @description Extract annotation enrichment estimates from a result object. +#' @description Extract the per-annotation enrichment of an +#' \code{H2Estimate}'s stratified estimates. Two shapes are possible, +#' depending on the route that produced an estimate: +#' \describe{ +#' \item{partitioned}{tau-based enrichment of the baseline annotations, +#' 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}.} +#' } #' @param object An \code{H2Estimate} object. -#' @return A \code{data.frame} of enrichment estimates, or NULL. +#' @return A tibble with one row per annotation of each stratified estimate, +#' led by the estimate's identity (\code{study}, \code{context}, +#' \code{trait}, \code{method}); no rows when none is stratified. #' @examples #' data(h2EstimateExample) #' stratifiedHeritabilityEnrichment(h2EstimateExample) @@ -264,9 +339,13 @@ setGeneric("stratifiedHeritabilityEnrichment", function(object) { }) #' @title Get Score Statistics -#' @description Extract score statistics for candidate annotations. +#' @description Extract score statistics for candidate annotations, suitable +#' for input to \code{susieRss}. #' @param object An \code{H2Estimate} object. -#' @return A list with \code{z} and \code{R}, or NULL. +#' @return A list with one entry per estimate: \code{NULL} when it tested no +#' candidate annotations, otherwise a list of \code{z} (each candidate's +#' score z), \code{R} (the scores' correlation matrix) and +#' \code{annotationNames}. #' @examples #' data(h2EstimateExample) #' scoreStats(h2EstimateExample) @@ -474,8 +553,8 @@ 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, or the number of variants an -#' \code{H2Estimate} was computed over. +#' entry, selected by its identity tuple, or the number of variants each of +#' an \code{H2Estimate}'s estimates was computed over. #' @param x A \code{GwasSumStats}, \code{QtlSumStats} or \code{H2Estimate} #' object. #' @param ... Class-specific selection arguments. @@ -485,7 +564,7 @@ setGeneric("af", function(x, ...) standardGeneric("af")) #' 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. -#' @return Integer. +#' @return Integer; for an \code{H2Estimate}, one per estimate. #' @export setGeneric("nSnps", function(x, ...) standardGeneric("nSnps")) @@ -1136,6 +1215,8 @@ setGeneric("credibleSets", function(x, ...) standardGeneric("credibleSets")) #' @param ... Reserved for future use. #' @return A \code{list} with \code{variantIds} (character) and \code{weights} #' (numeric) of equal length; both empty when no usable weights are present. +#' A method whose weights are a matrix (one column per fSuSiE feature or +#' outcome) returns that matrix as \code{weights}, one row per variant id. #' @examples #' data(twasWeightsExample) #' w <- resolveWeights(twasWeightsExample, studyName = "protocol_example", @@ -1188,16 +1269,31 @@ setGeneric("ctwasPosteriors", function(x, ...) { setGeneric("susieAlpha", function(x, ...) standardGeneric("susieAlpha")) #' @title Get cTWAS Group Prior Parameters -#' @description Return the estimated \code{group_prior} / \code{group_prior_var} -#' of a \code{\link{CtwasResultEntry}}. -#' @param x A \code{CtwasResultEntry}. +#' @description Return the group priors a cTWAS run's EM step estimated +#' across all its regions: each group's prior inclusion probability +#' (\code{group_prior}) and prior effect variance +#' (\code{group_prior_var}). +#' @param x A \code{CtwasResultEntry} or \code{CtwasResult}. #' @param ... Reserved for future use. -#' @return The stored parameter object (typically a list), or \code{NULL}. -#' @examples +#' @return On a \code{CtwasResultEntry}, the stored parameter object +#' (typically ctwas's \code{param} list), or \code{NULL}. On a +#' \code{CtwasResult}, a tibble with one row per run and group, led by the +#' run identity (\code{gwasStudy}, \code{study}, \code{context}, +#' \code{method}, and the joint columns when present), then \code{group}, +#' \code{group_size}, \code{group_prior} and \code{group_prior_var}. A +#' value the run did not record is \code{NA}, a run with no priors has no +#' rows, and each context of a joint run lists the priors they share. +#' @examples +#' priors <- list(group_prior = c(SNP = 1e-4, brain = 0.01), +#' group_prior_var = c(SNP = 10, brain = 20)) #' cre <- CtwasResultEntry( -#' 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))) +#' posteriors = GenomicRanges::GRanges("chr1", +#' IRanges::IRanges(100L, width = 1L), id = "g1", susie_pip = 0.9), +#' groupPriors = priors) #' ctwasGroupPriors(cre) +#' cr <- CtwasResult(gwasStudy = "gwas1", studyName = "s1", +#' context = "brain", method = "susie", entry = list(cre)) +#' ctwasGroupPriors(cr) #' @export setGeneric("ctwasGroupPriors", function(x, ...) { standardGeneric("ctwasGroupPriors") @@ -1271,8 +1367,8 @@ setGeneric("fullFit", function(x, ...) standardGeneric("fullFit")) setGeneric("cvFits", function(x, ...) standardGeneric("cvFits")) #' @title Get Method Names -#' @description Extract the method name(s) an object was produced with: one -#' per entry for a collection, a single name for one estimate. +#' @description Extract the unique method name(s) an object was produced +#' with. #' @param x A \code{QtlFineMappingResult}, \code{GwasFineMappingResult}, #' \code{TwasWeights}, \code{CtwasResult} or \code{H2Estimate} object. #' @return Character vector. @@ -1491,9 +1587,11 @@ setGeneric("writeBed", function(obj, filename, ...) { # ============================================================================= #' @title Get Study Identifier -#' @description Return the study identifier carried by a \code{QtlDataset}. -#' @param x A \code{QtlDataset} object. -#' @return Character (length 1). +#' @description Return the study identifier carried by a \code{QtlDataset}, +#' or the unique studies of a \code{CtwasResult} or \code{H2Estimate}. +#' @param x A \code{QtlDataset}, \code{CtwasResult} or \code{H2Estimate} +#' object. +#' @return Character: length 1 for a \code{QtlDataset}. #' @export setGeneric("studyName", function(x) standardGeneric("studyName")) @@ -1511,12 +1609,10 @@ 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}), the trait names of an -#' \code{\link{SldscData}}, or the single trait label an -#' \code{H2Estimate} was computed for. +#' class (e.g., \code{QtlSumStats} or \code{H2Estimate}, whose GWAS +#' estimates have none) or the trait names of an \code{\link{SldscData}}. #' @param x The object. -#' @return Character vector of unique trait names; length 1 for an -#' \code{H2Estimate}. +#' @return Character vector of unique trait names. #' @examples #' data(qtlSumStatsExample) #' traitNames(qtlSumStatsExample) @@ -1839,10 +1935,11 @@ setGeneric("mixtureWeights", function(x) { }) #' @title Get Per-Block tau Matrix -#' @description Return the per-block jackknife tau matrix carried by an -#' \code{H2Estimate}. +#' @description Return the per-block jackknife tau matrix of each of an +#' \code{H2Estimate}'s estimates. #' @param x An \code{H2Estimate}. -#' @return A numeric matrix or NULL. +#' @return A list with one entry per estimate: a numeric matrix (blocks x +#' annotations) for a stratified estimate, otherwise \code{NULL}. #' @examples #' data(h2EstimateExample) #' annotationJackknifeCoefs(h2EstimateExample) @@ -1851,11 +1948,11 @@ setGeneric("annotationJackknifeCoefs", function(x) { standardGeneric("annotationJackknifeCoefs") }) -#' @title Get Global SNP Heritability -#' @description Return the global SNP heritability estimate carried by an -#' \code{H2Estimate}. +#' @title Get SNP Heritability +#' @description Return the SNP heritability of each of an +#' \code{H2Estimate}'s estimates. #' @param x An \code{H2Estimate}. -#' @return Numeric (length 1). +#' @return Numeric, one per estimate. #' @examples #' data(h2EstimateExample) #' heritabilityEstimate(h2EstimateExample) @@ -1865,10 +1962,10 @@ setGeneric("heritabilityEstimate", function(x) { }) #' @title Get Heritability Standard Error -#' @description Return the standard error of the global SNP heritability -#' estimate carried by an \code{H2Estimate}. +#' @description Return the standard error of each of an \code{H2Estimate}'s +#' heritability estimates. #' @param x An \code{H2Estimate}. -#' @return Numeric (length 1). +#' @return Numeric, one per estimate. #' @examples #' data(h2EstimateExample) #' heritabilityEstimateSe(h2EstimateExample) @@ -1878,11 +1975,12 @@ setGeneric("heritabilityEstimateSe", function(x) { }) #' @title Get LD-Score Regression Intercept -#' @description Return the regression intercept carried by an -#' \code{H2Estimate}. Values above 1 indicate confounding or sample overlap -#' rather than polygenic signal. +#' @description Return the fitted intercept of each of an +#' \code{H2Estimate}'s estimates, \code{NA} for a method without one. An +#' S-LDSC intercept above 1 indicates confounding or sample overlap rather +#' than polygenic signal. #' @param x An \code{H2Estimate}. -#' @return Numeric (length 1). +#' @return Numeric, one per estimate. #' @examples #' data(h2EstimateExample) #' heritabilityIntercept(h2EstimateExample) @@ -1892,10 +1990,10 @@ setGeneric("heritabilityIntercept", function(x) { }) #' @title Get Intercept Standard Error -#' @description Return the standard error of the regression intercept carried -#' by an \code{H2Estimate}. +#' @description Return the standard error of each of an \code{H2Estimate}'s +#' fitted intercepts. #' @param x An \code{H2Estimate}. -#' @return Numeric (length 1). +#' @return Numeric, one per estimate. #' @examples #' data(h2EstimateExample) #' heritabilityInterceptSe(h2EstimateExample) @@ -2088,9 +2186,11 @@ setGeneric("sldscResults", function(x, trait = NULL, ...) { #' @title Colocalization Views #' @description The five views over a \code{\linkS4class{ColocResult}}. The -#' object stores one element per tested (QTL credible set, GWAS credible set, -#' block) pair; these accessors project it to the granularity a given -#' analysis needs, rather than any one of them being the stored shape. +#' object stores one element per scored group (a QTL row against a GWAS +#' row in one block) and, nested in it, one row per tested (QTL credible +#' set, GWAS credible set) pair; these accessors project it to the +#' granularity a given analysis needs, rather than any one of them being +#' the stored shape. #' #' \describe{ #' \item{\code{colocPairs()}}{One row per tested pair -- coloc's native diff --git a/R/AnnotationMatrix.R b/R/AnnotationMatrix.R index ffaa5ac1d..c1aac6f27 100644 --- a/R/AnnotationMatrix.R +++ b/R/AnnotationMatrix.R @@ -28,6 +28,11 @@ NULL #' together -- and \code{\link{baselineAnnotations}} / #' \code{\link{testedAnnotations}} #' are column subsets rather than reconstructions. +#' +#' The annotation matrix may be sparse (a \code{dgCMatrix}): +#' \code{\link{readAnnotations}} stores it so when that is smaller, as for +#' mostly-zero binary annotations, and the heritability estimators read +#' it either way. #' @importClassesFrom SummarizedExperiment RangedSummarizedExperiment #' @export setClass( diff --git a/R/ColocBoostResult.R b/R/ColocBoostResult.R index 3002a41a5..374778425 100644 --- a/R/ColocBoostResult.R +++ b/R/ColocBoostResult.R @@ -231,7 +231,11 @@ setMethod( refs <- map(old, .updateLdRefOrKeep) } else { dict <- .ldRefDict(list(.updateLdRefOrKeep(old))) - key <- if (length(dict$refs) == 0L) NA_character_ else dict$keys[[1L]] + key <- if (length(dict$entries) == 0L) { + NA_character_ + } else { + dict$keys[[1L]] + } info <- mutate( info, ldReference = if_else( @@ -240,10 +244,11 @@ setMethod( NA_character_ ) ) - refs <- dict$refs + refs <- dict$entries } - updated <- `slot<-`(object, "ldReference", check = FALSE, value = refs) - `slot<-`(updated, "outcomeInfo", value = info) + methods::slot(object, "ldReference", check = FALSE) <- refs + methods::slot(object, "outcomeInfo") <- info + object } # ---- construction ----------------------------------------------------------- diff --git a/R/ColocResult.R b/R/ColocResult.R index e049616dc..8a95219ba 100644 --- a/R/ColocResult.R +++ b/R/ColocResult.R @@ -1,10 +1,11 @@ # ============================================================================= # ColocResult S4 class # ----------------------------------------------------------------------------- -# The output of colocPipeline / colocboostPipeline. One ELEMENT per tested -# (QTL credible set x GWAS credible set x block) pair, holding that pair's -# aligned variants; the pair-level statistics live in outer mcols and the -# per-variant ones in inner mcols. +# The output of colocPipeline. One ELEMENT per scored group -- a QTL row +# against a GWAS row in one block, the credible-set pairs one coloc.bf_bf call +# scores -- holding the group's aligned variants once. Every pair of a group +# is scored over the same aligned variants, so they are stored once rather +# than once per pair. # # Why a class and not the flat tibble it replaces: the pair / variant / # credible-set / gene "tiers" are not four shapes of table, they are four VIEWS @@ -13,10 +14,12 @@ # unrecoverable -- which is exactly how the per-variant layer got lost when # process_coloc_results() was dropped. # -# element the aligned variants of one pair -# inner mcols per-variant: SNP.PP.H4 -# outer mcols per-pair: identity tuple, blockId, PP.H0..PP.H4, nSnps, -# retained alpha mass (both sides), enrichment / p12Used +# element the aligned variants of one scored group (A1, A2) +# outer mcols per group: identity tuple of both sides, blockId, the LD +# reference key, and `pairs` -- one table per group, one row +# per credible-set pair: qtlCs, gwasCs, nSnps, PP.H0..PP.H4, +# retained alpha mass (both sides), enrichment / p12Used, and +# the pair's SNP.PP.H4, aligned to the group's variants # slots ldReference, for the credible-set view's purity calculation # # Nothing is filtered at write time (spec 5.3): every testable pair and every @@ -55,16 +58,23 @@ NULL setClass("ColocResultBase", contains = c("VIRTUAL", "RangedTupleList")) #' @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{colocPairs}}, \code{\link{colocVariants}}, -#' \code{\link{colocCredibleSets}} and \code{\link{colocGenes}}. -#' @details The \code{ldReference} is what \code{colocCredibleSets()} uses to -#' compute credible-set purity, each pair's from its own reference. +#' @description A collection of colocalization results, one element per scored +#' group: a QTL row against a GWAS row in one block, whose credible-set +#' pairs coloc scores together over the same aligned variants. Build the +#' four views with \code{\link{colocPairs}} (one row per pair), +#' \code{\link{colocVariants}}, \code{\link{colocCredibleSets}} and +#' \code{\link{colocGenes}}. +#' @details Each element holds its group's variants once. Its identity and +#' block are columns of \code{mcols()}, and its pairs the \code{pairs} +#' column: one table per group, one row per credible-set pair, with the +#' pair's \code{SNP.PP.H4} aligned to the group's variants. So +#' \code{length()} counts groups; \code{colocPairs()} has a row per pair. +#' The \code{ldReference} is what \code{colocCredibleSets()} uses to +#' compute credible-set purity, each group's from its own reference. #' @slot ldReference A named list of the LD references the pairs were computed #' against, each a genotype panel, a \code{GenotypeMixture} or an #' \code{LdMatrix}, stored once apiece; the \code{ldReference} column of -#' \code{mcols} names the entry each pair used (\code{NA} for none). +#' \code{mcols} names the entry each group used (\code{NA} for none). #' @seealso \code{\link{colocPipeline}} #' @export setClass( @@ -99,27 +109,20 @@ methods::setValidity("ColocResult", function(object) { return(coll$getMessages()) } coll$push(.ldRefDictProblems(object@ldReference, .ldRefKeys(object))) - coll$push(.crCheckPpColumns(object)) - coll$push(.crCheckVariantColumn(object)) + coll$push(.crCheckPairColumns(object)) coll$getMessages() } +# The columns every pair of a group shares: both sides' identity and the +# block. +# @noRd +.crGroupCols <- function() { + c(.crGeneCols(), "blockId") +} + # @noRd .crRequiredCols <- function() { - c( - "study", - "context", - "trait", - "method", - "gwasStudy", - "gwasContext", - "gwasTrait", - "gwasMethod", - "blockId", - "qtlCs", - "gwasCs", - "nSnps" - ) + c(.crGroupCols(), "pairs") } # @noRd @@ -127,34 +130,39 @@ methods::setValidity("ColocResult", function(object) { str_c("PP.H", 0:4, ".abf") } -# The posterior columns are a distinct contract from the identity columns -# above, so they keep their own wording. +# The columns each pair's row must carry. The posteriors are a distinct +# contract from the identity columns, so a missing one keeps its own wording. +# The per-variant layer is the whole point of the class, so a pair without +# SNP.PP.H4 -- or with one not aligned to its group's variants -- is rejected +# rather than tolerated. # @noRd -.crCheckPpColumns <- function(object) { +.crCheckPairColumns <- function(object) { + pairs <- mcols(object, use.names = FALSE)$pairs + if (!methods::is(pairs, "SplitDataFrameList")) { + return("`pairs` must be a SplitDataFrameList, one table per element") + } + flat <- unlist(pairs, use.names = FALSE) res <- checkNames( - colnames(mcols(object, use.names = FALSE)), - must.include = .crPpCols(), + colnames(flat), + must.include = c(.crPpCols(), "qtlCs", "gwasCs", "SNP.PP.H4"), what = "colnames" ) - if (isTRUE(res)) { - return(NULL) + if (!isTRUE(res)) { + return(str_c("missing posterior columns: ", res)) } - str_c("missing posterior columns: ", res) + .crCheckPairVariants(object, flat$SNP.PP.H4, elementNROWS(pairs)) } -# The per-variant layer is the whole point of the class, so an element without -# it is rejected rather than tolerated -- a silently absent SNP.PP.H4 would -# reproduce the exact gap this class exists to close. The elements share one -# variant metadata table, so they all have the column or none does. # @noRd -.crCheckVariantColumn <- function(object) { - if (length(object) == 0L || .rtlHasVariantColumn(object, "SNP.PP.H4")) { +.crCheckPairVariants <- function(object, snpPp, pairsPerGroup) { + bad <- which(lengths(snpPp) != rep(lengths(object), pairsPerGroup)) + if (length(bad) == 0L) { return(NULL) } str_c( - "element(s) ", - str_flatten(seq_along(object), ", "), - " have no SNP.PP.H4 column in their variant metadata" + "pair(s) ", + str_flatten(bad, ", "), + " have SNP.PP.H4 not aligned to their element's variants" ) } @@ -163,17 +171,24 @@ methods::setValidity("ColocResult", function(object) { #' @rdname show-methods #' @export setMethod("show", "ColocResult", function(object) { - cat(class(object), "with", length(object), "colocalized pair(s)\n") + pairs <- .crPairsTable(object) + cat( + class(object), + "with", + nrow(pairs), + "colocalized pair(s) in", + length(object), + "scored group(s)\n" + ) if (length(object) == 0L) { return(invisible(NULL)) } - md <- mcols(object, use.names = FALSE) - cat(" studies :", str_flatten(unique(md$study), ", "), "\n") - cat(" paired with :", str_flatten(unique(md$gwasStudy), ", "), "\n") - cat(" variants :", sum(lengths(object)), "across all pairs\n") + cat(" studies :", str_flatten(unique(pairs$study), ", "), "\n") + cat(" paired with :", str_flatten(unique(pairs$gwasStudy), ", "), "\n") + cat(" variants :", sum(lengths(object)), "across all groups\n") cat( " max PP.H4 :", - format(max(md$PP.H4.abf, na.rm = TRUE), digits = 4), + format(max(pairs$PP.H4.abf, na.rm = TRUE), digits = 4), "\n" ) invisible(NULL) @@ -185,6 +200,9 @@ setMethod("show", "ColocResult", function(object) { #' @description Assemble a \code{\linkS4class{ColocResult}} from a pair-level #' table and the per-pair variant tables that go with it. Callers normally #' get one from \code{\link{colocPipeline}} rather than building it directly. +#' @details Pairs that share their identity columns, block, LD reference and +#' variants are one scored group, an element of the result; the group's +#' variants are stored once. #' @param pairs A data frame with one row per tested pair, carrying at least #' the identity columns of both sides (\code{study}, \code{context}, #' \code{trait}, \code{method} and \code{gwasStudy}, \code{gwasContext}, @@ -193,7 +211,8 @@ setMethod("show", "ColocResult", function(object) { #' \code{PP.H4.abf}. A GWAS side has no context or trait axis, so those two #' columns are \code{NA} for it. #' @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. +#' frames with a \code{variant_id} column and a \code{SNP.PP.H4} column, +#' all with the same columns. #' @param ldReference Optional LD reference -- a genotype panel (see #' \code{\link{readGenotypes}}), a \code{GenotypeMixture} or an #' \code{LdMatrix} -- for every pair, or a list with one per pair; used by @@ -233,33 +252,29 @@ ColocResult <- function( ) abort(msg) } - elements <- map(variants, .crVariantsToGRanges) + tables <- .crVariantTables(variants) dict <- .ldRefDict(.ldRefPerTuple(ldReference, nrow(pairs))) - # Set unconditionally, including at zero rows: an empty result still has to - # carry the column schema, or it fails validity and a caller reading - # `result$PP.H4.abf` gets NULL exactly when there is nothing to report. - cols <- list_assign(as.list(pairs), ldReference = dict$keys) + pairs$ldReference <- dict$keys + groups <- .crGroups(pairs, tables) grl <- S4Vectors::`mcols<-`( - .rtlBindElements(elements), - value = exec( - S4Vectors::DataFrame, - !!!c(cols, list(check.names = FALSE)) - ) + .rtlBindElements(map(tables[groups$first], .crGroupVariants)), + value = .crGroupMcols(pairs, tables, groups) ) - obj <- new("ColocResult", .rtlNamed(grl), ldReference = dict$refs) + obj <- new("ColocResult", .rtlNamed(grl), ldReference = dict$entries) .withMetadata(obj, metadata) } -# One pair's variant table -> a GRanges carrying SNP.PP.H4 in its mcols. -# -# The ids are parsed back into ranges rather than stored as strings, per the -# rule that a variant id is a RENDERING of (range, alleles) and never the -# stored identity -- that is what lets subsetByOverlaps() reach coloc results -# at all. -# @noRd -.crVariantsToGRanges <- function(v) { - v <- as.data.frame(v, stringsAsFactors = FALSE) - missingCols <- setdiff(c("variant_id", "SNP.PP.H4"), colnames(v)) +# Each pair's variant table as a data frame with a variant_id and a +# SNP.PP.H4 column, all with the same columns (the per-variant columns a +# group's pairs carry side by side). +# @noRd +.crVariantTables <- function(variants) { + tables <- map(variants, as.data.frame, stringsAsFactors = FALSE) + required <- colnames(.crEmptyVariants()) + missingCols <- setdiff( + required, + reduce(map(tables, colnames), intersect, .init = required) + ) if (length(missingCols) > 0L) { msg <- glue( "each `variants` element needs columns ", @@ -267,19 +282,98 @@ ColocResult <- function( ) abort(msg) } - gr <- .variantIdsToGRanges(as.character(v$variant_id), what = "variant_id") - # The A1 / A2 columns .variantIdsToGRanges() attaches ARE the variant - # identity: range plus alleles is what an id renders, so overwriting mcols - # wholesale here would leave the element unable to name its own variants. - # Append instead. - keep <- setdiff(colnames(v), "variant_id") - extra <- exec( + if (n_distinct(map_chr(tables, .crColumnKey)) > 1L) { + abort("every `variants` element must carry the same columns.") + } + tables +} + +# @noRd +.crColumnKey <- function(v) { + str_flatten(colnames(v), "\r") +} + +# Which scored group each pair is in: pairs that share their identity +# columns, block, LD reference and variants, in order of first appearance. +# `first` is each group's first pair, `order` the pairs group by group. +# @noRd +.crGroups <- function(pairs, tables) { + keys <- str_c( + .rtlTupleKeys(pairs, c(.crGroupCols(), "ldReference"), nrow(pairs)), + map_chr(tables, .crVariantSetKey), + sep = "\r" + ) + groupKeys <- unique(keys) + of <- match(keys, groupKeys) + list(of = of, first = match(groupKeys, keys), order = order(of)) +} + +# @noRd +.crVariantSetKey <- function(v) { + rlang::hash(as.character(v$variant_id)) +} + +# One group's variants as ranges with their alleles, parsed from the ids: +# a variant id is a RENDERING of (range, alleles) and never the stored +# identity, which is what lets subsetByOverlaps() reach coloc results at all. +# @noRd +.crGroupVariants <- function(v) { + .variantIdsToGRanges(as.character(v$variant_id), what = "variant_id") +} + +# The groups' outer columns: the identity, block and LD reference key their +# pairs share, then `pairs`. +# @noRd +.crGroupMcols <- function(pairs, tables, groups) { + shared <- intersect(c(.crGroupCols(), "ldReference"), colnames(pairs)) + md <- exec( S4Vectors::DataFrame, - !!!c(as.list(v[keep]), list(check.names = FALSE)) + !!!c( + as.list(pairs[groups$first, shared, drop = FALSE]), + list(check.names = FALSE) + ) ) - S4Vectors::`mcols<-`( - gr, - value = cbind(mcols(gr, use.names = FALSE), extra) + # Assigned, not passed to DataFrame(), which would spread the tables. + md$pairs <- .crPairsColumn(pairs, tables, groups) + md +} + +# Each group's pairs as one table: every other column of `pairs`, and each +# pair's per-variant columns -- SNP.PP.H4 and any other -- as list columns +# aligned to the group's variants. +# @noRd +.crPairsColumn <- function(pairs, tables, groups) { + ord <- groups$order + own <- setdiff(colnames(pairs), c(.crGroupCols(), "ldReference")) + perVariant <- setdiff( + colnames(if (length(tables) > 0L) tables[[1L]] else .crEmptyVariants()), + "variant_id" + ) + flat <- exec( + S4Vectors::DataFrame, + !!!c( + as.list(pairs[ord, own, drop = FALSE]), + set_names( + map(perVariant, .crPerVariantList, tables = tables[ord]), + perVariant + ), + list(check.names = FALSE) + ) + ) + S4Vectors::splitAsList( + flat, + factor(groups$of[ord], levels = seq_along(groups$first)) + ) +} + +# Column `cn` of each table, as one list column entry per pair. +# @noRd +.crPerVariantList <- function(cn, tables) { + values <- unname(map(tables, cn)) + flat <- if (length(values) == 0L) numeric(0) else list_c(values) + IRanges::relist( + flat, + IRanges::PartitioningByEnd(cumsum(lengths(values))) ) } @@ -301,8 +395,8 @@ ColocResult <- function( # @noRd .crPivotOne <- function(k, results) { - col <- str_c("SNP.PP.H4.row", k) - if (!is_in(col, colnames(results))) { + col <- .crPairPpColumn(k, colnames(results)) + if (is.null(col)) { return(.crEmptyVariants()) } tibble( @@ -311,11 +405,125 @@ ColocResult <- function( ) } +# The column of coloc's per-variant results holding pair `k`'s SNP.PP.H4, or +# NULL when it holds none. coloc names it SNP.PP.H4.row when it scored +# several pairs and SNP.PP.H4.abf when it scored one (coloc.bf_bf). +# @noRd +.crPairPpColumn <- function(k, cols) { + found <- intersect( + c(str_c("SNP.PP.H4.row", k), if (k == 1L) "SNP.PP.H4.abf"), + cols + ) + if (length(found) == 0L) NULL else found[[1L]] +} + # @noRd .crEmptyVariants <- function() { tibble(variant_id = character(0), SNP.PP.H4 = numeric(0)) } +# ---- element operations and saved objects ---------------------------------- + +# `rowsMd`, the outer columns of `x`'s rows `keep`, with each pair's +# per-variant columns following its group's variants into `bare`, the +# rebuilt elements, by variant id: an element operation -- endoapply(), sort(), +# a filter() -- may drop or reorder a group's variants. +# @noRd +.crRealignedMcols <- function(x, rowsMd, bare, keep) { + old <- unname(.crElementIds(x)[keep]) + new <- unname(.crElementIds(bare)) + if (identical(old, new)) { + return(rowsMd) + } + rowsMd$pairs <- .crRealignPairs(rowsMd$pairs, map2(new, old, match)) + rowsMd +} + +# `pairs` with each pair's per-variant columns taken at its group's positions +# `pos` of the rebuilt variants among the old. +# @noRd +.crRealignPairs <- function(pairs, pos) { + flat <- unlist(pairs, use.names = FALSE) + at <- pos[rep(seq_along(pos), elementNROWS(pairs))] + listCols <- names(keep(as.list(flat), methods::is, "List")) + IRanges::relist( + reduce(listCols, .crRealignColumn, .init = flat, at = at), + pairs + ) +} + +# @noRd +.crRealignColumn <- function(flat, cn, at) { + values <- map2(as.list(flat[[cn]]), at, `[`) + flat[[cn]] <- IRanges::relist( + list_c(values, ptype = numeric()), + IRanges::PartitioningByEnd(cumsum(lengths(values))) + ) + flat +} + +# A ColocResult saved with one element per credible-set pair -- each holding +# the pair's variants and SNP.PP.H4 -- folded into one element per scored +# group (ColocResult()). A current one is returned as it is. +# @noRd +.crFoldSavedPairs <- function(object) { + object <- .renameSavedSlots(object, c(ldSketch = "ldReference")) + md <- attr(object, "elementMetadata") + if (is_in("pairs", colnames(md))) { + return(object) + } + elements <- as.list(as(object, "CompressedGRangesList")) + pairs <- as.data.frame(md, optional = TRUE) + pairs$ldReference <- NULL + folded <- ColocResult( + pairs, + map(elements, .crSavedVariants), + ldReference = .crSavedPairRefs(object, md), + metadata = S4Vectors::metadata(object) + ) + `attr<-`(folded, "gwasFineMapping", attr(object, "gwasFineMapping")) +} + +# A saved pair's variant table: its ids, rendered from ranges and alleles, +# and its per-variant columns. +# @noRd +.crSavedVariants <- function(el) { + mc <- as.data.frame(mcols(el, use.names = FALSE), optional = TRUE) + as_tibble( + c( + list(variant_id = .grVariantIds(el)), + as.list(mc[setdiff(colnames(mc), c("A1", "A2"))]) + ), + .name_repair = "minimal" + ) +} + +# The LD reference each saved pair used: its key's entry, or the one +# reference an object saved before references were per row held. +# @noRd +.crSavedPairRefs <- function(object, md) { + old <- methods::slot(object, "ldReference") + if (!is.list(old) || is.object(old)) { + return(rep(list(old), nrow(md))) + } + keys <- md$ldReference %||% rep(NA_character_, nrow(md)) + map(as.character(keys), .dictEntryFor, entries = old) +} + +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "ColocResult", + function(object, ..., verbose = FALSE) { + methods::callNextMethod( + .crFoldSavedPairs(object), + ..., + verbose = verbose + ) + } +) + # ---- views ------------------------------------------------------------------ # The columns that identify a gene-level unit: everything that is fixed within @@ -347,14 +555,53 @@ setMethod( } ) -# colocPairs() as a tibble, for the views built on it. +# colocPairs() as a tibble, for the views built on it: one row per pair, its +# group's identity and block, its own columns, then its group's LD reference +# key -- the per-variant columns left in `pairs`. # @noRd .crPairsTable <- function(x) { md <- mcols(x, use.names = FALSE) - if (is.null(md) || length(x) == 0L) { + if (is.null(md)) { return(tibble()) } - as_tibble(as.data.frame(md), .name_repair = "minimal") + group <- .crPairGroups(x) + flat <- unlist(md$pairs, use.names = FALSE) + own <- flat[, !map_lgl(as.list(flat), methods::is, "List"), drop = FALSE] + shared <- intersect(.crGroupCols(), colnames(md)) + bind_cols( + as_tibble( + as.data.frame(md[group, shared, drop = FALSE], optional = TRUE), + .name_repair = "minimal" + ), + as_tibble( + as.data.frame(own, optional = TRUE), + .name_repair = "minimal" + ), + tibble(ldReference = as.character(md$ldReference)[group]), + .name_repair = "minimal" + ) +} + +# The group each pair is in, pair by pair. +# @noRd +#' @importFrom S4Vectors elementNROWS +.crPairGroups <- function(x) { + rep(seq_along(x), elementNROWS(mcols(x, use.names = FALSE)$pairs)) +} + +# Each pair's SNP.PP.H4, pair by pair, aligned to its group's variants. +# @noRd +.crPairPp <- function(x) { + unlist(mcols(x, use.names = FALSE)$pairs, use.names = FALSE)$SNP.PP.H4 +} + +# Each element's variant ids, element by element. +# @noRd +.crElementIds <- function(grl) { + split( + .grVariantIds(unlist(grl, use.names = FALSE)), + factor(rep(seq_along(grl), lengths(grl)), levels = seq_along(grl)) + ) } #' @rdname colocViews @@ -373,7 +620,7 @@ setMethod("colocPooledVariants", "ColocResult", function(x) { .withGenome(.variantTableGRanges(pooled), .oneBuild(x)) }) -# One row per (pair, variant): the pair's metadata repeated across its +# One row per (pair, variant): the pair's columns repeated across its group's # variants, plus colocPp -- the posterior that THIS variant is the shared # causal one, PP.H4 for the pair times the variant's share within it. # @noRd @@ -381,14 +628,15 @@ setMethod("colocPooledVariants", "ColocResult", function(x) { if (length(x) == 0L) { return(tibble()) } - md <- as.data.frame(mcols(x, use.names = FALSE)) - n <- lengths(x) - pairIdx <- rep(seq_len(length(x)), n) - flat <- unlist(x, use.names = FALSE) - snpPp <- as.numeric(mcols(flat, use.names = FALSE)$SNP.PP.H4) - as_tibble(md[pairIdx, , drop = FALSE], .name_repair = "minimal") |> + pairs <- .crPairsTable(x) + group <- .crPairGroups(x) + snpPp <- as.numeric(unlist(.crPairPp(x), use.names = FALSE)) + pairs[rep(seq_len(nrow(pairs)), lengths(x)[group]), , drop = FALSE] |> mutate( - variant_id = .grVariantIds(flat), + variant_id = list_c( + .crElementIds(x)[group], + ptype = character() + ), SNP.PP.H4 = snpPp, colocPp = .data$PP.H4.abf * snpPp ) @@ -503,11 +751,17 @@ setMethod( minAbsCorr = 0.8, requireMaxH4 = FALSE ) { - pairs <- .crPairFilter(x, minPp4, requireMaxH4) + view <- list( + x = x, + pairs = .crPairsTable(x), + group = .crPairGroups(x), + pp = as.list(.crPairPp(x)) + ) + kept <- .crPairFilter(view$pairs, minPp4, requireMaxH4) # Filtering happens BEFORE any LD work, so a stricter threshold costs # strictly less -- which is the reason purity lives on the accessor # rather than being precomputed at construction. - sets <- compact(map(pairs, .crCsForPair, x = x, coverage = coverage)) + sets <- compact(map(kept, .crCsForPair, view = view, coverage = coverage)) if (length(sets) == 0L) { return(list()) } @@ -558,14 +812,14 @@ setMethod( is.na(p) || p >= minAbsCorr } -# Which pairs survive the pair-level filters. Both conditions read columns -# already stored on the pair, so neither costs anything to evaluate. +# Which pairs -- rows of the colocPairs() table `md` -- survive the +# pair-level filters. Both conditions read columns already stored on the +# pair, so neither costs anything to evaluate. # @noRd -.crPairFilter <- function(x, minPp4, requireMaxH4) { - if (length(x) == 0L) { +.crPairFilter <- function(md, minPp4, requireMaxH4) { + if (nrow(md) == 0L) { return(integer(0)) } - md <- as.data.frame(mcols(x, use.names = FALSE)) byPp4 <- if (is.null(minPp4)) { rep(TRUE, nrow(md)) } else { @@ -587,23 +841,31 @@ setMethod( # This is a THIRD variant set -- section 3.7 -- not guaranteed to be a subset of # either input credible set, which is why nothing about it can be inherited # from the QTL or GWAS fine-mapping. +# +# `view` holds the result `x`, its colocPairs() table `pairs`, each pair's +# group and each pair's SNP.PP.H4 (`pp`). # @noRd -.crCsForPair <- function(i, x, coverage) { - g <- x[[i]] +.crCsForPair <- function(i, view, coverage) { + g <- view$x[[view$group[[i]]]] if (length(g) == 0L) { return(NULL) } - pp <- as.numeric(mcols(g, use.names = FALSE)$SNP.PP.H4) + pp <- as.numeric(view$pp[[i]]) ord <- order(pp, decreasing = TRUE) cum <- cumsum(pp[ord]) nKeep <- .crFirstAtLeast(cum, coverage) members <- ord[seq_len(nKeep)] ids <- .grVariantIds(g[members]) - md <- as.data.frame(mcols(x, use.names = FALSE))[i, , drop = FALSE] list( - members = g[members], + members = S4Vectors::`mcols<-`( + g[members], + value = cbind( + mcols(g[members], use.names = FALSE), + S4Vectors::DataFrame(SNP.PP.H4 = pp[members]) + ) + ), row = mutate( - as_tibble(md, .name_repair = "minimal"), + view$pairs[i, , drop = FALSE], csSize = length(members), csCoverage = cum[[nKeep]], leadVariant = ids[[1L]], @@ -627,7 +889,7 @@ setMethod( # @noRd #' @importFrom rlang try_fetch .crPurityOne <- function(ids, key, refs) { - ldReference <- .ldRefForKey(key, refs) + ldReference <- .dictEntryFor(key, refs) if (is.null(ldReference)) { return(NA_real_) } diff --git a/R/CtwasResult.R b/R/CtwasResult.R index c691fe46d..3156fa587 100644 --- a/R/CtwasResult.R +++ b/R/CtwasResult.R @@ -9,7 +9,10 @@ # region_id), the region's per-effect susie alpha table (`susieAlpha`), its # region metadata (`regionInfo`) and the run's jointly-estimated group priors # (`groupPriors`, repeated on each of the run's rows, as a GWAS fit's -# settings repeat on its blocks). +# settings repeat on its blocks). Those priors are the run's one genome-wide +# estimate -- its EM step fits them across every region, then fine-maps each +# region under them -- so validity requires a run's rows to carry the same +# priors, and ctwasGroupPriors() tabulates them once per run. # # Unlike the QTL family, `trait` is NOT a key -- cTWAS is multi-gene per run, # so genes live inside the elements. Optional joint columns (jointStudies, @@ -38,7 +41,11 @@ NULL #' multi-study or multi-context run and participate in the uniqueness key, #' exactly as in the \code{\linkS4class{TwasWeights}} and fine-mapping #' families. \code{\link{ctwasPosteriors}} and \code{\link{susieAlpha}} -#' stack every region back into one \code{GRanges}. +#' stack every region back into one \code{GRanges}. The group priors are +#' the run's one genome-wide estimate, fitted across all its regions, so a +#' run's rows must carry the same priors: rows of one identity whose +#' priors differ came from separately fitted runs and are refused. +#' \code{\link{ctwasGroupPriors}} tabulates them once per run. #' @seealso \code{\link{CtwasResult}} for the constructor and #' \code{\link{ctwasPipeline}} for the pipeline that builds one. #' @export @@ -79,7 +86,8 @@ setClass( jointCols <- intersect(c("jointStudies", "jointContexts"), cols) problems <- c( .ctwasResCheckJointCols(object, jointCols), - .ctwasResCheckTupleUniqueness(object, jointCols) + .ctwasResCheckTupleUniqueness(object, jointCols), + .ctwasResCheckRunPriors(object, jointCols) ) if (length(problems) == 0L) TRUE else problems } @@ -117,6 +125,40 @@ setClass( NULL } +# A run's regions are fine-mapped under the group priors its one EM fit +# estimated across all of them, so its rows carry the same priors. Rows of one +# identity whose priors differ came from separately fitted runs -- c() of +# per-chromosome runs, say -- which that identity cannot tell apart. +# @noRd +#' @importFrom purrr map2_lgl +.ctwasResCheckRunPriors <- function(object, jointCols) { + md <- mcols(object, use.names = FALSE) + first <- .ctwasRunFirstRows(md, c(.CTWAS_ID_COLS, jointCols)) + priors <- as.list(md$groupPriors) + mixed <- unique(first[!map2_lgl(priors, priors[first], identical)]) + if (length(mixed) == 0L) { + return(NULL) + } + ids <- as_tibble(as.data.frame(md[mixed, .CTWAS_ID_COLS, drop = FALSE])) + runs <- glue( + "({ids$gwasStudy}, {ids$study}, {ids$context}, {ids$method})" + ) + str_c( + "run(s) ", + str_flatten(utils::head(runs, 5L), ", "), + " carry different group priors on their rows; a run's regions ", + "share the priors of its one EM fit, so separately fitted runs ", + "need distinct identities" + ) +} + +# Each row's run, as the first row sharing its identity. +# @noRd +.ctwasRunFirstRows <- function(md, keyCols) { + keys <- .rtlTupleKeys(md, keyCols, nrow(md)) + match(keys, keys) +} + # @noRd .ctwasResColOf <- function(cn, object) { mcols(object, use.names = FALSE)[[cn]] @@ -429,6 +471,58 @@ setMethod("susieAlpha", "CtwasResult", function(x) { .ctwasAggregateRows(x, as.list(x$susieAlpha)) }) +#' @rdname ctwasGroupPriors +#' @export +setMethod("ctwasGroupPriors", "CtwasResult", function(x) { + md <- mcols(x, use.names = FALSE) + idCols <- c( + .CTWAS_ID_COLS, + intersect(c("jointStudies", "jointContexts"), colnames(md)) + ) + runs <- unique(.ctwasRunFirstRows(md, idCols)) + ids <- as_tibble(as.data.frame(md[runs, idCols, drop = FALSE])) + priors <- as.list(md$groupPriors)[runs] + list_rbind(c( + list(bind_cols(ids[0L, ], .ctwasPriorTable(NULL))), + map(seq_along(runs), .ctwasRunPriorRows, ids = ids, priors = priors) + )) +}) + +# One run's identity beside its priors, one row per group. +# @noRd +.ctwasRunPriorRows <- function(i, ids, priors) { + groups <- .ctwasPriorTable(priors[[i]]) + bind_cols(slice(ids, rep(i, nrow(groups))), groups) +} + +# ctwas's EM output (its `param` list) as one row per group. ctwas names +# group_prior, group_prior_var and group_size by group, so the groups are +# group_prior's and the other two are matched to them by name: NA where the +# run recorded none. +# @noRd +#' @importFrom purrr pluck +.ctwasPriorTable <- function(param) { + prior <- pluck(param, "group_prior") + groups <- names(prior) %||% rep(NA_character_, length(prior)) + tibble( + group = groups, + group_size = .ctwasPriorByGroup(pluck(param, "group_size"), groups), + group_prior = as.numeric(unname(prior)), + group_prior_var = .ctwasPriorByGroup( + pluck(param, "group_prior_var"), + groups + ) + ) +} + +# @noRd +.ctwasPriorByGroup <- function(values, groups) { + if (is.null(names(values))) { + return(rep(NA_real_, length(groups))) + } + as.numeric(unname(values[groups])) +} + #' @rdname show-methods #' @export setMethod("show", "CtwasResult", function(object) { diff --git a/R/GenotypeDosageSeed.R b/R/GenotypeDosageSeed.R index 24b819aa0..a48e57c53 100644 --- a/R/GenotypeDosageSeed.R +++ b/R/GenotypeDosageSeed.R @@ -53,7 +53,8 @@ NULL #' \code{IRanges} of the columns (or SeqArray's 2-bit planes) of the node #' holding it; for a PLINK1 fileset, an \code{IRanges} of each variant's #' position in the \code{.bed}. -#' @slot dn List of dimnames (variant ids, sample ids). +#' @slot dn List of dimnames: no variant names (a panel's rowRanges name +#' its rows) and the sample ids. #' @name GenotypeDosageSeed-class #' @keywords internal #' @importClassesFrom S4Vectors Vector @@ -70,6 +71,17 @@ setClass( ) ) +# `x` without row names, as a seed is built today, or NULL when it has +# none. +# @noRd +.slimDosageSeed <- function(x) { + dn <- dimnames(x) + if (is.null(dn[[1L]])) { + return(NULL) + } + methods::initialize(x, dn = list(NULL, dn[[2L]])) +} + #' @rdname GenotypeDosageSeed-class setMethod("dim", "GenotypeDosageSeed", function(x) { c(length(x@rowRecord), length(x@dn[[2L]])) diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index d52e1eef2..63d2d6216 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -832,9 +832,13 @@ setMethod("nSamples", "GenotypeHandle", function(x) x@nSamples) #' Lets genotype dosages back a \code{DelayedArray} that reads through the #' handle on demand, so an assay can describe a panel far larger than memory. #' -#' @slot handle The \code{\link{GenotypeHandle}} to read through. +#' @slot handle The \code{\link{GenotypeHandle}} to read through. Its +#' variant table keeps only the columns reading needs, since a panel's +#' rowRanges describe its variants. #' @slot dm Integer length-2 dimensions (variants, samples). -#' @slot dn List of dimnames (variant ids, sample ids). +#' @slot dn Dimnames, empty: a panel's rowRanges name the variants (a seed +#' saved earlier may still hold them), and the samples come from the +#' handle. #' @name GhSeed-class #' @keywords internal setClass( @@ -860,6 +864,18 @@ setMethod("dimnames", "GhSeed", function(x) { # @noRd .ghSeedHandle <- function(x) x@handle +# `x` as a seed is built today -- its handle cut to the columns reading needs +# (.readingHandle()), no row names -- or NULL when it is built so already. +# @noRd +.slimGhSeed <- function(x) { + handle <- .ghSeedHandle(x) + reading <- .readingHandle(handle) + if (identical(reading, handle) && is.null(dimnames(x)[[1L]])) { + return(NULL) + } + methods::initialize(x, handle = reading, dn = list(NULL, NULL)) +} + #' @rdname GhSeed-class #' @importFrom S4Arrays extract_array setMethod("extract_array", "GhSeed", function(x, index) { @@ -872,12 +888,9 @@ setMethod("extract_array", "GhSeed", function(x, index) { if (length(i) == 0L || length(j) == 0L) { return(matrix(numeric(0), length(i), length(j))) } - se <- extractBlockGenotypes( - .ghSeedHandle(x), - snpIdx = i, - meanImpute = FALSE - ) - as.matrix(SummarizedExperiment::assay(se, "dosage"))[, j, drop = FALSE] + # Read as stored, unlabelled: a panel's rowRanges, not its seed, describe + # its variants. + t(.handleDosage(.ghSeedHandle(x), i))[, j, drop = FALSE] }) #' Genotype dosages as a lazily-read DelayedArray @@ -902,18 +915,15 @@ genotypeDelayedArray <- function(handle) { ) abort(msg) } - si <- snpInfo(handle) seed <- methods::new( "GhSeed", - handle = 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. - dn = list( - normalizeVariantId(as.character(si$SNP)), - NULL - ) + # Its variant table keeps only the columns reading needs. + handle = .readingHandle(handle), + dm = c(nrow(snpInfo(handle)), as.integer(nSamples(handle))), + # Neither axis is stored: a panel's rowRanges name the variants, and + # the dimnames() method above derives the sample axis from the handle, + # so neither the variant ids nor the ~10k sample ids are duplicated. + dn = list(NULL, NULL) ) DelayedArray::DelayedArray(seed) } diff --git a/R/GenotypeMixture.R b/R/GenotypeMixture.R index 584276da6..4220b3f3d 100644 --- a/R/GenotypeMixture.R +++ b/R/GenotypeMixture.R @@ -130,7 +130,7 @@ setValidity("GenotypeMixture", function(object) { #' @export GenotypeMixture <- function(panels, mixtureWeights) { .gmAssertPanels(panels) - panels <- map(map(panels, .asLdRef), .ucscExperiment) + panels <- map(panels, .asLdRef) if (!all(map_lgl(panels, .gmIsPanel))) { abort("Every element of `panels` must be a genotype panel.") } @@ -311,6 +311,18 @@ setMethod("subsetByAssay", "GenotypeMixture", function(x, y) { MultiAssayExperiment::`experiments<-`(x, value = ExperimentList(comps)) } +# The mixture with each of its panels slimmed as .updatePanel() slims a +# panel (.slimPanel()), or as it is when none changes. +# @noRd +.slimMixture <- function(x) { + panels <- .gmComponents(x) + slim <- map(panels, .slimPanel) + if (identical(slim, panels)) { + return(x) + } + MultiAssayExperiment::`experiments<-`(x, value = ExperimentList(slim)) +} + # One panel's rows `i`. With no rows left it is held in memory with its # samples, which the sampleMap names, so an empty mixture does not carry its # panels' seeds (see .emptyPanel()). @@ -387,7 +399,9 @@ setMethod("show", "GenotypeMixture", function(object) { # columns that identify them. # @noRd .gmRanges <- function(x) { - rr <- SummarizedExperiment::rowRanges(.gmComponents(x)[[1L]]) + rr <- .withPanelLabels( + SummarizedExperiment::rowRanges(.gmComponents(x)[[1L]]) + ) S4Vectors::`mcols<-`( rr, value = S4Vectors::mcols(rr)[, c("SNP", "A1", "A2")] @@ -423,10 +437,11 @@ setMethod("show", "GenotypeMixture", function(object) { # @noRd .gmAddLd <- function(acc, k, x, idx) { - s <- .gmSign(x)[idx, k] term <- mixtureWeights(x)[[k]] * - unname(.ldRefLdAt(.gmComponents(x)[[k]], idx)) * - outer(s, s) + .ldSignFlipped( + unname(.ldRefLdAt(.gmComponents(x)[[k]], idx)), + .gmSign(x)[idx, k] + ) if (is.null(acc)) term else acc + term } diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index c59f1e57a..0c556f21a 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -201,7 +201,7 @@ GwasFineMappingResult <- function( study = as.character(studyName), method = as.character(method), susieFit = S4Vectors::SimpleList(map(entry, susieFit)), - cvResult = S4Vectors::SimpleList(map(entry, cvResult)), + cvResult = S4Vectors::SimpleList(map(entry, .fmRowCvStored)), derivedColumns = IRanges::CharacterList( map(entry, .fmRowDerivedColumns) ) @@ -222,7 +222,16 @@ GwasFineMappingResult <- function( .gfmrBuild <- function(entry, cols, region, ldReference) { n <- length(entry) dict <- .ldRefDict(.ldRefPerTuple(ldReference, n)) - dfArgs <- c(cols, list(ldReference = dict$keys, check.names = FALSE)) + cv <- .cvStoredColumn(as.list(cols[["cvResult"]])) + fitted <- .dictBuild(as.list(cols[["susieFit"]]), .FIT_DICT_PREFIX) + dfArgs <- c( + list_assign(cols, cvResult = cv$cvResult, susieFit = fitted$keys), + list( + ldReference = dict$keys, + cvPartition = cv$keys, + check.names = FALSE + ) + ) split <- .rtlSplitBySeqname(map(entry, variants)) pieces <- .rtlBindElements(split$entry) grl <- S4Vectors::`mcols<-`( @@ -234,7 +243,13 @@ GwasFineMappingResult <- function( pieces ) ) - new("GwasFineMappingResult", .rtlNamed(grl), ldReference = dict$refs) + new( + "GwasFineMappingResult", + .rtlStored("GwasFineMappingResult", .rtlNamed(grl)), + ldReference = dict$entries, + cvPartition = cv$entries, + fits = fitted$entries + ) } # The window each entry was given: its `region`, when the caller passed one. diff --git a/R/H2Estimate.R b/R/H2Estimate.R index ba6180749..d6250cccf 100644 --- a/R/H2Estimate.R +++ b/R/H2Estimate.R @@ -1,74 +1,177 @@ # ============================================================================= # H2Estimate S4 class # ----------------------------------------------------------------------------- -# Container for univariate heritability estimation results: global h2, -# optional per-block local estimates, optional annotation-stratified -# enrichment with jackknife blocks, and method-specific score statistics. -# Produced by `estimateH2()` and consumed by `h2EstimateToSldscTrait()` for -# integration with the sLDSC postprocessing pipeline. +# RangedTupleList collection of heritability estimates, one row each, keyed by +# the identity tuple (study, context, trait, method): a genome-wide estimate +# from GWAS summary statistics, one per study, with no context or trait, or a +# trait's cis estimate from QTL summary statistics. A cis estimate's element +# is the window it covers; a genome-wide estimate covers its whole reference, +# more chromosomes than an element may span, so its element holds no ranges. +# Produced by estimateH2() and consumed by h2EstimateToSldscTrait(). # ============================================================================= -#' @include MethodParam.R +#' @include AllGenerics.R RangedTupleList.R NULL -#' @title Heritability Estimate -#' @description Container for univariate heritability estimation results. Holds -#' global, local, and annotation-stratified estimates. -#' @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 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} of per-annotation enrichment results, -#' NULL if unstratified. Two shapes are possible, depending on which route -#' produced the estimate: +#' @title Heritability Estimates +#' @description Heritability estimates from \code{\link{estimateH2}}, one row +#' each, keyed by the identity tuple \code{(study, context, trait, +#' method)}: a genome-wide estimate from GWAS summary statistics, one per +#' study, whose \code{context} and \code{trait} are \code{NA}, or a trait's +#' cis estimate from QTL summary statistics. A cis estimate's element is the +#' window it covers. A genome-wide estimate covers its whole LD reference, +#' more chromosomes than an element may span, so its element holds no +#' ranges. +#' @details Besides the identity, \code{mcols()} hold each estimate's values: #' \describe{ -#' \item{partitioned}{enrichment of the user's baseline annotations -#' from their partitioned heritabilities \eqn{A'A\tau}, with -#' columns \code{annotation}, \code{tau}, \code{tauSe}, -#' \code{enrichment}, \code{enrichmentSe}, \code{enrichmentP}, -#' \code{propH2}, \code{propSnps}.} -#' \item{score test}{the score test over the tested (candidate) -#' annotations, with columns \code{annotation}, \code{scoreZ}, -#' \code{scoreP}.} +#' \item{\code{h2}, \code{h2_se}}{The heritability and its standard +#' error.} +#' \item{\code{intercept}, \code{intercept_se}}{The fitted intercept and +#' its standard error.} +#' \item{\code{p_value}}{The test of no heritability.} +#' \item{\code{n_snps}}{The variants the estimate used.} +#' \item{\code{n_components}}{The LD components or eigenpairs a cis +#' estimate used.} +#' \item{\code{scale}}{FastHer's fitted phenotypic variance relative to +#' its standardized value.} +#' \item{\code{enrichment}}{The per-annotation enrichment table of a +#' stratified estimate (\code{\link{stratifiedHeritabilityEnrichment}}).} +#' \item{\code{jackknife}}{The per-block jackknife matrix of the +#' annotation coefficients (\code{\link{annotationJackknifeCoefs}}).} +#' \item{\code{score_stats}}{The candidate annotations' score statistics +#' (\code{\link{scoreStats}}).} #' } -#' @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, -#' suitable for input to \code{susieRss}. Contains: -#' \describe{ -#' \item{z}{Numeric vector of z-scores for each candidate annotation} -#' \item{R}{Correlation matrix of the score statistics} -#' \item{annotationNames}{Character vector of candidate annotation names} -#' } -#' NULL if no candidate annotations provided. -#' @slot method Character string identifying the estimation method. -#' @slot nSnps Integer, number of SNPs used in estimation. -#' @slot traitName Character string for trait identifier. +#' A value a method does not report is \code{NA}, and an object it does not +#' produce is \code{NULL}. The accessors return one value per estimate, in +#' row order. +#' @seealso \code{\link{estimateH2}}, which builds one. #' @export setClass( "H2Estimate", - representation( - estimate = "numeric", - estimateSe = "numeric", - intercept = "numeric", - interceptSe = "numeric", - localBlocks = "data.frame_OR_NULL", - enrichment = "data.frame_OR_NULL", - annotationJackknifeCoefs = "matrix_OR_NULL", - scoreStats = "list_OR_NULL", - method = "character", - nSnps = "integer", - traitName = "character" - ) + contains = "RangedTupleList", + validity = function(object) .validateH2Estimate(object) ) +# The identity of an estimate. +# @noRd +.H2_ID_COLS <- c("study", "context", "trait", "method") + +# The values an estimate carries, and the type each is held as. +# @noRd +.H2_VALUE_COLS <- c( + h2 = "double", + h2_se = "double", + intercept = "double", + intercept_se = "double", + p_value = "double", + n_snps = "integer", + n_components = "integer", + scale = "double" +) + +# The objects an estimate carries, each NULL when it has none. +# @noRd +.H2_OBJECT_COLS <- c("enrichment", "jackknife", "score_stats") + +# ---- H2Estimate validity helpers ------------------------------------------- + +# Collect all contract violations (TRUE when there are none). The type and +# uniqueness checks read the columns, so they run once every one is present. +# @noRd +#' @importFrom checkmate makeAssertCollection assertNames +.validateH2Estimate <- function(object) { + md <- mcols(object, use.names = FALSE) + coll <- makeAssertCollection() + assertNames( + colnames(md), + must.include = c(.H2_ID_COLS, names(.H2_VALUE_COLS), .H2_OBJECT_COLS), + what = "colnames", + .var.name = "columns", + add = coll + ) + if (!coll$isEmpty()) { + return(coll$getMessages()) + } + problems <- c( + list_c( + map2( + names(.H2_VALUE_COLS), + unname(.H2_VALUE_COLS), + .h2TypeProblem, + md = md + ), + ptype = character() + ), + list_c( + map(.H2_OBJECT_COLS, .h2ObjectColumnProblem, md = md), + ptype = character() + ), + .h2UniquenessProblem(md) + ) + if (length(problems) == 0L) TRUE else problems +} + +# @noRd +.h2TypeProblem <- function(cn, type, md) { + got <- typeof(md[[cn]]) + if (identical(got, type)) { + return(character(0)) + } + as.character(glue("the `{cn}` column must be {type} (got {got}).")) +} + +# @noRd +.h2ObjectColumnProblem <- function(cn, md) { + if (is.list(md[[cn]])) { + return(character(0)) + } + as.character(glue( + "the `{cn}` column must be a list, holding each row's object or NULL." + )) +} + +# One row per estimate: the identity names it. +# @noRd +.h2UniquenessProblem <- function(md) { + if (anyDuplicated(.rtlTupleKeys(md, .H2_ID_COLS, nrow(md))) == 0L) { + return(character(0)) + } + str_c( + "(study, context, trait, method) tuple uniqueness violated: each ", + "estimate takes one row." + ) +} + +# ---- Columns --------------------------------------------------------------- + +# Column `cn`, one entry per estimate. +# @noRd +.h2Column <- function(x, cn) { + mcols(x, use.names = FALSE)[[cn]] +} + +# An H2Estimate from one element per estimate, with the estimates' `values` +# (one vector per value column) and `objects` (one list per object column). +# The result takes its genome from `seqinfoOf`. +# @noRd +.h2EstimateNew <- function(elements, values, objects, seqinfoOf) { + md <- exec( + S4Vectors::DataFrame, + !!!c(values, map(objects, I), list(check.names = FALSE)) + ) + grl <- .rtlRestoreSeqinfo(.rtlBindElements(elements), seqinfoOf) + new("H2Estimate", .rtlNamed(S4Vectors::`mcols<-`(grl, value = md))) +} + +# The object columns of `n` estimates that carry none. +# @noRd +.h2NoObjects <- function(n) { + set_names( + rep(list(rep(list(NULL), n)), length(.H2_OBJECT_COLS)), + .H2_OBJECT_COLS + ) +} + # ============================================================================= # Accessors @@ -76,58 +179,97 @@ setClass( #' @rdname heritabilityEstimate #' @export -setMethod("heritabilityEstimate", "H2Estimate", function(x) x@estimate) +setMethod("heritabilityEstimate", "H2Estimate", function(x) { + .h2Column(x, "h2") +}) #' @rdname heritabilityEstimateSe #' @export -setMethod("heritabilityEstimateSe", "H2Estimate", function(x) x@estimateSe) +setMethod("heritabilityEstimateSe", "H2Estimate", function(x) { + .h2Column(x, "h2_se") +}) #' @rdname heritabilityIntercept #' @export -setMethod("heritabilityIntercept", "H2Estimate", function(x) x@intercept) +setMethod("heritabilityIntercept", "H2Estimate", function(x) { + .h2Column(x, "intercept") +}) #' @rdname heritabilityInterceptSe #' @export -setMethod("heritabilityInterceptSe", "H2Estimate", function(x) x@interceptSe) +setMethod("heritabilityInterceptSe", "H2Estimate", function(x) { + .h2Column(x, "intercept_se") +}) #' @rdname nSnps #' @export -setMethod("nSnps", "H2Estimate", function(x) x@nSnps) +setMethod("nSnps", "H2Estimate", function(x) .h2Column(x, "n_snps")) + +#' @rdname studyName +#' @export +setMethod("studyName", "H2Estimate", function(x) { + unique(as.character(x$study)) +}) #' @rdname traitNames #' @export -setMethod("traitNames", "H2Estimate", function(x) x@traitName) +setMethod("traitNames", "H2Estimate", function(x) { + traits <- as.character(x$trait) + unique(traits[!is.na(traits)]) +}) #' @rdname methodNames #' @export -setMethod("methodNames", "H2Estimate", function(x) x@method) +setMethod("methodNames", "H2Estimate", function(x) { + unique(as.character(x$method)) +}) #' @rdname annotationJackknifeCoefs #' @export setMethod("annotationJackknifeCoefs", "H2Estimate", function(x) { - x@annotationJackknifeCoefs + .h2Column(x, "jackknife") }) -#' @rdname localH2Blocks +#' @rdname scoreStats #' @export -setMethod("localH2Blocks", "H2Estimate", function(object) { - object@localBlocks +setMethod("scoreStats", "H2Estimate", function(object) { + .h2Column(object, "score_stats") }) #' @rdname stratifiedHeritabilityEnrichment #' @export setMethod("stratifiedHeritabilityEnrichment", "H2Estimate", function(object) { - object@enrichment + md <- mcols(object, use.names = FALSE) + ids <- as_tibble(as.data.frame(md[.H2_ID_COLS])) + list_rbind(c( + list(ids[0L, ]), + map( + seq_along(object), + .h2EnrichmentWithId, + tables = md$enrichment, + ids = ids + ) + )) }) -#' @rdname scoreStats -#' @export -setMethod("scoreStats", "H2Estimate", function(object) { - object@scoreStats -}) +# Estimate `k`'s enrichment table, each row led by its identity; NULL when it +# has none. +# @noRd +.h2EnrichmentWithId <- function(k, tables, ids) { + table <- tables[[k]] + if (is.null(table)) { + return(NULL) + } + bind_cols(ids[rep(k, nrow(table)), ], as_tibble(table)) +} + + +# ============================================================================= +# updateObject +# ============================================================================= # Each slot an H2Estimate was saved under before its slots were renamed, and -# its name now. +# its name then. # @noRd .H2_RENAMED_SLOTS <- c( h2 = "estimate", @@ -136,9 +278,8 @@ setMethod("scoreStats", "H2Estimate", function(object) { tauBlocks = "annotationJackknifeCoefs" ) -# An H2Estimate saved before the rename holds its estimates under the old -# names, which the inherited update would drop as slots the class no longer -# has, leaving the estimate empty; they are moved to the new names first. +# An H2Estimate saved when it held one estimate in slots is rebuilt as a +# collection of one. #' @rdname updateObject-methods #' @export setMethod( @@ -148,14 +289,56 @@ setMethod( if (isTRUE(verbose)) { message("updateObject(object = 'H2Estimate')") } - methods::callNextMethod( - .renameSavedSlots(object, .H2_RENAMED_SLOTS), - ..., - verbose = verbose - ) + if (.h2SavedInSlots(object)) { + object <- .h2FromSlots(.renameSavedSlots(object, .H2_RENAMED_SLOTS)) + } + methods::callNextMethod(object, ..., verbose = verbose) } ) +# @noRd +.h2SavedInSlots <- function(object) { + !is.null(attr(object, "estimate", exact = TRUE)) || + !is.null(attr(object, "h2", exact = TRUE)) +} + +# The estimate an H2Estimate held in slots, as one row. The per-block local +# estimates some held are dropped, with a warning: the genome-wide +# estimators make one estimate per study. +# @noRd +.h2FromSlots <- function(object) { + if (!is.null(methods::slot(object, "localBlocks"))) { + warn(str_c( + "updateObject: this H2Estimate's per-block local estimates are ", + "dropped; the genome-wide estimators make one estimate per ", + "study." + )) + } + .h2EstimateNew( + list(GenomicRanges::GRanges()), + list( + study = methods::slot(object, "traitName"), + context = NA_character_, + trait = NA_character_, + method = methods::slot(object, "method"), + h2 = methods::slot(object, "estimate"), + h2_se = methods::slot(object, "estimateSe"), + intercept = methods::slot(object, "intercept"), + intercept_se = methods::slot(object, "interceptSe"), + p_value = NA_real_, + n_snps = methods::slot(object, "nSnps"), + n_components = NA_integer_, + scale = NA_real_ + ), + list( + enrichment = list(methods::slot(object, "enrichment")), + jackknife = list(methods::slot(object, "annotationJackknifeCoefs")), + score_stats = list(methods::slot(object, "scoreStats")) + ), + GenomicRanges::GRanges() + ) +} + # ============================================================================= # Show @@ -164,30 +347,12 @@ setMethod( #' @rdname show-methods #' @export setMethod("show", "H2Estimate", function(object) { - cat(glue( - "H2Estimate for '{object@traitName}' ", - "(method: {object@method})\n", - .trim = FALSE - )) - cat(sprintf( - " h2 = %.4f (SE = %.4f)\n", - object@estimate, - object@estimateSe - )) - if (!is.na(object@intercept)) { - cat(sprintf( - " intercept = %.4f (SE = %.4f)\n", - object@intercept, - object@interceptSe - )) + cat(glue("H2Estimate: {length(object)} estimate(s)\n", .trim = FALSE)) + if (length(object) == 0L) { + return(invisible(object)) } - has_local <- !is.null(object@localBlocks) - has_enrich <- !is.null(object@enrichment) - has_tau_blocks <- !is.null(object@annotationJackknifeCoefs) - cat(glue( - " Local: {has_local}, Enrichment: {has_enrich}, ", - "annotationJackknifeCoefs: {has_tau_blocks}\n", - .trim = FALSE - )) - cat(glue(" N SNPs: {object@nSnps}\n", .trim = FALSE)) + cols <- c(.H2_ID_COLS, "h2", "h2_se", "intercept", "p_value", "n_snps") + md <- mcols(object, use.names = FALSE)[cols] + print(as_tibble(as.data.frame(md)), n = 10L) + invisible(object) }) diff --git a/R/LdMatrix.R b/R/LdMatrix.R index 25e4db19e..6dc2def78 100644 --- a/R/LdMatrix.R +++ b/R/LdMatrix.R @@ -11,6 +11,11 @@ #' @include AllGenerics.R NULL +# An LdMatrix's correlation: packed symmetric (a dspMatrix), or a base +# matrix in one saved before packing, which updateObject() packs. +#' @importClassesFrom Matrix dspMatrix +setClassUnion("matrix_OR_dspMatrix", c("matrix", "dspMatrix")) + #' @title LD Correlation Matrix #' @description An \code{LdMatrix} carries one LD correlation matrix together #' with the variants it describes, and can stand wherever pecotmr takes an @@ -30,12 +35,20 @@ NULL #' filters, DENTIST, ldsc's unbiased \eqn{r^2}, HDL -- use \code{nSamples} #' and \code{AF} when they are supplied and refuse otherwise. #' -#' Validity checks the matrix's shape and labels, that its diagonal is 1, -#' that its entries lie in \eqn{[-1, 1]}, and its symmetry on an evenly -#' spaced subset of entries. It does not check positive semi-definiteness, -#' which costs an eigendecomposition; run \code{\link{checkLd}} for that. +#' The matrix is stored packed: its upper triangle, half the room of the +#' full matrix. A step that reads part of it -- a block, a row, one +#' product -- reads the packed triangle; a step that passes over it many +#' times (the RSS weight methods, PRS-CS, SDPR, DENTIST, an +#' eigendecomposition) unpacks the block it needs once, for that step. +#' \code{\link{ldMatrix}} hands it out whole, labelled by the variant ids. +#' +#' Validity checks the matrix's shape, that its diagonal is 1 and that its +#' entries lie in \eqn{[-1, 1]}. It does not check positive +#' semi-definiteness, which costs an eigendecomposition; run +#' \code{\link{checkLd}} for that. #' -#' @slot correlation The correlation matrix, its dimnames the variant ids. +#' @slot correlation The correlation matrix, packed symmetric (a +#' \code{dspMatrix}), its rows the variants in order. #' @slot nSamples Integer, the number of independent samples the LD is #' worth, or \code{NA} when unknown. For one panel this is its sample size. #' For a mixture it is \eqn{1 / \sum_k w_k^2 / n_k}, the size of a single @@ -44,13 +57,14 @@ NULL #' with; empty for a single panel's LD. #' @seealso \code{\link{LdMatrix}} to build one, \code{\link{checkLd}}. #' @importClassesFrom GenomicRanges GRanges +#' @importClassesFrom Matrix dspMatrix #' @importFrom S4Vectors extractROWS normalizeSingleBracketSubscript #' @export setClass( "LdMatrix", contains = "GRanges", slots = c( - correlation = "matrix", + correlation = "matrix_OR_dspMatrix", nSamples = "integer", mixtureWeights = "numeric" ), @@ -89,14 +103,17 @@ setValidity("LdMatrix", function(object) { ) } -# The matrix must be square over exactly the object's variants, labelled by -# their ids: every consumer looks LD up by id, so a matrix whose labels drift -# from the variant table would hand back some other variant's LD. +# The matrix must be square over exactly the object's variants. A packed one +# is labelled by them; a base matrix -- in an LdMatrix saved before packing -- +# carries their ids as dimnames, and every consumer looks LD up by id, so +# labels drifting from the variant table would hand back some other +# variant's LD. # @noRd .ldmCheckShape <- function(object) { R <- object@correlation p <- length(object) - if (!is.numeric(R) || nrow(R) != p || ncol(R) != p) { + numeric <- methods::is(R, "dspMatrix") || is.numeric(R) + if (!numeric || nrow(R) != p || ncol(R) != p) { return(glue( "`correlation` is {nrow(R)} x {ncol(R)} but there are {p} ", "variant(s); it must be numeric and square over them." @@ -105,7 +122,7 @@ setValidity("LdMatrix", function(object) { # An empty matrix has no labels to check: subsetting to zero variants # leaves NULL dimnames, which is as labelled as nothing gets. ids <- as.character(S4Vectors::mcols(object)$SNP) - if (p == 0L) { + if (p == 0L || methods::is(R, "dspMatrix")) { return(character()) } if ( @@ -120,11 +137,16 @@ setValidity("LdMatrix", function(object) { } # A correlation matrix has a unit diagonal, entries in [-1, 1] and is -# symmetric. Symmetry is checked on an evenly spaced block of rows and -# columns: comparing a large matrix with its transpose costs another copy of -# it, and the strided block catches a wrong input just as well. +# symmetric. A packed one is symmetric as stored, so its stored triangle is +# checked whole. A base one's symmetry is checked on an evenly spaced block +# of rows and columns: comparing a large matrix with its transpose costs +# another copy of it, and the strided block catches a wrong input just as +# well. # @noRd .ldmCheckValues <- function(R, tol = 1e-6) { + if (methods::is(R, "dspMatrix")) { + return(.ldmCheckPacked(R, tol)) + } p <- nrow(R) if (!is.numeric(R) || p == 0L || nrow(R) != ncol(R)) { return(character()) @@ -141,12 +163,39 @@ setValidity("LdMatrix", function(object) { "`correlation`'s diagonal is not 1." } ) + c(problems, .ldmCheckSymmetric(R, tol)) +} + +# @noRd +.ldmCheckSymmetric <- function(R, tol = 1e-6) { + p <- nrow(R) probe <- unique(round(seq(1, p, length.out = min(p, 200L)))) block <- R[probe, probe, drop = FALSE] if (max(abs(block - t(block))) > tol) { - problems <- c(problems, "`correlation` is not symmetric.") + return("`correlation` is not symmetric.") + } + character() +} + +# @noRd +.ldmCheckPacked <- function(R, tol) { + values <- R@x + if (anyNA(values)) { + return("`correlation` holds missing values.") } - problems + if (length(values) == 0L) { + return(character()) + } + span <- range(values) + diagonal <- Matrix::diag(R) + c( + if (span[[1L]] < -1 - tol || span[[2L]] > 1 + tol) { + "`correlation` holds entries outside [-1, 1]." + }, + if (max(abs(diagonal - 1)) > tol) { + "`correlation`'s diagonal is not 1." + } + ) } # @noRd @@ -256,14 +305,15 @@ LdMatrix <- function( methods::new( "LdMatrix", gr, - correlation = R, + correlation = .packedLd(R), nSamples = as.integer(round(nSamples)), mixtureWeights = as.numeric(mixtureWeights) ) } -# A plain numeric matrix: a Matrix-package matrix is made dense, as every -# consumer works on one. +# A plain numeric matrix: a Matrix-package matrix is made dense first, to be +# checked as one and then packed (.packedLd()). Symmetry is checked here, +# before packing keeps only the upper triangle. # @noRd #' @importFrom checkmate assertMatrix .ldmAsMatrix <- function(correlation) { @@ -276,6 +326,12 @@ LdMatrix <- function( any.missing = FALSE, .var.name = "correlation" ) + if (nrow(correlation) == ncol(correlation) && nrow(correlation) > 0L) { + asymmetric <- .ldmCheckSymmetric(correlation) + if (length(asymmetric) > 0L) { + abort(asymmetric) + } + } correlation } @@ -425,13 +481,15 @@ LdMatrix <- function( seqnames = withChrPrefix(as.character(tbl$chrom)), ranges = IRanges::IRanges(as.integer(tbl$pos), width = 1L) ) - S4Vectors::`mcols<-`( + # Alleles in upper case as every reader spells them; the labels (SNP, the + # matrix's dimnames) stay as given. + .canonAlleleMcols(S4Vectors::`mcols<-`( `names<-`(gr, tbl$SNP), value = S4Vectors::DataFrame( select(tbl, -all_of(c("chrom", "pos"))), row.names = NULL ) - ) + )) } # ---- mixtures --------------------------------------------------------------- @@ -458,12 +516,11 @@ LdMatrix <- function( aligned = aligned, w = w ) - ids <- rownames(ref@correlation)[common] gr <- .ldmMixtureVariants(ref[common], components, aligned, w) methods::new( "LdMatrix", gr, - correlation = `dimnames<-`(R, list(ids, ids)), + correlation = .packedLd(R), nSamples = .ldmMixtureN(map_int(components, nSamples), w), mixtureWeights = w ) @@ -524,7 +581,7 @@ LdMatrix <- function( # allele, which negates each of its correlations. # @noRd .ldmAlignedR <- function(x, aligned) { - R <- unname(x@correlation[aligned$idx, aligned$idx, drop = FALSE]) + R <- .ldmBlock(x, aligned$idx) if (all(aligned$sign > 0)) { return(R) } @@ -591,15 +648,69 @@ LdMatrix <- function( setMethod("extractROWS", "LdMatrix", function(x, i) { i <- normalizeSingleBracketSubscript(i, x) ans <- methods::callNextMethod(x, i) - ans@correlation <- x@correlation[i, i, drop = FALSE] + ans@correlation <- .packedLd(.ldmBlock(x, i)) ans }) +# ---- packed storage ---------------------------------------------------------- + +# `R`, a symmetric correlation matrix, packed: its upper triangle, the room +# of half the full matrix, without dimnames (an LdMatrix's variants name its +# rows). A matrix packed already is left as it is. +# @noRd +.packedLd <- function(R) { + if (methods::is(R, "dspMatrix")) { + return(R) + } + Matrix::pack(Matrix::forceSymmetric(unname(R), uplo = "U")) +} + +# `R` as a base matrix: unpacked when packed (.packedLd()), as it is when it +# is a base matrix already -- one saved before packing. +# @noRd +.unpackedLd <- function(R) { + if (methods::is(R, "dspMatrix")) methods::as(R, "matrix") else R +} + +# The block of `x`'s correlations over variants `idx`, as a base matrix +# without dimnames: the packed block .ldmPackedBlock() reads, unpacked. The +# whole matrix in order is unpacked as it is stored. +# @noRd +.ldmBlock <- function(x, idx) { + R <- x@correlation + if (!methods::is(R, "dspMatrix")) { + return(unname(R[idx, idx, drop = FALSE])) + } + if (identical(as.integer(idx), seq_len(nrow(R)))) { + return(methods::as(R, "matrix")) + } + methods::as(.ldmPackedBlock(x, idx), "matrix") +} + +# The block of `x`'s correlations over variants `idx`, packed: the Matrix +# package's subsetting of the stored triangle, which keeps the block packed. +# It reads the upper triangle, the one an LdMatrix stores: Matrix 1.7 +# misreads a lower one under indices out of order, so one saved that way is +# transposed (the same matrix, packed by its upper triangle) first. +# @noRd +.ldmPackedBlock <- function(x, idx) { + R <- x@correlation + if (!methods::is(R, "dspMatrix")) { + return(.packedLd(R[idx, idx, drop = FALSE])) + } + upper <- if (identical(R@uplo, "U")) R else Matrix::t(R) + upper[idx, idx, drop = FALSE] +} + # ---- accessors -------------------------------------------------------------- #' @rdname ldMatrix #' @export -setMethod("ldMatrix", "LdMatrix", function(x) x@correlation) +setMethod("ldMatrix", "LdMatrix", function(x) { + R <- .unpackedLd(x@correlation) + ids <- as.character(S4Vectors::mcols(x)$SNP) + if (length(ids) == 0L) R else `dimnames<-`(R, list(ids, ids)) +}) #' @rdname ldMatrix #' @importFrom S4Arrays as.matrix @@ -617,6 +728,21 @@ setAs("LdMatrix", "matrix", function(from) ldMatrix(from)) #' @export setMethod("nSamples", "LdMatrix", function(x, ...) x@nSamples) +# An LdMatrix saved before its matrix was stored packed has it packed. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "LdMatrix", + function(object, ..., verbose = FALSE) { + object <- methods::callNextMethod() + if (!methods::is(object@correlation, "dspMatrix")) { + object@correlation <- .packedLd(object@correlation) + } + object + } +) + #' @rdname mixtureWeights #' @export setMethod("mixtureWeights", "LdMatrix", function(x) { diff --git a/R/LdScore.R b/R/LdScore.R index c0e2a1717..262e1bd68 100644 --- a/R/LdScore.R +++ b/R/LdScore.R @@ -26,9 +26,11 @@ NULL #' panel, subsets freely. #' @slot ldMatrixList For g-LDSC: a list of per-block LD correlation (R) #' matrices used to compute the FGLS residual covariance, kept when the -#' scores were built from \code{LdMatrix} blocks. Empty for a scores-only -#' object, and for one built from a genotype panel, which reads each -#' block's LD from the panel instead (see \code{\linkS4class{LdStatistic}}). +#' scores were built from \code{LdMatrix} blocks, each stored packed (its +#' upper triangle) and handed out whole by \code{\link{ldMatrixList}}. +#' Empty for a scores-only object, and for one built from a genotype +#' panel, which reads each block's LD from the panel instead (see +#' \code{\linkS4class{LdStatistic}}). #' @export setClass( "LdScore", @@ -114,10 +116,41 @@ LdScore <- function( ldBlocks = .asLdBlockRanges(ldBlocks), nSamples = as.integer(nSamples), inSample = isTRUE(inSample), - ldMatrixList = ldMatrixList + ldMatrixList = map(ldMatrixList, .ldScorePackedBlock) ) } +# A stored block with its LD matrix packed (.packedLd()), or unpacked +# (.unpackedLd()) to hand out or compute with. +# @noRd +.ldScorePackedBlock <- function(block) { + list_assign(block, R = .packedLd(block$R)) +} + +# @noRd +.ldScoreUnpackedBlock <- function(block) { + list_assign(block, R = .unpackedLd(block$R)) +} + +# An LdScore saved before its block matrices were stored packed has them +# packed. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "LdScore", + function(object, ..., verbose = FALSE) { + object <- methods::callNextMethod() + blocks <- object@ldMatrixList + packed <- map(blocks, .ldScorePackedBlock) + if (identical(packed, blocks)) { + return(object) + } + object@ldMatrixList <- packed + object + } +) + #' @importFrom checkmate assertCount assertFlag #' @title Build an LdScore from an LD reference #' @description Compute per-variant LD scores from an LD reference, block by @@ -286,7 +319,7 @@ buildLdScore <- function( # @noRd .ldScoreKeepMatrix <- function(block, snpIdx) { - list(R = block$R, snpIdx = as.integer(snpIdx)) + list(R = .packedLd(block$R), snpIdx = as.integer(snpIdx)) } # The conventional LDSC heteroskedasticity weight, with the score floored at @@ -345,7 +378,7 @@ setMethod("show", "LdScore", function(object) { # @noRd .ldScoreStoredBlock <- function(block) { - list(idx = block$snpIdx, R = block$R) + list(idx = block$snpIdx, R = .unpackedLd(block$R)) } # ---- subsetting ------------------------------------------------------------- @@ -371,7 +404,7 @@ setMethod("extractROWS", "LdScore", function(x, i) { #' @export setMethod("ldMatrixList", "LdScore", function(x) { if (is.null(x@ldReference)) { - return(x@ldMatrixList) + return(map(x@ldMatrixList, .ldScoreUnpackedBlock)) } map(.ldScoreBlocks(x), .ldScorePanelMatrix, ldReference = x@ldReference) }) diff --git a/R/LdStatistic.R b/R/LdStatistic.R index 40fd4c175..c6e8c3feb 100644 --- a/R/LdStatistic.R +++ b/R/LdStatistic.R @@ -118,13 +118,13 @@ setClass( seqnames = withChrPrefix(as.character(snpInfo$CHR)), ranges = IRanges::IRanges(as.integer(snpInfo$BP), width = 1L) ) - labelled <- S4Vectors::`mcols<-`( + labelled <- .canonAlleleMcols(S4Vectors::`mcols<-`( `names<-`(gr, as.character(snpInfo$SNP)), value = S4Vectors::DataFrame( select(snpInfo, -any_of(c("CHR", "BP"))), row.names = NULL ) - ) + )) .withGenomeBuild( labelled, !is.null(genome) && length(genome) == 1L && nzchar(genome), @@ -458,12 +458,7 @@ setMethod( } object <- .renameSavedSlots(object, c(nRef = "nSamples")) if (!methods::.hasSlot(object, "ldReference")) { - object <- `slot<-`( - object, - "ldReference", - check = FALSE, - value = NULL - ) + methods::slot(object, "ldReference", check = FALSE) <- NULL } methods::callNextMethod(object, ..., verbose = verbose) } diff --git a/R/MethodOptions.R b/R/MethodOptions.R index 786feca76..303bd2b7f 100644 --- a/R/MethodOptions.R +++ b/R/MethodOptions.R @@ -72,6 +72,11 @@ NULL #' @export setClass("MethodOptions", contains = "SimpleList") +# A record is spliced into an engine call as !!!as.list(record), never as +# !!!record: rlang copies an S4 list into a list by out[[i]] <- x[[i]], which +# deletes the element when the value is NULL, so a record whose last setting +# is NULL fails to splice. + # Resolve "pkg::fn" to the function, or NULL when there is nothing to resolve: # a package that is not installed, or `callee = NULL` for a bundle pecotmr owns # outright. A missing Suggests package is not an error here -- building an @@ -222,13 +227,13 @@ setClass("MethodOptions", contains = "SimpleList") } # The Options-constructor names declared by every TWAS method that fills -# one capability field. +# one capability field, every backend's for a method with several. # @noRd .twasCtorNamesFor <- function(caps, field) { - unlist(compact(map( + unname(unlist(compact(map( compact(map(caps, field)), - .twasImplCtorName - ))) + .twasImplCtorNames + )))) } # TWAS stores pecotmr implementations rather than callees, and each one diff --git a/R/MethodParam.R b/R/MethodParam.R index 42d60062a..c8c5380dd 100644 --- a/R/MethodParam.R +++ b/R/MethodParam.R @@ -904,11 +904,17 @@ setValidity("MethodsSelectionParam", function(object) { if (identical(cls, "FineMappingMethodsParam")) { return(.fmExpectedEngine(token, inputKind)) } - ctor <- .twasMethodCtorFor(token, inputKind) - if (is.null(ctor)) { + ctors <- .twasMethodCtorNamesFor(token, inputKind) + if (is.null(ctors)) { return(NULL) } - .methodsRecordEngine(ctor) + # A method with several backends takes any of their constructors. + unique(unlist(map(ctors, .methodsCtorNameEngine))) +} + +# @noRd +.methodsCtorNameEngine <- function(ctorName) { + .methodsRecordEngine(get(ctorName, envir = asNamespace("pecotmr"))) } # @noRd @@ -953,12 +959,13 @@ setValidity("MethodsSelectionParam", function(object) { } want <- .methodsExpectedEngine(cls, nm, inputKind) got <- metadata(v)$engine - if (is.null(want) || is.null(got) || identical(got, want)) { + if (is.null(want) || is.null(got) || is_in(got, want)) { return(character(0)) } + wantStr <- str_flatten(str_c("'", want, "'"), " or ") glue( "`{slotName}${nm}` was built with the constructor for '{got}', but ", - "{nm} on {inputKind} uses the '{want}' constructor" + "{nm} on {inputKind} uses the {wantStr} constructor" ) } @@ -971,20 +978,49 @@ setValidity("MethodsSelectionParam", function(object) { if (.isMethodOptions(v) || !is.list(v) || length(v) == 0L) { return(character(0)) } - accepted <- .methodsPathAccepted(cls, nm, inputKind) - if (is.null(accepted)) { - return(character(0)) - } - unknown <- setdiff(names(v), accepted) + unknown <- .methodsUnknownNames(cls, nm, inputKind, names(v)) if (length(unknown) == 0L) { return(character(0)) } - glue( - "`{slotName}${nm}`: unknown argument(s) ", - "{str_flatten(unknown, ', ')} for {nm} on {inputKind}." + str_c( + glue( + "`{slotName}${nm}`: unknown argument(s) ", + "{str_flatten(unknown, ', ')} for {nm} on {inputKind}." + ), + .methodsUnknownArgHint(cls, nm, v, inputKind) ) } +# The names one method cannot take on one path. A chain with a `...` hop +# accepts any name, so only the names its pipeline sets for every method +# are refused there. +# @noRd +.methodsUnknownNames <- function(cls, token, inputKind, given) { + accepted <- .methodsPathAccepted(cls, token, inputKind) + if (is.null(accepted)) { + return(intersect(given, .methodsPipelineOwned(cls))) + } + setdiff(given, accepted) +} + +# @noRd +.methodsPipelineOwned <- function(cls) { + if (identical(cls, "FineMappingMethodsParam")) { + return(character(0)) + } + .twasPipelineOwnedArgs() +} + +# Where a refused name belongs, when it is a pipeline argument rather than a +# method option. Only TWAS has one: `backend`. +# @noRd +.methodsUnknownArgHint <- function(cls, token, entry, inputKind) { + if (identical(cls, "FineMappingMethodsParam")) { + return("") + } + .twasBackendArgHint(token, entry, inputKind) +} + # A record carries the input classes it is for (see .engineInputType), so a # summary-statistics record under `qtlDatasetMethods` is caught here rather # than failing inside the engine. diff --git a/R/QtlDataset.R b/R/QtlDataset.R index 6bef1c801..539a4552e 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -381,8 +381,9 @@ QtlDataset <- function( genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) ) { handle <- .qtlValidateInputs(phenotypes, genotypes) - # Every experiment's rowRanges in UCSC style, so the dataset's traits and - # variants meet every other range pecotmr holds exactly. + # Every experiment's rowRanges in UCSC style, and the genotypes' alleles + # in upper case, so the dataset's traits and variants meet every other + # range pecotmr holds exactly. experiments <- map( c( set_names( @@ -391,7 +392,7 @@ QtlDataset <- function( ), as.list(phenotypes) ), - .ucscExperiment + .canonExperiment ) mae <- MultiAssayExperiment::MultiAssayExperiment( experiments = experiments, diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index 727ff8371..ba4664c20 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -350,7 +350,7 @@ QtlFineMappingResult <- function( trait = as.character(trait), method = as.character(method), susieFit = S4Vectors::SimpleList(map(payloads, susieFit)), - cvResult = S4Vectors::SimpleList(map(payloads, cvResult)), + cvResult = S4Vectors::SimpleList(map(payloads, .fmRowCvStored)), derivedColumns = IRanges::CharacterList( map(payloads, .fmRowDerivedColumns) ) diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index 3cdb1f976..a7bfadd42 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -331,7 +331,24 @@ setMethod("genomicRegion", "RangedTupleList", function(x) { # during initialize(), and a subclass's validity method reads its identity # columns and slots. Building the object bare and filling it in afterwards # trips that check on the way past. - bare <- .rtlBindElements(elements) + .rtlFinish(x, .rtlBindElements(.rtlPlainElements(x, elements)), keep) +} + +# `elements` as rows of `x` hold them before it stores them: a summary- +# statistic collection's each with the columns it leaves out put back +# (.ssPlainElement()), as one taken from stored variants may lack them. +# @noRd +.rtlPlainElements <- function(x, elements) { + if (!methods::is(x, "SumStatsBase")) { + return(elements) + } + map(elements, .ssPlainElement) +} + +# `x`'s collection-level state -- seqinfo, outer mcols (rows `keep`), names +# and slots -- put on the bare GRangesList `bare`, as the rebuilt `x`. +# @noRd +.rtlFinish <- function(x, bare, keep) { # seqinfo is collection-level state, exactly like the slots below: it # carries the genome build. A rebuild from bare elements starts with the # seqlevels those elements happen to span -- none at all when everything @@ -339,21 +356,61 @@ setMethod("genomicRegion", "RangedTupleList", function(x) { # to nothing would silently discard the build. withSeqinfo <- .rtlRestoreSeqinfo(bare, x) md <- mcols(x, use.names = FALSE) - grl <- if (is.null(md)) { - withSeqinfo - } else { - S4Vectors::`mcols<-`(withSeqinfo, value = md[keep, , drop = FALSE]) + rowsMd <- if (is.null(md)) NULL else md[keep, , drop = FALSE] + if (methods::is(x, "TwasWeights")) { + # A TWAS row's weights sit beside its element, not in it, so they + # follow its variants into the rebuilt element by id. + rowsMd <- .twasRealignedMcols(x, rowsMd, bare, keep) } - # The rebuilt elements keep the names they had -- the caller may have set - # their own -- and an unnamed collection is named off its identity. - grl <- if (is.null(names(x))) { - .rtlNamed(grl) + if (methods::is(x, "ColocResult")) { + # So do a coloc group's pairs' SNP.PP.H4. + rowsMd <- .crRealignedMcols(x, rowsMd, bare, keep) + } + grl <- if (is.null(rowsMd)) { + withSeqinfo } else { - `names<-`(grl, names(x)[keep]) + S4Vectors::`mcols<-`(withSeqinfo, value = rowsMd) } + grl <- .rtlNamedLike(grl, x, keep) ownSlots <- .rtlOwnSlots(x) slotArgs <- set_names(map(ownSlots, .rtlGetSlot, x = x), ownSlots) - exec(methods::new, class(x), grl, !!!slotArgs) + # A fit is mostly one row's own, so a subset keeps only the fits its rows + # name; the shared dictionaries keep their few entries whole. + if (is_in("fits", ownSlots)) { + slotArgs$fits <- .fitsInUse( + slotArgs$fits, + mcols(grl, use.names = FALSE) + ) + } + exec(methods::new, class(x), .rtlStored(class(x), grl), !!!slotArgs) +} + +# `grl`, rebuilt from rows `keep` of `x`, with the names those rows had -- the +# caller may have set their own -- or, when `x` is unnamed, named off its +# identity. +# @noRd +.rtlNamedLike <- function(grl, x, keep) { + if (is.null(names(x))) { + return(.rtlNamed(grl)) + } + `names<-`(grl, names(x)[keep]) +} + +# `x` with its elements' variant metadata replaced by `flatMcols`, one row per +# variant of unlist(x): the variants, outer mcols and slots stay as they are. +# Relisting the joined variants costs one pass, where taking the elements +# apart costs milliseconds an element. +# @noRd +.rtlWithVariantMcols <- function(x, flatMcols) { + flat <- S4Vectors::`mcols<-`( + unlist(x, use.names = FALSE), + value = flatMcols + ) + bare <- IRanges::relist( + flat, + IRanges::PartitioningByEnd(cumsum(lengths(x)), names = names(x)) + ) + .rtlFinish(x, bare, seq_along(x)) } # @noRd @@ -371,9 +428,16 @@ setMethod("genomicRegion", "RangedTupleList", function(x) { # for a bare `unlist(x)`. Validity is not the cost (0.1 ms) -- the rebuild is. # # Nothing here re-validates: the elements came out of a collection that was -# validated when it was built. +# validated when it was built. The variants come out as the rows hand them +# out (.rtlPlain()). # @noRd .rtlGatherElements <- function(x, idx) { + .rtlPlain(x, .rtlGatherStored(x, idx)) +} + +# The variants of rows `idx` of `x`, joined, as stored. +# @noRd +.rtlGatherStored <- function(x, idx) { if (length(idx) == 0L) { return(unlist(x, use.names = FALSE)[0L]) } @@ -481,9 +545,25 @@ setMethod("[", "RangedTupleList", function(x, i, j, ..., drop = TRUE) { ) abort(msg) } - methods::callNextMethod(x, i, ..., drop = drop) + .rtlPruneFits(methods::callNextMethod(x, i, ..., drop = drop)) }) +# `x` keeping only the fits its rows name (.fitsInUse()): a fit is mostly one +# row's own, so a subset should not carry every other row's. The shared +# dictionaries keep their few entries whole. +# @noRd +#' @importFrom methods slot<- +.rtlPruneFits <- function(x) { + if (!methods::.hasSlot(x, "fits")) { + return(x) + } + methods::slot(x, "fits", check = FALSE) <- .fitsInUse( + x@fits, + mcols(x, use.names = FALSE) + ) + x +} + #' @rdname RangedTupleList-methods #' @export setMethod("[[<-", "RangedTupleList", function(x, i, j, ..., value) { @@ -712,11 +792,10 @@ setMethod("trim", "RangedTupleList", function(x, use.names = TRUE, ...) { #' both in one \code{qcInfo} record have it split between the two. #' Their genome build is in \code{seqinfo()}; ones saved with it in a #' \code{genome} slot have it moved there. -#' \item TWAS weights record the variants each row was fitted on in a -#' \code{fitVariants} column; ones saved without it have it filled in -#' from their fits. Fine-mapping results no longer record them (a row's -#' variants are its fit's variables); ones saved with the column have -#' it dropped. +#' \item Fine-mapping results and TWAS weights no longer record the +#' variants each row was fitted on: a row reads them off its fit. One +#' saved with a \code{fitVariants} column (or, for TWAS weights, slot) +#' has it dropped. #' \item A \code{CtwasResult} holds one element per region; one saved as a #' table of whole runs is rebuilt. #' \item A \code{QtlDataset} no longer stores run settings (genotype @@ -731,9 +810,11 @@ setMethod("trim", "RangedTupleList", function(x, use.names = TRUE, ...) { #' an LD reference stores its blocks' LD itself, and gets none; one #' saved with the reference's sample size as \code{nRef} has it moved #' to \code{nSamples}. -#' \item An \code{H2Estimate} saved with its estimates under the slots' -#' earlier names (\code{h2}, \code{h2Se}, \code{local}, -#' \code{tauBlocks}) has them moved to the current ones. +#' \item An \code{H2Estimate} saved when it held one estimate in slots +#' (also under their earlier names \code{h2}, \code{h2Se}, +#' \code{local}, \code{tauBlocks}) is rebuilt as a collection of that +#' estimate. The per-block local estimates some held are dropped, with +#' a warning: the genome-wide estimators make one estimate per study. #' } #' @param object A collection (summary statistics, fine-mapping results, TWAS #' weights, a colocalization or cTWAS result), a \code{QtlDataset}, a @@ -788,7 +869,8 @@ setMethod( } value <- methods::slot(object, from) attr(object, from) <- NULL - `slot<-`(object, to, check = FALSE, value = value) + methods::slot(object, to, check = FALSE) <- value + object } # ----------------------------------------------------------------------------- @@ -819,16 +901,121 @@ setMethod( # @noRd .rtlNewValidated <- function(Class, payloads, cols, ldReference) { dict <- .ldRefDict(.ldRefPerTuple(ldReference, length(payloads))) + cv <- .cvStoredColumn(as.list(cols[["cvResult"]])) + fitted <- .dictBuild(as.list(cols[["susieFit"]]), .FIT_DICT_PREFIX) + stored <- list_assign( + cols, + cvResult = cv$cvResult, + susieFit = fitted$keys + ) + grl <- .rtlNamed(.rtlGrlWithMetadata( + payloads, + c(stored, list(ldReference = dict$keys, cvPartition = cv$keys)) + )) new( Class, - .rtlNamed(.rtlGrlWithMetadata( - payloads, - c(cols, list(ldReference = dict$keys)) - )), - ldReference = dict$refs + .rtlStored(Class, grl), + ldReference = dict$entries, + cvPartition = cv$entries, + fits = fitted$entries + ) +} + +# ----------------------------------------------------------------------------- +# Run-length storage of variant metadata +# ----------------------------------------------------------------------------- +# A variant-metadata column that repeats -- a value fixed for a whole row, a +# sentinel most variants share -- takes less room as an Rle. A class chooses +# which of its columns may be stored so (.rtlStored()); each one is, where +# that is smaller, and the rows a collection hands out decode them +# (.rtlPlainMcols()). + +# `grl` as a collection of class `cls` stores it: a fine-mapping collection +# keeps its topLoci columns compact (.fmrCompactTopLoci()), a summary- +# statistic one its variant columns (.ssStored()), any other as is. +# @noRd +.rtlStored <- function(cls, grl) { + if (methods::extends(cls, "SumStatsBase")) { + return(.ssStored(grl)) + } + if (!methods::extends(cls, "FineMappingResultBase")) { + return(grl) + } + .fmrCompactTopLoci(grl) +} + +# `gr`, variants of `x`'s rows as stored, as its rows hand them out: with a +# fine-mapping collection's topLoci columns plain (.fmPlainElement()) or a +# summary-statistic one's variant columns (.ssPlainElement()), any other's +# as they are. +# @noRd +.rtlPlain <- function(x, gr) { + if (methods::is(x, "SumStatsBase")) { + return(.ssPlainElement(gr)) + } + if (!methods::is(x, "FineMappingResultBase")) { + return(gr) + } + .fmPlainElement(gr) +} + +# `md` with each column in `cols` stored as an Rle where that is smaller. +# @noRd +.rtlRleWhereSmaller <- function(md, cols) { + reduce(intersect(cols, colnames(md)), .rtlRleColumn, .init = md) +} + +# A run costs its value plus a four-byte length, a plain element its value +# alone. A column with attributes (a factor, a matrix) stays as it is; one +# already encoded is measured again as the values it holds. +# @noRd +.rtlRleColumn <- function(md, cn) { + v <- md[[cn]] + v <- if (.rtlIsRle(v)) as.vector(v) else v + if (!is.atomic(v) || !is.null(attributes(v)) || length(v) == 0L) { + return(md) + } + r <- S4Vectors::Rle(v) + size <- .rtlValueBytes(v) + md[[cn]] <- if (S4Vectors::nrun(r) * (size + 4) < length(v) * size) { + r + } else { + v + } + md +} + +# @noRd +.rtlValueBytes <- function(v) { + if (is.integer(v) || is.logical(v)) 4 else 8 +} + +# `gr` with its run-length encoded metadata columns as the plain vectors +# they encode. +# @noRd +.rtlPlainMcols <- function(gr) { + md <- mcols(gr, use.names = FALSE) + encoded <- names(keep(as.list(md), .rtlIsRle)) + if (length(encoded) == 0L) { + return(gr) + } + S4Vectors::`mcols<-`( + gr, + value = reduce(encoded, .rtlDecodeColumn, .init = md) ) } +# @noRd +.rtlIsRle <- function(v) { + methods::is(v, "Rle") +} + +# @noRd +.rtlDecodeColumn <- function(md, cn) { + md[[cn]] <- as.vector(md[[cn]]) + md +} + # ----------------------------------------------------------------------------- # Joining elements into a list # ----------------------------------------------------------------------------- @@ -846,6 +1033,12 @@ setMethod( # @noRd .rtlBindElements <- function(elements) { flat <- suppressWarnings(.rtlJoinPlainElements(elements)) + if (is.null(flat)) { + # Elements taken out of a collection carry its run-length encoded + # columns, which the plain join takes once they are decoded. + plain <- map(unname(as.list(elements)), .rtlPlainMcols) + flat <- suppressWarnings(.rtlJoinPlainElements(plain)) + } if (is.null(flat)) { return(GenomicRanges::GRangesList(elements)) } @@ -867,7 +1060,7 @@ setMethod( # silenced as GRangesList() silences them (.rtlBindElements()). # @noRd .rtlJoinParts <- function(parts) { - flats <- unname(map(parts, unlist, use.names = FALSE)) + flats <- unname(map(parts, .rtlPlainFlat)) flat <- suppressWarnings(exec(c, !!!flats)) ends <- cumsum(list_c(map(parts, .rtlElementLengths), ptype = integer())) IRanges::relist( @@ -876,6 +1069,13 @@ setMethod( ) } +# A collection's variants joined, as its rows hand them out (.rtlPlain()): +# parts stored in different ways join on the same columns. +# @noRd +.rtlPlainFlat <- function(x) { + .rtlGatherElements(x, seq_along(x)) +} + # @noRd .rtlElementLengths <- function(x) { unname(lengths(x)) @@ -1268,6 +1468,12 @@ setMethod( #' range, so there is no row to broadcast them onto. Use the accessors #' (\code{\link{susieFit}}, \code{\link{cvResult}}) for those. #' +#' A \code{\link{TwasWeights}} row holds a gene's methods, so it flattens to +#' one range per (variant, method, weight column). Each carries that +#' method's \code{weight} and \code{.method}; \code{.weightColumn} names the +#' column of a weight matrix (an fSuSiE feature, an outcome) and is +#' \code{NA} for a plain weight vector. +#' #' \code{as(x, "GRanges")} is the same conversion. #' #' @param x A \code{RangedTupleList}. @@ -1285,6 +1491,9 @@ flattenTupleRanges <- function(x) { ) abort(msg) } + if (methods::is(x, "TwasWeights")) { + return(.twasFlatten(x)) + } gr <- if (methods::is(x, "FineMappingResultBase")) { .fmrGatherVariants(x, seq_len(length(x))) } else { @@ -1294,7 +1503,7 @@ flattenTupleRanges <- function(x) { if (is.null(md) || ncol(md) == 0L || length(gr) == 0L) { return(gr) } - tupleCols <- names(md)[map_lgl(as.list(md), is.atomic)] + tupleCols <- .rtlTupleKeyCols(x) if (length(tupleCols) == 0L) { return(gr) } @@ -1344,6 +1553,9 @@ setAs("RangedTupleList", "GRanges", function(from) { #' #' A tuple with no surviving ranges becomes an empty element rather than being #' dropped, so the collection keeps its shape and its metadata stays aligned. +#' A \code{\link{TwasWeights}} is nested by (row, \code{.method}): each +#' method keeps its surviving ranges and their \code{weight}, and a method +#' left with none keeps its entry, with no variants. #' #' @param flat A \code{GRanges} produced by \code{flattenTupleRanges} (possibly #' filtered or mutated). @@ -1367,6 +1579,9 @@ nestTupleRanges <- function(flat, template) { msg <- glue("`flat` must be a GRanges (got {class(flat)[[1L]]}).") abort(msg) } + if (methods::is(template, "TwasWeights")) { + return(.twasNest(flat, template)) + } keys <- .rtlNestKeys(flat, template, .rtlTupleKeyCols(template)) picked <- map(keys$wanted, .rtlPickByKey, flat = flat, have = keys$have) elements <- if (methods::is(template, "FineMappingResultBase")) { @@ -1466,7 +1681,13 @@ nestTupleRanges <- function(flat, template) { # No is.null() arm: see ncol() above -- mcols() answers a zero-column # DataFrame, and names() of one is already character(0). md <- mcols(x, use.names = FALSE) - names(md)[map_lgl(as.list(md), is.atomic)] + # A fine-mapping row's `susieFit` and `cvPartition` hold its keys into the + # fits and CV-partition dictionaries: payloads, like the others not + # broadcast onto ranges. + setdiff( + names(md)[map_lgl(as.list(md), is.atomic)], + c("susieFit", "cvPartition") + ) } # One key string per row. With no identity columns every range belongs to the @@ -1609,10 +1830,17 @@ group_by.RangedTupleList <- function(.data, ...) { } # Put back any identity column a selection dropped. Without them the ranges -# carry no tuple and every one would fall into the first element. +# carry no tuple and every one would fall into the first element. A +# TwasWeights also keeps its weights, the method and column they belong to, +# and the alleles that name each variant. # @noRd .rtlRestoreKeys <- function(out, flat, template) { - dotted <- map_chr(.rtlTupleKeyCols(template), .rtlDotName) + dotted <- c( + map_chr(.rtlTupleKeyCols(template), .rtlDotName), + if (methods::is(template, "TwasWeights")) { + c(.TWAS_FLAT_COLUMNS, "A1", "A2") + } + ) missing <- setdiff( intersect(dotted, colnames(mcols(flat))), colnames(mcols(out)) diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index 464e2b6ba..e44d547f2 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -67,7 +67,11 @@ NULL #' @param fineMappingResult Optional \code{\link{QtlFineMappingResult}}. When #' supplied, drives the MR computation and (when \code{twasWeights = NULL}) #' the TWAS-Z weights via the SuSiE-style coefficients on each entry's -#' \code{topLoci}. +#' \code{topLoci}. MR reads the fine-mapping row of the same +#' \code{(study, context, trait, method)} as the TWAS row, so it runs only +#' for TWAS methods that are also fine-mapping methods (such as +#' \code{susie}); the MR columns of every other method's rows are +#' \code{NA}. #' @param weightSelectionParam How one TWAS method's weights are picked per #' \code{(study, context, trait, gwasStudy)} tuple, built with #' \code{\link{WeightSelectionParam}}: \code{cutoff} (minimum @@ -636,11 +640,13 @@ causalInferencePipeline <- function( # (so MR has something to attach). .cipBuildQtlWorkList <- function(twasWeights, fineMappingResult) { if (!is.null(twasWeights)) { + # One tuple per entry: a TwasWeights row holds a gene's methods. + cells <- .twasCells(twasWeights) df <- tibble( - qtlStudy = as.character(twasWeights$study), - context = as.character(twasWeights$context), - trait = as.character(twasWeights$trait), - method = as.character(twasWeights$method) + qtlStudy = cells$study, + context = cells$context, + trait = cells$trait, + method = cells$method ) } else { df <- tibble( @@ -860,6 +866,17 @@ causalInferencePipeline <- function( return(NULL) } wr <- resolveWeights(ent) + single <- .singleWeightColumn(wr$weights) + if (is.null(single)) { + warn(glue( + "causalInferencePipeline: the weights of (study={studyName}, ", + "context={context}, trait={trait}, method={method}) are a matrix ", + "with {ncol(wr$weights)} columns, and a tuple is scored with one ", + "weight vector; skipping." + )) + return(NULL) + } + wr$weights <- single if (length(wr$variantIds) == 0L) { warn(glue( "causalInferencePipeline: no weights resolved for ", @@ -881,13 +898,9 @@ causalInferencePipeline <- function( trait, method ) { - tuple <- list( - study = studyName, - context = context, - trait = trait, - method = method - ) - if (length(.matchTupleRows(twasWeights, tuple)) == 0L) { + cells <- .twasCells(twasWeights) + hit <- .twasCellIndex(cells, studyName, context, trait, method) + if (length(hit) == 0L) { return(NULL) } twasWeights( @@ -968,8 +981,9 @@ causalInferencePipeline <- function( } # twasZ() of weights `w` against GWAS z-scores `z` over the GWAS variants -# `gwasIds`, needing w'Rw only: a genotype reference gives its LD factor, so -# the p x p LD is never formed; an LdMatrix gives the matrix. +# `gwasIds` (`w` and `z` in their order), needing w'Rw only: a genotype +# reference gives its LD factor and an LdMatrix its packed triangle, so the +# p x p LD is never formed. # @noRd .cipTwasZ <- function(w, z, gwasLd, gwasIds) { label <- "causalInferencePipeline" @@ -980,7 +994,13 @@ causalInferencePipeline <- function( X = .ldFactorFromRef(gwasLd, gwasIds, label) )) } - twasZ(weights = w, z = z, R = .ldFromRef(gwasLd, gwasIds, label)) + weights <- .twasZPrepWeights(unname(w), z) + ld <- .ldPackedFromRef(gwasLd, gwasIds, label) + .twasZStatistics( + weights, + z, + crossprod(weights, .ldSourceTimes(ld, weights)) + ) } # Report how many QTL weight variants failed to match the GWAS sumstats. @@ -1720,6 +1740,13 @@ twasZ <- function( D = D, nSketch = nSketch )$covY + .twasZStatistics(weights, z, covY, combineMethods) +} + +# twasZ()'s statistics from the weights' covariance under the LD, +# covY = W' R W, however that was computed. +# @noRd +.twasZStatistics <- function(weights, z, covY, combineMethods = NULL) { ySd <- sqrt(diag(covY)) stats <- as.numeric(crossprod(weights, as.numeric(z))) zVec <- stats / ySd diff --git a/R/colocPipeline.R b/R/colocPipeline.R index 9bd3073ea..62d2dd139 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -404,10 +404,12 @@ GwasFineMappingParam <- function( #' \code{coloc::coloc.bf_bf}, built with \code{\link{ColocOptions}}. The #' prior probabilities are set through \code{priors} instead, since the #' enrichment adjustment reads them too. -#' @return A \code{\linkS4class{ColocResult}}: one element per tested -#' (first-side credible set, second-side credible set) pair, holding -#' that pair's aligned variants with their \code{SNP.PP.H4}. Pair-level -#' metadata carries the identity columns (\code{study}, \code{context}, +#' @return A \code{\linkS4class{ColocResult}}: one element per scored group +#' -- a first-side row against a second-side row in one block -- holding +#' the group's aligned variants once, and one row per tested (first-side +#' credible set, second-side credible set) pair in \code{colocPairs()}, +#' with the pair's \code{SNP.PP.H4} over those variants. The pair rows +#' carry the identity columns (\code{study}, \code{context}, #' \code{trait}, \code{method}, \code{gwasStudy}, \code{gwasContext}, #' \code{gwasTrait}, \code{gwasMethod}), the block and stable #' credible-set ids (\code{blockId}, \code{qtlCs}, \code{gwasCs}), the @@ -1433,8 +1435,9 @@ colocPipeline <- function( # spans fewer than 25% of the locus variants -- this prunes diffuse # signals before they reach coloc.bf_bf. # -# Returns an integer vector of kept effect indices (empty when nothing -# survives), or errors when susieR is unavailable. +# Returns the kept effects as rows of the fit's arrays (empty when nothing +# survives): susie_get_cs() names sets by row, which on a trimmed fit is not +# the effect's own index. Errors when susieR is unavailable. # @noRd #' @importFrom susieR susie_get_cs #' @importFrom purrr map_lgl @@ -1490,6 +1493,7 @@ colocPipeline <- function( if (ncol(lbfMatrix) == 0L) { return(NULL) } + effectIndex <- .fitEffectIndex(fit, nrow(allRows)) list( lbf = lbfMatrix, variantIds = colnames(lbfMatrix), @@ -1497,10 +1501,11 @@ colocPipeline <- function( # The fit's own effect indices, which -- unlike coloc's idx1 / idx2 -- # are stable across calls and blocks, so they are what identifies a # credible set in the result. - effect = keep, - # How many effects the fit has before filtering, which is what a - # collapse of several blocks numbers the next block's effects after. - nEffects = nrow(allRows) + effect = effectIndex[keep], + # The largest effect index the fit has before filtering, which is + # what a collapse of several blocks numbers the next block's effects + # after. + nEffects = max(c(nrow(allRows), effectIndex)) ) } @@ -1557,9 +1562,12 @@ colocPipeline <- function( isTRUE(colocLbfFilterParam$filterLbfCs) && is.null(colocLbfFilterParam$secondary) ) { + # cs_index numbers the effects as the credible sets do, which the + # rows of a trimmed fit no longer do. csIdx <- fit[["sets"]][["cs_index"]] if (!is.null(csIdx) && length(csIdx) > 0L) { - return(csIdx) + rows <- .fitEffectRows(fit, csIdx) + return(rows[!is.na(rows)]) } } else if (!is.null(colocLbfFilterParam$secondary)) { secIdx <- try_fetch( diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index f3fca1a38..6a6e9a609 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -2108,7 +2108,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # @noRd .cbResultLdRefs <- function(pairs) { dict <- .ldRefDict(map(unname(pairs), "ldReference")) - list(refs = dict$refs, keys = set_names(dict$keys, names(pairs))) + list(refs = dict$entries, keys = set_names(dict$keys, names(pairs))) } # The separate-GWAS run bundles, keyed by GWAS label. The runs are FOCAL: each diff --git a/R/cpp11.R b/R/cpp11.R index 616bd9e29..93f5da152 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -28,24 +28,32 @@ penalizedRssFactorCpp <- function(zR, factorR, shrink, lambdaR, penaltyStr, gamm .Call(`_pecotmr_penalizedRssFactorCpp`, zR, factorR, shrink, lambdaR, penaltyStr, gamma, alpha, lambda0, lambda2, thr, maxiter, maxSwaps) } -prsCsCpp <- function(a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed) { - .Call(`_pecotmr_prsCsCpp`, a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed) +qtlEnrichmentCpp <- function(rGwasPip, rQtlSusieFit, piGwas, piQtl, totalVariants, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) { + .Call(`_pecotmr_qtlEnrichmentCpp`, rGwasPip, rQtlSusieFit, piGwas, piQtl, totalVariants, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) } -prsCsFactorCpp <- function(a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thin, verbose, seed) { - .Call(`_pecotmr_prsCsFactorCpp`, a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thin, verbose, seed) +prsCsCpp <- function(a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed, shrinkCorr, raoBlackwell, track) { + .Call(`_pecotmr_prsCsCpp`, a, b, phi, bhat, maf, n, ldBlk, nIter, nBurnin, thin, verbose, seed, shrinkCorr, raoBlackwell, track) } -qtlEnrichmentCpp <- function(rGwasPip, rQtlSusieFit, piGwas, piQtl, totalVariants, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) { - .Call(`_pecotmr_qtlEnrichmentCpp`, rGwasPip, rQtlSusieFit, piGwas, piQtl, totalVariants, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) +prsCsFactorCpp <- function(a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thin, verbose, seed, shrinkCorr, raoBlackwell, track) { + .Call(`_pecotmr_prsCsFactorCpp`, a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thin, verbose, seed, shrinkCorr, raoBlackwell, track) +} + +sdprCpp <- function(bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, optLlk, verbose, seed, raoBlackwell, track) { + .Call(`_pecotmr_sdprCpp`, bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, optLlk, verbose, seed, raoBlackwell, track) +} + +sdprFactorCpp <- function(bhatR, factorR, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, optLlk, verbose, seed, raoBlackwell, track) { + .Call(`_pecotmr_sdprFactorCpp`, bhatR, factorR, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, optLlk, verbose, seed, raoBlackwell, track) } -sdprCpp <- function(bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) { - .Call(`_pecotmr_sdprCpp`, bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) +bayesAlphabetFactorCpp <- function(bhat, factorR, weights, n, method, legarra, pi, h2, nIter, nBurnin, thin, verbose, seed, shrinkCorr, allowJumpSign, raoBlackwell, track) { + .Call(`_pecotmr_bayesAlphabetFactorCpp`, bhat, factorR, weights, n, method, legarra, pi, h2, nIter, nBurnin, thin, verbose, seed, shrinkCorr, allowJumpSign, raoBlackwell, track) } -sdprFactorCpp <- function(bhatR, factorR, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) { - .Call(`_pecotmr_sdprFactorCpp`, bhatR, factorR, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) +ldpred2FactorCpp <- function(bhat, factorR, n, automatic, p, h2, sparse, shrinkCorr, allowJumpSign, pLower, pUpper, meanLd, nIter, nBurnin, verbose, seed) { + .Call(`_pecotmr_ldpred2FactorCpp`, bhat, factorR, n, automatic, p, h2, sparse, shrinkCorr, allowJumpSign, pLower, pUpper, meanLd, nIter, nBurnin, verbose, seed) } vcfGtDosageCpp <- function(gt, alleles) { diff --git a/R/crossValidation.R b/R/crossValidation.R index 13e66390a..7b9967f24 100644 --- a/R/crossValidation.R +++ b/R/crossValidation.R @@ -114,6 +114,7 @@ NULL preds <- map(ff$weights, .cvFoldPrediction, Xte = Xte) list( preds = preds, + weights = if (cv$keepFoldWeights) ff$weights, fits = if (identical(fitRetention, "none")) list() else ff$fits ) } @@ -136,7 +137,8 @@ NULL # out-of-fold predictions into full-Y matrices, scores them with .cvMetricRow, # and keys the output via .cvOutputKey(). `maxNumVariants` (optional) randomly # subsamples variants up front to bound compute; `BPPARAM` runs the folds -# (SerialParam() one at a time). +# (SerialParam() one at a time). `keepFoldWeights` adds each fold's weights +# to the output as `foldWeights`, for a caller that stores them. #' @importFrom BiocParallel SerialParam #' @importFrom stats sd lm cor #' @importFrom dplyr n_distinct @@ -153,7 +155,8 @@ NULL variantsToKeep = NULL, fitRetention = c("none", "slim", "full"), verbose = 1, - seed = NULL + seed = NULL, + keepFoldWeights = FALSE ) { fitRetention <- arg_match(fitRetention) .applySeed(seed) @@ -176,18 +179,32 @@ NULL fitFold = fitFold, fitFoldCtx = fitFoldCtx, fitRetention = fitRetention, + keepFoldWeights = keepFoldWeights, verbose = verbose, rngSeed = seed ) foldResults <- .cvRunFolds(foldIds, cvState, BPPARAM) - agg <- .cvAggregate(foldResults, Y, verbose) - list( - samplePartition = samplePartition, + .cvOutput(cvState, foldResults, st) +} + +# The engine's result from its folds': the partition, the out-of-fold +# predictions and their scores, the fits kept, and each fold's weights when +# the caller asked for them. `st` is when the folds started. +# @noRd +.cvOutput <- function(cvState, foldResults, st) { + agg <- .cvAggregate(foldResults, cvState$Y, cvState$verbose) + foldIds <- cvState$foldIds + out <- list( + samplePartition = cvState$samplePartition, prediction = agg$prediction, performance = agg$performance, foldFits = .cvCollectFoldFits(foldResults, foldIds), timeElapsed = proc.time() - st ) + if (!cvState$keepFoldWeights) { + return(out) + } + list_assign(out, foldWeights = .cvCollectFoldWeights(foldResults, foldIds)) } # Validate inputs, coerce a vector Y to a one-column matrix, and set stable @@ -568,6 +585,13 @@ NULL compact(fr$fits) } +# Every fold's weight matrices (method key -> variants x outcomes, rows named +# by the fold's training variants), keyed fold_ like the fits. +# @noRd +.cvCollectFoldWeights <- function(foldResults, foldIds) { + set_names(map(foldResults, "weights"), str_c("fold_", foldIds)) +} + # Test-fold prediction from one method's weight matrix W: align to the test # genotype columns, then Xte %*% W. NULL for a missing/non-overlapping W. # @noRd @@ -788,3 +812,225 @@ CrossValidationParam <- function( # folds = 0 (or 1) is the no-op default. !(length(x) == 1L && !is.na(x) && is.numeric(x) && (x == 0 || x == 1)) } + +# ============================================================================= +# Cross-validation results in a collection +# ----------------------------------------------------------------------------- +# A CV run's rows -- one per method and condition -- share its fold partition +# and the order its out-of-fold predictions are held in. A collection keeps +# each such pair once, in its cvPartition dictionary (see the row dictionaries +# in tupleSelectors.R); every row keeps its predictions without sample names +# and a key to the pair it shares. The rows a collection hands out get both +# back (.cvJoinPartition()), so they carry the CV their payload was built +# with. +# ============================================================================= + +# @noRd +.CV_PARTITION_DICT <- list( + slot = "cvPartition", + keyCol = "cvPartition", + prefix = "cv" +) + +# A collection's shared CV partitions; none for one saved before the slot +# existed, whose rows still hold their own. +# @noRd +.cvPartitionDict <- function(x) { + if (!methods::.hasSlot(x, "cvPartition")) { + return(list()) + } + x@cvPartition +} + +# What is wrong with a collection's CV partitions and its rows' keys into +# them, or NULL. +# @noRd +.cvPartitionProblems <- function(x) { + .dictProblems( + .cvPartitionDict(x), + .dictKeys(x, .CV_PARTITION_DICT), + "cvPartition", + "CV partition(s)" + ) +} + +# The partition row `i` of a collection with mcols `md` shares, NULL for a +# row with none (or a collection saved before rows kept a key). +# @noRd +.mdCvPartition <- function(x, md, i) { + keys <- md[["cvPartition"]] + if (is.null(keys)) { + return(NULL) + } + .dictEntryFor(keys[[i]], .cvPartitionDict(x)) +} + +# Every row's shared partition, NULL for a row with none. +# @noRd +.rowCvPartitions <- function(x) { + map( + .dictKeys(x, .CV_PARTITION_DICT), + .dictEntryFor, + entries = .cvPartitionDict(x) + ) +} + +# The CV partitions of `parts`, row-bound: each row keeps the one it had. +# @noRd +.cvPartitionCombine <- function(parts) { + perRow <- list_flatten(map(parts, .rowCvPartitions)) + .dictBuild(perRow, .CV_PARTITION_DICT$prefix) +} + +# A collection's cvResult column for `cvs`, one row's CV each: the rows as +# they store them (.cvSplitPartition()), every row's key into the partitions +# they share, and those partitions once each. +# @noRd +.cvStoredColumn <- function(cvs) { + split <- map(cvs, .cvSplitPartition) + dict <- .dictBuild(map(split, "partition"), .CV_PARTITION_DICT$prefix) + list( + cvResult = S4Vectors::SimpleList(map(split, "stored")), + keys = dict$keys, + entries = dict$entries + ) +} + +# One row's CV as a collection stores it, and the partition it shares: a +# merged row's per-region payloads each split, and a payload with no +# partition stays as it is. +# @noRd +.cvSplitPartition <- function(cv) { + if (!.cvIsPerRegion(cv)) { + return(.cvSplitPayload(cv)) + } + split <- map(cv, .cvSplitPayload) + shared <- map(split, "partition") + list( + stored = map(split, "stored"), + partition = if (all(map_lgl(shared, is.null))) NULL else shared + ) +} + +# One CV payload without its partition and with its predictions unnamed, and +# what it shares: the partition and the samples its predictions were held +# for, in their order. +# @noRd +.cvSplitPayload <- function(cv) { + sp <- if (is.list(cv)) cv[["samplePartition"]] + if (!is.data.frame(sp)) { + return(list(stored = cv, partition = NULL)) + } + ids <- .cvPredictionIds(cv) + list( + stored = list_assign( + .cvUnnamePredictions(cv, ids), + samplePartition = zap() + ), + partition = list(samplePartition = sp, sampleIds = ids) + ) +} + +# The samples a payload's out-of-fold predictions are held for, in their +# order: a fine-mapping payload names them as the rows of its `prediction` +# matrices, a TWAS payload as the elements of its `predictions` vector. A +# TWAS matrix of predictions (one column per condition) is stored as it is, +# its rows named. +# @noRd +.cvPredictionIds <- function(cv) { + if (length(cv[["prediction"]]) > 0L) { + return(rownames(cv[["prediction"]][[1L]])) + } + names(cv[["predictions"]]) +} + +# @noRd +.cvUnnamePredictions <- function(cv, ids) { + if (length(cv[["prediction"]]) > 0L) { + unnamed <- map(cv[["prediction"]], .cvUnnameRows, ids = ids) + return(list_assign(cv, prediction = unnamed)) + } + p <- cv[["predictions"]] + if (is.null(p) || !identical(names(p), ids)) { + return(cv) + } + list_assign(cv, predictions = unname(p)) +} + +# @noRd +.cvUnnameRows <- function(m, ids) { + if (!is.matrix(m) || !identical(rownames(m), ids)) { + return(m) + } + `rownames<-`(m, NULL) +} + +# A row's stored CV with the partition it shares put back: the partition +# first, as every CV payload holds it, and the predictions named again. +# @noRd +.cvJoinPartition <- function(stored, partition) { + if (is.null(partition)) { + return(stored) + } + if (is_in("samplePartition", names(partition))) { + return(.cvJoinPayload(stored, partition)) + } + map2(stored, partition, .cvJoinPayload) +} + +# @noRd +.cvJoinPayload <- function(stored, partition) { + if (is.null(partition)) { + return(stored) + } + c( + list(samplePartition = partition[["samplePartition"]]), + .cvNamePredictions(stored, partition[["sampleIds"]]) + ) +} + +# @noRd +.cvNamePredictions <- function(cv, ids) { + if (is.null(ids)) { + return(cv) + } + if (length(cv[["prediction"]]) > 0L) { + named <- map(cv[["prediction"]], .cvNameRows, ids = ids) + return(list_assign(cv, prediction = named)) + } + p <- cv[["predictions"]] + if ( + is.null(p) || + is.matrix(p) || + !is.null(names(p)) || + length(p) != length(ids) + ) { + return(cv) + } + list_assign(cv, predictions = set_names(p, ids)) +} + +# @noRd +.cvNameRows <- function(m, ids) { + if (!is.matrix(m) || !is.null(rownames(m)) || nrow(m) != length(ids)) { + return(m) + } + `rownames<-`(m, ids) +} + +# A collection saved while each row held its own CV partition and named +# predictions, with each partition kept once, as collections now store them. +# A collection whose rows already key into its partitions is left as is. +# @noRd +.cvSharePartitions <- function(object) { + cols <- .tupleColumnNames(object) + if (!is_in("cvResult", cols) || is_in("cvPartition", cols)) { + return(object) + } + md <- mcols(object, use.names = FALSE) + cv <- .cvStoredColumn(as.list(md$cvResult)) + md$cvResult <- cv$cvResult + md$cvPartition <- cv$keys + methods::slot(object, "cvPartition", check = FALSE) <- cv$entries + S4Vectors::`mcols<-`(object, value = md) +} diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index 528f5eb9f..0c51a31be 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -235,9 +235,12 @@ BoundaryMergeParam <- function( #' \code{pecotmrFitCoverage}): the fit no longer lines up with the row's #' variants, so its weights are not renormalized over the variants kept. #' @param twasZ Optional \code{GRanges} of TWAS Z-scores (output of -#' \code{\link{causalInferencePipeline}}). When supplied, the per-(trait, -#' context) Z is used as the \code{z_gene} input to \code{ctwas_sumstats} so -#' it is not recomputed. +#' \code{\link{causalInferencePipeline}}). When supplied, each weighted +#' gene's Z -- the row of its \code{(qtlStudy, context, trait, method)} +#' for the GWAS study of \code{gwasSumStats} -- is used as the +#' \code{z_gene} input to \code{ctwas_sumstats} so it is not recomputed. +#' Every weighted gene needs exactly one; rows for other genes, methods or +#' GWAS studies are ignored. #' @param fineMappingResult Optional \code{QtlFineMappingResult}: the genes' #' own fine-mapping, whose per-variant PIP and credible-set membership the #' CS / PIP rescue filters (\code{csMinCor} and \code{minPipCutoff}) read. @@ -557,38 +560,80 @@ assembleCtwasInputs <- function( variantPruningParam, "VariantPruningParam" ) + inp <- .ctwasResolveInputs( + gwasSumStats, + twasWeights, + twasZ, + fineMappingResult, + fineMappingMethod, + method + ) + regionIds <- names(inp$gwasSumStats) + fp <- .ctwasFirstPass( + regionIds, + inp$gwasSumStats, + inp$twasWeights, + inp$globalPanelInfo + ) + weightsList <- .ctwasSecondPass( + regionIds, + inp$twasWeights, + inp$method, + fp, + inp$fineMappingResult, + .ctwasPruningCutoffs(variantPruningParam), + unique(list_c(map(fp$zSnpPieces, "id"))) + ) + .ctwasAssembleResult( + regionIds, + fp, + weightsList, + list(twasZ = twasZ, gwasStudy = inp$gwasStudy), + inp$method + ) +} + +# The inputs of assembleCtwasInputs(), checked and resolved in the order a bad +# one should fail: the GWAS split by block with its panel summary, the weights +# placed on those blocks, the fine-mapping source and the weight method. +# @noRd +.ctwasResolveInputs <- function( + gwasSumStats, + twasWeights, + twasZ, + fineMappingResult, + fineMappingMethod, + method +) { .ctwasValidateGwasList(gwasSumStats) globalPanelInfo <- .ctwasGlobalPanelInfo(gwasSumStats) - gwasSumStats <- .ctwasGwasByBlock(gwasSumStats) - twasWeights <- .ctwasResolveAndValidateWeights(twasWeights, gwasSumStats) + # Only a supplied twasZ needs the run's one GWAS study, to pick its rows. + gwasStudy <- if (is.null(twasZ)) { + NA_character_ + } else { + .ctwasGwasStudy(gwasSumStats) + } + byBlock <- .ctwasGwasByBlock(gwasSumStats) + twasWeights <- .ctwasResolveAndValidateWeights(twasWeights, byBlock) .ctwasValidateOptional(twasZ, fineMappingResult) fineMappingResult <- .ctwasRescueSource( fineMappingResult, fineMappingMethod ) - regionIds <- names(gwasSumStats) resolvedMethod <- .ctwasResolveMethod(twasWeights, method) .ctwasCheckFitCoverage( twasWeights, resolvedMethod, "assembleCtwasInputs()" ) - fp <- .ctwasFirstPass( - regionIds, - gwasSumStats, - twasWeights, - globalPanelInfo - ) - weightsList <- .ctwasSecondPass( - regionIds, - twasWeights, - resolvedMethod, - fp, - fineMappingResult, - .ctwasPruningCutoffs(variantPruningParam), - unique(list_c(map(fp$zSnpPieces, "id"))) + list( + gwasSumStats = byBlock, + twasWeights = twasWeights, + globalPanelInfo = globalPanelInfo, + gwasStudy = gwasStudy, + fineMappingResult = fineMappingResult, + method = resolvedMethod ) - .ctwasAssembleResult(regionIds, fp, weightsList, twasZ, resolvedMethod) } # The bundle's terminal: .ctwasBuildWeights and below take scalars, under the @@ -1005,7 +1050,7 @@ assembleCtwasInputs <- function( regionIds, fp, weightsList, - twasZ, + supplied, resolvedMethod ) { # The ctwas engine indexes its input frames POSITIONALLY (`df[, "col"]` must @@ -1024,8 +1069,8 @@ assembleCtwasInputs <- function( ) list( z_snp = zSnp, - z_gene = if (!is.null(twasZ)) { - .ctwasBuildZGene(twasZ) + z_gene = if (!is.null(supplied$twasZ)) { + .ctwasBuildZGene(supplied$twasZ, weightsList, supplied$gwasStudy) } else { .ctwasGeneZ(weightsList, zSnp) }, @@ -1551,7 +1596,7 @@ mergeCtwasBoundaryRegions <- function( # @noRd .ctwasResolveMethod <- function(twasWeights, method = NULL) { sources <- .ctwasWeightSources(twasWeights) - available <- unique(.ctwasConcatChr(map(sources, .ctwasMethodsOf))) + available <- unique(.ctwasConcatChr(map(sources, methodNames))) if (length(available) == 0L) { abort("ctwasPipeline: the weight sources carry no method entries.") } @@ -1620,19 +1665,19 @@ mergeCtwasBoundaryRegions <- function( ) } -# The rows of TwasWeights `tw` fitted by `method` whose stored fit is a SuSiE -# fit, or NULL when it has none. +# The entries of TwasWeights `tw` fitted by `method` whose stored fit is a +# SuSiE fit, or NULL when it has none. # @noRd .ctwasSusieFitRows <- function(tw, method) { - fits <- mcols(tw, use.names = FALSE)$fits - susie <- map_lgl(seq_along(tw), .ctwasRowHasSusieFit, fits = fits) - rows <- which(as.character(tw$method) == method & susie) - if (length(rows) == 0L) NULL else tw[rows] + cells <- .twasCells(tw) + cells <- cells[cells$method == method, ] + susie <- map2_lgl(cells$row, cells$method, .ctwasCellHasSusieFit, x = tw) + if (!any(susie)) NULL else .twasKeepCells(tw, cells[susie, ]) } # @noRd -.ctwasRowHasSusieFit <- function(i, fits) { - .ctwasIsSusieFit(fits[[i]]) +.ctwasCellHasSusieFit <- function(row, method, x) { + .ctwasIsSusieFit(methodFits(.twrCellParts(x, row, method))) } # @noRd @@ -1868,12 +1913,6 @@ mergeCtwasBoundaryRegions <- function( .ctwasBucketWeights(twasWeights, gwasSumStats) } -# Extract the character vector of method names carried by a weight source -# (NULL-safe: a NULL source contributes no methods). -# @noRd -.ctwasMethodsOf <- function(tw) { - if (is.null(tw)) NULL else as.character(tw$method) -} # The single GWAS (disease) study a cTWAS run models. cTWAS solves one disease # per run (the z_snp carries a single z per SNP), so the input blocks must all @@ -2394,19 +2433,22 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasRowsToResult(rows) } -# Subset a TwasWeights collection to rows whose `method` matches the -# resolved method. Used to enforce the "one ctwas gene per (study, -# context, trait)" semantics -- the legacy pipeline fed a single -# best-CV-method weight per gene; the new S4 TwasWeights may carry -# many methods, but ctwas should only see one. +# Cut a weight source to the resolved method, or NULL when it has none of it. +# Used to enforce the "one ctwas gene per (study, context, trait)" semantics +# -- the legacy pipeline fed a single best-CV-method weight per gene; the S4 +# TwasWeights may carry many methods, but ctwas should only see one. A +# TwasWeights is cut along its method axis, a fine-mapping result by row. # @noRd .ctwasFilterMethod <- function(tw, method) { - keep <- which(as.character(tw$method) == method) - if (length(keep) == 0L) { + if (!is_in(method, methodNames(tw))) { return(NULL) } + if (methods::is(tw, "TwasWeights")) { + return(.twasKeepMethods(tw, method)) + } # Row subset carries every column forward (joint* / region / ...); the old # hand-listed rebuild silently dropped them. + keep <- which(as.character(tw$method) == method) methods::initialize(tw[keep, ], ldReference = ldReference(tw)) } @@ -2500,9 +2542,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasBuildSingleRegionInfo <- function(regionId, gss) { # The window is the block's own -- NOT the LD sketch's span. When many # blocks share one whole-chromosome LD payload (the common one-file-per-chr - # layout), snpInfo(ldReference) 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 + # layout), the LD reference's variants span 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). # # Emptiness is checked FIRST: a block with no variants has nothing for @@ -2659,18 +2701,20 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } # `alpha`, not `lbf_variable`: renormalization restricts the stored # per-effect alpha, which already carries the fit's prior. - needed <- c("alpha", "mu", "X_column_scale_factors") + # Not X_column_scale_factors: a stored fit drops them when all are 1. + needed <- c("alpha", "mu") all(is_in(needed, names(fits))) } # Renormalize SuSiE TWAS weights over the kept variant set. When some # variants got dropped by allele harmonization / panel intersection, # the posterior `alpha` values from the original fit no longer sum to -# 1 over the kept variants. We re-softmax `lbf_variable[, keptIdx]` -# into a renormalized alpha, sign-flip the rows of `mu[, keptIdx]` to -# match the panel's allele frame (carrying over the per-variant sign -# flip already applied to `harmonizedW`), and recompute the per-variant -# weight as `colSums(alpha * mu_subset) / X_column_scale_factors_subset`. +# 1 over the kept variants. We restrict each effect's stored `alpha` to +# `keptIdx` and renormalize it (.ctwasRenormAlpha()), sign-flip the columns +# of `mu[, keptIdx]` to match the panel's allele frame (carrying over the +# per-variant sign flip already applied to `harmonizedW`), and recompute the +# per-variant weight as +# `colSums(alpha * mu_subset) / X_column_scale_factors_subset`. # Returns the new weight vector (length = length(keptIdx)), or NULL if # the fit's dimensions don't line up with the entry's variantIds. # @noRd @@ -2681,47 +2725,57 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { keptIdx, harmonizedW ) { - # Fields are READ with `[[`: `$` on a list falls back to prefix matching, - # so `fits$mu` would silently return `mu2` on a fit that has no `mu`. - rawAlpha <- fits[["alpha"]] - mu <- fits[["mu"]] - xCol <- fits[["X_column_scale_factors"]] - if (is.null(rawAlpha) || is.null(mu) || is.null(xCol)) { - return(NULL) - } - # susieInf / susieAsh carry an infinitesimal term: coef.susie is - # colSums(alpha * mu) / scale + theta / scale. Recomputing the weight from - # alpha and mu alone would silently drop theta, changing what the weight - # means. Leave those fits to the plain subset-w-and-R path, which is - # unbiased and only loses power. - if (!is.null(fits[["theta"]]) || !is.null(fits[["omega_weights"]])) { - return(NULL) - } - alpha <- as.matrix(rawAlpha) - if ( - ncol(alpha) != length(origVids) || - ncol(mu) != length(origVids) || - length(xCol) != length(origVids) - ) { - # Fit-vs-entry dimension mismatch -- including a null_weight fit, whose - # alpha carries an extra column. Skip rather than mis-slice. + if (!.ctwasRenormalizable(fits, length(origVids))) { return(NULL) } # Per-variant sign flip applied by allele harmonization. NaN signs # (origW == 0) default to +1. rawSign <- sign(harmonizedW / origW[keptIdx]) signFlip <- replace(rawSign, !is.finite(rawSign), 1) - newAlpha <- .ctwasRenormAlpha(alpha, keptIdx) + newAlpha <- .ctwasRenormAlpha(as.matrix(fits[["alpha"]]), keptIdx) if (is.null(newAlpha)) { return(NULL) } - muSub <- sweep(mu[, keptIdx, drop = FALSE], 2L, signFlip, `*`) - rawScale <- xCol[keptIdx] + muSub <- sweep(fits[["mu"]][, keptIdx, drop = FALSE], 2L, signFlip, `*`) + rawScale <- .fitScaleFactors(fits, length(origVids))[keptIdx] # Guard against zero scale factors (shouldn't happen in practice). xColSub <- replace(rawScale, rawScale == 0, 1) as.numeric(colSums(newAlpha * muSub) / xColSub) } +# Whether a fit's weights can be recomputed from its alpha and mu over a +# subset of its `p` variants. Fields are READ with `[[`: `$` on a list falls +# back to prefix matching, so `fits$mu` would silently return `mu2` on a fit +# that has no `mu`. +# @noRd +.ctwasRenormalizable <- function(fits, p) { + alpha <- fits[["alpha"]] + mu <- fits[["mu"]] + if (is.null(alpha) || is.null(mu)) { + return(FALSE) + } + # susieInf / susieAsh carry an infinitesimal term: coef.susie is + # colSums(alpha * mu) / scale + theta / scale. Recomputing the weight from + # alpha and mu alone would silently drop theta, changing what the weight + # means. Leave those fits to the plain subset-w-and-R path, which is + # unbiased and only loses power. + if (!is.null(fits[["theta"]]) || !is.null(fits[["omega_weights"]])) { + return(FALSE) + } + # An mvSuSiE mu is L x p x R. .ctwasRenormFit() cuts it to the row's own + # condition when the row records its position in the fit; one that + # records none takes that same path. + if (length(dim(mu)) > 2L) { + return(FALSE) + } + # A fit-vs-entry dimension mismatch -- including a null_weight fit, whose + # alpha carries an extra column -- is skipped rather than mis-sliced. + # Absent scale factors are 1s (.fitScaleFactors()), which always fit. + xCol <- fits[["X_column_scale_factors"]] + nScale <- if (is.null(xCol)) p else length(xCol) + all(c(ncol(as.matrix(alpha)), ncol(as.matrix(mu)), nScale) == p) +} + # Restrict each single-effect posterior to `keptIdx` and renormalize. The # stored alpha already carries the fit's prior (alpha is proportional to # pi * BF), so restricting and renormalizing is exact for any prior weights, @@ -2821,7 +2875,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) ) prepared <- compact(map( - seq_len(nrow(twasWeights)), + .ctwasWeightUnits(twasWeights), .ctwasGenePrepared, twasWeights = twasWeights, ctx = ctx @@ -2832,10 +2886,50 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasGeneEntryFor, 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")) - keyed[!duplicated(names(keyed), fromLast = TRUE)] + keys <- map_chr(genes, "key") + .ctwasRequireUniqueGenes(keys) + set_names(map(genes, "entry"), keys) +} + +# One unit per weight vector a source holds: each (row, method) entry of a +# TwasWeights, each row of a fine-mapping result. +# @noRd +.ctwasWeightUnits <- function(x) { + if (methods::is(x, "TwasWeights")) { + cells <- .twasCells(x) + return(map2(cells$row, cells$method, .ctwasUnit)) + } + map2(seq_len(nrow(x)), as.character(x$method), .ctwasUnit) +} + +# @noRd +.ctwasUnit <- function(row, method) { + list(row = row, method = method) +} + +# The payload of one unit: a TwasWeights entry, or a fine-mapping row. +# @noRd +.ctwasUnitParts <- function(x, unit) { + if (methods::is(x, "TwasWeights")) { + return(.twrCellParts(x, unit$row, unit$method)) + } + .collectionEntry(x, unit$row) +} + +# Two weight vectors for one (study, context, trait, method) -- rows that +# differ only in their joint group -- would both be modeled under one gene +# id. Refuse, rather than keep whichever came last. +# @noRd +.ctwasRequireUniqueGenes <- function(keys) { + dup <- unique(keys[duplicated(keys)]) + if (length(dup) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "ctwasPipeline: the weights hold more than one fit of ", + "{str_flatten(dup, ', ')} (rows that differ only in their joint ", + "group). cTWAS models one weight vector per gene, so keep one." + )) } # Panel variant info in the (chrom/pos/A2/A1/variant_id) frame harmonizeAlleles @@ -2851,13 +2945,15 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } -# study/context/trait/method identity for gene row `i` + its collection key. +# study/context/trait/method identity for one unit (.ctwasWeightUnits()) + its +# collection key. # @noRd -.ctwasGeneMeta <- function(twasWeights, i) { +.ctwasGeneMeta <- function(twasWeights, unit) { + i <- unit$row studyName <- as.character(twasWeights$study)[[i]] context <- as.character(twasWeights$context)[[i]] trait <- as.character(twasWeights$trait)[[i]] - method <- as.character(twasWeights$method)[[i]] + method <- unit$method list( study = studyName, context = context, @@ -2876,6 +2972,20 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # @noRd .ctwasAlignGeneWeights <- function(parts, refVariants, panelSnps) { wr <- .rowResolveWeights(parts) + single <- .singleWeightColumn(wr$weights) + if (is.null(single)) { + inform( + str_c( + "ctwasPipeline: weights with several columns (one per ", + "feature or outcome) give no single weight per variant for ", + "cTWAS to model, so those genes are skipped." + ), + .frequency = "once", + .frequency_id = "pecotmrCtwasMatrixWeights" + ) + return(NULL) + } + wr$weights <- single if (length(wr$variantIds) == 0L) { return(NULL) } @@ -2899,12 +3009,77 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } +# The fit a gene's weights are renormalized with: the TWAS row's own, else -- +# a fine-mapping method's rows keep none (.twasRowRetention()) -- that +# method's fit for the gene in `fmr`, the fine-mapping result the run was +# given, cut to the gene's own condition when it is one of a joint fit's +# (.ctwasConditionFit()). A fine-mapping row as the weight source has none +# by design (.rowFits()). +# @noRd +.ctwasRenormFit <- function(parts, fmr, meta) { + own <- .rowFits(parts) + token <- .twasFmTokenFor(meta$method) + if ( + !is.null(own) || is.na(token) || !methods::is(parts, "TwasWeightsRow") + ) { + return(own) + } + if (is.null(fmr)) { + inform( + str_c( + "ctwasPipeline: a fine-mapping method's weights are ", + "renormalized over the variants kept from that method's fit ", + "in `fineMappingResult`; none was given, so they are used ", + "as they are." + ), + .frequency = "once", + .frequency_id = "pecotmrCtwasRenormFit" + ) + return(NULL) + } + idx <- .matchTupleRows( + fmr, + list(study = meta$study, context = meta$context, trait = meta$trait) + ) + fmTokens <- map_chr(as.character(fmr$method)[idx], .twasFmTokenFor) + hit <- idx[is_in(fmTokens, token)] + if (length(hit) == 0L) { + return(NULL) + } + .ctwasConditionFit( + .fmrPartsSusieFit(.fmrRowParts(fmr, hit[[1L]])), + .fmrJointIndexAt(fmr, hit[[1L]]) + ) +} + +# A joint fit cut to one of its conditions: an mvSuSiE mu is L x p x R, and +# the row's position `r` in the fit's condition axis picks its own L x p. A +# fit with no condition axis, or a row recording no position, is kept whole. +# @noRd +.ctwasConditionFit <- function(fit, r) { + mu <- fit[["mu"]] + if (length(dim(mu)) <= 2L || is.na(r)) { + return(fit) + } + d <- dim(mu) + own <- array(mu[,, r], dim = d[1:2], dimnames = dimnames(mu)[1:2]) + list_assign(fit, mu = own) +} + +# Row `i`'s position in its joint fit's condition axis, NA for a row from no +# joint fit (or one that records none). +# @noRd +.fmrJointIndexAt <- function(x, i) { + jointIndex <- mcols(x, use.names = FALSE)$jointIndex + if (is.null(jointIndex)) NA_integer_ else jointIndex[[i]] +} + # Steps 3-4: SuSiE alpha renormalization (when the kept variant set shrank the # fit) and variance scaling for non-standardized weights (w * sqrt(per-variant -# genotype variance from the LD panel)). Returns the adjusted weight vector. +# genotype variance from the LD panel)). `fits` is what .ctwasRenormFit() +# found. Returns the adjusted weight vector. # @noRd -.ctwasAdjustGeneWeights <- function(parts, aligned, spanVariance) { - fits <- .rowFits(parts) +.ctwasAdjustGeneWeights <- function(parts, aligned, spanVariance, fits) { shrank <- length(aligned$keptIdx) < length(aligned$origVids) # A NULL renormalization means the fit could not be re-keyed onto the # kept variants, so the harmonized weights stand as they are. @@ -2998,31 +3173,22 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # (PIP/CS + magnitude + cap) -> entry. Returns list(key, entry), or NULL when # the gene contributes no usable variants. # @noRd -.ctwasGenePrepared <- function(i, twasWeights, ctx) { +.ctwasGenePrepared <- function(unit, twasWeights, ctx) { # Polymorphic: the weight source may be a TwasWeights or a # fine-mapping result, so the payload comes from the class-aware bridge. - parts <- .collectionEntry(twasWeights, i) + parts <- .ctwasUnitParts(twasWeights, unit) aligned <- .ctwasAlignGeneWeights(parts, ctx$refVariants, ctx$panelSnps) if (is.null(aligned)) { return(NULL) } - w <- .ctwasAdjustGeneWeights(parts, aligned, ctx$spanVariance) - meta <- .ctwasGeneMeta(twasWeights, i) - finemapAux <- .ctwasGetFinemapAux( - ctx$fineMappingResult, - meta$study, - meta$context, - meta$trait - ) - kept <- .ctwasFilterVariants( - vids = aligned$vids, - w = w, - finemapAux = finemapAux, - twasWeightCutoff = ctx$cutoffs$twasWeightCutoff, - csMinCor = ctx$cutoffs$csMinCor, - minPipCutoff = ctx$cutoffs$minPipCutoff, - maxNumVariants = ctx$cutoffs$maxNumVariants + meta <- .ctwasGeneMeta(twasWeights, unit) + w <- .ctwasAdjustGeneWeights( + parts, + aligned, + ctx$spanVariance, + .ctwasRenormFit(parts, ctx$fineMappingResult, meta) ) + kept <- .ctwasGeneKept(aligned$vids, w, meta, ctx) if (length(kept) < 1L) { return(NULL) } @@ -3047,6 +3213,28 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } +# The gene's variants `vids` that pass the smart filter -- fine-mapping PIP +# and credible-set membership, weight magnitude, the cap -- with their +# weights (.ctwasFilterVariants()). +# @noRd +.ctwasGeneKept <- function(vids, w, meta, ctx) { + finemapAux <- .ctwasGetFinemapAux( + ctx$fineMappingResult, + meta$study, + meta$context, + meta$trait + ) + .ctwasFilterVariants( + vids = vids, + w = w, + finemapAux = finemapAux, + twasWeightCutoff = ctx$cutoffs$twasWeightCutoff, + csMinCor = ctx$cutoffs$csMinCor, + minPipCutoff = ctx$cutoffs$minPipCutoff, + maxNumVariants = ctx$cutoffs$maxNumVariants + ) +} + # One prepared gene's ctwas entry, given its weight variance w'Rw. # @noRd .ctwasGeneEntryFor <- function(g, wgtVar, spanInfo) { @@ -3150,9 +3338,17 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { "'{id}' have no GWAS z-score." )) } + z <- as.numeric(crossprod(wgt, zs)) / sqrt(entry$wgt_var) + .ctwasZGeneRow(entry, id, z) +} + +# A gene's z_gene row as ctwas reads it: its weight id, its z, and the type, +# context and group its weights carry. +# @noRd +.ctwasZGeneRow <- function(entry, id, z) { tibble( id = id, - z = as.numeric(crossprod(wgt, zs)) / sqrt(entry$wgt_var), + z = z, type = entry$type, context = entry$context, group = str_c(entry$context, "|", entry$type) @@ -3408,29 +3604,101 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { list(vids = vids[keepIdx], w = w[keepIdx]) } -# Build z_gene data.frame from a TWAS-Z GRanges (output of -# causalInferencePipeline). One row per (qtlStudy, context, trait, -# method, gwasStudy) tuple. +# z_gene from a supplied TWAS-Z GRanges (output of causalInferencePipeline): +# each weighted gene's z, from the twasZ row of its (study, context, trait, +# method) for the run's GWAS study, under the gene's weight id with the +# columns ctwas reads (.ctwasZGeneRow()). ctwas keeps only the genes whose +# weight id z_gene names, so a weighted gene with no z is refused rather than +# dropped. Rows for other genes, methods or GWAS studies are not this run's. # @noRd -.ctwasBuildZGene <- function(twasZ) { - mc <- as.data.frame(S4Vectors::mcols(twasZ)) +.ctwasBuildZGene <- function(twasZ, weightsList, gwasStudy) { + if (length(weightsList) == 0L) { + return(NULL) + } + rows <- .ctwasTwasZForStudy( + as_tibble(as.data.frame(S4Vectors::mcols(twasZ))), + gwasStudy + ) + keys <- str_c( + rows$qtlStudy, + "|", + rows$context, + "|", + rows$trait, + "|", + rows$method + ) + geneKeys <- map_chr(unname(weightsList), .ctwasEntryKey) + .ctwasRequireOneZ(names(weightsList), geneKeys, keys) + zs <- as.numeric(rows$twasZ)[match(geneKeys, keys)] # Base data.frame (not tibble): z_gene is indexed positionally by the ctwas # engine (df[, "col"] -> vector); a tibble breaks it. See # .ctwasSnpInfoForBlock. - data.frame( - id = as.character(glue( - "{mc$qtlStudy}|{mc$context}|{mc$trait}|{mc$method}" - )), - z = as.numeric(mc$twasZ), - type = as.character(mc$context), - context = as.character(mc$context), - gene_name = as.character(mc$trait), - study = as.character(mc$qtlStudy), - method = as.character(mc$method), - stringsAsFactors = FALSE + as.data.frame(list_rbind(pmap( + list(weightsList, names(weightsList), zs), + .ctwasZGeneRow + ))) +} + +# A gene's (study, context, trait, method) key, as twasZ identifies it. +# @noRd +.ctwasEntryKey <- function(entry) { + str_c( + entry$study, + "|", + entry$context, + "|", + entry$gene_name, + "|", + entry$method ) } +# The twasZ rows for GWAS study `gwasStudy`. One with no gwasStudy column, or +# a run whose GWAS names no study but whose twasZ holds just one, is used +# whole. +# @noRd +#' @importFrom rlang .env +.ctwasTwasZForStudy <- function(rows, gwasStudy) { + if (!is_in("gwasStudy", names(rows))) { + return(rows) + } + studies <- unique(as.character(rows$gwasStudy)) + if (is.na(gwasStudy) && length(studies) > 1L) { + abort(glue( + "assembleCtwasInputs: `twasZ` holds several GWAS studies ", + "({str_flatten(studies, ', ')}) and `gwasSumStats` names none, ", + "so which z-scores apply is ambiguous." + )) + } + if (is.na(gwasStudy)) { + return(rows) + } + filter(rows, .data$gwasStudy == .env$gwasStudy) +} + +# Every weighted gene must have exactly one twasZ z. +# @noRd +.ctwasRequireOneZ <- function(ids, geneKeys, keys) { + missing <- ids[!is_in(geneKeys, keys)] + if (length(missing) > 0L) { + abort(glue( + "assembleCtwasInputs: `twasZ` has no z-score for ", + "{length(missing)} weighted gene(s), e.g. ", + "{str_flatten(utils::head(missing, 3L), ', ')}. ctwas would drop ", + "them; supply their TWAS z-scores or leave `twasZ` NULL." + )) + } + repeated <- unique(keys[duplicated(keys) & is_in(keys, geneKeys)]) + if (length(repeated) > 0L) { + abort(glue( + "assembleCtwasInputs: `twasZ` has more than one z-score for ", + "{str_flatten(utils::head(repeated, 3L), ', ')}." + )) + } + invisible(NULL) +} + # A cTWAS payload's `LD_file` token does double duty: ctwas asserts the file # exists, and pecotmr dispatches on the same string into the cached per-region # LD panels. Each token is a sentinel in the session's tempdir @@ -3520,9 +3788,16 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # cache travels on the function object itself, as its `ldPanelsByRegion` # attribute: .ctwasLoadRegionLd() reads it back through sys.function(), and # .ctwasCachedPanels() reads the same attribute, so the cache has one home. +# The function goes without its source references: a payload is saved, and +# a function loaded with them would carry its whole source file along. # @noRd +#' @importFrom utils removeSource .ctwasMultiBlockLdLoader <- function(ldPanelsByRegion) { - `attr<-`(.ctwasLoadRegionLd, "ldPanelsByRegion", ldPanelsByRegion) + `attr<-`( + removeSource(.ctwasLoadRegionLd), + "ldPanelsByRegion", + ldPanelsByRegion + ) } # The LD loader ctwas calls: region `LD_file`'s full LD, from the panel cache @@ -3535,10 +3810,22 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasPanelLd(.ctwasLoaderPanel(sys.function(), LD_file, "LD loader")) } -# Multi-block SNP-info loader for ctwas. Mirrors the LD loader. +# Multi-block SNP-info loader for ctwas. Mirrors the LD loader, but carries +# only each panel's snpInfo: a saved payload would otherwise hold every +# region's LD twice, once on each loader. # @noRd .ctwasMultiBlockSnpInfoLoader <- function(ldPanelsByRegion) { - `attr<-`(.ctwasLoadRegionSnpInfo, "ldPanelsByRegion", ldPanelsByRegion) + `attr<-`( + removeSource(.ctwasLoadRegionSnpInfo), + "ldPanelsByRegion", + map(ldPanelsByRegion, .ctwasSnpInfoPanel) + ) +} + +# The part of a cached panel the SNP-info loader reads. +# @noRd +.ctwasSnpInfoPanel <- function(panel) { + list(snpInfo = panel$snpInfo) } # The snpInfo loader ctwas calls, reading the same attribute. diff --git a/R/exampleData.R b/R/exampleData.R index 352dd2ec3..890648f6f 100644 --- a/R/exampleData.R +++ b/R/exampleData.R @@ -443,10 +443,10 @@ NULL #' Derived from the de-identified \code{protocol_example} toy data #' (gene ENSG00000130538, chr22); all identifiers are synthetic. #' -#' @format A \code{TwasWeights} collection with 11 rows (one per method: -#' \code{mrash}, \code{susie}, \code{susie_inf}, \code{enet}, \code{lasso}, -#' \code{mcp}, \code{scad}, \code{l0learn}, \code{bayes_r}, \code{bayes_c}, -#' \code{ensemble}). +#' @format A \code{TwasWeights} collection with one row, the gene, holding +#' 11 methods: \code{mrash}, \code{susie}, \code{susieInf}, \code{enet}, +#' \code{lasso}, \code{mcp}, \code{scad}, \code{l0learn}, \code{bayesR}, +#' \code{bayesC} and \code{ensemble}. #' #' @keywords data #' @@ -738,15 +738,17 @@ NULL #' #' @docType data #' -#' @description A small synthetic \code{H2Estimate} (the output of -#' \code{\link{estimateH2}}) carrying the SNP heritability, intercept, and a -#' per-annotation enrichment table. Intended for the \code{H2Estimate} -#' accessors and \code{\link{h2EstimateToSldscTrait}}. All identifiers are -#' synthetic. -#' -#' @format An \code{H2Estimate} object with \code{h2}, \code{h2Se}, -#' \code{intercept}, an \code{enrichment} data frame, and -#' \code{annotationJackknifeCoefs}. +#' @description A stratified g-LDSC estimate from \code{\link{estimateH2}}, +#' on \code{\link{ldScoreExample}}, of a GWAS simulated on that reference's +#' LD with one baseline annotation carrying three times the per-variant +#' heritability of the rest, and one candidate annotation scored against the +#' fit. Intended for the \code{H2Estimate} accessors and +#' \code{\link{h2EstimateToSldscTrait}}. Built by +#' \code{inst/scripts/build_h2_estimate_example.R}. +#' +#' @format An \code{H2Estimate} holding one estimate (study \code{trait1}, +#' method \code{gldsc}), which carries an enrichment table, the annotation +#' jackknife matrix and a candidate's score statistics. #' @keywords data #' #' @examples diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index cf792b0bb..386ea105a 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -586,7 +586,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { maxNumSingleEffects, maxNumSingleEffectsGreedy ) { - seeded <- intersect(tokens, c("susie", "susieInf", "susieAsh")) + seeded <- intersect(tokens, c("susie", "susieInf", "susieAsh", "mvsusie")) if (length(seeded) == 0L) { return(methodArgs) } @@ -1712,33 +1712,34 @@ combineFineMappingResults <- function(..., ldReference = NULL) { list(xRegions = .makeXRegions(region, jointRegions)) } -# 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". +# The mr.mash entries (rows of .twasCells()) of a TwasWeights whose identity +# matches every axis the caller FIXED. A NULL axis means "do not filter on +# it". # @noRd -.fmMrmashSelector <- function(mrmashPrior, studyName, trait, context) { +.fmMrmashCells <- function(mrmashPrior, studyName, trait, context) { + cells <- .twasCells(mrmashPrior) axes <- compact(list(study = studyName, trait = trait, context = context)) - reduce( + sel <- reduce( names(axes), .fmMrmashNarrow, - mrmashPrior = mrmashPrior, + cells = cells, axes = axes, - .init = as.character(mrmashPrior$method) == "mrmash" + .init = cells$method == "mrmash" ) + cells[sel, ] } -# `.tupleColumn()` not `[[`: on a RangedTupleList `[[` extracts an ELEMENT -# (the variant set), while the identity axes live in mcols. # @noRd -.fmMrmashNarrow <- function(sel, axis, mrmashPrior, axes) { - sel & as.character(.tupleColumn(mrmashPrior, axis)) == axes[[axis]] +.fmMrmashNarrow <- function(sel, axis, cells, axes) { + sel & is_in(cells[[axis]], axes[[axis]]) } # Locate the retained mr.mash fit payload {dataDrivenPriorMatrices, w0, V} for # one (study, trait[, context]) inside a `TwasWeights` collection from a prior # mr.mash twasWeightsPipeline run (the producer side of the mvSuSiE data-driven -# prior). The joint fit is attached to a single mrmash row of the group (the -# other rows carry fits = NULL), so scan the matching mrmash rows and return the -# first non-NULL payload. The fit may span more conditions than the mvsusie +# prior). Every mrmash row of the group keys the one joint fit, so the first +# matching row with a fit has it; a row kept without one (fitRetention = +# "none") is passed over. The fit may span more conditions than the mvsusie # block fits -- `.buildMvsusieReweightedPrior(include_indices=)` subsets it. # # Each axis is optional: a NULL axis is NOT filtered (match-any). A joint fit is @@ -1761,9 +1762,9 @@ combineFineMappingResults <- function(..., ldReference = 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, studyName, trait, context) - for (i in which(sel)) { - f <- methodFits(.twrRowParts(mrmashPrior, i)) + cells <- .fmMrmashCells(mrmashPrior, studyName, trait, context) + for (row in cells$row) { + f <- methodFits(.twrCellParts(mrmashPrior, row, "mrmash")) if (!is.null(f)) return(f) } NULL @@ -1785,9 +1786,9 @@ combineFineMappingResults <- function(..., ldReference = NULL) { if (is.null(mrmashPrior)) { return(NULL) } - sel <- .fmMrmashSelector(mrmashPrior, studyName, trait, context) - for (i in which(sel)) { - cv <- cvResult(.twrRowParts(mrmashPrior, i)) + cells <- .fmMrmashCells(mrmashPrior, studyName, trait, context) + for (row in cells$row) { + cv <- cvResult(.twrCellParts(mrmashPrior, row, "mrmash")) if (!is.null(cv) && !is.null(cv$foldFits)) return(cv) } NULL @@ -2068,19 +2069,34 @@ combineFineMappingResults <- function(..., ldReference = NULL) { isFormal <- is_in(names(args), setdiff(fm, "methodArgs")) c( args[isFormal], - list(methodArgs = .methodConfigLike(target, args[!isFormal])) + list( + methodArgs = .methodConfigLike( + target, + args[!isFormal], + fn, + args$backend + ) + ) ) } # Wrap the remainder in the record the target's `methodArgs` expects, so a # target that demands a constructor gets one rather than the bare list it # would refuse. The constructor is read off the target's own default -- -# `methodArgs = MvsusieOptions()` names it, as every target's default does -- -# so this needs no registry and cannot drift from the signature. +# `methodArgs = MvsusieOptions()` names it, as nearly every target's default +# does -- so this needs no registry and cannot drift from the signature. A +# target that runs on several engines (the Bayesian alphabet) defaults it to +# NULL instead, and takes the constructor of `backend` (or of its default +# backend) from the TWAS registry. # @noRd -.methodConfigLike <- function(target, extra) { +.methodConfigLike <- function(target, extra, fn = NULL, backend = NULL) { d <- formals(target)$methodArgs - exec(match.fun(as.character(d[[1L]])), !!!extra) + ctor <- if (is.call(d)) { + as.character(d[[1L]]) + } else { + .twasImplCtorName(fn, backend) + } + exec(match.fun(ctor), !!!extra) } # Merge per-method user kwargs onto a base arg list. `userArgs` is the @@ -2206,28 +2222,6 @@ combineFineMappingResults <- function(..., ldReference = NULL) { NULL } -# The minimal fold-fit payload: exactly the fields the weight extractors -# read, so K folds x (study, context, trait) does not retain K full SuSiE fits. -# `trimFinemappingFit()` is the credible-set-driven trimmer for the fit stored -# on a row; a fold fit has no credible sets to key on and is only ever used to -# re-extract weights, so it keeps a smaller set. -# @noRd -.fmLeanFoldFit <- function(fit, token) { - if (is.null(fit)) { - return(NULL) - } - keep <- c( - "pip", - "alpha", - "mu", - "X_column_scale_factors", - "theta", - "coef", - "V" - ) - lean <- fit[intersect(keep, names(fit))] - `class<-`(lean, unique(c(token, class(fit)))) -} # Per-fold univariate-susie-family weights (susie / susieInf / susieAsh). # @noRd @@ -2246,8 +2240,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { susieInf = susieInfWeights(susieInfFit = fit), susieAsh = susieAshWeights(susieAshFit = fit) ) - out <- .fmAsMat(set_names(as.numeric(w), colnames(Xtr))) - `attr<-`(out, "fit", .fmLeanFoldFit(fit, token)) + .fmAsMat(set_names(as.numeric(w), colnames(Xtr))) } # Per-fold fsusie weights. @@ -2260,13 +2253,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { userArgs ) fit <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fsArgs)) - W <- fsusieWeights(fsusieFit = fit, variantIds = colnames(Xtr)) - out <- as.matrix(W) - # fSuSiE cannot be re-extracted from a trimmed fit, so the precomputed - # weight matrix rides along as `coef` the same way the row-level trimmer - # does it. - withCoef <- list_assign(fit, coef = out) - `attr<-`(out, "fit", .fmLeanFoldFit(withCoef, "fsusie")) + as.matrix(fsusieWeights(fsusieFit = fit, variantIds = colnames(Xtr))) } # Per-fold fine-mapping fit for the CV engine. `ctx` carries mvPrior, mvPriorCv, @@ -2303,16 +2290,11 @@ combineFineMappingResults <- function(..., ldReference = NULL) { j = j, verbose = verbose ) - list( - weights = set_names(map(results, "weights"), keys), - fits = compact(set_names(map(results, "fit"), keys)) - ) + # Weights only: the fold's fit is never read (.fmCvResult()). + list(weights = set_names(results, keys), fits = list()) } -# One token's fold result. The CV engine's fitFold contract is -# list(weights = matrix>, fits = fitted model>); the fold -# helpers attach their (lean) fit to the weight matrix, so it is split back -# out here rather than stripped in place. +# One token's fold weights (variants x outcomes), or NULL when its fit failed. # @noRd .fmFoldTokenResult <- function( tk, @@ -2325,7 +2307,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { j, verbose ) { - w <- try_fetch( + try_fetch( .fmFoldWeights( tk, Xtr, @@ -2347,13 +2329,6 @@ combineFineMappingResults <- function(..., ldReference = NULL) { NULL } ) - if (is.null(w)) { - return(list(weights = NULL, fit = NULL)) - } - list( - weights = `attr<-`(w, "fit", NULL), - fit = attr(w, "fit") - ) } # Cross-validate a homogeneous set of fine-mapping `tokens` over (X, Y) via the @@ -2405,30 +2380,24 @@ combineFineMappingResults <- function(..., ldReference = NULL) { BPPARAM = BPPARAM, verbose = verbose, seed = seed, - # Retained so twasWeightsCv can cross-validate a SuSiE-family method: - # those wrappers extract from a supplied fit and never refit, so the - # fold's own fit is the only thing that makes per-fold extraction - # possible. - fitRetention = "slim" + keepFoldWeights = TRUE ) - .fmCvResult(res) + .fmCvResult(res, colnames(X)) } -# The cross-validation result, with the sample partition recorded on the -# fold fits. Recorded at the producer so a consumer can refuse fits trained -# on a different split; without it a mismatched partition would leak -# held-out samples into training and inflate the CV metrics. +# The cross-validation result: each fold's weights rather than its fit, +# since a SuSiE-family method is cross-validated from the weights its fold +# fit gave and nothing reads the fit itself. `variantIds` are the variants +# the folds were fit over -- the row's own -- which the per-method slice +# aligns every fold's weights to. # @noRd -.fmCvResult <- function(res) { +.fmCvResult <- function(res, variantIds) { list( samplePartition = res$samplePartition, prediction = res$prediction, performance = res$performance, - foldFits = `attr<-`( - res$foldFits, - "partitionKey", - .cvPartitionKey(res$samplePartition) - ) + foldWeights = res$foldWeights, + variantIds = variantIds ) } @@ -2449,21 +2418,36 @@ combineFineMappingResults <- function(..., ldReference = NULL) { samplePartition = cv$samplePartition, prediction = cv$prediction[pk], performance = cv$performance[mk], - foldFits = .fmSliceFoldFits(cv$foldFits, key) + foldWeights = .fmSliceFoldWeights(cv, key) ) } -# One method's per-fold fits, keyed by fold, from the full CV payload. +# One method's fold weights: a variants x folds matrix on the variants the +# folds were fit over, zero where a fold had no weight for a variant and NA +# throughout for a fold whose fit failed, with the fingerprint of the +# partition the folds were drawn from, so a consumer can refuse weights +# trained on a different split. The row they are attached to drops the ids +# when they are its own (.cvStoredFoldWeights()). # @noRd -.fmSliceFoldFits <- function(foldFits, key) { - if (is.null(foldFits) || length(foldFits) == 0L) { +.fmSliceFoldWeights <- function(cv, key) { + fw <- cv$foldWeights + if (length(fw) == 0L) { return(NULL) } - out <- map(foldFits, key) - if (all(map_lgl(out, is.null))) { - return(NULL) + cols <- map(fw, .fmFoldWeightColumn, key = key, variantIds = cv$variantIds) + W <- `dimnames<-`(exec(cbind, !!!cols), list(cv$variantIds, names(fw))) + `attr<-`(W, "partitionKey", .cvPartitionKey(cv$samplePartition)) +} + +# One fold's weights for method `key`, on `variantIds`. +# @noRd +.fmFoldWeightColumn <- function(fold, key, variantIds) { + w <- fold[[key]] + if (is.null(w)) { + return(rep(NA_real_, length(variantIds))) } - `attr<-`(out, "partitionKey", attr(foldFits, "partitionKey")) + hit <- match(rownames(w), variantIds) + replace(numeric(length(variantIds)), hit[!is.na(hit)], w[!is.na(hit), 1L]) } # Rebuild a FineMappingRow with a cvResult attached (the class is immutable). @@ -2677,81 +2661,93 @@ combineFineMappingResults <- function(..., ldReference = NULL) { c(cachedRows, computed) } -# Fit one PCA X window for (ctx, pcName): residualize genotype, align to the -# PC scores, SER pre-screen, then univariate-susie .fmFitXBlock. Returns -# list() when too few shared samples or the window screens out (soft skip). +# One window's fits for every top PC of a context, as pcName -> block entry +# (list() for a PC whose block is skipped). The window's genotype block is the +# same for each PC -- they differ only in the response -- so it is built, and +# its allele frequencies read, once rather than once per PC. # @noRd -.fmPcaBlockFit <- function(rg, ctx, traits, pcName, pcY, samples, cfg) { +.fmPcaRegionFits <- function(rg, ctx, traits, scores, cfg) { + pcNames <- colnames(scores) + skipped <- set_names(rep(list(list()), length(pcNames)), pcNames) X <- .fmResidGenoBlock( ctx, traits, rg, - samples, + rownames(scores), data = cfg$data, cisWindow = cfg$cisWindow, residualizationParam = cfg$residualizationParam, genotypeFilter = cfg$genotypeFilter ) - common <- intersect(rownames(X), names(pcY)) + common <- intersect(rownames(X), rownames(scores)) if (length(common) < 2L) { - return(list()) + return(skipped) } Xb <- X[common, , drop = FALSE] - if (!.fmSerScreen(Xb, pcY[common], cfg$screen)) { - return(list()) - } - afVec <- .fmAfForX( - cfg$data, - Xb, - genotypeFilter = cfg$genotypeFilter, - traitId = traits, - region = rg, - cisWindow = cfg$cisWindow + shared <- scores[common, , drop = FALSE] + pass <- map_lgl(pcNames, .fmPcaPassesScreen, Xb = Xb, scores = shared, cfg) + if (!any(pass)) { + return(skipped) + } + blk <- list( + X = Xb, + af = .fmAfForX( + cfg$data, + Xb, + genotypeFilter = cfg$genotypeFilter, + traitId = traits, + region = rg, + cisWindow = cfg$cisWindow + ), + window = .fmBlockWindow(rg, ctx, traits, cfg) ) - # The PC path never chains susieInf: a PC is not a trait whose fit the - # susieInf stage is defined for. + fits <- map(pcNames[pass], .fmPcaBlockFit, blk, shared, ctx, cfg) + list_assign(skipped, !!!set_names(fits, pcNames[pass])) +} + +# Whether one PC's response clears the SER pre-screen on a window's block. +# @noRd +.fmPcaPassesScreen <- function(pcName, Xb, scores, cfg) { + .fmSerScreen(Xb, scores[, pcName], cfg$screen) +} + +# One PC's univariate-susie fit on a window's shared block. The PC path never +# chains susieInf: a PC is not a trait whose fit the susieInf stage is defined +# for. +# @noRd +.fmPcaBlockFit <- function(pcName, blk, scores, ctx, cfg) { .fmFitXBlockP( - Xb, - pcY[common], + blk$X, + scores[, pcName], "susie", FALSE, ctx, pcName, - afVec, + blk$af, cfg, - region = .fmBlockWindow(rg, ctx, traits, cfg) + region = blk$window ) } -# Row-records for one PC pseudo-trait: a cache hit, else per-window fits merged -# into the single "susie" token (trait = the PC name). +# Row-records for one PC pseudo-trait: its cached row, else its per-window +# fits merged into the single "susie" token (trait = the PC name). # @noRd -.fmPcaScoreRows <- function(pcName, ctx, traits, scores, cfg) { - cached <- .fmCacheLookup( - cfg$fineMappingResult, - cfg$study, - ctx, - pcName, - "susie" - ) - if (!is.null(cached)) { - return(list(.fmQtlRow(cfg$study, ctx, pcName, "susie", cached))) +.fmPcaPcRows <- function(pcName, ctx, cached, perRegion, cfg) { + if (!is.null(cached[[pcName]])) { + return(list( + .fmQtlRow(cfg$study, ctx, pcName, "susie", cached[[pcName]]) + )) } - pcY <- scores[, pcName] - samples <- rownames(scores) - blockEntries <- map( - cfg$xRegions, - .fmPcaBlockFit, - ctx = ctx, - traits = traits, - pcName = pcName, - pcY = pcY, - samples = samples, - cfg = cfg - ) + blockEntries <- map(perRegion, pluck, pcName, .default = list()) .fmMergeTokenRows(cfg$study, ctx, pcName, "susie", blockEntries) } +# One PC's entry in the resume cache, or NULL. +# @noRd +.fmPcaCacheLookup <- function(pcName, ctx, cfg) { + .fmCacheLookup(cfg$fineMappingResult, cfg$study, ctx, pcName, "susie") +} + # All usePCA row-records for one context: PCA-reduce the multi-trait phenotype # and fine-map each top PC. A single-trait context (or one with no usable PC # scores) contributes nothing. @@ -2780,12 +2776,39 @@ combineFineMappingResults <- function(..., ldReference = NULL) { "({nTr} traits) ..." )) } + .fmPcaRows(ctx, traits, scores, cfg) +} + +# A context's top-PC rows: a PC in the resume cache as cached, the rest fit +# window by window. +# @noRd +.fmPcaRows <- function(ctx, traits, scores, cfg) { + pcNames <- colnames(scores) + cached <- set_names( + map(pcNames, .fmPcaCacheLookup, ctx = ctx, cfg = cfg), + pcNames + ) + toFit <- pcNames[map_lgl(cached, is.null)] + # Windows outermost, so each window's block is built once for all the + # PCs and released before the next window's. + perRegion <- if (length(toFit) == 0L) { + list() + } else { + map( + cfg$xRegions, + .fmPcaRegionFits, + ctx = ctx, + traits = traits, + scores = scores[, toFit, drop = FALSE], + cfg = cfg + ) + } list_flatten(map( - colnames(scores), - .fmPcaScoreRows, + pcNames, + .fmPcaPcRows, ctx = ctx, - traits = traits, - scores = scores, + cached = cached, + perRegion = perRegion, cfg = cfg )) } @@ -3813,7 +3836,7 @@ setMethod( rep(fromData, 4L), c("Z", "R", "N", "prior_variance") ), - csHome["coverage"] + csHome ), "fsusieR::susiF" = c( set_names(rep(fromData, 3L), c("X", "Y", "pos")), diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index 9db22ccaa..1bddd5232 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -141,7 +141,7 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { "FineMappingRow", variants = cs$variants, susieFit = susieFit, - cvResult = cvResult, + cvResult = .cvStoredFoldWeights(cvResult, .grVariantIds(bare)), derivedColumns = cs$derived ) } @@ -875,24 +875,16 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # The per-effect single-effect log Bayes factor: log of the average (over the # flat prior) of the effect's per-variant Bayes factors, i.e. # logSumExp(lbf_variable[L, ]) - log(p). This is the principled per-CS evidence, -# unlike the max-member per-variant logBF. NA when the fit carries no lbf -# matrix. -.csEffectLogBf <- function(fit, Lidx) { +# unlike the max-member per-variant logBF. `effRow` is the effect's row of +# lbf_variable. NA when the fit carries no lbf matrix. +.csEffectLogBf <- function(fit, effRow) { lbf <- fit$lbf_variable - if (is.null(lbf) || !is.matrix(lbf) || is.na(Lidx)) { - return(NA_real_) - } - row <- if (.namedByEffect(lbf)) { - match(str_c("L", Lidx), rownames(lbf)) - } else if (Lidx <= nrow(lbf)) { - Lidx - } else { - NA_integer_ - } - if (is.na(row)) { + if ( + is.null(lbf) || !is.matrix(lbf) || is.na(effRow) || effRow > nrow(lbf) + ) { return(NA_real_) } - lv <- keep(as.numeric(lbf[row, ]), is.finite) + lv <- keep(as.numeric(lbf[effRow, ]), is.finite) if (length(lv) == 0L) { return(NA_real_) } @@ -1090,6 +1082,8 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { } Lidx <- spec$eff Lname <- if (!is.na(Lidx)) str_c("L", Lidx) else NA_character_ + # The effect's row in the fit's arrays, which a trimmed fit has compacted. + effRow <- .fitEffectRows(ctx$fit, Lidx) lead <- which.max(m$pip) tibble( cs = spec$lab, @@ -1100,11 +1094,11 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { n_variants = length(spec$ids), purity_min = .csPurityMin(m, ctx$purCol), purity_mean = .csPurityMean(ctx$meanPur, Lname), - V = .csEffectV(ctx$Vvec, Lidx), + V = .csEffectV(ctx$Vvec, effRow), # cs_log10bf: the strongest MEMBER variant's logBF (max over the CS). cs_log10bf = .csLog10Bf(m), # cs_log_bf: the true per-EFFECT single-effect log Bayes factor. - cs_log_bf = .csEffectLogBf(ctx$fit, Lidx), + cs_log_bf = .csEffectLogBf(ctx$fit, effRow), # cs_pip: total posterior inclusion mass captured by the CS. cs_pip = suppressWarnings(sum(as.numeric(m$pip), na.rm = TRUE)), # cs_mean_effect: mean effect over the CS members CONDITIONAL on the @@ -1131,18 +1125,15 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { } } -# V: the effect's prior variance (NA when out of range / unavailable). +# V: the prior variance at the effect's row `effRow` (NA when out of range / +# unavailable). # @noRd -.csEffectV <- function(Vvec, Lidx) { - if (is.null(Vvec) || is.na(Lidx)) { - return(NA_real_) - } - # A trimmed fit keeps only its effects of positive prior variance, named - # by effect id, so V[k] would be some other effect's; read it by name. - if (.namedByEffect(Vvec)) { - return(unname(as.numeric(Vvec[str_c("L", Lidx)]))) +.csEffectV <- function(Vvec, effRow) { + if (!is.null(Vvec) && !is.na(effRow) && effRow <= length(Vvec)) { + as.numeric(Vvec[[effRow]]) + } else { + NA_real_ } - if (Lidx <= length(Vvec)) Vvec[Lidx] else NA_real_ } # TRUE when a per-effect vector or matrix rows carry "L" effect ids. @@ -1575,7 +1566,8 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { .adjustPipsCsAtCoverage( varAlpha, fit[["V"]], - .adjustPipsCoverage(fit[["sets"]]) + .adjustPipsCoverage(fit[["sets"]]), + .fitEffectIndex(fit, nrow(varAlpha)) ) }, sets_secondary = if (!is.null(fit[["sets_secondary"]])) { @@ -1583,7 +1575,8 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { fit[["sets_secondary"]], .adjustPipsRebuildSecondary, varAlpha = varAlpha, - V = fit[["V"]] + V = fit[["V"]], + effectIndex = .fitEffectIndex(fit, nrow(varAlpha)) ) } )) @@ -1592,7 +1585,7 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # Rebuild one secondary-coverage credible-set table at its own coverage. # @noRd -.adjustPipsRebuildSecondary <- function(entry, varAlpha, V) { +.adjustPipsRebuildSecondary <- function(entry, varAlpha, V, effectIndex) { if (is.null(entry$sets)) { return(entry) } @@ -1601,7 +1594,8 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { sets = .adjustPipsCsAtCoverage( varAlpha, V, - .adjustPipsCoverage(entry$sets) + .adjustPipsCoverage(entry$sets), + effectIndex ) ) } @@ -1623,16 +1617,24 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # Smallest-prefix credible sets from a renormalized alpha, in susie_get_cs's # shape. Effects at or below `priorTol` prior variance are skipped, matching # susie_get_cs's own V filter; purity is left NULL (no LD available here). -# @noRd -.adjustPipsCsAtCoverage <- function(varAlpha, V, coverage, priorTol = 1e-9) { +# Each set is named for its effect's own index (`effectIndex`, by row of +# varAlpha), which a trimmed fit no longer numbers by row. +# @noRd +.adjustPipsCsAtCoverage <- function( + varAlpha, + V, + coverage, + effectIndex = seq_len(nrow(varAlpha)), + priorTol = 1e-9 +) { idx <- if (is.null(V)) seq_len(nrow(varAlpha)) else which(V > priorTol) cs <- set_names( map(idx, .adjustPipsOneCs, varAlpha = varAlpha, coverage = coverage), - str_c("L", idx) + str_c("L", effectIndex[idx]) ) list( cs = cs, - cs_index = as.integer(idx), + cs_index = as.integer(effectIndex[idx]), coverage = map_dbl( seq_along(idx), .adjustPipsCsMass, @@ -1725,7 +1727,14 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # @noRd .adjustPipsRelabelColumn <- function(csCol, varAlpha, fit, label, nRow) { - .adjustPipsCsLabels(varAlpha, fit[["V"]], csCol, label, nRow) + .adjustPipsCsLabels( + varAlpha, + fit[["V"]], + csCol, + label, + nRow, + .fitEffectIndex(fit, nrow(varAlpha)) + ) } # @noRd @@ -1736,9 +1745,9 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # Membership labels at the coverage encoded in the column name: "_" # for members of effect k, "_0" for variants in no credible set. # @noRd -.adjustPipsCsLabels <- function(varAlpha, V, csCol, label, n) { +.adjustPipsCsLabels <- function(varAlpha, V, csCol, label, n, effectIndex) { coverage <- as.numeric(str_remove(csCol, "^cs_")) / 100 - sets <- .adjustPipsCsAtCoverage(varAlpha, V, coverage) + sets <- .adjustPipsCsAtCoverage(varAlpha, V, coverage, effectIndex) if (length(sets$cs) == 0L) { return(rep(str_c(label, "_0"), n)) } @@ -1793,7 +1802,10 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { ) { return(newTopLoci) } - posteriorMean <- as.numeric(colSums(alphaMat * muMat)) + # Back on the scale buildTopLoci() reports, as mu and mu2 are stored in + # the units of the standardized X. + scaleFactors <- .fitScaleFactors(fit, ncol(alphaMat)) + posteriorMean <- as.numeric(colSums(alphaMat * muMat) / scaleFactors) mu2Mat <- if (!is.null(fit[["mu2"]])) as.matrix(fit[["mu2"]]) else NULL mutate( newTopLoci, @@ -1802,10 +1814,9 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { posterior_sd = if ( !is.null(mu2Mat) && all(dim(alphaMat) == dim(mu2Mat)) ) { - as.numeric(sqrt(pmax( - colSums(alphaMat * mu2Mat) - posteriorMean^2, - 0 - ))) + as.numeric( + .susiePosteriorSd(alphaMat, muMat, mu2Mat) / scaleFactors + ) } )) ) @@ -1999,13 +2010,14 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { .fmeIdentityCols <- c("variant_id", "chrom", "pos", "A1", "A2") # Rebuild the canonical topLoci table from an element: the identity columns are -# re-rendered from the range and alleles, the rest come straight from mcols. +# re-rendered from the range and alleles, the rest come from mcols as the row +# holds them (.fmPlainElement()). # @noRd .fmeTopLociFromElement <- function(gr) { if (length(gr) == 0L) { return(as_tibble(list(variant_id = character(0), pip = numeric(0)))) } - mc <- as.list(mcols(gr)) + mc <- as.list(mcols(.fmPlainElement(gr))) identity <- list( variant_id = .grVariantIds(gr), chrom = as.character(seqnames(gr)), @@ -2014,6 +2026,85 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { as_tibble(c(identity, mc), .name_repair = "minimal") } +# ============================================================================= +# topLoci in a collection +# ----------------------------------------------------------------------------- +# A fine-mapping collection stores topLoci compactly: marginal_p is left out +# where it is the 2 * pnorm(-|z|) that .btlMarginal() derives when the source +# gave none, and every payload column is run-length encoded where that is +# smaller (.rtlRleWhereSmaller()). The rows it hands out get plain columns and +# marginal_p back (.fmPlainElement()), so topLoci() reads the same either way. +# ============================================================================= + +# The marginal p-value of z, as .btlMarginal() derives it. +# @noRd +.fmDerivedP <- function(z) { + 2 * stats::pnorm(-abs(z)) +} + +# A fine-mapping collection's elements as it stores them. +# @noRd +.fmrCompactTopLoci <- function(grl) { + flat <- unlist(grl, use.names = FALSE) + md <- .fmDropDerivedP(mcols(flat, use.names = FALSE)) + compact <- .rtlRleWhereSmaller(md, setdiff(colnames(md), .fmeIdentityCols)) + bare <- IRanges::relist( + S4Vectors::`mcols<-`(flat, value = compact), + IRanges::PartitioningByEnd(cumsum(lengths(grl)), names = names(grl)) + ) + S4Vectors::`mcols<-`(bare, value = mcols(grl, use.names = FALSE)) +} + +# `md` without marginal_p when every value is the one marginal_z gives and +# the column sits where .fmPlainElement() puts it back. +# @noRd +.fmDropDerivedP <- function(md) { + cn <- colnames(md) + at <- .fmDerivedPPosition(setdiff(cn, "marginal_p")) + if (is.na(at) || !identical(match("marginal_p", cn), at)) { + return(md) + } + p <- as.vector(md[["marginal_p"]]) + if (!identical(p, .fmDerivedP(as.vector(md[["marginal_z"]])))) { + return(md) + } + md[, cn != "marginal_p", drop = FALSE] +} + +# Where marginal_p goes among columns `cn` that lack it: after +# marginal_z_supplied, else after marginal_z; NA without marginal_z. +# @noRd +.fmDerivedPPosition <- function(cn) { + if (!is_in("marginal_z", cn)) { + return(NA_integer_) + } + anchor <- if (is_in("marginal_z_supplied", cn)) { + "marginal_z_supplied" + } else { + "marginal_z" + } + match(anchor, cn) + 1L +} + +# `gr` as a row holds it: plain metadata columns, and marginal_p back where +# its collection left it out. +# @noRd +.fmPlainElement <- function(gr) { + plain <- .rtlPlainMcols(gr) + md <- mcols(plain, use.names = FALSE) + at <- .fmDerivedPPosition(colnames(md)) + if (is.na(at) || is_in("marginal_p", colnames(md))) { + return(plain) + } + before <- seq_len(at - 1L) + restored <- cbind( + md[, before, drop = FALSE], + S4Vectors::DataFrame(marginal_p = .fmDerivedP(md[["marginal_z"]])), + md[, setdiff(seq_len(ncol(md)), before), drop = FALSE] + ) + S4Vectors::`mcols<-`(plain, value = restored) +} + #' @rdname adjustPips #' @noRd setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { @@ -2032,8 +2123,9 @@ setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { fit, common ) - # cvResult is sample-indexed (partition + held-out predictions), not - # variant-indexed, so it carries through a variant-subsetting unchanged. + # cvResult carries through unchanged: its predictions are indexed by + # sample, and its fold weights, which cvResult() names, describe the fold + # fits' own variants, as fitVariants does the fit's. FineMappingRow( variantIds = common, susieFit = fit, @@ -2058,7 +2150,159 @@ setMethod("susieFit", "FineMappingRow", function(x) x@susieFit) #' @rdname cvResult #' @export -setMethod("cvResult", "FineMappingRow", function(x) x@cvResult) +setMethod("cvResult", "FineMappingRow", function(x) { + .cvNamedFoldWeights(x@cvResult, variantIds(x)) +}) + +# The CV a row stores, as a collection keeps it (cvResult() names the fold +# weights on the way out). +# @noRd +.fmRowCvStored <- function(x) x@cvResult + +# A row's CV with its fold weights' rows named by the row's variants, where +# the row stored them without names (.cvStoredFoldWeights()). A multi-region +# row keeps one payload per region, whose unnamed weights cover the regions' +# variants in order. +# @noRd +.cvNamedFoldWeights <- function(cv, ids) { + if (!.cvIsPerRegion(cv)) { + return(.cvNameFoldWeights(cv, ids)) + } + n <- map_int(cv, .cvFoldWeightRows) + if (any(n == 0L) || sum(n) != length(ids)) { + return(cv) + } + map2(cv, split(ids, rep(seq_along(n), n)), .cvNameFoldWeights) +} + +# One CV payload with its unnamed fold weights named by `ids`. +# @noRd +.cvNameFoldWeights <- function(cv, ids) { + fw <- cv$foldWeights + if (!is.matrix(fw) || !is.null(rownames(fw)) || nrow(fw) != length(ids)) { + return(cv) + } + list_assign(cv, foldWeights = `rownames<-`(fw, ids)) +} + +# @noRd +.cvFoldWeightRows <- function(cv) { + fw <- cv$foldWeights + if (is.matrix(fw) && is.null(rownames(fw))) nrow(fw) else 0L +} + +# The CV as a row stores it. Fold weights on the row's own variants, in its +# order, drop their rownames: the row holds those ids once, and cvResult() +# names them. Any others keep theirs, such as those of a cross-validation-only +# row, which has no variants. A merged row's per-region payloads drop theirs +# only when together they name its variants in order. +# @noRd +.cvStoredFoldWeights <- function(cv, ids) { + if (!is.list(cv)) { + return(cv) + } + if (!.cvIsPerRegion(cv)) { + return(.cvUnnameFoldWeights(cv, ids)) + } + held <- map(unname(cv), .cvFoldWeightIds) + if (!identical(list_c(held, ptype = character()), ids)) { + return(cv) + } + map2(cv, held, .cvUnnameFoldWeights) +} + +# One CV payload with its fold weights unnamed, when they are named `ids`. +# @noRd +.cvUnnameFoldWeights <- function(cv, ids) { + fw <- cv$foldWeights + if (!is.matrix(fw) || !identical(rownames(fw), ids)) { + return(cv) + } + list_assign(cv, foldWeights = `rownames<-`(fw, NULL)) +} + +# @noRd +.cvFoldWeightIds <- function(cv) { + rownames(cv$foldWeights) +} + +# Whether `cv` holds one CV payload per region, as a merged row keeps them +# (.fmMergeEntries()), rather than a single payload. +# @noRd +.cvIsPerRegion <- function(cv) { + length(cv) > 0L && + !is_in("samplePartition", names(cv)) && + all(map_lgl(cv, .cvIsRegionPayload)) +} + +# @noRd +.cvIsRegionPayload <- function(x) { + is.null(x) || (is.list(x) && is_in("samplePartition", names(x))) +} + +# A saved row's CV with its per-fold fits turned into the per-fold weights +# rows now keep: each fold's coefficients, then stored as a new row stores +# them (.cvStoredFoldWeights()). A single payload's weights align to the row's +# variants, or, for a row with none, to its fits' own; a multi-region row's +# payloads keep the variants their fits carried, since the row does not +# record which of its variants each region holds. +# @noRd +.cvFoldFitsToWeights <- function(cv, ids) { + converted <- if (.cvIsPerRegion(cv)) { + map(cv, .cvPayloadFoldWeights, ids = character(0)) + } else { + .cvPayloadFoldWeights(cv, ids) + } + .cvStoredFoldWeights(converted, ids) +} + +# @noRd +.cvPayloadFoldWeights <- function(cv, ids) { + ff <- cv$foldFits + if (is.null(ff)) { + return(cv) + } + named <- map(ff, .foldFitWeights) + on <- if (length(ids) > 0L) { + ids + } else { + unique(list_c(map(unname(named), names), ptype = "")) + } + W <- `dimnames<-`( + exec(cbind, !!!map(named, .alignFoldWeights, on = on)), + list(on, names(ff)) + ) + list_assign( + cv, + foldFits = zap(), + foldWeights = `attr<-`(W, "partitionKey", attr(ff, "partitionKey")) + ) +} + +# One fold fit's coefficients, named by variant: the precomputed `coef` of an +# mvSuSiE / fSuSiE fit, else SuSiE's alpha * mu over its scale factors. +# @noRd +.foldFitWeights <- function(fit) { + if (is.null(fit)) { + return(NULL) + } + if (is.matrix(fit$coef)) { + return(set_names(fit$coef[, 1L], rownames(fit$coef))) + } + ids <- names(fit$pip) %||% colnames(fit$alpha) + set_names(.susieCoefWeights(fit), ids) +} + +# Named fold weights on `on`: zero for a variant the fold had no weight for, +# NA throughout for a fold with no fit. +# @noRd +.alignFoldWeights <- function(w, on) { + if (is.null(w)) { + return(rep(NA_real_, length(on))) + } + hit <- match(names(w), on) + replace(numeric(length(on)), hit[!is.na(hit)], w[!is.na(hit)]) +} #' @rdname show-methods #' @export diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 4c0d836c3..bd9cef4b2 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -830,6 +830,37 @@ selectEffects <- function(fit, priorEffTol = 1e-9) { } } +# The effect index of each row of a fit's effect arrays. A trimmed fit keeps +# only its non-null effects and records which they were; an untrimmed fit +# holds them all, in order. +# @noRd +.fitEffectIndex <- function(fit, nRows) { + as.integer(.fitRecordedEffects(fit) %||% seq_len(nRows)) +} + +# The rows of a fit's effect arrays that hold effects `eff`, as numbered by +# the credible sets' L names: NA for an effect the fit no longer holds. +# @noRd +.fitEffectRows <- function(fit, eff) { + idx <- .fitRecordedEffects(fit) + if (is.null(idx)) { + return(eff) + } + match(eff, idx) +} + +# The effects a trimmed fit records it kept: trimFineMappingResult() names +# alpha's rows by them (.trimEffects()), trimFinemappingFit() lists them in +# `effect_index`. NULL for an untrimmed fit. +# @noRd +.fitRecordedEffects <- function(fit) { + alpha <- fit[["alpha"]] + if (is.matrix(alpha) && .namedByEffect(alpha)) { + return(as.integer(str_remove(rownames(alpha), "^L"))) + } + fit[["effect_index"]] +} + .asEffectMatrix <- function(x) { if (is.null(x)) { return(matrix(numeric(0), nrow = 0)) @@ -1827,11 +1858,12 @@ buildTopLoci <- function( # The per-variant standardization factors susie divides its coefficients by, -# or 1 where the fit records none -- an RSS fit has no X to scale, and a fit -# run with `standardize = FALSE` records all-1s. Read with `[[`: `$` on a list -# falls back to prefix matching. +# or 1 where the fit records none -- an RSS fit has no X to scale, a fit run +# with `standardize = FALSE` records all-1s, and a stored (trimmed) fit drops +# all-1s (.storedScaleFactors()). Every reader of the factors goes through +# here. Read with `[[`: `$` on a list falls back to prefix matching. # @noRd -.btlScaleFactors <- function(fit, nV) { +.fitScaleFactors <- function(fit, nV) { sf <- fit[["X_column_scale_factors"]] if (is.null(sf) || !is.numeric(sf) || length(sf) != nV) { return(rep(1, nV)) @@ -1868,7 +1900,7 @@ buildTopLoci <- function( alpha <- as.matrix(fit$alpha) mu <- .fmSliceCond(fit$mu, conditionIdx) mu2 <- .fmSliceCond(fit$mu2, conditionIdx) - scaleFactors <- .btlScaleFactors(fit, nV) + scaleFactors <- .fitScaleFactors(fit, nV) infinitesimal <- .btlInfinitesimal(fit, nV) meanStd <- if (!is.null(mu) && all(dim(alpha) == dim(mu))) { colSums(alpha * mu) + infinitesimal @@ -1883,14 +1915,10 @@ buildTopLoci <- function( # Zero for every method that has no infinitesimal component. postTheta <- infinitesimal / scaleFactors postSd <- if (!is.null(mu2) && all(dim(alpha) == dim(mu2))) { - # From the STANDARDIZED mean, then rescaled: an SD rescales the same - # way its mean does, but the mu2 identity only holds in the units mu2 - # is stored in. - sdStd <- sqrt(pmax( - colSums(alpha * mu2) - colSums(alpha * mu)^2, - 0 - )) - sdStd / scaleFactors + # From the STANDARDIZED moments, then rescaled: an SD rescales the + # same way its mean does, but the mu2 identity only holds in the + # units mu2 is stored in. + .susiePosteriorSd(alpha, mu, mu2) / scaleFactors } else { rep(NA_real_, nV) } @@ -1911,6 +1939,16 @@ buildTopLoci <- function( ) } +# A variant's posterior SD from the single effects' moments, on the scale mu +# and mu2 are stored in. The effects are independent in the variational +# posterior, so their variances add: each is alpha * mu2 - (alpha * mu)^2, as +# susieR::susie_get_posterior_sd() sums them. Subtracting the square of the +# summed mean instead would treat the effects as one. +# @noRd +.susiePosteriorSd <- function(alpha, mu, mu2) { + sqrt(pmax(colSums(alpha * mu2 - (alpha * mu)^2), 0)) +} + # Parse variant IDs to chrom/pos/A1/A2; error on missing or invalid coordinates. #' @importFrom rlang try_fetch .btlParseVariants <- function(variantNames) { @@ -1970,7 +2008,7 @@ buildTopLoci <- function( p <- if (!is.null(sumstats$p)) { as.numeric(sumstats$p) } else if (any(!is.na(z))) { - 2 * stats::pnorm(-abs(z)) + .fmDerivedP(z) } else { rep(NA_real_, nV) } @@ -2400,6 +2438,9 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { NULL }, V = if (!is.null(fit$V)) fit$V[effectIdx] else NULL, + # The kept effects' own indices: the rows above no longer number + # them, while the credible sets' L names still do. + effect_index = as.integer(effectIdx), niter = fit$niter, max_L = nrow(alpha), n_effects = nrow(alpha) @@ -2412,7 +2453,9 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { withCommon <- list_assign( trimmed, !!!compact(list( - X_column_scale_factors = fit$X_column_scale_factors, + X_column_scale_factors = .storedScaleFactors( + fit[["X_column_scale_factors"]] + ), mu = .trimEffectSlice(fit$mu, effectIdx), mu2 = .trimEffectSlice(fit$mu2, effectIdx), theta = fit$theta, @@ -2422,6 +2465,16 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { .trimAddScalars(withCommon, fit) } +# A fit's column scale factors as stored: NULL when every factor is 1 -- X +# was not rescaled -- which .fitScaleFactors() reads back as 1. +# @noRd +.storedScaleFactors <- function(sf) { + if (is.null(sf) || isTRUE(all(sf == 1))) { + return(NULL) + } + sf +} + # The selected effects of a posterior array, which is L x p for a univariate # fit and L x p x R for a multivariate one. # @noRd @@ -2459,17 +2512,22 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { } # Copy one non-effect-indexed field from `fit` onto `trimmed`, when present. +# Uniform prior weights are not stored: absent is what every reader takes +# for uniform. # @noRd .trimCopyField <- function(trimmed, nm, fit) { value <- fit[[nm]] + if (identical(nm, "pi") && length(value) > 0L) { + if (isTRUE(all(value == value[[1L]]))) { + return(trimmed) + } + } if (is.null(value)) { return(trimmed) } list_assign(trimmed, !!!set_names(list(value), nm)) } -# mvsusie-specific slots: per-effect mu2_diag, the coefficient matrix, and the -# conditional lfsr array. # fSuSiE: the fields the wavelet reconstruction would otherwise take with # it. The base trimmed fit already keeps alpha, lbf_variable and the sets for # coloc; these carry the fitted curve, its credible band and the functional @@ -2499,23 +2557,33 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { list_assign(trimmed, !!!populated[keep]) } +# mvsusie-specific slots: the coefficient matrix and the conditional lfsr +# array (re-summarizing the stored fit reads it per condition). mu2_diag has +# no reader once topLoci is built, so it is not stored. +# @noRd .trimAddMvsusie <- function(trimmed, fit, effectIdx) { list_assign( trimmed, !!!compact(list( - mu2_diag = if (!is.null(fit$mu2_diag)) { - fit$mu2_diag[effectIdx, , , drop = FALSE] - }, coef = if (requireNamespace("mvsusieR", quietly = TRUE)) { mvsusieR::coef.mvsusie(fit)[-1, , drop = FALSE] }, - clfsr = if (!is.null(fit$conditional_lfsr)) { - fit$conditional_lfsr[effectIdx, , , drop = FALSE] - } + clfsr = .trimEffectArray(fit$conditional_lfsr, effectIdx) )) ) } +# The selected effects of an L x p x R array, or NULL when the fit holds none: +# a fit whose every effect is null carries NA where mvsusieR would put the +# lfsr arrays, having no effect to report them for. +# @noRd +.trimEffectArray <- function(x, effectIdx) { + if (length(dim(x)) != 3L) { + return(NULL) + } + x[effectIdx, , , drop = FALSE] +} + #' Format Fine-mapping Post-processing for Protocol Output #' #' Promotes the primary method's per-method post-processing payload to the root @@ -2732,6 +2800,13 @@ fsusieGetCs <- function(fsusieObj, X, requestedCoverage = 0.95) { #' to \code{mvsusieR::create_mixture_prior()} and defaults to the #' canonical mixture over the conditions it is given. #' @param coverage Credible set coverage (default 0.95). +#' @param L Maximum number of single effects (default 10). +#' \code{fineMappingPipeline()} sets it from \code{maxNumSingleEffects} on +#' its \code{\link{CredibleSetParam}}. +#' @param L_greedy The effect count mvsusieR's greedy loop starts from and +#' grows by, up to \code{L}, or \code{NULL} (default) to fit all \code{L} +#' at once. \code{fineMappingPipeline()} sets it from +#' \code{maxNumSingleEffectsGreedy}. #' @param methodArgs Options forwarded to \code{mvsusieR::mvsusie}, built #' with \code{\link{MvsusieOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be silently @@ -2755,18 +2830,26 @@ fitMvsusie <- function( Y, prior_variance, coverage = 0.95, + L = 10L, + L_greedy = NULL, methodArgs = MvsusieOptions() ) { .assertMethodOptions(methodArgs, "MvsusieOptions", "methodArgs") assertNumber(coverage, lower = 0, upper = 1) + assertCount(L, positive = TRUE) + assertCount(L_greedy, positive = TRUE, null.ok = TRUE) callArgs <- list_modify( - list( - X = X, - Y = Y, - prior_variance = prior_variance, - coverage = coverage + c( + list( + X = X, + Y = Y, + prior_variance = prior_variance, + coverage = coverage, + L = L + ), + compact(list(L_greedy = L_greedy)) ), - !!!methodArgs + !!!as.list(methodArgs) ) exec(mvsusieR::mvsusie, !!!callArgs) } @@ -2782,6 +2865,7 @@ fitMvsusie <- function( #' @param N Scalar sample size (median across conditions when N varies). #' @param prior_variance Prior variance matrix. #' @param coverage Credible set coverage (default 0.95). +#' @inheritParams fitMvsusie #' @param methodArgs Options forwarded to \code{mvsusieR::mvsusie_rss}, #' built with \code{\link{MvsusieRssOptions}} --- the RSS entry point has #' its own constructor, since it is a different function from @@ -2809,20 +2893,28 @@ fitMvsusieRss <- function( N, prior_variance, coverage = 0.95, + L = 10L, + L_greedy = NULL, methodArgs = MvsusieRssOptions() ) { .assertMethodOptions(methodArgs, "MvsusieRssOptions", "methodArgs") assertNumber(N, lower = 0, finite = TRUE) assertNumber(coverage, lower = 0, upper = 1) + assertCount(L, positive = TRUE) + assertCount(L_greedy, positive = TRUE, null.ok = TRUE) callArgs <- list_modify( - list( - Z = Z, - R = R, - N = N, - prior_variance = prior_variance, - coverage = coverage + c( + list( + Z = Z, + R = R, + N = N, + prior_variance = prior_variance, + coverage = coverage, + L = L + ), + compact(list(L_greedy = L_greedy)) ), - !!!methodArgs + !!!as.list(methodArgs) ) exec(mvsusieR::mvsusie_rss, !!!callArgs) } @@ -2967,7 +3059,7 @@ buildMvsusieMixturePrior <- function( weights_tol = weightsTol )) ), - !!!methodArgs + !!!as.list(methodArgs) ) exec(mvsusieR::create_mixture_prior, !!!callArgs) } @@ -3027,7 +3119,7 @@ fitFsusie <- function( )) callArgs <- list_modify( c(list(X = X, Y = Y, pos = pos), owned), - !!!methodArgs + !!!as.list(methodArgs) ) exec(fsusieR::susiF, !!!callArgs) } @@ -3042,7 +3134,11 @@ fitFsusie <- function( # (zero the intercept, then coef.susie without the intercept row). # @noRd .susieCoefWeights <- function(fit) { - coef.susie(list_assign(fit, intercept = 0))[-1] + coef.susie(list_assign( + fit, + intercept = 0, + X_column_scale_factors = .fitScaleFactors(fit, length(fit$pip)) + ))[-1] } # Shared helper for susie/susieAsh/susieInf weight extraction: the @@ -3093,7 +3189,7 @@ fitFsusie <- function( if (identical(fitRetention, "none")) { return(weights) } - `attr<-`(weights, "fit", fit) + `attr<-`(weights, "fit", .withFitVariantIds(fit, colnames(X))) } #' Compute single-effect (SER) TWAS weights @@ -3137,7 +3233,7 @@ serWeights <- function( .susieExtractWeights( serFit, X, - requiredFields = c("alpha", "mu", "X_column_scale_factors"), + requiredFields = c("alpha", "mu"), token = "ser", fitRetention = fitRetention ) @@ -3175,7 +3271,7 @@ susieWeights <- function( .susieExtractWeights( susieFit, X, - requiredFields = c("alpha", "mu", "X_column_scale_factors"), + requiredFields = c("alpha", "mu"), token = "susie", fitRetention = fitRetention ) @@ -3213,7 +3309,7 @@ susieAshWeights <- function( .susieExtractWeights( susieAshFit, X, - requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), + requiredFields = c("alpha", "mu", "theta"), token = "susieAsh", fitRetention = fitRetention ) @@ -3262,7 +3358,7 @@ susieInfWeights <- function( .susieExtractWeights( susieInfFit, X, - requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), + requiredFields = c("alpha", "mu", "theta"), token = "susieInf", fitRetention = fitRetention ) @@ -3276,7 +3372,8 @@ susieInfWeights <- function( nVariants, requiredFields, token = "susie", - fitRetention = c("none", "slim", "full") + fitRetention = c("none", "slim", "full"), + variantIds = NULL ) { fitRetention <- arg_match(fitRetention) if (is.null(fit)) { @@ -3304,7 +3401,7 @@ susieInfWeights <- function( if (identical(fitRetention, "none")) { return(weights) } - `attr<-`(weights, "fit", fit) + `attr<-`(weights, "fit", .withFitVariantIds(fit, variantIds)) } #' Compute SuSiE-RSS TWAS weights @@ -3353,9 +3450,10 @@ susieRssWeights <- function( .susieRssExtractWeights( fit = susieRssFit, nVariants = .rssVariantCount(stat, ldReference, "susieRssWeights"), - requiredFields = c("alpha", "mu", "X_column_scale_factors"), + requiredFields = c("alpha", "mu"), token = "susie", - fitRetention = fitRetention + fitRetention = fitRetention, + variantIds = stat[["variantNames"]] ) } @@ -3395,9 +3493,10 @@ susieInfRssWeights <- function( .susieRssExtractWeights( fit = susieInfRssFit, nVariants = .rssVariantCount(stat, ldReference, "susieInfRssWeights"), - requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), + requiredFields = c("alpha", "mu", "theta"), token = "susieInf", - fitRetention = fitRetention + fitRetention = fitRetention, + variantIds = stat[["variantNames"]] ) } @@ -3437,19 +3536,31 @@ susieAshRssWeights <- function( .susieRssExtractWeights( fit = susieAshRssFit, nVariants = .rssVariantCount(stat, ldReference, "susieAshRssWeights"), - requiredFields = c("alpha", "mu", "theta", "X_column_scale_factors"), + requiredFields = c("alpha", "mu", "theta"), token = "susieAsh", - fitRetention = fitRetention + fitRetention = fitRetention, + variantIds = stat[["variantNames"]] ) } + #' Compute mvSuSiE TWAS weights #' #' Extracts coefficients from an existing mvSuSiE fit. This never fits #' mvSuSiE itself: fine-mapping belongs to \code{fineMappingPipeline()}, and a #' missing fit is an error rather than an invitation to refit. #' -#' @param mvsusieFit A fitted mvSuSiE object. Required. -#' @return Matrix of variant weights. +#' @param X,Y Unused; accepted so that \code{learnTwasWeights()} can call +#' every multivariate weight method with its genotype and phenotype +#' matrices, as it does \code{fsusieWeights()}. +#' @param mvsusieFit A fitted mvSuSiE object, or the trimmed one a +#' fine-mapping result stores, whose precomputed \code{coef} is read. +#' Required. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} the fit the weights were +#' extracted from, as given. It names the variants it was fitted on. +#' @return Matrix of variant weights, with the fit attached as attribute +#' \code{"fit"} unless \code{fitRetention = "none"}. #' @examples #' \donttest{ #' # Requires susieR attached (mvsusieR 0.3.0 packaging limitation). @@ -3463,10 +3574,13 @@ susieAshRssWeights <- function( #' mvsusieWeights(mvsusieFit = fit) #' } #' @export -mvsusieWeights <- function(mvsusieFit = NULL) { - if (!requireNamespace("mvsusieR", quietly = TRUE)) { - abort("Package 'mvsusieR' is required.") - } +mvsusieWeights <- function( + X = NULL, + Y = NULL, + mvsusieFit = NULL, + fitRetention = c("none", "slim", "full") +) { + fitRetention <- arg_match(fitRetention) if (is.null(mvsusieFit)) { msg <- glue( "mvsusieWeights: `mvsusieFit` is required. This extracts weights ", @@ -3475,7 +3589,29 @@ mvsusieWeights <- function(mvsusieFit = NULL) { ) abort(msg) } - mvsusieR::coef.mvsusie(mvsusieFit)[-1, , drop = FALSE] + weights <- .mvsusieFitCoef(mvsusieFit) + if (identical(fitRetention, "none")) { + return(weights) + } + `attr<-`( + weights, + "fit", + .withFitVariantIds(mvsusieFit, rownames(weights)) + ) +} + +# The variants x conditions weights of an mvSuSiE fit. A trimmed fit (as +# fineMappingPipeline stores it) carries them in `$coef`, computed before +# trimming dropped the intercept and the effects coef.mvsusie() sums over. +# @noRd +.mvsusieFitCoef <- function(fit) { + if (is.list(fit) && is.matrix(fit$coef)) { + return(fit$coef) + } + if (!requireNamespace("mvsusieR", quietly = TRUE)) { + abort("Package 'mvsusieR' is required.") + } + mvsusieR::coef.mvsusie(fit)[-1, , drop = FALSE] } # One wavelet basis row: inverse-DWT (wr) of the unit coefficient vector e_k, @@ -3517,12 +3653,17 @@ mvsusieWeights <- function(mvsusieFit = NULL) { #' (\code{nSNP x n_wac}) and inclusion probabilities \code{alpha[[l]]}. Because #' the inverse wavelet transform \code{wr()} is linear, the posterior-mean #' prediction pushes through to a per-SNP, per-feature weight matrix: -#' \deqn{W[j, f] = \sum_l alpha[[l]][j] \cdot -#' \mathrm{wr}\!\left(fitted\_wc[[l]][j, ] / csd\_X[j]\right)[f].} +#' \deqn{W[j, f] = csd\_Y\_pos[f] \sum_l alpha[[l]][j] \cdot +#' \mathrm{wr}\!\left(csd\_Yf \cdot fitted\_wc[[l]][j, ] / csd\_X[j] +#' \right)[f].} #' This is the exact analog of \code{coef.susie} for scalar SuSiE (all SNPs, #' alpha-weighted), which spreads weight across the credible set -- more robust #' for out-of-sample TWAS than fSuSiE's in-sample lead-SNP summary -#' (\code{update_cal_indf}). +#' (\code{update_cal_indf}). \code{csd_Yf} and \code{csd_Y_pos} undo the +#' response standardization fsusieR records when it scales the response +#' (its \code{standardize_Y}), per wavelet coefficient and per position, so +#' the weights are in the response's own units; a fit that records neither +#' was never scaled. #' #' The reconstruction uses the raw posterior wavelet coefficients #' \code{fitted_wc}, so it is independent of the \code{post_processing} mode @@ -3594,7 +3735,13 @@ fsusieWeights <- function( csdX <- as.numeric(fit$csd_X) alphaList <- .fsusieAlphaList(fit$alpha) S <- .fsusieSynthesisMatrix(fit$n_wac, .fsusieScaleCols(fit)) + # fitted_wc lives in fsusieR's standardized response space: each wavelet + # coefficient is scaled back before the inverse transform (the rows of + # S) and each position after it (the columns of W), as fsusieR's own + # fitted_func is. + S <- sweep(S, 1L, .fsusieResponseScale(fit, "csd_Yf", nrow(S)), `*`) W <- .fsusieComputeW(fit, alphaList, csdX, S) |> + sweep(2L, .fsusieResponseScale(fit, "csd_Y_pos", ncol(S)), `*`) |> .fsusieWeightsNames( fit, variantIds, @@ -3605,7 +3752,25 @@ fsusieWeights <- function( if (identical(fitRetention, "none")) { return(W) } - `attr<-`(W, "fit", fit) + `attr<-`(W, "fit", .withFitVariantIds(fit, rownames(W))) +} + +# The response standardization fsusieR recorded on the fit, one factor per +# wavelet coefficient (csd_Yf) or per position (csd_Y_pos). An fsusieR that +# did not scale the response records neither, so the factor is 1. +# @noRd +.fsusieResponseScale <- function(fit, part, n) { + s <- fit[[part]] + if (is.null(s)) { + return(rep(1, n)) + } + if (length(s) != n) { + abort(glue( + "fsusieWeights: the fit's `{part}` has {length(s)} values for ", + "its {n} wavelet coefficients." + )) + } + as.numeric(s) } # Row names only mean the variants when there is one per row of the matrix. @@ -3626,7 +3791,11 @@ fsusieWeights <- function( } W <- .withRownamesIfSized(fsusieFit$coef, variantIds) if (!identical(fitRetention, "none")) { - return(`attr<-`(W, "fit", fsusieFit)) + return(`attr<-`( + W, + "fit", + .withFitVariantIds(fsusieFit, rownames(W)) + )) } W } @@ -3810,7 +3979,11 @@ mvsusieRssWeights <- function( if (identical(fitRetention, "none")) { return(weights) } - `attr<-`(weights, "fit", mvsusieRssFit) + `attr<-`( + weights, + "fit", + .withFitVariantIds(mvsusieRssFit, stat[["variantNames"]]) + ) } # The supplied fit must describe the LD block it is being extracted against; @@ -5548,8 +5721,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { mvArgs <- .fmMergeUserArgs(withPrior, userArgs) fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, mvArgs)) raw <- as.matrix(mvsusieWeights(mvsusieFit = fit)) - W <- `rownames<-`(raw, rownames(raw) %||% colnames(Xtr)) - `attr<-`(W, "fit", .fmLeanFoldFit(fit, "mvsusie")) + `rownames<-`(raw, rownames(raw) %||% colnames(Xtr)) } #' @rdname fineMappingMethodOptions diff --git a/R/genotypeIo.R b/R/genotypeIo.R index 1f0253b10..0a97c5318 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -239,6 +239,31 @@ setMethod( methods::initialize(handle, snpInfo = slice(si, keepIdx)) } +# The columns of a handle's variant table that reading its genotypes needs: +# each variant's position in its file (fileIdx) and, for BGEN, the record +# and allele it reads. A handle over one file per chromosome also keeps CHR, +# which routes each variant to its file. +.HANDLE_READ_COLUMNS <- c("fileIdx", "bgen_offset", "bgen_size", "bgen_allele") + +# `handle` with only the columns of its variant table that reading needs +# (.HANDLE_READ_COLUMNS), as a panel's seed keeps it: the panel's rowRanges +# describe its variants. +# @noRd +.readingHandle <- function(handle) { + si <- snpInfo(handle) + routed <- length(.genotypeChromPaths(handle)) > 0L + drop <- setdiff(names(si), c(if (routed) "CHR", .HANDLE_READ_COLUMNS)) + if (length(drop) == 0L) { + return(handle) + } + # Set as a slot, as initialize() would refuse a handle saved in a format + # no handle reads today, which must still be cut so the panel over it + # can be read again (.updatePanel()). The replacement form copies the + # handle: `slot<-`() called directly would cut the caller's own. + methods::slot(handle, "snpInfo") <- select(si, -all_of(drop)) + handle +} + #' @keywords internal .makePlink2Handle <- function(path) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { @@ -307,24 +332,35 @@ setMethod( #' @importFrom purrr map2 map set_names #' @keywords internal extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { + # An empty request is answered without reaching a reader, which need not + # accept one. + if (length(snpIdx) == 0L) { + return(.emptyBlockSe(sampleIds(handle))) + } + geno <- .handleDosage(handle, snpIdx) + .blockGenotypesToSe( + if (meanImpute) .meanImputeGeno(geno) else geno, + handle, + snpIdx + ) +} + +# The samples x variants dosages of a handle's variants at `snpIdx` (never +# an empty request), as read: neither imputed nor labelled. It reads only +# the columns of the handle's variant table that find each variant in its +# file (.HANDLE_READ_COLUMNS), which are all a panel's seed keeps. +# @noRd +.handleDosage <- function(handle, snpIdx) { # One-file-per-chromosome handle: route by chromosome to the right file. # `.genotypeChromPaths` tolerates handles deserialized before the slot # existed (treated as single-file). if (length(.genotypeChromPaths(handle)) > 0L) { - return(.extractBlockSharded(handle, snpIdx, meanImpute = meanImpute)) - } - # An empty request is answered without reaching a reader, which need not - # accept one, as the sharded branch above already answers it. - if (length(snpIdx) == 0L) { - return(.emptyBlockSe(sampleIds(handle))) + return(.handleDosageSharded(handle, snpIdx)) } # Read ascending, then put the columns back in the requested order. See # .restoreRequestedOrder() for why this is not merely tidiness. ord <- order(.genotypeFilePos(handle, snpIdx)) - raw <- .extractBlockByFormat(handle, snpIdx[ord]) - ordered <- .restoreRequestedOrder(raw, ord) - geno <- if (meanImpute) .meanImputeGeno(ordered) else ordered - .blockGenotypesToSe(geno, handle, snpIdx) + .restoreRequestedOrder(.extractBlockByFormat(handle, snpIdx[ord]), ord) } # Position of each requested variant in the underlying file. snpInfo rows are @@ -384,7 +420,10 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { .withLdProjection( SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), - rowRanges = .genotypeSnpRanges(genotypes, rownames(dosage)), + rowRanges = .genotypeSnpRanges( + genotypes, + .panelRowNames(snpInfo(genotypes)) + ), colData = cd, metadata = list(genotypeSource = .genotypeSourceRecord(genotypes)) ), @@ -424,23 +463,85 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # ============================================================================= # `panel` as a panel built today: read again from its files when it was -# saved before the changes above, else `panel` itself -- as for one that -# reads through no handle (a VCF, GDS or PLINK1 panel built since, or one -# held in memory). A bare GenotypeHandle, which an LD reference was before -# it was a panel, is taken as the panel over it. +# saved before the changes above, else without the copies of its variants' +# labels a panel saved before this version kept (.slimPanel()) -- as is +# one that reads through no handle (a VCF, GDS or PLINK1 panel built since, +# or one held in memory). A bare GenotypeHandle, which an LD reference was +# before it was a panel, is taken as the panel over it, a mixture has each +# of its panels slimmed, and an LdMatrix is brought up to date +# (updateObject()). # @noRd .updatePanel <- function(panel) { panel <- .asLdRef(panel) + if (.ldIsMixtureRef(panel)) { + return(.slimMixture(panel)) + } + if (.ldIsMatrixRef(panel)) { + return(updateObject(panel)) + } handle <- .ldRefHandle(panel) - if (is.null(handle)) { + if (!is.null(handle)) { + source <- .genotypeSourceRecord(handle) + recorded <- !is.null(S4Vectors::metadata(panel)$genotypeSource) + if (!recorded || is_in(source$format, .DOSAGE_PANEL_FORMATS)) { + return(.rereadPanel(panel, source)) + } + } + .slimPanel(panel) +} + +# `panel` without the copies of its variants' labels that a panel saved +# before this version kept: an SNP column repeating its row names, row names +# on its dosage seed, and the columns of a handle's variant table that +# reading does not need (.readingHandle()). One that keeps none, and an +# LdMatrix, are returned as they are. +# @noRd +.slimPanel <- function(panel) { + if (!methods::is(panel, "RangedSummarizedExperiment")) { return(panel) } - source <- .genotypeSourceRecord(handle) - recorded <- !is.null(S4Vectors::metadata(panel)$genotypeSource) - if (recorded && !is_in(source$format, .DOSAGE_PANEL_FORMATS)) { + rr <- SummarizedExperiment::rowRanges(panel) + labelled <- .dropRedundantLabels(rr) + if (!identical(labelled, rr)) { + SummarizedExperiment::rowRanges(panel) <- labelled + } + dosage <- .slimPanelDosage(panel) + if (is.null(dosage)) { return(panel) } - .rereadPanel(panel, source) + SummarizedExperiment::assay(panel, "dosage", withDimnames = FALSE) <- + dosage + panel +} + +# `panel`'s dosage assay over its seed slimmed (.slimSeed()), the same rows +# and columns of it; NULL when the seed is slim already or out of reach +# (.panelSeedIndex()). +# @noRd +.slimPanelDosage <- function(panel) { + slim <- .slimSeed(.panelSeed(panel)) + index <- .panelSeedIndex(panel) + if (is.null(slim) || is.null(index)) { + return(NULL) + } + whole <- DelayedArray::DelayedArray(slim) + if (identical(index, map(dim(whole), seq_len))) { + return(whole) + } + whole[index[[1L]], index[[2L]], drop = FALSE] +} + +# A dosage seed without the copies .slimPanel() drops, or NULL when it keeps +# none or is not a seed pecotmr builds. +# @noRd +.slimSeed <- function(seed) { + if (methods::is(seed, "GhSeed")) { + return(.slimGhSeed(seed)) + } + if (methods::is(seed, "GenotypeDosageSeed")) { + return(.slimDosageSeed(seed)) + } + NULL } # `panel` read again from `source`, the record of where its genotypes come @@ -569,6 +670,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { .snpInfoRanges(snpInfo(genotypes), variantIds) } +# A panel's row names for the variants of table `si`: each file label in +# the canonical form (an rsID kept as it is). Its seed keeps none: a panel's +# rowRanges name its rows. +# @noRd +.panelRowNames <- function(si) { + normalizeVariantId(as.character(si$SNP)) +} + # A panel's variants snpInfo-style, one row per rowRanges element: SNP (the # file's own ids), CHR, BP, A1, A2. The inverse of .snpInfoRanges(), so # genotypes from any backend answer alike. @@ -576,7 +685,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { .rangesSnpInfo <- function(gr) { mc <- S4Vectors::mcols(gr) tibble( - SNP = as.character(mc$SNP), + SNP = .panelLabels(gr), CHR = as.character(seqnames(gr)), BP = as.integer(start(gr)), A1 = as.character(mc$A1), @@ -586,18 +695,73 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # The rowRanges of variants described snpInfo-style (SNP, CHR, BP, A1, A2), # named `variantIds`: a handle's, or a VCF, GDS or PLINK1 panel's rows. Every -# reader spells CHR in UCSC style as it reads the file. +# reader spells CHR in UCSC style as it reads the file. The file's labels are +# kept in an SNP column only when some differs from the names they give the +# rows; otherwise the names are the labels (.panelLabels()). # @noRd .snpInfoRanges <- function(si, variantIds) { - `names<-`( - GenomicRanges::GRanges( - seqnames = as.character(si$CHR), - ranges = IRanges::IRanges(as.integer(si$BP), width = 1L), - SNP = as.character(si$SNP), - A1 = as.character(si$A1), - A2 = as.character(si$A2) - ), - variantIds + labels <- as.character(si$SNP) + gr <- GenomicRanges::GRanges( + seqnames = as.character(si$CHR), + ranges = IRanges::IRanges(as.integer(si$BP), width = 1L), + A1 = as.character(si$A1), + A2 = as.character(si$A2) + ) + if (!identical(labels, variantIds)) { + gr <- .withLabelColumn(gr, labels) + } + `names<-`(gr, variantIds) +} + +# A panel's rows' file labels: its SNP column where it keeps one, else its +# row names, which are then those labels. +# @noRd +.panelLabels <- function(gr) { + labels <- S4Vectors::mcols(gr)$SNP + if (is.null(labels)) names(gr) else as.character(labels) +} + +# `gr` (a panel's rowRanges) with its file labels as its first column, SNP, +# as readers of a panel's variants take them. +# @noRd +.withPanelLabels <- function(gr) { + if (is_in("SNP", colnames(S4Vectors::mcols(gr)))) { + return(gr) + } + .withLabelColumn(gr, names(gr)) +} + +# Panels' rowRanges as one GRanges, the parts' rows in turn. Their file +# labels are kept in an SNP column only when some differs from its row name, +# as for one panel (.snpInfoRanges()), so parts that keep the column bind +# with parts that do not. +# @noRd +.bindPanelRanges <- function(grs) { + .dropRedundantLabels( + suppressWarnings(exec(c, !!!unname(map(grs, .withPanelLabels)))) + ) +} + +# `gr` (a panel's rowRanges) without its SNP column when every label in it +# is its row's name. +# @noRd +.dropRedundantLabels <- function(gr) { + mc <- S4Vectors::mcols(gr) + labels <- mc$SNP + if (is.null(labels) || !identical(as.character(labels), names(gr))) { + return(gr) + } + S4Vectors::`mcols<-`(gr, value = mc[setdiff(colnames(mc), "SNP")]) +} + +# @noRd +.withLabelColumn <- function(gr, labels) { + S4Vectors::`mcols<-`( + gr, + value = cbind( + S4Vectors::DataFrame(SNP = labels), + S4Vectors::mcols(gr, use.names = FALSE) + ) ) } @@ -635,69 +799,51 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) } -# Extract one chromosome's block from a sharded handle: reslice the handle to -# that chrom's file + SNP subset and delegate to extractBlockGenotypes. +# .handleDosage() for a one-file-per-chromosome (sharded) handle. `snpIdx` +# index its unified variant table; they are grouped by chromosome, each +# group read from its chromosome's file (.chromDosage()), and the columns +# put back in the requested order. # @noRd -.extractBlockForChrom <- function( - chrom, - posInReq, - handle, - snpIdx, - unifiedChr, - meanImpute -) { +.handleDosageSharded <- function(handle, snpIdx) { + unifiedChr <- snpInfo(handle)$CHR + groups <- split(seq_along(snpIdx), unifiedChr[snpIdx]) + blocks <- map2( + names(groups), + groups, + .chromDosage, + handle = handle, + snpIdx = snpIdx, + unifiedChr = unifiedChr + ) + exec(cbind, !!!unname(blocks))[, + order(unname(list_c(groups))), + drop = FALSE + ] +} + +# One chromosome's dosages from a sharded handle, read through a transient +# single-file view of that chromosome's file holding the chromosome's rows of +# the unified table, so positional backends like PLINK2 stay valid. +# @noRd +.chromDosage <- function(chrom, posInReq, handle, snpIdx, unifiedChr) { if (!is_in(chrom, names(chromPaths(handle)))) { msg <- glue( "extractBlockGenotypes: no per-chromosome file for chromosome ", "'{chrom}' (have: ", - "{str_flatten(names(handle@chromPaths), collapse = ', ')})." + "{str_flatten(names(chromPaths(handle)), collapse = ', ')})." ) abort(msg) } blockGlobal <- which(unifiedChr == chrom) # file-order global indices - localIdx <- match(snpIdx[posInReq], blockGlobal) - th <- methods::initialize( + view <- methods::initialize( handle, - path = handle@chromPaths[[chrom]], - snpInfo = slice(handle@snpInfo, blockGlobal), + path = chromPaths(handle)[[chrom]], + snpInfo = slice(snpInfo(handle), blockGlobal), pgenPtr = NULL, # Treated as single-file: the view addresses one chromosome's payload. chromPaths = character(0) ) - extractBlockGenotypes(th, localIdx, meanImpute = meanImpute) -} - -# Extract a block from a one-file-per-chromosome (sharded) handle. The global -# snpIdx index the unified @snpInfo; we group them by chromosome, route each -# group to its per-chromosome payload via a transient single-file view (with -# the chromosome-local snpInfo so positional backends like PLINK2 stay valid), -# then row-bind across chromosomes (samples identical by construction) and -# restore the requested order. A single-chromosome request -- the common cis -# case -- returns its one SE directly. -#' @keywords internal -.extractBlockSharded <- function(handle, snpIdx, meanImpute = TRUE) { - sampleIds <- sampleIds(handle) - if (length(snpIdx) == 0L) { - return(.emptyBlockSe(sampleIds)) - } - unifiedChr <- snpInfo(handle)$CHR - groups <- split(seq_along(snpIdx), unifiedChr[snpIdx]) - ses <- set_names( - map2( - names(groups), - groups, - .extractBlockForChrom, - handle = handle, - snpIdx = snpIdx, - unifiedChr = unifiedChr, - meanImpute = meanImpute - ), - names(groups) - ) - if (length(ses) == 1L) { - return(ses[[1L]]) - } - .combineShardedSes(ses, groups) + .handleDosage(view, match(snpIdx[posInReq], blockGlobal)) } # Empty-block SE (no variants) carrying the handle's sample dimension. @@ -716,22 +862,6 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) } -# Combine per-chromosome SEs at the assay/rowRanges level (rbind-ing the SEs -# trips on disjoint seqlevels) and restore the requested snpIdx order. -# @noRd -.combineShardedSes <- function(ses, groups) { - ord <- order(unname(list_c(groups))) - dosages <- map(ses, .seDosage) - combinedDos <- exec(rbind, !!!dosages)[ord, , drop = FALSE] - rowRangesList <- unname(map(ses, SummarizedExperiment::rowRanges)) - combinedGr <- suppressWarnings(exec(c, !!!rowRangesList))[ord] - SummarizedExperiment( - assays = list(dosage = combinedDos), - rowRanges = combinedGr, - colData = SummarizedExperiment::colData(ses[[1L]]) - ) -} - #' @keywords internal #' @importFrom rlang try_fetch .extractBlockPlink2 <- function(handle, snpIdx) { @@ -980,17 +1110,21 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @importFrom SummarizedExperiment assay readBim <- function(bed) { bimf <- str_c(.genotypeStem(bed), ".bim") - `colnames<-`( - vroom(bimf, col_names = FALSE), + # Typed columns: left to guess, a column of "T" alleles reads as logical. + bim <- `colnames<-`( + vroom(bimf, col_names = FALSE, col_types = "ccdicc"), c("chrom", "id", "gpos", "pos", "a1", "a0") ) + mutate(bim, a1 = .canonAllele(.data$a1), a0 = .canonAllele(.data$a0)) } #' Read a PLINK2 allele frequency file (.afreq or .afreq.zst) #' #' @param path File prefix (without .afreq extension). -#' @return A data.frame with columns: chrom, id, A2 (REF), A1 (ALT), alt_freq, -#' obs_ct. alt_freq is the frequency of the A1 (ALT/effect) allele. +#' @return A data.frame with columns: chrom (as the file spells it), id, A2 +#' (REF) and A1 (ALT), in upper case as pecotmr holds every allele, +#' alt_freq and obs_ct. alt_freq is the frequency of the A1 (ALT/effect) +#' allele. #' @importFrom vroom vroom #' @importFrom archive archive_read #' @importFrom dplyr rename select @@ -1019,14 +1153,18 @@ readAfreq <- function(path) { # here, so the file need not be named *.afreq. # @noRd .readAfreqFile <- function(file) { + # All-character, typed below: left to guess, an all-"T" allele column + # reads as logical and a numeric chromosome as a number. + asText <- cols(.default = col_character()) af <- if (str_detect(file, "\\.zst$")) { vroom( archive_read(file, format = "raw", filter = "zstd"), delim = "\t", + col_types = asText, show_col_types = FALSE ) } else { - vroom(file, delim = "\t", show_col_types = FALSE) + vroom(file, delim = "\t", col_types = asText, show_col_types = FALSE) } # PLINK2 .afreq: REF = A2, ALT = A1, ALT_FREQS = A1 (effect allele) # frequency @@ -1042,7 +1180,7 @@ readAfreq <- function(path) { # A stochastic-genotype .afreq also carries U_MIN / U_MAX, which # invertMinmaxScaling() needs for an exact min-max inversion. stochastic <- is_in("U_MIN", colnames(renamed)) - cols <- c( + keep <- c( c("chrom", "id", "A2", "A1", "alt_freq", "obs_ct"), if (stochastic) c("u_min", "u_max") ) @@ -1051,7 +1189,12 @@ readAfreq <- function(path) { } else { renamed } - select(out, all_of(cols)) + mutate( + select(out, all_of(keep)), + A2 = .canonAllele(.data$A2), + A1 = .canonAllele(.data$A1), + across(any_of(c("alt_freq", "obs_ct", "u_min", "u_max")), as.numeric) + ) } #' Read stochastic genotype sidecar metadata (U_MIN/U_MAX). @@ -1279,8 +1422,8 @@ readPvar <- function(pvarPath) { chrom = map_chr(idx, .pvarChrom, pvar = pvar), id = map_chr(idx, .pvarId, pvar = pvar), pos = map_int(idx, .pvarPos, pvar = pvar), - A2 = map_chr(idx, .pvarAlleleCode, pvar = pvar, k = 1L), - A1 = map_chr(idx, .pvarAlleleCode, pvar = pvar, k = 2L) + A2 = .canonAllele(map_chr(idx, .pvarAlleleCode, pvar = pvar, k = 1L)), + A1 = .canonAllele(map_chr(idx, .pvarAlleleCode, pvar = pvar, k = 2L)) ) } @@ -1424,8 +1567,14 @@ refVariantInfo <- function(source, which = NULL) { #' @importFrom readr read_lines #' @noRd matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { + # All-character: left to guess, an all-"T" allele column reads as + # logical; parseVariantId() types chrom and pos itself. keepRaw <- try_fetch( - as.data.frame(vroom(keepVariantsPath, show_col_types = FALSE)), + as.data.frame(vroom( + keepVariantsPath, + col_types = cols(.default = col_character()), + show_col_types = FALSE + )), error = function(cnd) NULL ) if ( @@ -1439,34 +1588,24 @@ matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { ids <- read_lines(keepVariantsPath) keepVariants <- parseVariantId(ids) } - viChrom <- variantInfo$chrom hasAlleles <- is_in("A1", names(keepVariants)) && is_in("A2", names(keepVariants)) && !any(is.na(keepVariants$A1)) && !any(is.na(keepVariants$A2)) - if (hasAlleles) { - is_in( - str_c( - viChrom, - variantInfo$pos, - variantInfo$A2, - variantInfo$A1, - sep = ":" - ), - str_c( - keepVariants$chrom, - keepVariants$pos, - keepVariants$A2, - keepVariants$A1, - sep = ":" - ) - ) - } else { - is_in( - str_c(viChrom, variantInfo$pos, sep = ":"), - str_c(keepVariants$chrom, keepVariants$pos, sep = ":") - ) + is_in( + .keepVariantKey(variantInfo, hasAlleles), + .keepVariantKey(keepVariants, hasAlleles) + ) +} + +# A variant table's keep-list match key: chrom:pos:A2:A1 when the keep list +# names alleles, chrom:pos when it names positions only. +# @noRd +.keepVariantKey <- function(tbl, withAlleles) { + if (withAlleles) { + return(str_c(tbl$chrom, tbl$pos, tbl$A2, tbl$A1, sep = ":")) } + str_c(tbl$chrom, tbl$pos, sep = ":") } #' Load genotype data for a specific region @@ -1731,8 +1870,8 @@ loadGenotypeRegion <- function( allele <- gdsfmt::read.gdsn(gdsfmt::index.gdsn(gds, "snp.allele")) allelesSplit <- str_split(allele, "/") # `[` (single-bracket) so a missing second allele yields NA, not an error. - a1 <- map_chr(allelesSplit, `[`, 1L) - a2 <- map_chr(allelesSplit, `[`, 2L) + a1 <- .canonAllele(map_chr(allelesSplit, `[`, 1L)) + a2 <- .canonAllele(map_chr(allelesSplit, `[`, 2L)) tibble( SNP = snpId, CHR = withChrPrefix(chr), @@ -1946,8 +2085,8 @@ loadGenotypeRegion <- function( SNP = if_else(named, index$rsid, ids), CHR = withChrPrefix(index$chromosome), BP = as.integer(index$position), - A1 = index$allele2, - A2 = index$allele1, + A1 = .canonAllele(index$allele2), + A2 = .canonAllele(index$allele1), bgen_offset = as.numeric(index$file_start_position), bgen_size = as.numeric(index$size_in_bytes), bgen_allele = rep(2L, nrow(index)) @@ -1963,8 +2102,8 @@ loadGenotypeRegion <- function( SNP = formatVariantId(chrom, pos, alleles[[1L]], others), CHR = withChrPrefix(chrom), BP = as.integer(pos), - A1 = others, - A2 = alleles[[1L]], + A1 = .canonAllele(others), + A2 = .canonAllele(alleles[[1L]]), bgen_offset = as.numeric(offset), bgen_size = as.numeric(size), bgen_allele = seq_along(others) + 1L @@ -2202,7 +2341,7 @@ loadGenotypeRegion <- function( dosage <- DelayedArray::DelayedArray(seed) SummarizedExperiment::SummarizedExperiment( assays = list(dosage = dosage), - rowRanges = .snpInfoRanges(rows, rownames(dosage)), + rowRanges = .snpInfoRanges(rows, .panelRowNames(rows)), colData = S4Vectors::DataFrame(row.names = colnames(dosage)), metadata = list( genotypeSource = list( @@ -2229,8 +2368,10 @@ loadGenotypeRegion <- function( )) } record <- rep(seq_len(nrow(records)), nAlt) - a1 <- as.character(list_c(records$alt)) - a2 <- records$ref[record] + # Upper case here, after .vcfRecordIds() has matched VariantAnnotation's + # synthetic ids against the alleles as the file spells them. + a1 <- .canonAllele(list_c(records$alt)) + a2 <- .canonAllele(records$ref[record]) named <- !is.na(records$id) & !multi tibble( SNP = if_else( @@ -2269,10 +2410,7 @@ loadGenotypeRegion <- function( ranges = IRanges(records$pos, records$end), posRank = .positionRank(records$chrom, records$pos) ), - dn = list( - normalizeVariantId(rows$SNP), - as.character(VariantAnnotation::samples(header)) - ) + dn = list(NULL, as.character(VariantAnnotation::samples(header))) ) .dosageSeedPanel(seed, rows, "vcf", path(file)) } @@ -2474,7 +2612,7 @@ loadGenotypeRegion <- function( rowRecord = rows$record, rowAllele = rows$allele, records = IRanges(rows$record, width = 1L), - dn = list(normalizeVariantId(rows$SNP), meta$sampleIds) + dn = list(NULL, meta$sampleIds) ) .dosageSeedPanel(seed, rows, "gds", path) } @@ -2505,7 +2643,7 @@ loadGenotypeRegion <- function( rowRecord = rows$record, rowAllele = rows$allele, records = IRanges(start = cumsum(counts) - counts + 1L, width = counts), - dn = list(normalizeVariantId(rows$SNP), meta$sampleIds) + dn = list(NULL, meta$sampleIds) ) .dosageSeedPanel(seed, rows, "gds", path) } @@ -2619,7 +2757,7 @@ loadGenotypeRegion <- function( rowRecord = seq_len(nVariants), rowAllele = rep(1L, nVariants), records = IRanges(seq_len(nVariants), width = 1L), - dn = list(normalizeVariantId(meta$snpInfo$SNP), meta$sampleIds) + dn = list(NULL, meta$sampleIds) ) .dosageSeedPanel(seed, meta$snpInfo, "plink1", stem) } @@ -2661,8 +2799,8 @@ loadGenotypeRegion <- function( SNP = bim$SNP, CHR = withChrPrefix(bim$CHR), BP = as.integer(bim$BP), - A1 = bim$A1, - A2 = bim$A2 + A1 = .canonAllele(bim$A1), + A2 = .canonAllele(bim$A2) ) list( snpInfo = snpInfo, @@ -2680,7 +2818,6 @@ loadGenotypeRegion <- function( # @noRd .stackDosagePanels <- function(panels, format, metaPath, paths) { .stackCheckSamples(panels, paths) - rowRangesList <- unname(map(panels, SummarizedExperiment::rowRanges)) SummarizedExperiment::SummarizedExperiment( assays = list( dosage = exec( @@ -2688,7 +2825,9 @@ loadGenotypeRegion <- function( !!!unname(map(panels, .seDosage)) ) ), - rowRanges = suppressWarnings(exec(c, !!!rowRangesList)), + rowRanges = .bindPanelRanges( + map(panels, SummarizedExperiment::rowRanges) + ), colData = SummarizedExperiment::colData(panels[[1L]]), metadata = list( genotypeSource = list( diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index ff26229e4..de6bd32f4 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -216,7 +216,7 @@ GwasSumStats <- function( abort("`studyName`, `entry`, and `genome` are all required.") } varY <- .gwasValidateArgs(studyName, entry, genome, varY) - entry <- .ucscEntries(entry) + entry <- .ssEntries(entry) cols <- list( study = as.character(studyName), varY = varY @@ -230,7 +230,7 @@ GwasSumStats <- function( .sumStatsNewValidated( "GwasSumStats", grl, - dict$refs, + dict$entries, genome, qcOptions ), @@ -294,7 +294,7 @@ GwasSumStats <- function( ) methods::new( Class, - built, + .rtlStored(Class, built), ldReference = ldReference, qcOptions = as.list(qcOptions) ) diff --git a/R/h2Annotations.R b/R/h2Annotations.R index 73f7afc19..128dc459d 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -41,24 +41,53 @@ setMethod( annotationMeta <- tibble( name = annotNames, tier = rep("candidate", nAnnots), - type = .readAnnotTypes(path) + type = .readAnnotTypes(path, annotMat) ) } - AnnotationMatrix(annotMat, snpRanges, annotationMeta, genome) + AnnotationMatrix( + .annotStored(annotMat), + snpRanges, + annotationMeta, + genome + ) } ) -# Auto-detected annotation types (continuous for BigWig, else binary). Unnamed -# so the tibble column carries no element names (tibble, unlike data.frame, -# would otherwise keep the paths' names on the column). +# Auto-detected annotation types: continuous for a BigWig signal, binary for +# BED intervals, and for an LDSC .annot column whichever its values say (0 / 1 +# is binary). Unnamed so the tibble column carries no element names (tibble, +# unlike data.frame, would otherwise keep the paths' names on the column). # @noRd -.readAnnotTypes <- function(paths) { - unname(map_chr(paths, .annotType)) +.readAnnotTypes <- function(paths, annotMat) { + unname(map2_chr(paths, seq_along(paths), .annotType, annotMat = annotMat)) } # @noRd -.annotType <- function(p) { - if (.annotDetectFormat(p) == "bigwig") "continuous" else "binary" +.annotType <- function(p, j, annotMat) { + fmt <- .annotDetectFormat(p) + if (fmt == "bigwig") { + return("continuous") + } + values <- annotMat[, j] + if (fmt == "bed" || all(is_in(values, c(0, 1)) | is.na(values))) { + return("binary") + } + "continuous" +} + +# `A`, the variant x annotation matrix, as a sparse dgCMatrix when that is +# smaller than the dense matrix -- as binary annotations, mostly zero, are -- +# and as it is otherwise. A sparse matrix costs 12 bytes a stored value (a +# double and its row index) plus 4 a column; a dense one 4 a cell when it is +# integer or logical and 8 when it is double. +# @noRd +.annotStored <- function(A) { + stored <- sum(A != 0 | is.na(A)) + cellBytes <- if (is.integer(A) || is.logical(A)) 4 else 8 + if (12 * stored + 4 * (ncol(A) + 1) >= cellBytes * length(A)) { + return(A) + } + methods::as(A, "CsparseMatrix") } # @noRd diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index 56e9e6635..a72c963c0 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -1,19 +1,31 @@ # ============================================================================= # Heritability Estimation Wrappers # ----------------------------------------------------------------------------- -# Consolidated entry points for univariate heritability estimation. Three -# methods are exposed via the `estimateH2` S4 generic: +# Consolidated entry points for univariate heritability estimation: both +# `estimateH2` methods, with the estimators they call. # +# From GWAS summary statistics, one genome-wide estimate per study: # * gLDSC (Generalized LD Score Regression, Xiong et al. 2024) # * HDL/sHDL (High-Definition Likelihood, Ning et al. 2020 + Zhao 2023) # * LDER (LD Eigenvalue Regression, Song et al. 2022) +# * S-LDSC (stratified LD score regression, Finucane et al. 2015) +# +# From QTL summary statistics, one cis estimate per gene: +# * LAVA (Werme et al. 2022) +# * HDL-L (Li et al. 2025) +# * FastHer (Svishcheva 2025; HEELS, Li et al. 2023, maximizes the same +# likelihood) +# +# The estimators are pecotmr's own implementations rather than an external +# engine, so the entry points live beside them instead of in a *Pipeline.R +# file. # # Plus shared utilities (block ops, WLS, jackknife SE, enrichment, # genome-build checks, tauStar standardization, meta-analysis) and the # converter that bridges H2Estimate results into the sLDSC postprocessing # pipeline. # -# The H2Estimate result class itself lives in R/h2Estimate.R. +# The H2Estimate result class itself lives in R/H2Estimate.R. # ============================================================================= #' @title Shared Utilities for Heritability Estimation @@ -333,8 +345,8 @@ RmaOptions <- function(...) { #' @title LDER: LD Eigenvalue Regression #' @description Estimate heritability using LD eigenvalue regression (Song et -#' al. 2022). Supports univariate global and local estimation, with optional -#' annotation stratification. +#' al. 2022): one genome-wide estimate, with optional annotation +#' stratification. #' @name pecotmr-h2-lder #' @keywords internal #' @references @@ -476,7 +488,6 @@ NULL A, tau, tauBlocks, - localDf, scoreStats ) { if (is.null(A)) { @@ -485,7 +496,7 @@ NULL tauSe = h2Se, annotationJackknifeCoefs = NULL ) - return(.h2Result(h2, jkRes, intercept, h2, localDf, NULL, scoreStats)) + return(.h2Result(h2, jkRes, intercept, h2, NULL, scoreStats)) } report <- .h2StratifiedReport(A, tau, tauBlocks) jkRes <- list( @@ -493,15 +504,7 @@ NULL tauSe = report$tauSe, annotationJackknifeCoefs = report$annotationJackknifeCoefs ) - .h2Result( - h2, - jkRes, - intercept, - report$tau, - localDf, - report$enrichment, - scoreStats - ) + .h2Result(h2, jkRes, intercept, report$tau, report$enrichment, scoreStats) } # Per-block whitened statistics x_i = (u_i'z)/sqrt(lam_i) and stratified @@ -526,6 +529,15 @@ NULL ) } +# Rows `idx` of an annotation matrix, dense: the matrix may be stored sparse +# (.annotStored()), and each estimator computes on its block as a base matrix. +# Its column and row sums read either form (Matrix's colSums()/rowSums()). +# @noRd +#' @importFrom Matrix colSums rowSums +.denseBlock <- function(A, idx) { + methods::as(A[idx, , drop = FALSE], "matrix") +} + # One block's eigenvalue scores sum_k V_ki^2 a_k for each column of # `annotMat`, with a zero row for each zero-eigenvalue direction the # decomposition does not list: every use multiplies a direction's row by its @@ -534,10 +546,7 @@ NULL if (is.null(annotMat)) { return(NULL) } - listed <- crossprod( - dec$vectors^2, - annotMat[dec$snpIdx, , drop = FALSE] - ) + listed <- crossprod(dec$vectors^2, .denseBlock(annotMat, dec$snpIdx)) rbind(listed, matrix(0, dec$nNull, ncol(annotMat))) } @@ -692,41 +701,6 @@ NULL sqrt((n - 1) / n * sum((v - mean(v))^2)) } -# Local heritability for one block: single-slope fit with intercept fixed at -# the global inflation; h2Local = tau * (block directions). -.lderLocalBlock <- function(bs, b, N, a) { - d <- bs$lam - if (length(d) < 3) { - return(tibble( - blockId = b, - h2Local = NA_real_, - h2LocalSe = NA_real_ - )) - } - chi2 <- bs$x^2 - w <- 1 / (2 * pmax(chi2, 1)^2) - slope <- sum(w * d * (chi2 - (N * a + 1))) / sum(w * d^2) - info <- sum(w * (N * d)^2) - tibble( - blockId = b, - h2Local = slope / N * length(d), - h2LocalSe = length(d) / sqrt(max(info, 1e-10)) - ) -} - -# Per-block local heritability (NULL unless requested). -.lderLocal <- function(blockStats, N, a) { - bind_rows( - map( - seq_along(blockStats), - .lderLocalRow, - blockStats = blockStats, - N = N, - a = a - ) - ) -} - # LDER candidate-annotation score statistics against the fitted baseline: # the regression of chi2 = x^2 on mu = N lam (l_a tau) + N a + 1, scored for # each candidate's column N lam l_c with the weights 1 / (2 mu^2) and the @@ -760,13 +734,7 @@ NULL ) } -lderUnivariate <- function( - z, - n, - eigenRef, - annotations = NULL, - local = FALSE -) { +lderUnivariate <- function(z, n, eigenRef, annotations = NULL) { rough <- !inSample(eigenRef) baselineMat <- .h2DesignMat(annotations) blockStats <- .lderAllBlockStats(eigenRef, z, baselineMat, annotations) @@ -783,7 +751,6 @@ lderUnivariate <- function( TRUE ) jk <- .lderJackknife(blockStats, baselineMat, n, M, design$M_a, rough, TRUE) - localDf <- if (local) .lderLocal(blockStats, n, fit$a) else NULL .h2FitResult( h2 = fit$h2, h2Se = jk$h2Se, @@ -792,7 +759,6 @@ lderUnivariate <- function( A = baselineMat, tau = fit$tau, tauBlocks = jk$annotationJackknifeCoefs, - localDf = localDf, scoreStats = .lderCandidateScores( blockStats, annotations, @@ -845,15 +811,7 @@ lderUnivariate <- function( # Assemble the shared H2Estimate-style result list (used by all methods). -.h2Result <- function( - h2, - jkRes, - intercept, - tau, - localDf, - enrichmentDf, - scoreStats -) { +.h2Result <- function(h2, jkRes, intercept, tau, enrichmentDf, scoreStats) { list( h2 = h2, h2Se = jkRes$se[1], @@ -862,7 +820,6 @@ lderUnivariate <- function( tau = tau, tauSe = jkRes$tauSe, annotationJackknifeCoefs = jkRes$annotationJackknifeCoefs, - local = localDf, enrichment = enrichmentDf, scoreStats = scoreStats ) @@ -913,8 +870,8 @@ NULL # a time (.ldSquaredProduct()). .gldscBlockDesign <- function(block, panel, z, A, candMat) { idx <- block$idx - Ab <- A[idx, , drop = FALSE] - Cb <- if (!is.null(candMat)) candMat[idx, , drop = FALSE] + Ab <- .denseBlock(A, idx) + Cb <- if (!is.null(candMat)) .denseBlock(candMat, idx) scores <- .ldSquaredProduct(.ldStatBlockLd(block, panel), cbind(Ab, Cb)) nA <- ncol(Ab) list( @@ -966,7 +923,6 @@ NULL list( L = crossprod(Pw, P), R = as.vector(crossprod(Pw, Py)), - p = length(block$idx), cand = .gldscCandidatePieces(om, design$ldCand, P, Py) ) } @@ -1022,32 +978,6 @@ NULL ) } -# Local heritability for one LD block: a per-block GLS on [1 | base LD score], -# whose normal equations are the leading 2 x 2 of the block's own; -# h2Local = tau_base * (block SNPs), SE from the GLS coefficient covariance. -.gldscLocalBlock <- function(cb, b, N) { - L <- cb$L[1:2, 1:2] - coef <- solve(L, cb$R[1:2]) - covTau <- (solve(L) / N^2)[2, 2] - tibble( - blockId = b, - h2Local = coef[2] / N * cb$p, - h2LocalSe = sqrt(max(covTau, 0)) * cb$p - ) -} - -# Per-block local heritability (NULL unless requested). -.gldscLocal <- function(contrib, N) { - bind_rows( - map( - seq_along(contrib), - .gldscLocalRow, - contrib = contrib, - N = N - ) - ) -} - # One block's score for each candidate, against the fitted baseline GLS # residual r = y - X coef, with the candidate's LD scores l_c first # residualized on the design: U_c = (l_c - X beta_c)' Omega^-1 r, beta_c = @@ -1127,13 +1057,7 @@ NULL list(scoreZ = unname(U / sqrt(pmax(V, .Machine$double.xmin))), R = R) } -gldscUnivariate <- function( - z, - n, - ldRef, - annotations = NULL, - local = FALSE -) { +gldscUnivariate <- function(z, n, ldRef, annotations = NULL) { if (!.ldScoreHasLd(ldRef)) { abort(c( "g-LDSC needs each LD block's LD, and this LdScore carries none.", @@ -1170,7 +1094,7 @@ gldscUnivariate <- function( right <- reduce(map(contrib, "R"), `+`) fit <- .gldscEstimate(left, right, A, n) jk <- .gldscJackknife(contrib, left, right, A, n) - .gldscResult(fit, jk, annotations, contrib, local, n, M, A) + .gldscResult(fit, jk, annotations, contrib, A) } # The candidate-annotation score statistics, when candidates were supplied. @@ -1190,8 +1114,8 @@ gldscUnivariate <- function( ) } -# Assemble the gldscUnivariate return (enrichment, local, candidate scores). -.gldscResult <- function(fit, jk, annotations, contrib, local, n, M, A) { +# Assemble the gldscUnivariate return (enrichment, candidate scores). +.gldscResult <- function(fit, jk, annotations, contrib, A) { .h2FitResult( h2 = fit$h2, h2Se = jk$h2Se, @@ -1200,7 +1124,6 @@ gldscUnivariate <- function( A = if (is.null(.h2BaselineMat(annotations))) NULL else A, tau = fit$tau, tauBlocks = jk$annotationJackknifeCoefs, - localDf = if (local) .gldscLocal(contrib, n) else NULL, scoreStats = .gldscCandidateScores(annotations, contrib, fit) ) } @@ -1404,8 +1327,8 @@ NULL invisible(TRUE) } -# Baseline modeled variance lamh2_i at the fitted parameters (for local h2 and -# the sHDL candidate score test). +# Baseline modeled variance lamh2_i at the fitted parameters (for the sHDL +# candidate score test). .hdlBaselineVar <- function(design, ft, n, nSamples, lim = exp(-10)) { s <- as.vector(design$ldAnnotScaled %*% ft$h2a) pmax( @@ -1447,68 +1370,376 @@ NULL } # ============================================================================= -# HDL local heritability + sHDL candidate score test +# HDL-L: one locus's heritability with its own intercept # ============================================================================= -# 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, nSamples, int, M, lim = exp(-10)) { - # `intercept`, not `int`: optimize() would partially match `int` to its - # own `interval` argument. - h2 <- optimize( - .hdlLocalNll, - c(0, 1), - bd = bd, - M = M, - nSamples = nSamples, - intercept = int, +# HDL-L's fit of one locus (HDL's HDL.L()), from the standardized marginal +# effects `corInput` (z / sqrt(n)) and the locus' LD source `ld` from a +# reference of `nRef` samples: the rotated effects bstar = V' corInput over the +# eigenvalues that cover 99% of the trace, with modelled variance h2 / M lam^2 +# - h2 lam / nRef + intercept lam / n (.hdlLocusVar()), h2 and the intercept +# fitted together from HDL.L()'s grid of starting values. Returns h2, the +# intercept, HDL.L()'s p-value for h2 (the likelihood ratio against the +# intercept-only null of the chosen start, on one degree of freedom) and the +# number of eigenpairs used. All three are NA when no fit both converges and +# beats the null, where HDL.L() itself stops with an error. +# @noRd +#' @importFrom stats pchisq +.hdlLocusFit <- function(corInput, ld, n, nRef) { + dec <- .hdlLocusEigen(ld) + data <- list( + lam = dec$values, + bstar = as.vector(crossprod(dec$vectors, corInput)), n = n, - lim = lim - )$minimum - lamh2 <- .hdlLocalVar(h2, bd, M, nSamples, int, n, lim) - g <- bd$lam^2 / M - bd$lam / nSamples - info <- sum(g^2 / (2 * lamh2^2)) - tibble( - blockId = b, - h2Local = h2, - h2LocalSe = 1 / sqrt(max(info, 1e-10)) + nRef = nRef, + M = length(corInput) + ) + fits <- pmap( + .hdlLocusStarts(corInput, ld, n), + .hdlLocusFitOne, + data = data + ) + none <- list( + h2 = NA_real_, + intercept = NA_real_, + p = NA_real_, + nComponents = length(dec$values) + ) + accepted <- map_lgl(fits, "accepted") + if (!any(accepted)) { + return(none) + } + best <- fits[[which.max(replace(map_dbl(fits, "value"), !accepted, -Inf))]] + list_modify( + none, + h2 = best$par[[1L]], + intercept = best$par[[2L]], + p = pchisq(2 * (best$value - best$nullValue), 1, lower.tail = FALSE) + ) +} + +# The locus' eigenpairs, cut where they first cover more than 99% of the +# trace (HDL.L()'s eigen.cut, the trace being the number of variants), or +# all of them when they never do. +# @noRd +.hdlLocusEigen <- function(ld) { + dec <- if (!is.null(ld$F)) { + .ldFactorEigen(ld$F) + } else { + eigen(ld$R, symmetric = TRUE) + } + share <- cumsum(dec$values) / .ldSourceSize(ld) + keep <- if (share[[length(share)]] > 0.99) { + which(share > 0.99)[[1L]] + } else { + length(share) + } + list( + values = dec$values[seq_len(keep)], + vectors = dec$vectors[, seq_len(keep), drop = FALSE] ) } -# Modeled variance of one block's bstar^2 at local heritability `h2`, the -# intercept fixed at the global fit; floored at `lim`. +# HDL.L()'s starting values, in the order its loops try them: h2 from the +# weighted LD-score regression, 0 and 0.5; the intercept 1, 0.5, 1.5 and 0; +# the finite-difference step 1e-5, 1e-8 and 1e-16, innermost. # @noRd -.hdlLocalVar <- function(h2, bd, M, nSamples, intercept, n, lim) { +.hdlLocusStarts <- function(corInput, ld, n) { + starts <- expand.grid( + ndeps = c(1e-5, 1e-8, 1e-16), + intercept = c(1, 0.5, 1.5, 0), + h2 = c(.hdlLocusLdscH2(corInput, ld, n), 0, 0.5) + ) + starts[c("h2", "intercept", "ndeps")] +} + +# HDL.L()'s LD-score regression start: corInput^2 on the locus' LD scores, +# by least squares and then weighted by 1 / (h2 l / M + 1 / n)^2 from that +# fit, its slope times M. Where every LD score is the same (one variant, or +# no LD) there is no slope, and the start is 0, already one of the others. +# @noRd +#' @importFrom stats lm coef +.hdlLocusLdscH2 <- function(corInput, ld, n) { + M <- length(corInput) + ldScore <- as.vector(.ldSquaredProduct(ld, matrix(1, M, 1L))) + sq <- corInput^2 + olsH2 <- coef(lm(sq ~ ldScore))[[2L]] * M + if (!is.finite(olsH2)) { + return(0) + } + w <- 1 / (olsH2 * ldScore / M + 1 / n)^2 + coef(lm(sq ~ ldScore, weights = w))[[2L]] * M +} + +# One start: HDL.L()'s fit of (h2, intercept) and of the intercept-only null, +# by L-BFGS-B on the log-likelihood (h2 in [0, 1], the intercept in [0, 20]). +# The fit counts when both converge and the full fit beats the null. +# @noRd +#' @importFrom stats optim +.hdlLocusFitOne <- function(h2, intercept, ndeps, data) { + control <- list(factr = 1e-8, maxit = 1000, trace = 0, fnscale = -1) + opt <- optim( + c(h2, intercept), + .hdlLocusLl, + data = data, + method = "L-BFGS-B", + lower = c(0, 0), + upper = c(1, 20), + control = c(control, list(ndeps = c(ndeps, ndeps * 100))) + ) + null <- optim( + intercept, + .hdlLocusNullLl, + data = data, + method = "L-BFGS-B", + lower = 0, + upper = 20, + control = c(control, list(ndeps = ndeps * 100)) + ) + list( + par = opt$par, + value = opt$value, + nullValue = null$value, + accepted = opt$convergence == 0 && + null$convergence == 0 && + opt$value > null$value + ) +} + +# HDL.L()'s log-likelihood of the locus at (h2, intercept), the modelled +# variance floored at exp(-18). +# @noRd +.hdlLocusLl <- function(param, data) { + lamh2 <- .hdlLocusVar( + param[[1L]], + data, + data$M, + data$nRef, + param[[2L]], + data$n, + exp(-18) + ) + -(sum(log(lamh2)) + sum(data$bstar^2 / lamh2)) / 2 +} + +# The modelled variance of a locus's rotated effects `bd$bstar` at +# heritability `h2` and `intercept`, for M variants, a reference of +# `nSamples` and a study of `n`; floored at `lim`. +# @noRd +.hdlLocusVar <- function(h2, bd, M, nSamples, intercept, n, lim) { pmax( h2 / M * bd$lam^2 - h2 * bd$lam / nSamples + intercept * bd$lam / n, lim ) } -# Gaussian negative log-likelihood (up to a constant) of one block's bstar at -# local heritability `h2` -- what .hdlLocalBlock() minimizes. +# The same at h2 = 0. # @noRd -.hdlLocalNll <- function(h2, bd, M, nSamples, intercept, n, lim) { - lamh2 <- .hdlLocalVar(h2, bd, M, nSamples, intercept, n, lim) - sum(log(lamh2) + bd$bstar^2 / lamh2) +.hdlLocusNullLl <- function(intercept, data) { + .hdlLocusLl(c(0, intercept), data) } -# Per-block local heritability (NULL unless requested). -.hdlLocal <- function(blockData, n, nSamples, int, M) { - bind_rows( - map( - seq_along(blockData), - .hdlLocalRow, - blockData = blockData, - n = n, - nSamples = nSamples, - int = int, - M = M - ) +# ============================================================================= +# Per-gene cis heritability: one window's estimate (for estimateH2() on a +# QtlSumStats, below) +# ============================================================================= + +# Each per-gene method's estimator of one window, from the window's +# z, per-variant sample sizes and LD source (.rssLdSource(), carrying the +# reference's sample size). +# @noRd +.cisH2Estimators <- c( + lava = ".cisH2Lava", + hdlL = ".cisH2HdlL", + fastHer = ".cisH2FastHer" +) + +# One window's result; what a method does not report stays NA. +# @noRd +.cisH2Result <- function( + nComponents, + h2 = NA_real_, + h2Se = NA_real_, + p = NA_real_, + intercept = NA_real_, + scale = NA_real_ +) { + list( + h2 = h2, + h2Se = h2Se, + p = p, + nComponents = as.integer(nComponents), + intercept = intercept, + scale = scale + ) +} + +# The window's LD eigenpairs with positive eigenvalues, largest first: from +# the thin SVD of a factor, or the matrix's own decomposition. +# @noRd +.cisH2Eigen <- function(ld) { + dec <- if (!is.null(ld$F)) { + .ldFactorEigen(ld$F) + } else { + eigen(ld$R, symmetric = TRUE) + } + keep <- dec$values > 0 + list( + values = dec$values[keep], + vectors = dec$vectors[, keep, drop = FALSE] + ) +} + +# LAVA's univariate local heritability, implemented from the estimator as +# Werme et al. (2022, Methods) and LAVA's documentation describe it: LAVA's +# code is not licensed for reuse, and none of it is used here. The marginal +# correlations r_j = z_j / sqrt(z_j^2 + n_j - 2) are projected onto the K +# standardized LD components of .lavaComponents() (no estimate with fewer +# than 2): delta = Lambda_K^-1/2 Q_K' r. h2 is the adjusted R^2, +# delta'delta - K sigma with sigma = (1 - delta'delta) / (n - K - 1) for the +# mean sample size n, times the reference correction (nRef - K - 1) / +# (nRef - 1) that LAVA's release notes describe; p is the F test of +# delta = 0 on the corrected statistic. LAVA withholds h2 where K / n +# exceeds 0.1; it is reported here at any K, since a cis window's K usually +# does. Where delta'delta reaches 1, the LD contradicts the statistics and +# both are NA. +# @noRd +#' @importFrom stats pf +.cisH2Lava <- function(z, nVariant, ld) { + dec <- .cisH2Eigen(ld) + n <- mean(nVariant) + K <- .lavaComponents(dec$values, n) + if (K < 2L) { + return(.cisH2Result(K)) + } + r <- z / sqrt(z^2 + nVariant - 2) + top <- seq_len(K) + delta <- crossprod(dec$vectors[, top, drop = FALSE], r) / + sqrt(dec$values[top]) + dtd <- sum(delta^2) + if (dtd >= 1) { + return(.cisH2Result(K)) + } + sigma <- (1 - dtd) / (n - K - 1) + scale <- (ld$nSamples - K - 1) / (ld$nSamples - 1) + p <- pf(dtd / sigma * scale / K, K, n - K - 1, lower.tail = FALSE) + .cisH2Result(K, h2 = (dtd - K * sigma) * scale, p = p) +} + +# LAVA's number of LD components for a mean sample size n, as its +# documentation gives them: the first K whose eigenvalues hold 99% of the +# variance, at most floor(0.75 n), or 2 if that is less. +# @noRd +.lavaComponents <- function(values, n) { + held <- cumsum(values) / sum(values) + as.integer(min(which(held >= 0.99)[[1L]], max(floor(0.75 * n), 2L))) +} + +# HDL-L's estimate (.hdlLocusFit()) from the z and per-variant sample sizes: +# HDL.L()'s effects z_j / sqrt(n_j) and its median sample size. +# @noRd +.cisH2HdlL <- function(z, nVariant, ld) { + fit <- .hdlLocusFit( + z / sqrt(nVariant), + ld, + median(nVariant), + ld$nSamples + ) + .cisH2Result( + fit$nComponents, + h2 = fit$h2, + p = fit$p, + intercept = fit$intercept + ) +} + +# FastHer's local heritability (Svishcheva 2025), the maximum-likelihood +# estimate HEELS (Li, Mazumder and Lin 2023) reaches by iteration, following +# FastHer's R code (MIT; see inst/COPYRIGHTS) for the inputs, the eigen cut +# and the standard error, with d profiled out of the likelihood instead of +# FastHer's joint optimization: the n study samples' y ~ N(0, d (h2 X X' / m + +# (1 - h2) I)) over the window's m variants, in the eigenbasis of the LD with +# X'X = n R, X'y = sqrt(n) z and y'y = n. As FastHer does, z is rescaled to +# the harmonic mean n of the per-variant sizes and the eigenpairs are kept +# down to the one that reaches 99.999% of the trace (r of them). With a_k = +# (Q'z)_k^2 / lambda_k and S their sum, the likelihood needs r < n and S < n, +# which in-sample LD guarantees; the estimate is NA otherwise. d is profiled +# out, h2 maximized over [0, 1), and its standard error is FastHer's, from +# the expected information in (h2, d). +# @noRd +#' @importFrom stats optimize +.cisH2FastHer <- function(z, nVariant, ld) { + n <- 1 / mean(1 / nVariant) + dec <- .fastHerEigen(.cisH2Eigen(ld)) + r <- length(dec$values) + a <- as.vector(crossprod(dec$vectors, z * sqrt(n / nVariant)))^2 / + dec$values + if (r >= n || sum(a) >= n) { + return(.cisH2Result(r)) + } + ck <- n * dec$values / length(z) - 1 + h2 <- optimize( + .fastHerProfileLl, + c(0, 1 - 1e-9), + a = a, + ck = ck, + n = n, + maximum = TRUE, + tol = 1e-10 + )$maximum + d <- .fastHerScale(h2, a, ck, n) + .cisH2Result(r, h2 = h2, h2Se = .fastHerSe(h2, d, ck, n), scale = d) +} + +# FastHer's eigenpairs: those down to the one at which the eigenvalues reach +# 99.999% of their sum, and any tied with it. +# @noRd +.fastHerEigen <- function(dec) { + held <- cumsum(dec$values) / sum(dec$values) + keep <- dec$values >= dec$values[[which(held > 0.99999)[[1L]]]] + list( + values = dec$values[keep], + vectors = dec$vectors[, keep, drop = FALSE] ) } +# FastHer's log-likelihood at h2 with d at its maximum given h2 +# (.fastHerScale()), up to a constant. +# @noRd +.fastHerProfileLl <- function(h2, a, ck, n) { + W <- 1 + h2 * ck + d <- .fastHerScale(h2, a, ck, n) + -(sum(log(W)) + (n - length(a)) * log(1 - h2) + n * log(d)) / 2 +} + +# d's maximum given h2: (sum(a / W) + (n - S) / (1 - h2)) / n. +# @noRd +.fastHerScale <- function(h2, a, ck, n) { + (sum(a / (1 + h2 * ck)) + (n - sum(a)) / (1 - h2)) / n +} + +# h2's standard error from the expected information in (h2, d), FastHer's: +# with K = ck / W, I_hh = (sum(K^2) + (n - r) / (1 - h2)^2) / 2, I_dd = n / +# (2 d^2) and I_hd = (sum(K) - (n - r) / (1 - h2)) / (2 d). With n > r the +# information is positive definite. +# @noRd +.fastHerSe <- function(h2, d, ck, n) { + K <- ck / (1 + h2 * ck) + rest <- (n - length(ck)) / (1 - h2) + info <- matrix( + c( + sum(K^2) + rest / (1 - h2), + (sum(K) - rest) / d, + (sum(K) - rest) / d, + n / d^2 + ), + 2L, + 2L + ) / + 2 + sqrt(solve(info)[[1L, 1L]]) +} + # sHDL candidate-annotation score statistics. Each eigen-direction's rotated # effect has modelled variance v_i = lamh2_i, and the likelihood's score for # a candidate's heritability is sum_i g_ic (bstar_i^2 / v_i^2 - 1 / v_i), @@ -1554,13 +1785,7 @@ NULL # hdlUnivariate -- orchestrator # ============================================================================= -hdlUnivariate <- function( - z, - n, - eigenRef, - annotations = NULL, - local = FALSE -) { +hdlUnivariate <- function(z, n, eigenRef, annotations = NULL) { M <- length(eigenRef) nPanel <- ldPanelNSamples(eigenRef) baselineMat <- .h2DesignMat(annotations) @@ -1577,7 +1802,6 @@ hdlUnivariate <- function( design <- .hdlDesign(blockData, M, baselineMat) ft <- .hdlFit(design, n, nPanel) jk <- .hdlJackknife(blockData, M, baselineMat, n, nPanel) - localDf <- if (local) .hdlLocal(blockData, n, nPanel, ft$int, M) else NULL .h2FitResult( h2 = ft$h2, h2Se = jk$h2Se, @@ -1586,7 +1810,6 @@ hdlUnivariate <- function( A = baselineMat, tau = ft$h2a / design$M_a, tauBlocks = sweep(jk$h2aBlocks, 2L, design$M_a, "/"), - localDf = localDf, scoreStats = .hdlCandidateScores( blockData, nPanel, @@ -1698,14 +1921,7 @@ NULL NULL # @noRd -sldscUnivariate <- function( - z, - n, - ldRef, - annotations = NULL, - local = FALSE, - nIter = 2L -) { +sldscUnivariate <- function(z, n, ldRef, annotations = NULL, nIter = 2L) { M <- length(ldRef) chi2 <- z^2 # Same design g-LDSC uses (.h2DesignMat()), so `crossprod(A)` is the @@ -1726,7 +1942,6 @@ sldscUnivariate <- function( A = if (is.null(.h2BaselineMat(annotations))) NULL else A, tau = fit$tau, tauBlocks = jk$annotationJackknifeCoefs, - localDf = if (local) .sldscLocal(chi2, baseScore, fit) else NULL, scoreStats = scoreStats ) } @@ -1820,7 +2035,7 @@ sldscUnivariate <- function( # @noRd .h2BlockAnnotScores <- function(block, panel, annotMat, nRef) { idx <- block$idx - Ab <- annotMat[idx, , drop = FALSE] + Ab <- .denseBlock(annotMat, idx) raw <- .ldSquaredProduct(.ldStatBlockLd(block, panel), Ab) list(idx = idx, values = .ldscUnbiasedSum(raw, colSums(Ab), nRef)) } @@ -2084,18 +2299,6 @@ sldscUnivariate <- function( ) } -# Per-variant local h2 contribution: the fitted non-intercept signal spread -# over the variant's own LD score. -# @noRd -.sldscLocal <- function(chi2, baseScore, fit) { - tibble( - variantIdx = seq_along(chi2), - chi2 = chi2, - ldScore = baseScore, - h2Local = fit$tau[[1L]] * pmax(baseScore, 0) - ) -} - # ============================================================================= # estimateH2 -- main dispatch # ============================================================================= @@ -2125,7 +2328,6 @@ sldscUnivariate <- function( n, ldRef, annotations, - local, estimatorArgs = list() ) { # `estimatorArgs` rather than `...`: the estimators take different @@ -2135,7 +2337,7 @@ sldscUnivariate <- function( # ridge `lambda` here that nothing read -- the original LDER and HDL # implementations have no such penalty, and the function behind it had no # callers. - base <- list(z, n, ldRef, annotations, local) + base <- list(z, n, ldRef, annotations) fn <- switch( method, "lder" = lderUnivariate, @@ -2228,21 +2430,34 @@ sldscUnivariate <- function( abort(msg) } -# Wrap a univariate estimator result list into an H2Estimate S4 object. -.h2EstimateFromResult <- function(result, method, M, studyName) { - new( - "H2Estimate", - estimate = result$h2, - estimateSe = result$h2Se, - intercept = result$intercept %||% NA_real_, - interceptSe = result$interceptSe %||% NA_real_, - localBlocks = result$local, - enrichment = result$enrichment, - annotationJackknifeCoefs = result$annotationJackknifeCoefs, - scoreStats = result$scoreStats, - method = method, - nSnps = as.integer(M), - traitName = studyName +# A univariate estimator's result as an H2Estimate of one genome-wide +# estimate, one row for the study. The estimate covers the whole reference, +# which spans more chromosomes than an element may, so its element holds no +# ranges; the row takes the reference's genome. +# @noRd +.h2EstimateFromResult <- function(result, method, M, studyName, ldRef) { + .h2EstimateNew( + list(GenomicRanges::GRanges()), + list( + study = studyName, + context = NA_character_, + trait = NA_character_, + method = method, + h2 = unname(result$h2), + h2_se = unname(result$h2Se), + intercept = unname(result$intercept %||% NA_real_), + intercept_se = unname(result$interceptSe %||% NA_real_), + p_value = NA_real_, + n_snps = as.integer(M), + n_components = NA_integer_, + scale = NA_real_ + ), + list( + enrichment = list(result$enrichment), + jackknife = list(result$annotationJackknifeCoefs), + score_stats = list(result$scoreStats) + ), + ldRef ) } @@ -2256,7 +2471,6 @@ setMethod( ldRef, method = "lder", annotations = NULL, - local = FALSE, studyName = NULL, estimatorArgs = list() ) { @@ -2277,10 +2491,9 @@ setMethod( n, ldRef, annotations, - local, estimatorArgs = estimatorArgs ) - .h2EstimateFromResult(result, method, M, studyName) + .h2EstimateFromResult(result, method, M, studyName, ldRef) } ) @@ -2303,6 +2516,209 @@ setMethod( invisible(TRUE) } +# ============================================================================= +# estimateH2 on QTL summary statistics -- one cis estimate per gene +# ============================================================================= + +#' @rdname estimateH2 +#' @param contexts For a \code{QtlSumStats}: optional context selection, as +#' \code{\link{twasWeightsPipeline}} takes it; \code{NULL} (the default) +#' uses every context. +#' @param traitId For a \code{QtlSumStats}: optional trait selection, as +#' \code{\link{twasWeightsPipeline}} takes it; \code{NULL} (the default) +#' uses every trait. +#' @param cisWindow For a \code{QtlSumStats}: optionally, each selected row +#' is analysed over its \code{traitPos} \eqn{\pm} \code{cisWindow}, within +#' its \code{region}. Every selected row then needs a \code{traitPos}. +#' @param BPPARAM For a \code{QtlSumStats}: a \code{BiocParallelParam} over +#' the selected rows, each row's estimate on one worker. Default +#' \code{SerialParam()}. +#' @export +#' @importFrom BiocParallel SerialParam +setMethod( + "estimateH2", + signature(sumstats = "QtlSumStats", ldRef = "missing"), + function( + sumstats, + ldRef, + method = "lava", + annotations = NULL, + contexts = NULL, + traitId = NULL, + cisWindow = NULL, + BPPARAM = SerialParam() + ) { + method <- arg_match(method, names(.cisH2Estimators)) + .cisH2AssertInput(sumstats, annotations) + selection <- .qssSelection( + sumstats, + contexts, + traitId, + cisWindow, + "estimateH2" + ) + fits <- .bpMap( + .cisH2SelectedRows(selection), + .cisH2Row, + data = selection$data, + method = method, + BPPARAM = BPPARAM + ) + out <- .h2EstimateNew( + map(fits, "window"), + as.list(list_rbind(map(fits, "values"))), + .h2NoObjects(length(fits)), + sumstats + ) + .cisH2WarnEmpty(out) + .cisH2WarnUndefined(out, method) + out + } +) + +# The input a cis estimate needs: QC'd QTL summary statistics, and none of +# the genome-wide estimators' annotations. +# @noRd +.cisH2AssertInput <- function(data, annotations) { + if (length(qcOptions(data)) == 0L) { + abort(glue( + "estimateH2: the QtlSumStats has no QC record (qcOptions() ", + "is empty). Call summaryStatsQc() first and pass the QC-applied ", + "result." + )) + } + if (!is.null(annotations)) { + abort(c( + str_c( + "estimateH2: a cis estimate from QTL summary statistics takes ", + "no `annotations`." + ), + i = str_c( + "They partition a genome-wide estimate from GWAS summary ", + "statistics." + ) + )) + } + invisible(NULL) +} + +# The rows the selection keeps, refusing an empty selection. +# @noRd +.cisH2SelectedRows <- function(selection) { + rows <- which(.sumStatsRowsSelected( + selection$data, + selection$contexts, + selection$traitId + )) + if (length(rows) == 0L) { + abort(glue( + "estimateH2: no rows matched the supplied contexts / traitId ", + "filters." + )) + } + rows +} + +# One row's estimate, from its z and per-variant sample sizes against its LD +# reference's block for those variants: the window it covers, and its values. +# @noRd +.cisH2Row <- function(i, data, method) { + st <- as.character(data$study[[i]]) + ctx <- as.character(data$context[[i]]) + tr <- as.character(data$trait[[i]]) + label <- glue("estimateH2: study='{st}', context='{ctx}', trait='{tr}'") + df <- .sumStatsDf( + data, + studyName = st, + context = ctx, + trait = tr, + require = c("Z", "N"), + derive = "zFromBetaSe" + ) + fit <- .cisH2Fit(df, .rowLdRef(data, i), method, label) + list( + window = .rowRegionAt(data, i), + values = tibble( + study = st, + context = ctx, + trait = tr, + method = method, + h2 = fit$h2, + h2_se = fit$h2Se, + intercept = fit$intercept, + intercept_se = NA_real_, + p_value = fit$p, + n_snps = nrow(df), + n_components = fit$nComponents, + scale = fit$scale + ) + ) +} + +# One row's fit by `method`; NA when its window holds no variants, as there +# is nothing to estimate from. +# @noRd +.cisH2Fit <- function(df, ldReference, method, label) { + if (nrow(df) == 0L) { + return(.cisH2Result(NA_integer_)) + } + ld <- .cisH2LdSource(df$variant_id, ldReference, method, label) + exec(.cisH2Estimators[[method]], z = df$z, nVariant = df$N, ld = ld) +} + +# The row's LD source (.rssLdSource()) for its variants, refusing a missing +# reference, and for the methods that read the reference's sample size, a +# reference that does not record it. +# @noRd +.cisH2LdSource <- function(ids, ldReference, method, label) { + if (is.null(ldReference)) { + abort(glue("{label}: the row has no LD reference.")) + } + ld <- .rssLdSource(list(variantNames = ids), ldReference, label) + if (is_in(method, c("lava", "hdlL")) && is.na(ld$nSamples)) { + abort(c( + glue( + "{label}: method = \"{method}\" reads the LD reference's ", + "sample size." + ), + i = "Build the LdMatrix with `nSamples`." + )) + } + ld +} + +# A gene whose window holds no variants has no estimate; one warning lists +# them. +# @noRd +.cisH2WarnEmpty <- function(out) { + empty <- out$n_snps == 0L + if (!any(empty)) { + return(invisible(NULL)) + } + warn(glue( + "estimateH2: {sum(empty)} of {length(empty)} gene(s) hold no ", + "variants in their window; their h2 is NA: ", + "{str_flatten(out$trait[empty], ', ')}." + )) +} + +# FastHer's likelihood is undefined for some genes (see estimateH2()); one +# warning lists them. +# @noRd +.cisH2WarnUndefined <- function(out, method) { + undefined <- identical(method, "fastHer") & is.na(out$h2) & out$n_snps > 0L + if (!any(undefined)) { + return(invisible(NULL)) + } + warn(glue( + "estimateH2: FastHer's likelihood is undefined for ", + "{sum(undefined)} of {nrow(out)} gene(s), whose LD reference's rank ", + "or statistics reach the sample size (an external reference larger ", + "than the study); their h2 is NA: ", + "{str_flatten(out$trait[undefined], ', ')}." + )) +} + # ============================================================================= # computeLdScores -- LD score computation # ============================================================================= @@ -2391,7 +2807,7 @@ setMethod( .h2BlockStratScores <- function(block, ldRef, annotMat, nRef) { dec <- .ldEigenBlockAt(block, ldRef) idx <- dec$snpIdx - Ab <- annotMat[idx, , drop = FALSE] + Ab <- .denseBlock(annotMat, idx) raw <- .ldSquaredProduct(dec[c("vectors", "values")], cbind(1, Ab)) list( idx = idx, @@ -2446,9 +2862,8 @@ setMethod( } ) -# H2Estimate accessor methods (localH2Blocks / -# stratifiedHeritabilityEnrichment / scoreStats) live -# in R/h2Estimate.R alongside the class definition. +# H2Estimate accessor methods (stratifiedHeritabilityEnrichment / +# scoreStats) live in R/H2Estimate.R alongside the class definition. # ============================================================================= # Converter: H2Estimate -> sldsc_wrapper list format @@ -2460,8 +2875,10 @@ 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 -#' \code{annotationJackknifeCoefs}. +#' @param h2Est An \code{H2Estimate} holding one stratified estimate, with +#' its enrichment table and \code{annotationJackknifeCoefs}. Select one +#' from several by its identity columns, e.g. +#' \code{x[x$study == "trait1"]}. #' @return A named list matching the format of \code{\link{readSldscTrait}}: #' \describe{ #' \item{categories}{Character vector of annotation names} @@ -2482,8 +2899,9 @@ setMethod( #' @export h2EstimateToSldscTrait <- function(h2Est) { assertClass(h2Est, "H2Estimate") - - enrichDf <- stratifiedHeritabilityEnrichment(h2Est) + .h2AssertOneEstimate(h2Est) + md <- mcols(h2Est, use.names = FALSE) + enrichDf <- md$enrichment[[1L]] if (is.null(enrichDf)) { msg <- glue( "H2Estimate has no enrichment results. ", @@ -2493,9 +2911,8 @@ h2EstimateToSldscTrait <- function(h2Est) { } cats <- as.character(enrichDf$annotation) - nCats <- length(cats) - rawTau <- annotationJackknifeCoefs(h2Est) + rawTau <- md$jackknife[[1L]] # Without per-block estimates the point estimates stand in as one block. jkCoefs <- `colnames<-`( rawTau %||% matrix(enrichDf$tau, nrow = 1), @@ -2512,12 +2929,27 @@ h2EstimateToSldscTrait <- function(h2Est) { enrichmentP = set_names(enrichDf$enrichmentP, cats), propH2 = set_names(enrichDf$propH2, cats), propSnps = set_names(enrichDf$propSnps, cats), - h2g = heritabilityEstimate(h2Est), + h2g = md$h2[[1L]], annotationJackknifeCoefs = jkCoefs, nBlocks = nBlocks ) } +# An error unless the H2Estimate holds one estimate. +# @noRd +.h2AssertOneEstimate <- function(h2Est) { + if (length(h2Est) == 1L) { + return(invisible(h2Est)) + } + abort(c( + glue( + "h2EstimateToSldscTrait: the H2Estimate holds {length(h2Est)} ", + "estimates; it converts one." + ), + i = "Select one by its identity, e.g. `x[x$study == \"trait1\"]`." + )) +} + # ---- map/apply helpers (lambda-free callbacks) --------------------------- # One LDER delete-one-block jackknife fold: design and fit with block `b` left @@ -2537,12 +2969,6 @@ h2EstimateToSldscTrait <- function(h2Est) { .lderGetRes(d$x, d$lam, d$ldAnnot, N, M, M_aFull, rough, twostage) } -# One LDER local-heritability row for block `b`. -# @noRd -.lderLocalRow <- function(b, blockStats, N, a) { - .lderLocalBlock(blockStats[[b]], b, N, a) -} - # One g-LDSC delete-one-block jackknife fold: re-solve the normal equations with # block `cb`'s Omega-weighted contribution removed. # @noRd @@ -2550,12 +2976,6 @@ h2EstimateToSldscTrait <- function(h2Est) { .gldscEstimate(left - cb$L, right - cb$R, A, N) } -# One g-LDSC local-heritability row for block `b`. -# @noRd -.gldscLocalRow <- function(b, contrib, N) { - .gldscLocalBlock(contrib[[b]], b, N) -} - # g-LDSC leave-one-block-out standardized candidate score vector for block `b`. # @noRd # One HDL delete-one-block jackknife fold: refit leaving block `b` out. @@ -2570,9 +2990,3 @@ h2EstimateToSldscTrait <- function(h2Est) { warnOnBound = FALSE ) } - -# One HDL local-heritability row for block `b`. -# @noRd -.hdlLocalRow <- function(b, blockData, n, nSamples, int, M) { - .hdlLocalBlock(blockData[[b]], b, n, nSamples, int, M) -} diff --git a/R/jointEngine.R b/R/jointEngine.R index 5f1ff8f9c..add5d3c94 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -794,15 +794,15 @@ setMethod( } # Reshape a twasWeightsCv() result into the single joint entry's cvResult: the -# out-of-fold prediction matrix, the per-condition metric rows, and the per-fold -# mr.mash fits (named fold_) that fineMappingPipeline's mvSuSiE path -# consumes. +# out-of-fold prediction matrix, the per-condition metric rows, and -- for +# mr.mash only, the one method whose fold fits are read -- the per-fold fits +# (named fold_) fineMappingPipeline builds each fold's mvSuSiE prior from. .jointTwasCvResult <- function(cv, token) { if (is.null(cv)) { return(NULL) } ffKey <- str_c(token, "_weights") - foldFits <- if (!is.null(cv$foldFits)) { + foldFits <- if (.twasKeepsFoldFits(token) && !is.null(cv$foldFits)) { ff <- map(cv$foldFits, ffKey) if (all(map_lgl(ff, is.null))) NULL else ff } else { @@ -832,11 +832,14 @@ setMethod( if (is.null(fineMappingCv) || is.null(fineMappingCv$prediction)) { return(NULL) } + # The fine-mapping CV names its tables by the method's key (susie_inf), + # which differs from the twas token (susieInf) for some methods. + key <- .fmTwasMethodKey(token) base <- str_remove( names(fineMappingCv$prediction), "(_predicted|Predicted)$" ) - hit <- which(base == token) + hit <- which(base == key) if (length(hit) == 0L) { return(NULL) } @@ -844,7 +847,7 @@ setMethod( names(fineMappingCv$performance), "(_performance|Performance)$" ) - pHit <- which(pBase == token) + pHit <- which(pBase == key) list( samplePartition = fineMappingCv$samplePartition, predictions = fineMappingCv$prediction[[hit[[1L]]]], @@ -852,14 +855,17 @@ setMethod( fineMappingCv$performance[[pHit[[1L]]]] } else { NULL - }, - # The fine-mapping CV refits the method on each fold's training rows; - # those fits are what let a SuSiE-family method be cross-validated at - # all now that its weight wrappers never fit. - foldFits = fineMappingCv$foldFits + } ) } +# Whether a TWAS method's cross-validation keeps its per-fold fits: only +# mr.mash's are read (fineMappingPipeline's per-fold mvSuSiE priors). +# @noRd +.twasKeepsFoldFits <- function(token) { + identical(token, "mrmash") +} + # (individual, twas) -> ONE weight method fit over the group's conditions, as # per-condition entries (sliced from the variants x conditions weight matrix), # each with its full-data weights + retained fit + per-condition CV slice. This @@ -902,7 +908,8 @@ setMethod( fittedModels, cfg, stdz, - nCond + nCond, + token ) cvRes <- .jointTwasCv(Xc, Yc, wm, ma, full$W, args, cfg, token) # One per-condition entry: that condition's weight column + the shared @@ -918,6 +925,13 @@ setMethod( } ) +# The first of `keys` that `lst` holds, or NULL. +# @noRd +.jointTwasSuppliedArgs <- function(lst, keys) { + hit <- intersect(keys, names(lst)) + if (length(hit) == 0L) NULL else lst[[hit[[1L]]]] +} + # Resolve the method args for a TWAS token: prefer the unified methodList, else # the explicit-jointSpec methodArgs; inject an FM-derived fit; compute a # spike-and-slab pi for bayes_c / bayes_b when estimatePi is on. @@ -933,15 +947,12 @@ setMethod( cfg, stdz ) { - supplied <- if ( - !is.null(args$methodList) && is_in(methodKey, names(args$methodList)) - ) { - args$methodList[[methodKey]] - } else if (!is.null(args$methodArgs)) { - args$methodArgs[[methodKey]] - } else { - NULL - } + # A method's arguments sit under its .twasMethodMap list key + # (bayes_r_weights), which differs from its engine key (bayesR_weights) + # for every multi-word token, so both are looked up. + keys <- unique(c(methodKey, .twasMethodMap[[token]]$fn)) + supplied <- .jointTwasSuppliedArgs(args$methodList, keys) %||% + .jointTwasSuppliedArgs(args$methodArgs, keys) # FM-fit injection: an FM-derived token extracts its weights from the # precomputed fine-mapping fit rather than refitting. withFit <- .jointTwasInjectFit( @@ -973,6 +984,10 @@ setMethod( # Spike-and-slab pi from an internal mr.ash fit (self-contained per method). # @noRd .jointTwasSpikeSlabPi <- function(ma, token, Xc, Yc, cond, cfg, stdz) { + # A pi the caller set wins, and then no mr.ash fit is needed. + if (!is.null(ma$pi)) { + return(ma) + } mrA <- learnTwasWeights( Xc, Yc, @@ -986,23 +1001,18 @@ setMethod( verbose = 0, seed = cfg$seed ) - piHat <- as.numeric(estimateSparsity(mrA)) - list_assign( - ma, - !!!compact(list( - pi = if (token == "bayesC" && is.null(ma$pi)) piHat, - probIn = if (token == "bayesB" && is.null(ma$probIn)) piHat - )) - ) + list_assign(ma, pi = as.numeric(estimateSparsity(mrA))) } -# The retention level a joint fit runs at. The engine always keeps its fit -- -# the joint layers downstream read it -- so "none" from the pipeline means -# "keep the least we can", not "keep nothing". +# The retention level a joint fit runs at. The engine keeps its fit -- the +# joint layers downstream read it -- so "none" from the pipeline means "keep +# the least we can", not "keep nothing". A fine-mapping token's fit is the +# fineMappingResult's own, which its TWAS rows keep none of +# (.twasRowRetention()). # @noRd -.jointRetentionLevel <- function(cfg) { +.jointRetentionLevel <- function(cfg, token = NULL) { level <- cfg$fitRetention %||% "slim" - if (identical(level, "none")) "slim" else level + .twasRowRetention(token, if (identical(level, "none")) "slim" else level) } # The mr.mash RSS fit of one summary-statistics joint group, with the caller's @@ -1038,12 +1048,13 @@ setMethod( fittedModels, cfg, stdz, - nCond + nCond, + token ) { if (!.jointFitsFullData(cfg)) { return(list(W = NULL, fitParts = NULL, vids = colnames(Xc))) } - retention <- .jointRetentionLevel(cfg) + retention <- .jointRetentionLevel(cfg, token) verbose <- if (is.null(cfg$verbose)) 1 else cfg$verbose tw <- learnTwasWeights( Xc, @@ -1151,7 +1162,7 @@ setMethod( # twasWeightsCv() over this cell, with the CV settings resolved from the # per-call args first and the pipeline config as the fallback. # @noRd -.jointTwasRunCv <- function(Xc, Yc, wm, args, cfg, cvFolds) { +.jointTwasRunCv <- function(Xc, Yc, wm, args, cfg, cvFolds, token) { cv <- cfg$crossValidationParam %||% list() maxCv <- if ((cv$maxVariants %||% -1) <= 0) { Inf @@ -1164,7 +1175,7 @@ setMethod( fold = cvFolds, samplePartitions = args$samplePartition %||% cv$samplePartition, weightMethods = wm, - fitRetention = "slim", + fitRetention = if (.twasKeepsFoldFits(token)) "slim" else "none", maxNumVariants = maxCv, BPPARAM = cv$BPPARAM %||% SerialParam(), dataDrivenPriorMatricesCv = args$dataDrivenPriorMatricesCv, @@ -1190,7 +1201,7 @@ setMethod( } .jointTwasLeakageWarn(args, ma) .jointTwasCvResult( - .jointTwasRunCv(Xc, Yc, wm, args, cfg, cvFolds), + .jointTwasRunCv(Xc, Yc, wm, args, cfg, cvFolds, token), token ) } @@ -1301,15 +1312,16 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { return(list()) } verbose <- if (is.null(args$verbose)) 1 else args$verbose - compact(map( + map( scopedTraits, - .enumCrossContextGroupFor, + .deferGroups, + builder = .enumCrossContextGroupFor, data = data, studyName = studyName, scopedContexts = scopedContexts, args = args, verbose = verbose - )) + ) } # One trait's cross-context group, or NULL when it has no usable (X, Y). @@ -1481,15 +1493,16 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scopedContexts <- scope$contexts[[studyName]] scopedTraits <- scope$traits[[studyName]] verbose <- if (is.null(args$verbose)) 1 else args$verbose - compact(map( + map( scopedContexts, - .enumCrossTraitGroupFor, + .deferGroups, + builder = .enumCrossTraitGroupFor, data = data, studyName = studyName, scopedTraits = scopedTraits, args = args, verbose = verbose - )) + ) } # One context's cross-trait group, or NULL when it has no usable (X, Y). @@ -1801,15 +1814,16 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s = studyName, cx = cx ) - compact(map( + map( traits, - .enumUnivariateGroupFor, + .deferGroups, + builder = .enumUnivariateGroupFor, data = data, args = args, studyName = studyName, cx = cx, phenotypeFilter = phenotypeFilter - )) + ) } # One (context, trait) univariate group, or NULL when fewer than two samples @@ -1940,7 +1954,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ) } -# The group's fine-mapping fits + CV, keyed on its first condition. Empty when +# The group's fine-mapping fits, read off its first condition's row (every +# condition's row of a joint fit keys the one fit), and its CV. Empty when # the caller supplied no fine-mapping result. # @noRd .twasGroupFmArgs <- function(args, cond) { @@ -1960,10 +1975,71 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { } else { .twasFitsForRegion(af, bi, nR) }, - fineMappingCv = .twasCvResultFor(fmRes, s1, c1, t1) + fineMappingCv = .twasGroupFmCv(fmRes, cond) + ) +} + +# The group's fine-mapping CV with one prediction column and one performance +# row per condition, in the group's order -- the shape .jointTwasCvResult() +# gives, which the per-condition slice indexes. A joint fit stores each +# condition's slice on that condition's row, so the first row alone covered +# only the first condition. A method is handed off only when every condition +# carries its CV, and only from one fold partition. +# @noRd +.twasGroupFmCv <- function(fmRes, cond) { + cvs <- pmap( + list( + studyName = as.character(cond$study), + context = as.character(cond$context), + trait = as.character(cond$trait) + ), + .twasCvResultFor, + fineMappingResult = fmRes + ) + if (length(cvs) == 1L) { + return(cvs[[1L]]) + } + if (any(map_lgl(cvs, is.null))) { + return(NULL) + } + .twasCheckGroupPartitions(map(cvs, "samplePartition"), cond) + list( + samplePartition = cvs[[1L]]$samplePartition, + prediction = .twasCvBindKeys(map(cvs, "prediction"), cbind), + performance = .twasCvBindKeys(map(cvs, "performance"), rbind) ) } +# The conditions of one joint group were cross-validated together, so their +# fine-mapping rows share one fold partition. Rows from separate runs would +# pair out-of-fold predictions made on different folds. +# @noRd +.twasCheckGroupPartitions <- function(partitions, cond) { + if (all(map_lgl(partitions, identical, partitions[[1L]]))) { + return(invisible(NULL)) + } + labels <- str_c(cond$study, cond$context, cond$trait, sep = ":") + abort(glue( + "twasWeightsPipeline: the fine-mapping cross-validation of ", + "{str_c(labels, collapse = ', ')} used different fold partitions; ", + "a joint group needs the CV of one joint fit." + )) +} + +# Per key every condition carries, the conditions' pieces bound into one +# matrix: cbind for sample x condition predictions, rbind for condition x +# metric performance. +# @noRd +.twasCvBindKeys <- function(pieces, bind) { + keys <- reduce(map(pieces, names), intersect) + set_names(map(keys, .twasCvBindKey, pieces = pieces, bind = bind), keys) +} + +# @noRd +.twasCvBindKey <- function(key, pieces, bind) { + exec(bind, !!!map(pieces, key)) +} + # The fold partition every method in this group is scored on. A fine-mapping # CV carries fits tied to its own folds, so when one is present it governs: # the other weight methods are cross-validated on those same folds, which is @@ -2033,18 +2109,44 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # @noRd .jointEntryRecords <- function(entries, method, grp, data) { cond <- grp$cond + n <- min(length(entries), nrow(cond)) recs <- map( - seq_len(min(length(entries), nrow(cond))), + seq_len(n), .jointEntryRecordAt, entries = entries, cond = cond, method = method, grp = grp, - data = data + data = data, + jointIndex = .jointIndexOf(entries[seq_len(n)], grp) ) compact(recs) } +# Each entry's position in its joint fit's condition axis: its rank among the +# group's fitted conditions, as a condition the SER screen dropped has no +# entry. NA for a group that is not a joint fit. +# @noRd +.jointIndexOf <- function(entries, grp) { + out <- rep(NA_integer_, length(entries)) + if (!.jointGroupIsJoint(grp)) { + return(out) + } + fitted <- !map_lgl(entries, is.null) + replace(out, fitted, seq_len(sum(fitted))) +} + +# Whether group `grp` joins conditions (a joint* axis is set). +# @noRd +.jointGroupIsJoint <- function(grp) { + any(map_lgl(list(grp$js, grp$jc, grp$jt), .jointAxisIsSet)) +} + +# @noRd +.jointAxisIsSet <- function(value) { + length(value) == 1L && !is.na(value) +} + # Run one dispatch cell: enumerate joint groups, fit each method (S4 dispatch on # the group x pipeline pair) per group, accumulate per-context rows, build the # per-pipeline result. The loop is GROUP-outer / token-inner so the twas @@ -2060,16 +2162,49 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { } else { scope$traitSelection } - groups <- .jcEnumerate(cell)(data, scope, args) |> + doEnsemble <- is(pipeline, "TwasJointPipeline") && + isTRUE(.jpConfig(pipeline)$ensembleParam$enabled) + perUnit <- map( + .jcEnumerate(cell)(data, scope, args), + .jointCellUnit, + selection = selection, + minGroup = .jcMinGroup(cell), + pipeline = pipeline, + data = data, + tokens = tokens, + args = args, + doEnsemble = doEnsemble + ) + fitted <- discard(perUnit, is.null) + if (length(fitted) == 0L) { + return(NULL) + } + construct(pipeline, .jeConcat(fitted)) +} + +# One enumerated unit built, filtered and fitted: the records of its groups, +# or NULL when none survives the selection and the minimum size. The unit is +# built here, inside the loop, so its residualized X is let go before the next +# unit's is built. +# @noRd +.jointCellUnit <- function( + unit, + selection, + minGroup, + pipeline, + data, + tokens, + args, + doEnsemble +) { + groups <- .unitGroups(unit) |> map(.jointGroupSelect, traitId = selection) |> compact() |> - keep(.jointGroupMeetsMin, minGroup = .jcMinGroup(cell)) + keep(.jointGroupMeetsMin, minGroup = minGroup) if (length(groups) == 0L) { return(NULL) } - doEnsemble <- is(pipeline, "TwasJointPipeline") && - isTRUE(.jpConfig(pipeline)$ensembleParam$enabled) - records <- list_flatten(map( + list_flatten(map( groups, .jointCellGroup, pipeline = pipeline, @@ -2078,7 +2213,31 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { args = args, doEnsemble = doEnsemble )) - construct(pipeline, records) +} + +# A unit of joint groups not built yet: the function that builds it, and its +# arguments, `x` first. The individual-level enumerators return these, so a +# unit's residualized X and Y exist only while its groups are fitted rather +# than every unit's being held at once. A unit is one group, or a context's +# principal components, which share one X. +# @noRd +.deferGroups <- function(x, builder, ...) { + list(builder = builder, args = list(x, ...)) +} + +# The groups of an enumerated unit: built when it was deferred, as given when +# it was enumerated built (the summary-statistics groups, which hold no X). +# @noRd +.unitGroups <- function(unit) { + built <- if (is(unit, "JointGroup")) { + unit + } else { + exec(unit$builder, !!!unit$args) + } + if (is(built, "JointGroup")) { + return(list(built)) + } + compact(as.list(built)) } # The group less any (context, trait) condition a per-context `traitId` @@ -2139,7 +2298,11 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ldReference = .jgLdRefOf(g) ) fitArgs <- .twasGroupArgs(g, pipeline, args) - fitArgs$af <- .jointAfForGroup(data, g, args$genotypeFilter) + # Allele frequencies go into fine-mapping's topLoci; TWAS never reads + # them, and computing them reads the group's genotypes a second time. + fitArgs$af <- if (is(pipeline, "FmJointPipeline")) { + .jointAfForGroup(data, g, args$genotypeFilter) + } fitArgs$region <- args$region perTokenEntries <- compact(set_names( map( @@ -2395,15 +2558,17 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { return(list()) } phenotypeFilter <- .jointPhenotypeFilter(args) - .jeConcat(map( + # One unit per context: its components share the context's one X. + map( scope$contexts[[studyName]], - .enumTopPcForContext, + .deferGroups, + builder = .enumTopPcForContext, data = data, scope = scope, args = args, studyName = studyName, phenotypeFilter = phenotypeFilter - )) + ) } # @noRd @@ -2763,10 +2928,32 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .jointBuildRecordPart <- function(rec, constructor) { jointCols <- c("jointStudies", "jointContexts", "jointTraits") absent <- jointCols[map_lgl(rec[jointCols], .jointAxisIsAbsent)] - kept <- rec[setdiff(names(rec), absent)] + kept <- rec[setdiff(names(rec), c(absent, "study", "jointIndex"))] # `list_assign()`, not `list_modify()`: the entry payload is itself a - # list, and list_modify would merge into it rather than wrap it. - exec(constructor, !!!list_assign(kept, entry = list(rec$entry))) + # list, and list_modify would merge into it rather than wrap it. The + # study goes in under the constructor's own name, not by partial + # matching. + part <- exec( + constructor, + !!!list_assign(kept, studyName = rec$study, entry = list(rec$entry)) + ) + .withJointIndex(part, rec$jointIndex) +} + +# `x`, one row of one method, recording its position in its joint fit's +# condition axis (`jointIndex`, internal). A row from no joint fit records +# none, so a collection holding no joint rows has no such column. +# @noRd +.withJointIndex <- function(x, jointIndex) { + if (is.null(jointIndex) || is.na(jointIndex)) { + return(x) + } + value <- if (methods::is(x, "TwasWeights")) { + IRanges::IntegerList(jointIndex) + } else { + jointIndex + } + `$<-`(x, "jointIndex", value) } # TRUE when tuple row `r`'s study keeps context `cx` and trait `tid` in scope. @@ -2789,7 +2976,15 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # (.jointGroupWindow(): an explicit region, else the union of its traits' cis # windows). # @noRd -.jointEntryRecordAt <- function(i, entries, cond, method, grp, data) { +.jointEntryRecordAt <- function( + i, + entries, + cond, + method, + grp, + data, + jointIndex +) { e <- entries[[i]] if (is.null(e)) { return(NULL) @@ -2811,7 +3006,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { region = grp$region, # The reference the group was fitted against, so each result row # keeps it; NULL for an individual-level group. - ldReference = grp$ldReference + ldReference = grp$ldReference, + jointIndex = jointIndex[[i]] ) } diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 363417439..454f66ae5 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -1592,11 +1592,16 @@ parseTraitIds <- function(traitId, data) { } # Reconstruct the per-tuple result object from the accumulated rows, each on -# the LD reference it had. +# the LD reference it had. A TwasWeights is already that: row-binding +# regroups its entries by gene, and every row keeps its window, trait +# position and LD reference. .msDriverPerTuple <- function(out, resultCtor) { + if (methods::is(out, "TwasWeights")) { + return(out) + } ctorArgs <- c( list( - study = as.character(out$study), + studyName = as.character(out$study), context = as.character(out$context), trait = as.character(out$trait), method = as.character(out$method), @@ -1952,38 +1957,99 @@ parseTraitIds <- function(traitId, data) { # TWAS-weights dispatchers # ============================================================================= -# Merge per-region TwasWeights collections (same keys across regions) into one -# by concatenating each (study, context, trait, method) row's entry via -# .twasMergeRegionEntries (stacked weights + flat per-region cvResult). +# Merge per-region TwasWeights collections into one by concatenating each +# entry across the regions that fitted it (.twasMergeRegionEntries: stacked +# weights + flat per-region cvResult). Entries are matched on (study, +# context, trait, joint*, method) over EVERY region, so one that a region +# lacks is kept and two joint groups stay apart. A merged entry keeps its +# trait position and LD reference, and its window spans the windows it was +# fitted over. # @noRd .twasMergeResultsByKey <- function(results, regionLabels) { - base <- results[[1L]] - n <- length(base$method) - if (n == 0L) { - return(base) - } - baseKeys <- .mergeResultKeyOf(base) - mergedEntries <- map( - seq_len(n), - .twasMergedEntryAt, - results = results, - baseKeys = baseKeys, - regionLabels = regionLabels - ) - # Passthrough columns (joint keys + region + traitPos) are per-row - # properties of `base`, which aligns row-for-row with mergedEntries; splice - # them so a multi-region merge preserves provenance instead of dropping it. - twArgs <- c( - list( - study = as.character(base$study), - context = as.character(base$context), - trait = as.character(base$trait), - method = as.character(base$method), - entry = mergedEntries + inputs <- map(results, .twasAllCellInputs) + stacked <- list( + keys = bind_rows(map(inputs, "keys")), + method = list_c(map(inputs, "method"), ptype = character()), + entry = list_flatten(map(inputs, "entry")), + traitPos = .twasJoinRanges(map(inputs, "traitPos"), inputs), + region = .twasJoinRanges(map(inputs, "region"), inputs), + ldRefs = list_flatten(map(inputs, "ldRefs")), + jointIndex = .twasJoinJointIndex(inputs), + block = rep(seq_along(inputs), map_int(inputs, .twasInputCells)) + ) + groups <- unname(split( + seq_along(stacked$method), + as.integer(vctrs::vec_group_id( + bind_cols(stacked$keys, .method = stacked$method) + )) + )) + first <- map_int(groups, .twasFirstCell) + merged <- list( + keys = stacked$keys[first, ], + method = stacked$method[first], + entry = map( + groups, + .twasMergedGroupEntry, + stacked = stacked, + regionLabels = regionLabels ), - .jointCols(base) + traitPos = stacked$traitPos[first], + region = .twasMergedWindows(stacked$region, groups), + ldRefs = stacked$ldRefs[first], + jointIndex = .twasMergedJointIndex(stacked$jointIndex, groups) ) - exec(TwasWeights, !!!twArgs) + .withMetadata(.twasNewValidated(merged), S4Vectors::metadata(results[[1L]])) +} + +# The merged entry of one group of stacked cells (one entry, several regions). +# @noRd +.twasMergedGroupEntry <- function(group, stacked, regionLabels) { + .twasMergeRegionEntries( + stacked$entry[group], + regionLabels[stacked$block[group]] + ) +} + +# Each group's joint-fit position: the one its regions agree on, else NA (a +# region's screen can drop different conditions). NULL when no cell has one. +# @noRd +.twasMergedJointIndex <- function(jointIndex, groups) { + if (is.null(jointIndex)) { + return(NULL) + } + map_int(groups, .twasGroupJointIndex, jointIndex = jointIndex) +} + +# @noRd +.twasGroupJointIndex <- function(group, jointIndex) { + v <- unique(jointIndex[group]) + if (length(v) == 1L) v else NA_integer_ +} + +# Each group's window: the span of its regions' windows (NULL for none). +# @noRd +.twasMergedWindows <- function(region, groups) { + if (is.null(region)) { + return(NULL) + } + suppressWarnings(exec(c, !!!map(groups, .twasWindowSpan, region = region))) +} + +# @noRd +.twasWindowSpan <- function(group, region) { + gr <- region[group] + known <- gr[!.twasIsPlaceholder(gr)] + if (length(known) == 0L) { + return(gr[1L]) + } + span <- range(known, ignore.strand = TRUE) + if (length(span) != 1L) { + abort(glue( + "TwasWeights: an entry was fitted over windows on ", + "{length(span)} chromosomes; a row's window is one range." + )) + } + span } # ---- TWAS joint dispatch ---------------------------------------------------- @@ -2232,15 +2298,6 @@ parseTraitIds <- function(traitId, data) { .fmMergeEntries(compact(perRegion)) } -# The merged TWAS entry for base row `i`: gather + concatenate that key's entry -# across regions, keeping region labels aligned to the surviving entries. -# @noRd -.twasMergedEntryAt <- function(i, results, baseKeys, regionLabels) { - perRegion <- map(results, .mergeEntryForKey, key = baseKeys[[i]]) - keep <- !map_lgl(perRegion, is.null) - .twasMergeRegionEntries(perRegion[keep], regionLabels[keep]) -} - # TRUE when a parsed joint spec includes the `study` axis. # @noRd .jsHasStudyAxis <- function(s) { diff --git a/R/ld.R b/R/ld.R index 9ea55c389..aa268ae2c 100644 --- a/R/ld.R +++ b/R/ld.R @@ -372,17 +372,19 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # Normalise an LD-reference input to the shape the slot holds: a panel or an # LdMatrix as given, a bare GenotypeHandle wrapped into a panel -- so a sketch # and QtlDataset's genotype experiment end up being the same object with -# different provenance rather than two spellings of one idea. +# different provenance rather than two spellings of one idea. A panel leaves +# in pecotmr's spelling (UCSC chromosomes, upper-case alleles), as one built +# outside pecotmr may not arrive in it. # @noRd .asLdRef <- function(x) { if (is.null(x) || .ldIsMatrixRef(x) || .ldIsMixtureRef(x)) { return(x) } if (methods::is(x, "RangedSummarizedExperiment")) { - return(x) + return(.canonExperiment(x)) } if (methods::is(x, "GenotypeHandle")) { - return(.genotypeExperiment(x)) + return(.canonExperiment(.genotypeExperiment(x))) } abort(glue( "`ldReference` must be a genotype panel (see readGenotypes()), a ", @@ -453,47 +455,27 @@ resolveGenotypePathForRegion <- function(metaPath, region) { map(unname(ldReference), .asLdRef) } -# Each distinct reference among `perRow` once, named ld1, ld2, ... in order -# of first use, and every row's key into them (NA for an LD-free row). +# The ldReference row dictionary (see the row dictionaries in +# tupleSelectors.R): the slot holds each distinct reference once, named ld1, +# ld2, ..., and the `ldReference` mcols column names every row's. # @noRd -.ldRefDict <- function(perRow) { - present <- which(!map_lgl(perRow, is.null)) - ids <- .ldRefIdentities(perRow[present]) - firstIdx <- which(!duplicated(ids)) - keys <- str_c("ld", seq_along(firstIdx)) - rowKeys <- replace( - rep(NA_character_, length(perRow)), - present, - keys[match(ids, ids[firstIdx])] - ) - refs <- if (length(firstIdx) == 0L) { - list() - } else { - set_names(perRow[present[firstIdx]], keys) - } - list(refs = refs, keys = rowKeys) -} +.LD_REF_DICT <- list( + slot = "ldReference", + keyCol = "ldReference", + prefix = "ld" +) -# A content identity per reference, so equal references -- the same object -# handed to every row, or two equal copies -- collapse to one entry. Hashed -# once per distinct object rather than per row: a large LdMatrix shared by -# every row is read once, not once per row. +# Each distinct reference among `perRow` once, and every row's key into them +# (NA for an LD-free row). # @noRd -#' @importFrom rlang hash obj_address -.ldRefIdentities <- function(refs) { - if (length(refs) == 0L) { - return(character(0)) - } - addresses <- map_chr(refs, obj_address) - firstOfAddress <- !duplicated(addresses) - hashes <- map_chr(refs[firstOfAddress], hash) - hashes[match(addresses, addresses[firstOfAddress])] +.ldRefDict <- function(perRow) { + .dictBuild(perRow, .LD_REF_DICT$prefix) } # Each row's key into its collection's LD references (NA for an LD-free row). # @noRd .ldRefKeys <- function(x) { - mcols(x, use.names = FALSE)$ldReference %||% rep(NA_character_, length(x)) + .dictKeys(x, .LD_REF_DICT) } # What a collection reports as its LD references: the entries some row names, @@ -514,7 +496,7 @@ resolveGenotypePathForRegion <- function(metaPath, region) { if (!is.list(refs) || is.object(refs)) { .abortSavedLdRef(x) } - .ldRefsUsed(refs, .ldRefKeys(x)) + .dictUsed(refs, .ldRefKeys(x)) } # @noRd @@ -528,18 +510,10 @@ resolveGenotypePathForRegion <- function(metaPath, region) { )) } -# The entries of `refs` some key in `keys` names. -# @noRd -.ldRefsUsed <- function(refs, keys) { - used <- refs[is_in(names(refs), keys)] - if (length(used) == 0L) list() else used -} - # Every row's LD reference, NULL for an LD-free row. # @noRd .rowLdRefs <- function(x) { - refs <- ldReference(x) - map(.ldRefKeys(x), .ldRefForKey, refs = refs) + map(.ldRefKeys(x), .dictEntryFor, entries = ldReference(x)) } # Result records tagged with the LD reference of the input row they came @@ -555,15 +529,8 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # written first and the keys second, so the object is only validated once # the two agree. # @noRd -#' @importFrom methods slot<- .withRowLdRefs <- function(x, ldReference) { - dict <- .ldRefDict(.ldRefPerTuple(ldReference, length(x))) - md <- mcols(x, use.names = FALSE) - md[["ldReference"]] <- dict$keys - S4Vectors::`mcols<-`( - `slot<-`(x, "ldReference", check = FALSE, value = dict$refs), - value = md - ) + .withRowDict(x, .LD_REF_DICT, .ldRefPerTuple(ldReference, length(x))) } # `object` as saved before its references became per-row -- one reference, @@ -584,12 +551,11 @@ resolveGenotypePathForRegion <- function(metaPath, region) { if (!is.list(old) || is.object(old)) { return(.withRowLdRefs(object, .updateLdRefOrKeep(old))) } - `slot<-`( - object, - "ldReference", - check = FALSE, - value = map(old, .updateLdRefOrKeep) + methods::slot(object, "ldReference", check = FALSE) <- map( + old, + .updateLdRefOrKeep ) + object } # A collection's LD reference as saved, brought up to date (.updatePanel()). @@ -614,12 +580,7 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # Row `i`'s LD reference, or NULL for an LD-free row. # @noRd .rowLdRef <- function(x, i) { - .ldRefForKey(.ldRefKeys(x)[[i]], ldReference(x)) -} - -# @noRd -.ldRefForKey <- function(key, refs) { - if (is.na(key)) NULL else refs[[key]] + .dictEntryFor(.ldRefKeys(x)[[i]], ldReference(x)) } # What is wrong with an LD-reference list and the keys pointing into it, or @@ -627,31 +588,18 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # repeated one leaves a row pointing at nothing, or at two references. # @noRd .ldRefDictProblems <- function(refs, keys) { - if (length(refs) > 0L) { - nms <- names(refs) - badNames <- is.null(nms) || - anyNA(nms) || - any(nms == "") || - anyDuplicated(nms) > 0L - if (badNames) { - return("ldReference entries must have unique, non-empty names") - } - bad <- nms[!map_lgl(refs, .ldIsReference)] - if (length(bad) > 0L) { - return(str_c( - "ldReference entries that are not LD references: ", - str_flatten(bad, ", ") - )) - } - } - unknown <- setdiff(keys[!is.na(keys)], names(refs)) - if (length(unknown) == 0L) { - return(NULL) + named <- .dictNameProblem(refs, "ldReference") + if (!is.null(named)) { + return(named) + } + bad <- names(refs)[!map_lgl(refs, .ldIsReference)] + if (length(bad) > 0L) { + return(str_c( + "ldReference entries that are not LD references: ", + str_flatten(bad, ", ") + )) } - str_c( - "rows name LD reference(s) not in ldReference: ", - str_flatten(unknown, ", ") - ) + .dictKeyProblem(refs, keys, "ldReference", "LD reference(s)") } # The GenotypeHandle a panel reads through, or NULL when it reads through @@ -795,14 +743,15 @@ resolveGenotypePathForRegion <- function(metaPath, region) { } # A panel cut to the variants `keep` marks (a mask or positions). A panel -# whose rows are exactly its seed's, cut to an ordered subset, has the seed -# cut too -- a GenotypeHandle trimmed, a VCF, GDS or PLINK1 seed cut to the -# records the kept rows read -- so the cut panel's seed does not carry the -# dropped variants' metadata (see .emptyPanel()); its rowRanges, samples, -# colData and recorded metadata are its own, cut alike, so no sidecar is read -# again. Any other cut -- of a panel that is itself a row subset, of one held -# in memory or whose handle predates fileIdx, or one that reorders or repeats -# rows -- is taken from its assay, which then reads only those rows. +# whose rows are its seed's, or a row subset of them, cut to rows the seed +# holds in order, has the seed cut too -- a GenotypeHandle trimmed, a VCF, +# GDS or PLINK1 seed cut to the records the kept rows read -- so the cut +# panel's seed does not carry the dropped variants' metadata (see +# .emptyPanel()); its rowRanges, samples, colData and recorded metadata are +# its own, cut alike, so no sidecar is read again. Any other cut -- of a +# panel held in memory or whose handle predates fileIdx, or one that +# reorders or repeats the seed's rows -- is taken from its assay, which then +# reads only those rows. # @noRd .panelSubsetRows <- function(panel, keep) { keepIdx <- if (is.logical(keep)) which(keep) else as.integer(keep) @@ -824,24 +773,66 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # or NULL when the seed cannot be cut so (see .panelSubsetRows()). # @noRd .panelCutDosage <- function(panel, keepIdx) { + rows <- .panelSeedRows(panel) + if (is.null(rows)) { + return(NULL) + } + seedRows <- rows[keepIdx] if ( - length(keepIdx) >= nrow(panel) || - is.unsorted(keepIdx, strictly = TRUE) + is.unsorted(seedRows, strictly = TRUE) || + length(seedRows) >= .panelFullDims(panel)[[1L]] ) { return(NULL) } seed <- .panelSeed(panel) - if ( - methods::is(seed, "GenotypeDosageSeed") && - identical(rownames(panel), dimnames(seed)[[1L]]) - ) { - return(DelayedArray::DelayedArray(.gdSeedRows(seed, keepIdx))) + if (methods::is(seed, "GenotypeDosageSeed")) { + return(DelayedArray::DelayedArray(.gdSeedRows(seed, seedRows))) } handle <- .ldRefHandle(panel) - if (is.null(handle) || !.panelRowsAreHandle(panel, handle)) { + if (is.null(handle) || !is_in("fileIdx", names(snpInfo(handle)))) { + return(NULL) + } + genotypeDelayedArray(.subsetGenotypeHandle(handle, seedRows)) +} + +# A panel's rows as rows of its dosage seed (.panelSeedIndex()), or NULL. +# @noRd +.panelSeedRows <- function(panel) { + .panelSeedIndex(panel)[[1L]] +} + +# A panel's rows and columns as positions in its dosage seed: all of each, +# in order, when its dosages are the seed's own; the indices of the one +# subset that takes them from it otherwise. NULL when its dosages are held +# another way (in memory, or behind other delayed operations). Positions, +# not names: a seed keeps no row names, and a panel's rows may have been +# renamed. +# @noRd +.panelSeedIndex <- function(panel) { + dosage <- SummarizedExperiment::assay( + panel, + "dosage", + withDimnames = FALSE + ) + if (!methods::is(dosage, "DelayedArray")) { return(NULL) } - genotypeDelayedArray(.subsetGenotypeHandle(handle, keepIdx)) + if (DelayedArray::isPristine(dosage)) { + return(list(seq_len(nrow(dosage)), seq_len(ncol(dosage)))) + } + node <- methods::slot(dosage, "seed") + if ( + !methods::is(node, "DelayedSubset") || + methods::is(methods::slot(node, "seed"), "DelayedOp") + ) { + return(NULL) + } + whole <- dim(methods::slot(node, "seed")) + index <- methods::slot(node, "index") + list( + index[[1L]] %||% seq_len(whole[[1L]]), + index[[2L]] %||% seq_len(whole[[2L]]) + ) } # A panel's dimensions before any subsetting: its dosage seed's, or its own @@ -852,15 +843,6 @@ resolveGenotypePathForRegion <- function(metaPath, region) { if (is.null(seed)) dim(panel) else dim(seed) } -# TRUE when a panel's rows are its handle's own, in order, and the handle can -# be trimmed (it records each variant's file position). -# @noRd -.panelRowsAreHandle <- function(panel, handle) { - si <- snpInfo(handle) - is_in("fileIdx", names(si)) && - identical(rownames(panel), normalizeVariantId(as.character(si$SNP))) -} - # A panel with no variants, held in memory. `x[integer(0), ]` would drop the # rows but keep the dosage seed -- a handle carrying every variant's # metadata, or a backend over the whole file -- which is precisely the @@ -982,9 +964,12 @@ resolveGenotypePathForRegion <- function(metaPath, region) { } if (methods::is(x, "RangedSummarizedExperiment")) { # A panel built outside pecotmr may spell its chromosomes otherwise. - return(.ucscRanges(SummarizedExperiment::rowRanges(x))) + # Its file labels are put back where it keeps them as its rownames. + return(.withPanelLabels( + .ucscRanges(SummarizedExperiment::rowRanges(x)) + )) } - .genotypeSnpRanges(x, normalizeVariantId(as.character(snpInfo(x)$SNP))) + .withPanelLabels(.genotypeSnpRanges(x, .panelRowNames(snpInfo(x)))) } # How many variants an LD reference covers. @@ -1014,12 +999,49 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # misses the variant it just harmonized. # @noRd .ldRefMatchIds <- function(x) { + gr <- .ldRefRanges(x) + mc <- S4Vectors::mcols(gr) + # Rendered from the reference's own ranges and alleles, in the canonical + # form harmonization gives every id (UCSC chromosome, colons, upper-case + # alleles), so a variant meets it however the file labelled it: lower + # case, underscores, a tag where an allele belongs, or an rsID, which + # names no position to match on. A reference without alleles has only + # its labels. + if (is.null(mc$A1) || is.null(mc$A2)) { + return(.ldRefLabels(x)) + } + .grVariantIds(gr) +} + +# A reference's own labels, in the canonical form: an id whose allele fields +# are tags is repaired from the A2/A1 columns, and an rsID passes through. +# @noRd +.ldRefLabels <- function(x) { mc <- S4Vectors::mcols(.ldRefRanges(x)) ids <- as.character(mc$SNP) - if (is.null(mc$A1) || is.null(mc$A2)) { - return(ids) + repaired <- if (is.null(mc$A1) || is.null(mc$A2)) { + ids + } else { + .repairVariantIds(ids, as.character(mc$A2), as.character(mc$A1)) } - .repairVariantIds(ids, as.character(mc$A2), as.character(mc$A1)) + normalizeVariantId(repaired) +} + +# The keys reference `x` is matched by for the query ids `ids`: its rendered +# ids (.ldRefMatchIds()), which chrom:pos:ref:alt ids meet by position and +# alleles; or its labels when the query is itself labels (rsIDs), which +# carry no position to match on. +# @noRd +.ldRefKeysFor <- function(x, ids) { + if (.areVariantLabels(ids)) .ldRefLabels(x) else .ldRefMatchIds(x) +} + +# TRUE when ids cannot be read as chrom:pos:ref:alt, as matchVariants() then +# falls back to matching them as strings. +# @noRd +.areVariantLabels <- function(ids) { + parsed <- parseVariantId(ids) + nrow(parsed) == 0L || anyNA(parsed$chrom) || anyNA(parsed$pos) } # Per-variant chromosome. @@ -1195,7 +1217,7 @@ resolveGenotypePathForRegion <- function(metaPath, region) { rr <- SummarizedExperiment::rowRanges(panel) mc <- S4Vectors::mcols(rr) mc$AF <- as.numeric(record$af$alt_freq)[ - match(as.character(mc$SNP), record$af$id) + match(.panelLabels(rr), record$af$id) ] withAf <- SummarizedExperiment::`rowRanges<-`( panel, @@ -1285,11 +1307,11 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # Match requested ids to the panel; NULL if none match. Returns kept ids/order. .ldFromRefMatch <- function(ldReference, variantIds, label, onMissing) { - # Match by (chrom, pos, allele) tuple with an exact id-string fallback for - # rsID panels; the caller's original ids and order are preserved. + # Match by (chrom, pos, allele) tuple, or by label for a query of labels; + # the caller's original ids and order are preserved. m <- matchVariants( variantIds, - .ldRefMatchIds(ldReference), + .ldRefKeysFor(ldReference, variantIds), removeStrandAmbiguous = FALSE ) nMissing <- length(variantIds) - length(m$idxA) @@ -1348,7 +1370,6 @@ resolveGenotypePathForRegion <- function(metaPath, region) { if (is.null(matched)) { return(NULL) } - ldMat <- .ldRefLdAt(ldReference, matched$idx) # The match above is allele-aware, so a panel entry whose alleles are # swapped relative to the caller's id still matches -- but the dosage it # returns counts the OTHER allele, which negates every correlation that @@ -1356,16 +1377,58 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # the caller's frame exactly as `.cbFlipPairToCanonical()` does: # LD_ij -> sign_i * sign_j * LD_ij. A no-op on a harmonized panel, where # every sign is +1. - signed <- if (any(matched$sign < 0)) { - ldMat * outer(matched$sign, matched$sign) - } else { - ldMat + ldMat <- .ldSignFlipped( + .ldRefLdAt(ldReference, matched$idx), + matched$sign + ) + dimnames(ldMat) <- list(matched$keptIds, matched$keptIds) + if (onMissing == "drop") { + attr(ldMat, "keptVariantIds") <- matched$keptIds + } + ldMat +} + +# `R` with each variant's rows and columns multiplied by its allele sign, +# LD_ij -> sign_i * sign_j * LD_ij: the flipped variants' rows and columns +# are negated where they stand, so a flip costs only those rows. +# @noRd +.ldSignFlipped <- function(R, sign) { + flip <- which(sign < 0) + if (length(flip) == 0L) { + return(R) } - named <- `dimnames<-`(signed, list(matched$keptIds, matched$keptIds)) + R[flip, ] <- -R[flip, , drop = FALSE] + R[, flip] <- -R[, flip, drop = FALSE] + R +} + +# An LdMatrix's LD over `variantIds`, matched and allele-aligned as +# .ldFromRef() aligns its matrix, as a packed LD source (.ldSourceRows()): +# its block, read packed from the LdMatrix's storage, with each variant's +# allele sign applied as the source is read, so the p x p matrix is never +# formed. `onMissing` is .ldFromRef()'s, with the ids kept recorded the same +# way. +# @noRd +.ldPackedFromRef <- function( + ldReference, + variantIds, + label, + onMissing = c("error", "drop") +) { + .ldFromRefValidate(ldReference, label) + onMissing <- arg_match(onMissing) + matched <- .ldFromRefMatch(ldReference, variantIds, label, onMissing) + if (is.null(matched)) { + return(NULL) + } + ld <- list( + P = .ldmPackedBlock(ldReference, matched$idx), + sign = matched$sign + ) if (onMissing == "drop") { - return(`attr<-`(named, "keptVariantIds", matched$keptIds)) + attr(ld, "keptVariantIds") <- matched$keptIds } - named + ld } # The factor of a genotype reference's LD over `variantIds` (see @@ -1406,7 +1469,7 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # @noRd .ldRefLdAt <- function(ldReference, idx) { if (.ldIsMatrixRef(ldReference)) { - return(unname(ldMatrix(ldReference)[idx, idx, drop = FALSE])) + return(.ldmBlock(ldReference, idx)) } if (.ldIsMixtureRef(ldReference)) { return(.gmLdAt(ldReference, idx)) @@ -1497,34 +1560,77 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # ---------- LD rows a stripe at a time ---------- # -# An LD source is one block's LD in any of three forms: the matrix itself, -# list(R = ); a factor of it, list(F = ) with R = crossprod(F) / (m - 1); or -# an eigendecomposition, list(vectors = , values = ) with R = V diag(values) -# V'. The helpers below read R's rows from any of them, so a computation over -# R's rows never needs the matrix whole. +# An LD source is one block's LD in any of four forms: the matrix itself, +# list(R = ); an LdMatrix's packed block, list(P = , sign = ), a dspMatrix +# read with each variant's allele sign (.ldPackedFromRef()); a factor of it, +# list(F = ) with R = crossprod(F) / (m - 1); or an eigendecomposition, +# list(vectors = , values = ) with R = V diag(values) V'. The helpers below +# read R's rows from any of them, so a computation over R's rows never needs +# the matrix whole. A source of any form may also carry `eigen`, its R's +# eigendecomposition, computed once for a computation that reads R's +# spectrum many times (.ldSourceEigen()). # How many of R's rows a stripe holds. # @noRd .ldStripeSize <- function() 256L +# The LD of an LD source as a base matrix, for an engine that takes nothing +# else. +# @noRd +.ldSourceMatrix <- function(ld) { + if (!is.null(ld$R)) { + return(ld$R) + } + if (!is.null(ld$P)) { + return(.ldSignFlipped(methods::as(ld$P, "matrix"), ld$sign)) + } + if (!is.null(ld$F)) { + return(crossprod(ld$F) / (nrow(ld$F) - 1)) + } + tcrossprod(sweep(ld$vectors, 2L, ld$values, "*"), ld$vectors) +} + # The number of variants an LD source covers. # @noRd .ldSourceSize <- function(ld) { if (!is.null(ld$R)) { return(nrow(ld$R)) } + if (!is.null(ld$P)) { + return(nrow(ld$P)) + } if (!is.null(ld$F)) { return(ncol(ld$F)) } nrow(ld$vectors) } +# The eigendecomposition of an LD source's R: the one the source carries as +# `eigen`, its own when it is one, a factor's from its thin SVD +# (.ldFactorEigen()), or eigen() of the matrix, unpacked first when packed. +# @noRd +.ldSourceEigen <- function(ld) { + if (!is.null(ld$eigen)) { + return(ld$eigen) + } + if (!is.null(ld$vectors)) { + return(ld[c("values", "vectors")]) + } + if (!is.null(ld$F)) { + return(.ldFactorEigen(ld$F)) + } + eigen(.ldSourceMatrix(ld), symmetric = TRUE) +} + # Rows `rows` of an LD source's R, without forming the rest. # @noRd .ldSourceRows <- function(ld, rows) { if (!is.null(ld$R)) { return(ld$R[rows, , drop = FALSE]) } + if (!is.null(ld$P)) { + return(.ldPackedRows(ld, rows)) + } if (!is.null(ld$F)) { return( crossprod(ld$F[, rows, drop = FALSE], ld$F) / (nrow(ld$F) - 1) @@ -1534,6 +1640,27 @@ resolveGenotypePathForRegion <- function(metaPath, region) { tcrossprod(scaled, ld$vectors) } +# Rows `rows` of a packed LD source's matrix, read from its triangle by the +# Matrix package and signed. +# @noRd +.ldPackedRows <- function(ld, rows) { + block <- methods::as(ld$P[rows, , drop = FALSE], "matrix") + ld$sign[rows] * sweep(block, 2L, ld$sign, "*") +} + +# An LD source cut to the variants at `idx`, in that order: the matrix's +# block, the packed triangle's, or the factor's columns. +# @noRd +.ldSourceSubset <- function(ld, idx) { + if (!is.null(ld$R)) { + return(list(R = ld$R[idx, idx, drop = FALSE])) + } + if (!is.null(ld$P)) { + return(list(P = ld$P[idx, idx, drop = FALSE], sign = ld$sign[idx])) + } + list(F = ld$F[, idx, drop = FALSE]) +} + # (R o R) A -- R squared element-wise, times A -- for an LD source: column a # of the result is the LD score sum_k r^2_jk a_k. The element-wise square # does not inherit a factor's low rank (R has rank below m, R o R is in @@ -1589,14 +1716,82 @@ resolveGenotypePathForRegion <- function(metaPath, region) { ) } -# b' R b for each column b of B, from an LD matrix or a factor of it: -# ||F b||^2 / (m - 1), never forming R. +# R B for an LD source, never forming R from its packed triangle, a factor +# or a decomposition. The packed triangle's product (the Matrix package's) +# costs a pass over it per column of B, so it serves a few columns; a step +# with many unpacks the block first (.ldSourceMatrix()). # @noRd -.ldQuadForms <- function(ld, B) { +.ldSourceTimes <- function(ld, B) { + B <- as.matrix(B) if (!is.null(ld$R)) { - return(colSums(B * (ld$R %*% B))) + return(ld$R %*% B) + } + if (!is.null(ld$P)) { + return(ld$sign * methods::as(ld$P %*% (ld$sign * B), "matrix")) } - colSums((ld$F %*% B)^2) / (nrow(ld$F) - 1) + if (!is.null(ld$F)) { + return(crossprod(ld$F, ld$F %*% B) / (nrow(ld$F) - 1)) + } + ld$vectors %*% (ld$values * crossprod(ld$vectors, B)) +} + +# b' R b for each column b of B, from an LD source: ||F b||^2 / (m - 1) for +# a factor, never forming R. +# @noRd +.ldQuadForms <- function(ld, B) { + if (!is.null(ld$F)) { + return(colSums((ld$F %*% B)^2) / (nrow(ld$F) - 1)) + } + colSums(B * .ldSourceTimes(ld, B)) +} + +# `nDraws` draws from N(0, R), as the columns of a p x nDraws matrix: F' e / +# sqrt(m - 1) for a factor, exact without forming R, and otherwise through +# R's eigendecomposition (.ldSourceEigen()), which takes the zero eigenvalues +# a reference smaller than the number of variants leaves. +# @noRd +#' @importFrom stats rnorm +.ldSourceDraws <- function(ld, nDraws) { + if (!is.null(ld$F)) { + e <- matrix(rnorm(nrow(ld$F) * nDraws), nrow(ld$F), nDraws) + return(crossprod(ld$F, e) / sqrt(nrow(ld$F) - 1)) + } + ev <- .ldSourceEigen(ld) + e <- matrix(rnorm(length(ev$values) * nDraws), length(ev$values), nDraws) + ev$vectors %*% (sqrt(pmax(ev$values, 0)) * e) +} + +# Schafer and Strimmer's (2005) intensity for shrinking a correlation matrix +# estimated from `nSamples` samples toward the identity: the summed sampling +# variance of the off-diagonal correlations, (1 - r^2)^2 / (nSamples - 1) +# each, over their summed squares, capped at 1. R's rows are read a stripe +# at a time, so a factor never forms R. With no off-diagonal correlation at +# all (a single variant, or none in LD) there is nothing to shrink, and 1 +# leaves R as it is. +# @noRd +.ldShrinkIntensity <- function(ld, nSamples) { + p <- .ldSourceSize(ld) + starts <- seq.int(1L, p, by = .ldStripeSize()) + sums <- map(starts, .ldShrinkStripeSums, ld = ld, p = p) + squares <- sum(map_dbl(sums, "squares")) + if (squares == 0) { + return(1) + } + variances <- sum(map_dbl(sums, "variances")) + min(1, variances / (nSamples - 1) / squares) +} + +# One stripe of R's rows: the sums of r^2 and of (1 - r^2)^2 off the +# diagonal. +# @noRd +.ldShrinkStripeSums <- function(start, ld, p) { + rows <- seq.int(start, min(start + .ldStripeSize() - 1L, p)) + r2 <- .ldSourceRows(ld, rows)^2 + r2[cbind(seq_along(rows), rows)] <- NA + list( + squares = sum(r2, na.rm = TRUE), + variances = sum((1 - r2)^2, na.rm = TRUE) + ) } # ---------- LD reference: per-variant statistics and filtering ---------- @@ -2169,8 +2364,8 @@ resolveGenotypePathForRegion <- function(metaPath, region) { return(TRUE) } probe <- unique(round(seq(1, n, length.out = min(n, 200L)))) - xR <- ldMatrix(x)[xIdx[probe], xIdx[probe], drop = FALSE] - yR <- ldMatrix(y)[yIdx[probe], yIdx[probe], drop = FALSE] + xR <- .ldmBlock(x, xIdx[probe]) + yR <- .ldmBlock(y, yIdx[probe]) max(abs(xR - yR)) <= tol } @@ -2275,8 +2470,8 @@ resolveGenotypePathForRegion <- function(metaPath, region) { nullPolicy ) { .requireMatchingLdRefs( - .ldRefForKey(qtlKey, qtlRefs), - .ldRefForKey(gwasKey, gwasRefs), + .dictEntryFor(qtlKey, qtlRefs), + .dictEntryFor(gwasKey, gwasRefs), pipelineName = pipelineName, label = glue("{label} row {qtlRow} (with gwas row {gwasRow})"), nullPolicy = nullPolicy diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index 568930887..c9706bab4 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -855,8 +855,8 @@ NULL chrom = as.character(df[[resolved$chrom]]), pos = as.integer(df[[resolved$pos]]), SNP = as.character(df[[resolved$variant_id]]), - A1 = as.character(df[[resolved$A1]]), - A2 = as.character(df[[resolved$A2]]) + A1 = .canonAllele(df[[resolved$A1]]), + A2 = .canonAllele(df[[resolved$A2]]) ) } @@ -1063,8 +1063,8 @@ NULL chrom = as.character(GenomicRanges::seqnames(rr)), pos = unname(as.integer(GenomicRanges::start(rr))), SNP = names(rr), - A1 = .mlFirstAlts(altList), - A2 = unname(as.character(VariantAnnotation::ref(vcf))), + A1 = .canonAllele(.mlFirstAlts(altList)), + A2 = .canonAllele(unname(as.character(VariantAnnotation::ref(vcf)))), Z = z$z, z_supplied = z$supplied, N = fld$N diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index b41f89e49..957b9b55f 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -143,23 +143,41 @@ QvalueOptions <- function(...) { } # Per-variant MAF + cis-window keep mask (the FILTERED-flavour restriction) from -# an entry's af / tss_distance / tes_distance mcols. Shared by the correction +# an entry's AF / tss_distance / tes_distance mcols. Shared by the correction # and the significance derivation so the filtered set is defined once. .qapFilterKeep <- function(mc, mafCutoff, cisWindow, afCol, nVar) { - byMaf <- if (mafCutoff > 0 && !is.null(mc[[afCol]])) { + .qapRequireFilterCols(mc, mafCutoff, cisWindow, afCol, nVar) + byMaf <- if (mafCutoff > 0) { pmin(mc[[afCol]], 1 - mc[[afCol]]) > mafCutoff } else { rep(TRUE, nVar) } - inCis <- cisWindow > 0 && - !is.null(mc$tss_distance) && - !is.null(mc$tes_distance) - if (!inCis) { + if (cisWindow <= 0) { return(byMaf) } byMaf & (mc$tss_distance >= -cisWindow & mc$tes_distance <= cisWindow) } +# A filter the caller asked for needs its columns. Skipping it instead -- as +# a wrong `afCol` once did -- reports unfiltered results as the filtered ones. +# An entry with no variants has nothing to filter. +# @noRd +.qapRequireFilterCols <- function(mc, mafCutoff, cisWindow, afCol, nVar) { + needed <- c( + if (mafCutoff > 0) afCol, + if (cisWindow > 0) c("tss_distance", "tes_distance") + ) + missing <- setdiff(needed, names(mc)) + if (length(missing) == 0L || nVar == 0L) { + return(invisible(NULL)) + } + abort(glue( + "qtlAssociationPostprocess: the filtered correction needs the ", + "per-variant column(s) {str_flatten(missing, ', ')}, which the ", + "entries do not carry." + )) +} + # Per-gene logical masks of significant variants under a correction method (the # derived significance, never stored). `method` is one of permutation, # bonferroni_original, bonferroni_filtered, qvalue; `threshold` defaults to the @@ -379,7 +397,7 @@ setMethod( grl <- S4Vectors::`mcols<-`(built, value = md) methods::new( "QtlSumStats", - grl, + .rtlStored("QtlSumStats", grl), ldReference = ldReference(x), qcOptions = qcOptions ) @@ -388,7 +406,7 @@ setMethod( #' @rdname qtlAssociationPostprocess #' @param fdrThreshold Event- and variant-level FDR threshold (default 0.05). #' @param mafCutoff Minor-allele-frequency cutoff for the FILTERED Bonferroni -#' flavour (fold of the per-variant \code{af} mcol). \code{0} disables it. +#' flavour (fold of the per-variant \code{AF} mcol). \code{0} disables it. #' @param cisWindow cis-window (bp) for the FILTERED Bonferroni flavour, applied #' to the per-variant \code{tss_distance}/\code{tes_distance} mcols. \code{0} #' disables it. When either \code{mafCutoff} or \code{cisWindow} is > 0 the @@ -401,7 +419,8 @@ setMethod( #' no stored column -- it is a significance query (see #' \code{significantQtls}). #' @param pvalueCol,afCol Entry mcol names for the per-variant p-value / allele -#' frequency (defaults \code{"P"} / \code{"af"}). +#' frequency (defaults \code{"P"} / \code{"AF"}, the columns a +#' \code{QtlSumStats} stores them in). #' @param qvalueArgs Extra arguments for \code{qvalue::qvalue()}, built with #' \code{\link{QvalueOptions}} -- the \code{pi0.method} / \code{lambda} #' pair in particular, which sets how the null proportion is estimated. @@ -416,7 +435,7 @@ setMethod( cisWindow = 0, methods = c("permutation", "bonferroni"), pvalueCol = "P", - afCol = "af", + afCol = "AF", qvalueArgs = QvalueOptions() ) { .assertMethodOptions(qvalueArgs, "QvalueOptions", "qvalueArgs") diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index 88c6cecfd..127c3535a 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -201,24 +201,38 @@ QtlSumStats <- function( n <- length(studyName) varY <- .qssValidateArgs(context, trait, entry, genome, varY, n) windows <- .qssWindows(region, n) - entry <- .qssWithinWindows(.ucscEntries(entry), windows) |> + entry <- .qssWithinWindows(.ssEntries(entry), windows) |> .qssAddTraitDistances(traitPos, n) cols <- .qssBaseCols(studyName, context, trait, varY) |> .qssAppendNSample(nSample, n) |> .appendTraitPosCol(traitPos, n) |> .qssAppendExtras(extraCols) dict <- .ldRefDict(.ldRefPerTuple(ldReference, n)) - dfArgs <- c(cols, list(ldReference = dict$keys, check.names = FALSE)) + grl <- .qssElements(entry, cols, dict$keys, windows) + .withMetadata( + .sumStatsNewValidated( + "QtlSumStats", + grl, + dict$entries, + genome, + qcOptions + ), + metadata + ) +} + +# The collection's elements: each tuple's entry split by seqname, each piece +# with its tuple's row of `cols` and LD reference key (`ldKeys`), and its +# analysis window. +# @noRd +.qssElements <- function(entry, cols, ldKeys, windows) { + dfArgs <- c(cols, list(ldReference = ldKeys, check.names = FALSE)) split <- .rtlSplitBySeqname(entry) pieces <- .rtlBindElements(split$entry) - grl <- S4Vectors::`mcols<-`( + S4Vectors::`mcols<-`( pieces, value = .qssPieceMetadata(dfArgs, split, pieces, windows) ) - .withMetadata( - .sumStatsNewValidated("QtlSumStats", grl, dict$refs, genome, qcOptions), - metadata - ) } # Each piece's metadata row, its tuple's, with the tuple's analysis window: diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 1e8817f9f..70ee27057 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -77,13 +77,17 @@ mrashRssWeights <- function( # it is given, which would otherwise be the caller's. w0 = (w0 %||% rep(1 / length(s0), length(s0))) + 0 ), - !!!methodArgs + !!!as.list(methodArgs) ) model <- exec(mr.ash.rss, !!!callArgs) if (identical(fitRetention, "none")) { return(model$mu1) } - `attr<-`(model$mu1, "fit", model) + `attr<-`( + model$mu1, + "fit", + .withFitVariantIds(model, stat[["variantNames"]]) + ) } # The z-scores mr.ash.rss() fits: the statistics' own, or b / seb. @@ -142,11 +146,26 @@ mrashRssWeights <- function( #' standardize the effect sizes by MAF. Default is NULL. #' @param verbose Whether to print verbose output. Default is FALSE. #' @param seed Random seed for reproducibility. Default is NULL. +#' @param shrinkCorr The LD shrinkage \eqn{c}: the sampler reads +#' \eqn{cR + (1 - c)I}. Default 1, none. +#' @param raoBlackwell Report the blocks' conditional posterior means, +#' averaged over the kept iterations, rather than the draws' average. +#' Default \code{FALSE}. +#' @param nChains The number of chains, from seeds \code{seed}, +#' \code{seed + 1}, ... (each drawn when \code{seed} is \code{NULL}). +#' A single chain warns when its posterior mean effects' squares sum past +#' twice the squared marginal effects, a sign that it diverged. With more +#' than one, a chain stops once a kept draw's squared effects do, and is +#' dropped, and the rest are filtered and averaged as LDpred2's vignette +#' does (see \code{\link{ldpred2AutoWeights}}). Default 1. #' #' @return A list containing the posterior estimates: - betaEst: Posterior #' estimates of SNP effect sizes. - psiEst: Posterior estimates of psi #' (shrinkage parameters). - sigmaEst: Posterior estimate of the residual #' variance. - phiEst: Posterior estimate of the global shrinkage parameter. +#' With several chains, these are the kept chains' means, and +#' \code{chains} records each chain's seed and whether it diverged and was +#' kept. #' @keywords internal prsCs <- function( bhat, @@ -160,7 +179,10 @@ prsCs <- function( nBurnin = 500, thin = 5, verbose = FALSE, - seed = NULL + seed = NULL, + shrinkCorr = 1, + raoBlackwell = FALSE, + nChains = 1 ) { .rssValidateInputs(bhat, R, n) .prsCsRun( @@ -175,13 +197,16 @@ prsCs <- function( nBurnin, thin, verbose, - seed + seed, + shrinkCorr, + raoBlackwell, + nChains ) } # PRS-CS on an LD source (.ldSourceRows()): the sampler that factors R for a -# matrix, or for a factor the one that never forms R (prscs_mcmc.h), which -# draws differently from the same posterior. +# matrix, or for a factor the one that never forms R (FactorLdBlock in +# rss_mcmc.h), which draws differently from the same posterior. # @noRd .prsCsRun <- function( bhat, @@ -195,11 +220,15 @@ prsCs <- function( nBurnin, thin, verbose, - seed + seed, + shrinkCorr = 1, + raoBlackwell = FALSE, + nChains = 1 ) { if (!is.null(maf) && length(bhat) != length(maf)) { abort("The length of 'bhat' must be the same as 'maf'.") } + .mcmcAssertShared(shrinkCorr, raoBlackwell, nChains) # cpp11 requires exact integer types for int parameters settings <- list( a = a, @@ -212,20 +241,37 @@ prsCs <- function( nBurnin = as.integer(nBurnin), thin = as.integer(thin), verbose = verbose, - seed = seed + shrinkCorr = shrinkCorr, + raoBlackwell = raoBlackwell ) - result <- if (is.null(ld$F)) { - exec(prsCsCpp, !!!settings, ldBlk = list(blk1 = ld$R)) - } else { - exec(prsCsFactorCpp, !!!settings, factorR = ld$F) + .mcmcChains( + ".prsCsChain", + list(settings = settings, ld = ld), + .mcmcSeeds(seed, nChains), + c("betaEst", "psiEst", "sigmaEst", "phiEst"), + "prsCs", + bhat + ) +} + +# One PRS-CS chain, on the LD matrix or a factor of it. +# @noRd +.prsCsChain <- function(settings, ld, seed, track) { + if (is.null(ld$F)) { + return(exec( + prsCsCpp, + !!!settings, + ldBlk = list(blk1 = ld$R), + seed = seed, + track = track + )) } - # Return the result as a list (camelCase to match the rest of the package - # API). - list( - betaEst = result$betaEst, - psiEst = result$psiEst, - sigmaEst = result$sigmaEst, - phiEst = result$phiEst + exec( + prsCsFactorCpp, + !!!settings, + factorR = ld$F, + seed = seed, + track = track ) } @@ -298,7 +344,10 @@ prsCsWeights <- function( "nBurnin", "thin", "verbose", - "seed" + "seed", + "shrinkCorr", + "raoBlackwell", + "nChains" ) ), !!!as.list(methodArgs) @@ -307,7 +356,11 @@ prsCsWeights <- function( if (identical(fitRetention, "none")) { return(model$betaEst) } - `attr<-`(model$betaEst, "fit", model) + `attr<-`( + model$betaEst, + "fit", + .withFitVariantIds(model, stat[["variantNames"]]) + ) } #' SDPR (Summary-Statistics-Based Dirichelt Process Regression for Polygenic @@ -347,14 +400,27 @@ prsCsWeights <- function( #' #' @param seed Integer or \code{NULL}. Random seed for the Gibbs sampler; #' \code{NULL} leaves the RNG state unchanged. +#' @param raoBlackwell Report \eqn{\eta} times the effects' conditional +#' posterior means, averaged over the kept iterations, rather than the +#' draws' average. Default \code{FALSE}. +#' @param nChains The number of chains, from seeds \code{seed}, +#' \code{seed + 1}, ...; they are tested for divergence and, with more +#' than one, combined as \code{\link{prsCs}}'s are. Default 1. #' @return A list with \code{betaEst} (the estimated effect sizes) and -#' \code{h2} (the estimated heritability). +#' \code{h2} (the estimated heritability), and with several chains +#' \code{chains} as \code{\link{prsCs}} records it. #' @note This function wraps a rewritten and adapted version of the SDPR C++ #' implementation. SDPR is described in Zhou G, Zhao H (2021), "A fast and #' robust Bayesian nonparametric method for prediction of complex traits #' using summary statistics", PLoS Genetics 17(7): e1009697. #' \doi{10.1371/journal.pgen.1009697} #' +#' It departs from the original where a window has few causal variants. +#' A lone causal variant is drawn jointly, as several are; the original's +#' closed-form draw let the global scale of the effects run away. That +#' scale has an N(1, 1) prior where the original's is flat, under which a +#' window that drew no causal variant tended to stay null. +#' #' @keywords internal sdpr <- function( bhat, @@ -372,7 +438,9 @@ sdpr <- function( thin = 5, optLlk = 1, verbose = TRUE, - seed = NULL + seed = NULL, + raoBlackwell = FALSE, + nChains = 1 ) { .rssValidateInputs(bhat, R, n) .sdprRun( @@ -391,13 +459,16 @@ sdpr <- function( thin, optLlk, verbose, - seed + seed, + raoBlackwell, + nChains ) } # SDPR on an LD source (.ldSourceRows()): the sampler on the matrix, or the # same sampler on the low-rank form of SDPR's matrices from a factor of it -# (sdpr_mcmc.h), which draws as the matrix route does without forming R. +# (sdpr_factor_block() in rss_mcmc.h), which draws as the matrix route does +# without forming R. # @noRd .sdprRun <- function( bhat, @@ -415,9 +486,12 @@ sdpr <- function( thin, optLlk, verbose, - seed + seed, + raoBlackwell = FALSE, + nChains = 1 ) { .sdprValidate(M, perVariantSampleSize, array) + .mcmcAssertShared(1, raoBlackwell, nChains) # cpp11 requires exact integer types for int params + sexp vectors. settings <- list( bhatR = bhat, @@ -432,18 +506,33 @@ sdpr <- function( iter = as.integer(iter), burn = as.integer(burn), thin = as.integer(thin), - # The kernel's thread pool splits its work across LD blocks, and a - # window is always one block, so a second thread would sit idle. - numThreads = 1L, optLlk = as.integer(optLlk), verbose = verbose, - seed = seed + raoBlackwell = raoBlackwell ) + .mcmcChains( + ".sdprChain", + list(settings = settings, ld = ld), + .mcmcSeeds(seed, nChains), + c("betaEst", "h2"), + "sdpr", + bhat + ) +} + +# One SDPR chain, on the LD matrix (a one-block list) or a factor of it. +# @noRd +.sdprChain <- function(settings, ld, seed, track) { if (is.null(ld$F)) { - # The C++ backend takes a block list; the window is one block. - return(exec(sdprCpp, !!!settings, LD = list(blk1 = ld$R))) + return(exec( + sdprCpp, + !!!settings, + LD = list(blk1 = ld$R), + seed = seed, + track = track + )) } - exec(sdprFactorCpp, !!!settings, factorR = ld$F) + exec(sdprFactorCpp, !!!settings, factorR = ld$F, seed = seed, track = track) } # Validate the SDPR settings: M >= 4 (SDPR uses M-2 indexing in sample_V; @@ -536,7 +625,9 @@ sdprWeights <- function( "thin", "optLlk", "verbose", - "seed" + "seed", + "raoBlackwell", + "nChains" ) ), !!!as.list(methodArgs) @@ -545,7 +636,11 @@ sdprWeights <- function( if (identical(fitRetention, "none")) { return(model$betaEst) } - `attr<-`(model$betaEst, "fit", model) + `attr<-`( + model$betaEst, + "fit", + .withFitVariantIds(model, stat[["variantNames"]]) + ) } @@ -602,8 +697,8 @@ mrmashWeights <- function( abort("Both X and Y must be provided if mrmashFit is NULL.") } # methodArgs is one flat bag; the prior-construction names belong to - # mrmashWrapper's `prior` group, so they are routed there rather - # than passed as top-level arguments it no longer has. + # mrmashWrapper's `prior` group and the rest to its `methodArgs`, as + # neither is a top-level argument of mrmashWrapper. split <- .mrmashSplitPriorArgs(as.list(methodArgs)) mrmashFit <- exec( mrmashWrapper, @@ -611,7 +706,7 @@ mrmashWeights <- function( Y, dataDrivenPriorMatrices = dataDrivenPriorMatrices, prior = exec(MrmashPriorParam, !!!split$prior), - !!!split$rest + methodArgs = exec(MrmashOptions, !!!split$rest) ) } out <- mr.mashr::coef.mr.mash(mrmashFit)[-1, , drop = FALSE] @@ -622,7 +717,8 @@ mrmashWeights <- function( out, mrmashFit, dataDrivenPriorMatrices, - fitRetention + fitRetention, + colnames(X) ) } @@ -637,7 +733,8 @@ mrmashWeights <- function( weights, fit, dataDrivenPriorMatrices, - fitRetention + fitRetention, + variantIds = NULL ) { if (identical(fitRetention, "none")) { return(weights) @@ -650,7 +747,7 @@ mrmashWeights <- function( ), compact(list(fit = if (fitRetention == "full") fit)) ) - `attr<-`(weights, "fit", fitList) + `attr<-`(weights, "fit", .withFitVariantIds(fitList, variantIds)) } # The `beta.init` override for mr.ash: lasso weights when the caller supplied @@ -775,7 +872,8 @@ mrmashRssWeights <- function( weights, mrmashRssFit, dataDrivenPriorMatrices, - fitRetention + fitRetention, + stat[["variantNames"]] ) } @@ -823,6 +921,50 @@ mrmashRssWeights <- function( dots ) { ss <- .mrmashRssStats(stat) + prior <- .mrmashRssDefaults( + ss, + dataDrivenPriorMatrices, + canonicalPriorMatrices, + S0, + w0, + V, + covY + ) + # 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. + callArgs <- c( + list( + Bhat = ss$Bhat, + Shat = ss$Shat, + R = LD, + n = as.numeric(stats::median(ss$nVec)), + covY = prior$covY, + V = prior$V, + S0 = prior$S0, + w0 = prior$w0, + # One thread: see .mrmashUnavailable(). + nthreads = 1L + ), + # `dots` is the caller's MrmashOptions() record; c() would append it as + # one opaque element instead of splicing its entries. + as.list(dots) + ) + exec(mr.mashr::mr.mash.rss, !!!callArgs) +} + +# The prior (S0, w0) and the residual and Y covariances (V, covY) mr.mash.rss +# is given: each as supplied, else its default for the statistics `ss` +# (.mrmashRssStats()). +# @noRd +.mrmashRssDefaults <- function( + ss, + dataDrivenPriorMatrices, + canonicalPriorMatrices, + S0, + w0, + V, + covY +) { if (is.null(S0)) { S0 <- buildMrmashPriorMatrices( Bhat = ss$Bhat, @@ -841,24 +983,7 @@ mrmashRssWeights <- function( if (is.null(covY)) { covY <- diag(ss$K) } - # 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. - callArgs <- c( - list( - Bhat = ss$Bhat, - Shat = ss$Shat, - R = LD, - n = as.numeric(stats::median(ss$nVec)), - covY = covY, - V = V, - S0 = S0, - w0 = w0 - ), - # `dots` is the caller's MrmashOptions() record; c() would append it as - # one opaque element instead of splicing its entries. - as.list(dots) - ) - exec(mr.mashr::mr.mash.rss, !!!callArgs) + list(S0 = S0, w0 = w0, V = V, covY = covY) } @@ -900,7 +1025,9 @@ mrmashRssWeights <- function( #' DIFFERENT engines, and then each takes its own constructor: #' \code{lassoWeights} fits with glmnet (\code{GlmnetOptions}) while #' \code{lassosumRssWeights} runs pecotmr's lassosum -#' (\code{LassosumOptions}); \code{enetWeights} / \code{ridgeWeights} fit +#' (\code{LassosumOptions}), or with \code{backend = "bigsnpr"} bigsnpr's +#' lassosum2 (\code{BigsnprOptions}, whose \code{delta} grid comes from +#' the wrapper's \code{s}); \code{enetWeights} / \code{ridgeWeights} fit #' with glmnet too, while \code{enetRssWeights} / \code{ridgeRssWeights} #' use \code{PenalizedRssOptions}; \code{scadWeights} / \code{mcpWeights} / #' \code{l0learnWeights} use ncvreg and L0Learn while their \code{*Rss} @@ -909,6 +1036,18 @@ mrmashRssWeights <- function( #' 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. #' +#' The Bayesian alphabet methods run on several engines each, chosen with +#' their \code{backend}, and each engine takes its own constructor: +#' \code{QggOptions} for qgg on either path, \code{BglrOptions} for BGLR, +#' \code{HibayesOptions} for hibayes on individual-level data and +#' \code{HibayesRssOptions} on summary statistics, and +#' \code{BayesAlphabetRssOptions} for pecotmr's own summary-statistics +#' sampler. Their wrappers set the iterations, burn-in, thinning and prior +#' inclusion probability themselves (\code{nIter}, \code{nBurnin}, +#' \code{thin}, \code{pi}), so every constructor refuses its engine's +#' spelling of them, and hibayes' \code{seed} (drawn from R's random +#' number generator) and \code{threads} (one). +#' #' \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 @@ -929,6 +1068,10 @@ mrmashRssWeights <- function( #' enabling it would nest two frameworks and oversubscribe the machine. #' The glasso and univariate-glmnet \code{mr.mash} initialisations are #' single-threaded for the same reason. +#' +#' \code{MrmashOptions} and \code{MrmashRssOptions} refuse +#' \code{nthreads}: mr.mash itself runs on one thread, because on macOS +#' its worker threads can later hang R inside the OpenMP runtime. #' @param ... Arguments for the engine, under its own names. #' @return A \code{\link{MethodOptions}} object. #' @examples @@ -998,17 +1141,27 @@ QggOptions <- function(...) { 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. + # genotype matrix is `W` here, and 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`" + stat = "supplied from the data by the pipeline", + Glist = "supplied from the data by the pipeline", + LD = "supplied from the data by the pipeline", + method = "the wrapper's `method` (the function called)", + nit = "the wrapper's `nIter`", + nburn = "the wrapper's `nBurnin`", + nthin = "the wrapper's `thin`" + ), + "QggOptions" + ) + .configRefuseUnavailable( + extra, + c( + # qgg's `X` is its covariates. + X = str_c( + "covariates are regressed out of the phenotype before ", + "weights are fitted, so none reach the engine" + ) ), "QggOptions" ) @@ -1031,7 +1184,7 @@ BglrOptions <- function(...) { 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`", + burnIn = "the wrapper's `nBurnin`", thin = "the wrapper's `thin`" ), "BglrOptions" @@ -1045,6 +1198,110 @@ BglrOptions <- function(...) { ) } +#' @rdname twasEngineOptions +#' @export +HibayesOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + formula = "supplied from the data by the pipeline", + data = "supplied from the data by the pipeline", + M = "supplied from the data by the pipeline", + M.id = "supplied from the data by the pipeline", + method = "the wrapper's `method` (the function called)", + niter = "the wrapper's `nIter`", + nburn = "the wrapper's `nBurnin`", + thin = "the wrapper's `thin`" + ), + "HibayesOptions" + ) + .configRefuseUnavailable(extra, .hibayesUnavailable(), "HibayesOptions") + # The individual-level entry point. Its summary-statistics twin, + # HibayesRssOptions(), is separate because hibayes::sbrm() takes + # different arguments, so one record checked against both would accept + # a name meant for the other path. + .newMethodOptions( + "hibayes::ibrm", + defaults = list(), + extra = list(...), + label = "HibayesOptions", + engine = "hibayes" + ) +} + +#' @rdname twasEngineOptions +#' @export +HibayesRssOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + sumstat = "supplied from the data by the pipeline", + ldm = "supplied from the data by the pipeline", + method = "the wrapper's `method` (the function called)", + niter = "the wrapper's `nIter`", + nburn = "the wrapper's `nBurnin`", + thin = "the wrapper's `thin`" + ), + "HibayesRssOptions" + ) + .configRefuseUnavailable(extra, .hibayesUnavailable(), "HibayesRssOptions") + # The summary-statistics twin of HibayesOptions(): hibayes::sbrm() + # takes different arguments from hibayes::ibrm(). + .newMethodOptions( + "hibayes::sbrm", + defaults = list(), + extra = list(...), + label = "HibayesRssOptions", + engine = "hibayesRss" + ) +} + +#' @rdname twasEngineOptions +#' @export +BayesAlphabetRssOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + bhat = "supplied from the data by the pipeline", + F = "supplied from the data by the pipeline", + n = "supplied from the data by the pipeline", + nPerVariant = "supplied from the data by the pipeline", + method = "the wrapper's `method` (the function called)", + nIter = "the wrapper's `nIter`", + nBurnin = "the wrapper's `nBurnin`", + thin = "the wrapper's `thin`", + pi = "the wrapper's `pi`", + shrinkCorr = "the wrapper's `shrinkCorr`" + ), + "BayesAlphabetRssOptions" + ) + .newMethodOptions( + "pecotmr::bayesAlphabetRss", + defaults = list(), + extra = list(...), + label = "BayesAlphabetRssOptions", + engine = "bayesAlphabetRss" + ) +} + +# hibayes arguments pecotmr sets itself and does not expose, with why. +# @noRd +.hibayesUnavailable <- function() { + c( + seed = str_c( + "it is drawn from R's random number generator, so set.seed() ", + "sets it" + ), + threads = str_c( + "hibayes runs on one thread, as weight fitting already runs ", + "inside BiocParallel workers" + ) + ) +} + #' @rdname twasEngineOptions #' @export DprOptions <- function(...) { @@ -1215,6 +1472,33 @@ LassosumOptions <- function(...) { ) } +#' @rdname twasEngineOptions +#' @export +BigsnprOptions <- function(...) { + extra <- list(...) + .configRefuseOwned( + extra, + c( + corr = "supplied from the data by the pipeline", + df_beta = "supplied from the data by the pipeline", + ind.corr = "supplied from the data by the pipeline", + delta = "lassosumRssWeights()'s `s`, as delta = s / (1 - s)", + ncores = str_c( + "one per window: BiocParallel already parallelizes over ", + "windows" + ) + ), + "BigsnprOptions" + ) + .newMethodOptions( + "bigsnpr::snp_lassosum2", + defaults = list(), + extra = list(...), + label = "BigsnprOptions", + engine = "bigsnpr" + ) +} + #' @rdname twasEngineOptions #' @export PenalizedRssOptions <- function(...) { @@ -1290,11 +1574,11 @@ MrmashOptions <- function(...) { 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 `BPPARAM`" + update_V_method = "the wrapper's `updateVMethod`" ), "MrmashOptions" ) + .configRefuseUnavailable(extra, .mrmashUnavailable(), "MrmashOptions") .newMethodOptions( "mr.mashr::mr.mash", defaults = list(), @@ -1330,6 +1614,11 @@ MrmashRssOptions <- function(...) { ), "MrmashRssOptions" ) + .configRefuseUnavailable( + extra, + .mrmashUnavailable(), + "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 @@ -1349,6 +1638,22 @@ MrmashRssOptions <- function(...) { ) } +# mr.mash arguments pecotmr sets itself and does not expose, with why. Its +# RcppParallel workers run OpenMP BLAS, which registers them with the OpenMP +# runtime. SparseArray pauses that runtime after every call, and on macOS +# (LLVM libomp) resuming it spins forever on such workers, so the next +# parallel region after any SparseArray call hangs R. One thread has no +# workers. +# @noRd +.mrmashUnavailable <- function() { + c( + nthreads = str_c( + "mr.mash runs on one thread, as its worker threads can leave ", + "OpenMP in a state that hangs R on macOS" + ) + ) +} + #' Fit a cross-validated glmnet model #' #' The single interface to \code{glmnet::cv.glmnet}, which every glmnet fit in @@ -1421,7 +1726,7 @@ fitGlmnetCv <- function( nfolds = nfolds )) ), - !!!methodArgs + !!!as.list(methodArgs) ) exec(glmnet::cv.glmnet, !!!callArgs) } @@ -1434,10 +1739,20 @@ fitGlmnetCv <- function( #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param alpha Elastic-net mixing parameter in \code{[0, 1]}: \code{1} = lasso, #' \code{0} = ridge, \code{0.5} = elastic net. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing; \code{"slim"} the selected fit, as a list of its coefficients +#' (\code{coef}, over the variants fitted), \code{intercept}, +#' \code{lambda} and cross-validated error there (\code{cvm}, +#' \code{cvsd}); \code{"full"} the whole \code{cv.glmnet} object, with +#' every \code{lambda}'s coefficients. Either names the variants it was +#' fitted on. #' @param methodArgs Additional arguments forwarded to #' \code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare #' list is refused, since it cannot be checked against the engine's formals. -#' @return Numeric vector of length \code{ncol(X)} of per-variant weights. +#' @return Numeric vector of length \code{ncol(X)} of per-variant weights, +#' with the fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @importFrom stats coef #' @examples #' data(eqtlRegionExample) @@ -1445,7 +1760,14 @@ fitGlmnetCv <- function( #' y <- eqtlRegionExample$yRes #' glmnetWeights(X, y, alpha = 0.5) #' @export -glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { +glmnetWeights <- function( + X, + y, + alpha, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) { + fitRetention <- arg_match(fitRetention) eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "glmnetWeights") # `alpha` is the wrapper's own dial and is refused by GlmnetOptions() @@ -1461,7 +1783,31 @@ glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { nfolds = 5, methodArgs = methodArgs ) - replace(eff.wgt, keep, coef(enet, s = "lambda.min")[2:(sum(keep) + 1)]) + coefs <- as.numeric(coef(enet, s = "lambda.min")) + weights <- replace(eff.wgt, keep, coefs[-1L]) + if (identical(fitRetention, "none")) { + return(weights) + } + fit <- if (identical(fitRetention, "full")) { + enet + } else { + .glmnetSlimFit(enet, coefs) + } + `attr<-`(weights, "fit", .withFitVariantIds(fit, colnames(X)[keep])) +} + +# The fit cv.glmnet selected: its coefficients over the variants fitted, the +# intercept, its lambda and the cross-validated error there. +# @noRd +.glmnetSlimFit <- function(cvFit, coefs) { + at <- match(cvFit$lambda.min, cvFit$lambda) + list( + coef = coefs[-1L], + intercept = coefs[[1L]], + lambda = cvFit$lambda.min, + cvm = cvFit$cvm[[at]], + cvsd = cvFit$cvsd[[at]] + ) } #' Compute TWAS weights via elastic net (glmnet) @@ -1471,7 +1817,9 @@ glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { #' @param alpha Elastic-net mixing in \code{[0, 1]}: the L1 share of the #' penalty. Default 0.5. #' @inheritParams glmnetWeights -#' @return Numeric vector of length \code{ncol(X)} of per-variant weights. +#' @return Numeric vector of length \code{ncol(X)} of per-variant weights, +#' with the fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -1481,42 +1829,80 @@ glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { #' enetWeights(X, y, alpha = 0.2) #' @importFrom checkmate assertNumber #' @export -enetWeights <- function(X, y, alpha = 0.5, methodArgs = GlmnetOptions()) { +enetWeights <- function( + X, + y, + alpha = 0.5, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) { .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") assertNumber(alpha, lower = 0, upper = 1) - glmnetWeights(X, y, alpha, methodArgs = methodArgs) + glmnetWeights( + X, + y, + alpha, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) } #' Compute TWAS weights via ridge regression (glmnet, alpha = 0) #' #' Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 0}. #' @inheritParams glmnetWeights -#' @return Numeric vector of length \code{ncol(X)} of per-variant weights. +#' @return Numeric vector of length \code{ncol(X)} of per-variant weights, +#' with the fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' ridgeWeights(X, y) #' @export -ridgeWeights <- function(X, y, methodArgs = GlmnetOptions()) { +ridgeWeights <- function( + X, + y, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) { .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") - glmnetWeights(X, y, 0, methodArgs = methodArgs) + glmnetWeights( + X, + y, + 0, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) } #' Compute TWAS weights via lasso (glmnet, alpha = 1) #' #' Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 1}. #' @inheritParams glmnetWeights -#' @return Numeric vector of length \code{ncol(X)} of per-variant weights. +#' @return Numeric vector of length \code{ncol(X)} of per-variant weights, +#' with the fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' lassoWeights(X, y) #' @export -lassoWeights <- function(X, y, methodArgs = GlmnetOptions()) { +lassoWeights <- function( + X, + y, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) { .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") - glmnetWeights(X, y, 1, methodArgs = methodArgs) + glmnetWeights( + X, + y, + 1, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) } #' Compute Weights Using mr.ash Shrinkage @@ -1538,9 +1924,10 @@ lassoWeights <- function(X, y, methodArgs = GlmnetOptions()) { #' @param y Numeric response (phenotype) vector of length \code{nrow(X)}. #' @param fitRetention How much of the fit is kept as the \code{"fit"} #' attribute of the returned weights: \code{"none"} (default) attaches -#' nothing, \code{"slim"} and \code{"full"} attach the fitted model. This -#' engine keeps no trimmable intermediates, so the two retaining levels -#' behave alike here. +#' nothing, \code{"slim"} the fitted model without its copy of the data +#' (\code{data}) or the order it updated the variants in each iteration +#' (\code{update.order}), \code{"full"} the whole fitted model. Either +#' names the variants it was fitted on. #' @param methodArgs Options forwarded to \code{susieR::mr.ash}, built #' with \code{\link{MrashOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be @@ -1576,743 +1963,2299 @@ mrashWeights <- function( if (identical(fitRetention, "none")) { return(eff.wgt) } - `attr<-`(eff.wgt, "fit", fit.mr.ash) + kept <- if (identical(fitRetention, "full")) { + fit.mr.ash + } else { + .withoutFields(fit.mr.ash, c("data", "update.order")) + } + `attr<-`(eff.wgt, "fit", .withFitVariantIds(kept, colnames(XKeep))) +} +# --- Bayesian alphabet ------------------------------------------------------ +# +# Each alphabet method runs on several engines (backends), so its weight +# function takes `backend` and the settings every engine shares under one +# spelling -- nIter, nBurnin, thin and pi -- which each engine's adapter +# renames to its own. .alphabetBackends is the one record of which engines a +# method has on each data path and which Options constructor configures each. + +# The engines each Bayesian alphabet method runs on, per data path, with the +# Options constructor that configures each. The first is the default. +# @noRd +.alphabetBackends <- list( + individual = list( + bayesA = c(qgg = "QggOptions", hibayes = "HibayesOptions"), + bayesB = c(bglr = "BglrOptions", hibayes = "HibayesOptions"), + bayesC = c(qgg = "QggOptions", hibayes = "HibayesOptions"), + bayesL = c( + qgg = "QggOptions", + bglr = "BglrOptions", + hibayes = "HibayesOptions" + ), + bayesN = c(qgg = "QggOptions", hibayes = "HibayesOptions"), + bayesR = c(qgg = "QggOptions", hibayes = "HibayesOptions") + ), + # On summary statistics the first is the default for an LD matrix; a + # genotype reference defaults to pecotmr (.rssBackend()). + sumstat = list( + bayesA = c( + qgg = "QggOptions", + hibayes = "HibayesRssOptions", + pecotmr = "BayesAlphabetRssOptions" + ), + bayesB = c( + hibayes = "HibayesRssOptions", + pecotmr = "BayesAlphabetRssOptions" + ), + bayesC = c( + qgg = "QggOptions", + hibayes = "HibayesRssOptions", + pecotmr = "BayesAlphabetRssOptions" + ), + bayesL = c( + hibayes = "HibayesRssOptions", + qgg = "QggOptions", + pecotmr = "BayesAlphabetRssOptions" + ), + bayesN = c( + qgg = "QggOptions", + hibayes = "HibayesRssOptions", + pecotmr = "BayesAlphabetRssOptions" + ), + bayesR = c( + qgg = "QggOptions", + hibayes = "HibayesRssOptions", + pecotmr = "BayesAlphabetRssOptions" + ) + ) +) + +# Every method with several engines on a data path: the Bayesian alphabet +# (.alphabetBackends), and on summary statistics the lasso and LDpred2. Each +# engine maps to its Options constructor, NA where it takes none. On summary +# statistics the first engine is an LD matrix's default (.rssBackend()). +# @noRd +.methodBackends <- list( + individual = .alphabetBackends$individual, + sumstat = c( + .alphabetBackends$sumstat, + list( + lasso = c( + pecotmr = "LassosumOptions", + bigsnpr = "BigsnprOptions" + ), + ldpred2Auto = c(bigsnpr = NA_character_, pecotmr = NA_character_), + ldpred2Grid = c(bigsnpr = NA_character_, pecotmr = NA_character_) + ) + ) +) + +# The summary-statistics methods whose pecotmr engine reads only a genotype +# reference's factor of the LD: the alphabet's sampler and LDpred2's. +# @noRd +.rssFactorOnlyMethods <- function() { + c(names(.alphabetBackends$sumstat), "ldpred2Auto", "ldpred2Grid") } -#' Extract Coefficients From Bayesian Linear Regression + +# Each engine's name for each method. hibayes takes the variants that update +# pi, as qgg and BGLR do by default. +# @noRd +.alphabetEngineMethods <- list( + qgg = c( + bayesA = "bayesA", + bayesC = "bayesC", + bayesL = "bayesL", + bayesN = "bayesN", + bayesR = "bayesR" + ), + bglr = c(bayesB = "BayesB", bayesL = "BL"), + hibayes = c( + bayesA = "BayesA", + bayesB = "BayesBpi", + bayesC = "BayesCpi", + bayesL = "BayesL", + bayesN = "BayesRR", + bayesR = "BayesR" + ) +) + +# The adapter that runs each engine, per data path. An individual-level +# adapter returns the engine's fitted object, which .alphabetPosterior() +# reads. +# @noRd +.alphabetFitters <- list( + individual = c( + qgg = ".alphabetQggFit", + bglr = ".alphabetBglrFit", + hibayes = ".alphabetHibayesFit" + ), + sumstat = c( + qgg = ".alphabetQggRssFit", + hibayes = ".alphabetHibayesRssFit", + pecotmr = ".alphabetPecotmrRssFit" + ) +) + +# The prior proportion of non-null effects, for the methods that have one. +# @noRd +.alphabetPiDefaults <- c(bayesB = 0.2, bayesC = 0.1) + +#' Bayesian Alphabet TWAS Weights #' -#' This function performs Bayesian linear regression using the `gbayes` function -#' from the `qgg` package. It then returns the estimated slopes. +#' Fits a Bayesian linear regression of \code{y} on \code{X} under one of +#' the "Bayesian alphabet" priors and returns the posterior mean effects. +#' Each method runs on several engines, chosen by \code{backend}: +#' \itemize{ +#' \item \code{bayesA} (a scaled-t prior), \code{bayesC} (spike and slab +#' with one slab variance), \code{bayesN} (Gaussian, ridge-like) and +#' \code{bayesR} (a mixture of normals): \code{"qgg"} (default, +#' \code{qgg::gbayes}) or \code{"hibayes"} (\code{hibayes::ibrm}). +#' \item \code{bayesB} (spike and slab with a variance per variant): +#' \code{"bglr"} (default, \code{BGLR::BGLR}) or \code{"hibayes"}. +#' \item \code{bayesL} (the Bayesian LASSO): \code{"qgg"} (default), +#' \code{"bglr"} or \code{"hibayes"}, the last two in Park and +#' Casella's form. +#' } +#' The same settings reach every engine: \code{nIter}, \code{nBurnin}, +#' \code{thin} and \code{pi} are renamed to each engine's own spelling, and +#' everything else goes through \code{methodArgs}, built with the backend's +#' own constructor. #' -#' @param y A numeric vector of phenotypes. -#' @param X A numeric matrix of genotypes. -#' @param method A character string declaring the method/prior to be used. -#' Options are bayesN, bayesL, bayesA, bayesC, or bayesR. -#' @param Z An optional numeric matrix of covariates. -#' @param h2 Numeric or \code{NULL}. Prior heritability for the sampler; -#' \code{NULL} lets \code{qgg} estimate it. -#' @param nit Integer. Total number of MCMC iterations. Default \code{5000}. -#' @param nburn Integer. Number of burn-in iterations discarded. Default -#' \code{1000}. -#' @param nthin Integer. Thinning interval for retained MCMC samples. Default +#' @param X A numeric matrix of genotypes (samples x variants). +#' @param y A numeric vector of phenotypes, one per row of \code{X}. +#' @param method The prior: \code{"bayesA"}, \code{"bayesB"}, +#' \code{"bayesC"}, \code{"bayesL"}, \code{"bayesN"} or \code{"bayesR"}. +#' @param backend The engine, one the method has (see Description); +#' \code{NULL} picks the method's default. +#' @param pi For \code{bayesB} and \code{bayesC}, the prior proportion of +#' non-null effects, where each engine's estimate of it starts; \code{NULL} +#' gives 0.2 for \code{bayesB} and 0.1 for \code{bayesC}. Refused for the +#' other methods. +#' @param nIter Integer. Total number of MCMC iterations, burn-in included, +#' on every engine. Default \code{5000}. +#' @param nBurnin Integer. Number of burn-in iterations discarded; less than +#' \code{nIter}. Default \code{1000}. +#' @param thin 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 -#' silently ignored. -#' @return A vector containing the weights to be applied to each genotype in -#' predicting the phenotype. -#' @details This function fits a Bayesian linear regression model with a range -#' of priors. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing; \code{"slim"} the posterior summaries, as a list of the +#' effects' posterior means (\code{coef}, over the variants fitted) and, +#' where the backend reports them, their posterior inclusion probabilities +#' (\code{pip}); \code{"full"} the backend's whole fitted object. Either +#' names the variants it was fitted on. +#' @param methodArgs Options for the backend's engine, built with its +#' constructor: \code{\link{QggOptions}}, \code{\link{BglrOptions}} or +#' \code{\link{HibayesOptions}}. \code{NULL} keeps the engine's defaults. +#' A bare list is refused: it cannot be checked against the engine, so a +#' misspelled option would be silently ignored. +#' @return A numeric vector of weights, one per variant (column of +#' \code{X}); columns dropped for zero variance receive weight 0. Unless +#' \code{fitRetention = "none"} the fit is attached as attribute +#' \code{"fit"}. #' @examples -#' X <- matrix(rnorm(100000), nrow = 1000) -#' Z <- matrix(round(runif(3000, 0, 0.8), 0), nrow = 1000) -#' set1 <- sample(seq_len(ncol(X)), 5) -#' set2 <- sample(seq_len(ncol(X)), 5) -#' sets <- list(set1, set2) -#' g <- rowSums(X[, c(set1, set2)]) -#' e <- rnorm(nrow(X), mean = 0, sd = 1) -#' y <- g + e -#' bayesLWeights(y = y, X = X, Z = Z) -#' bayesRWeights(y = y, X = X, Z = Z) +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' bayesAlphabetWeights(X, y, "bayesR", nIter = 1000, nBurnin = 200) +#' @importFrom checkmate assertVector #' @export bayesAlphabetWeights <- function( X, y, method, - Z = NULL, - h2 = NULL, - nit = 5000, - nburn = 1000, - nthin = 5, - methodArgs = QggOptions() + backend = NULL, + pi = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL ) { - .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") - .bayesAlphabetValidate(X, y, Z) - - eff.wgt <- rep(0, ncol(X)) + method <- arg_match(method, names(.alphabetBackends$individual)) + fitRetention <- arg_match(fitRetention) + backend <- .methodBackend(method, backend, "individual") + .assertMcmcSchedule(nIter, nBurnin, thin) + pi <- .alphabetPi(method, pi) + methodArgs <- .backendOptions( + methodArgs, + .alphabetBackends$individual[[method]][[backend]], + backend + ) + assertVector(y, len = nrow(X)) keep <- .dropZeroVariance(X, "bayesAlphabetWeights") - - callArgs <- list_modify( + fit <- exec( + .alphabetFitters$individual[[backend]], + X = X[, keep, drop = FALSE], + y = y, + method = method, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + pi = pi, + methodArgs = methodArgs + ) + posterior <- .alphabetPosterior(fit, backend) + weights <- replace(rep(0, ncol(X)), keep, posterior$coef) + if (identical(fitRetention, "none")) { + return(weights) + } + kept <- if (identical(fitRetention, "full")) fit else posterior + `attr<-`(weights, "fit", .withFitVariantIds(kept, colnames(X)[keep])) +} + +# A backend's posterior summaries over the variants it fitted: the effects' +# posterior means and, where it reports them, their posterior inclusion +# probabilities. +# @noRd +.alphabetPosterior <- function(fit, backend) { + parts <- switch( + backend, + qgg = list(coef = fit$bm, pip = fit$dm), + bglr = list( + coef = pluck(fit, "ETA", 1L, "b"), + pip = pluck(fit, "ETA", 1L, "d") + ), + hibayes = list(coef = fit$alpha, pip = fit$pip) + ) + map(compact(parts), as.numeric) +} + +# The backend `backend` names for `method` on one data path, or the method's +# default when NULL. Refuses an engine the method does not have there. +# @noRd +.methodBackend <- function(method, backend, path) { + choices <- names(.methodBackends[[path]][[method]]) + if (is.null(backend)) { + return(choices[[1L]]) + } + if (length(backend) != 1L || !is_in(backend, choices)) { + abort(glue( + "`backend` for {method} must be one of ", + "{str_flatten(choices, ', ')}." + )) + } + backend +} + +# The MCMC schedule every backend shares: nIter counts every iteration, +# burn-in included. +# @noRd +#' @importFrom checkmate assertCount +.assertMcmcSchedule <- function(nIter, nBurnin, thin) { + assertCount(nIter, positive = TRUE) + assertCount(nBurnin) + assertCount(thin, positive = TRUE) + if (nIter <= nBurnin) { + abort("`nIter`, the total iterations, must exceed `nBurnin`.") + } + invisible(NULL) +} + +# The starting prior proportion of non-null effects: `pi`, else the method's +# default, for the methods that have one; NULL for the others, which refuse +# one. +# @noRd +#' @importFrom checkmate assertNumber +.alphabetPi <- function(method, pi) { + if (!is_in(method, names(.alphabetPiDefaults))) { + if (!is.null(pi)) { + abort(glue("`pi` applies to bayesB and bayesC, not {method}.")) + } + return(NULL) + } + pi <- pi %||% .alphabetPiDefaults[[method]] + assertNumber(pi, lower = 0, upper = 1) + pi +} + +# The record the backend's engine runs with: its constructor's defaults for +# NULL or an empty list, otherwise `methodArgs`, which must have been built +# by that constructor. +# @noRd +.backendOptions <- function(methodArgs, ctorName, backend) { + ctor <- get(ctorName, envir = asNamespace("pecotmr")) + if (is.null(methodArgs) || identical(methodArgs, list())) { + return(ctor()) + } + .assertMethodOptions(methodArgs, ctorName, "methodArgs") + want <- metadata(ctor())$engine + got <- metadata(methodArgs)$engine + if (!identical(got, want)) { + abort(glue( + "`methodArgs` was built for engine '{got}', but backend ", + "'{backend}' takes {ctorName}()." + )) + } + methodArgs +} + +# qgg's sampler on individual-level data. qgg's `X` is its covariates, which +# never reach it: they are regressed out of the phenotype beforehand. qgg +# runs nit + nburn iterations, so its `nit` counts the draws after the +# burn-in, where `nIter` counts them all. +# @noRd +.alphabetQggFit <- function( + X, + y, + method, + nIter, + nBurnin, + thin, + pi, + methodArgs +) { + if (!requireNamespace("qgg", quietly = TRUE)) { + abort("Package 'qgg' is required for backend = \"qgg\".") + } + if (!is.null(pi)) { + methodArgs <- .methodOptionsWith(methodArgs, "QggOptions", pi = pi) + } + callArgs <- list_modify( list( y = y, - W = X[, keep, drop = FALSE], - X = Z, - method = method, - h2 = h2, - nit = nit, - nburn = nburn, - nthin = nthin + W = X, + method = .alphabetEngineMethods$qgg[[method]], + nit = nIter - nBurnin, + nburn = nBurnin, + nthin = thin + ), + !!!as.list(methodArgs) + ) + exec(qgg::gbayes, !!!callArgs) +} + +# BGLR's sampler, through bglrWeights(), which keeps BGLR's files in a +# temporary directory; the fitted object is what it returns as the weights' +# fit. BayesB's prior inclusion probability belongs to the linear term rather +# than to BGLR() itself. +# @noRd +.alphabetBglrFit <- function( + X, + y, + method, + nIter, + nBurnin, + thin, + pi, + methodArgs +) { + weights <- bglrWeights( + X, + y, + model = .alphabetEngineMethods$bglr[[method]], + nIter = nIter, + burnIn = nBurnin, + thin = thin, + etaArgs = if (is.null(pi)) list() else list(probIn = pi), + fitRetention = "full", + methodArgs = methodArgs + ) + attr(weights, "fit", exact = TRUE) +} + +# hibayes' sampler on individual-level data. ibrm() matches the genotypes to +# the phenotypes by id and calls set.seed() itself, so it gets a seed drawn +# from R's generator and the caller's stream is put back afterwards. +# @noRd +.alphabetHibayesFit <- function( + X, + y, + method, + nIter, + nBurnin, + thin, + pi, + methodArgs +) { + if (!requireNamespace("hibayes", quietly = TRUE)) { + abort("Package 'hibayes' is required for backend = \"hibayes\".") + } + if (!is.null(pi)) { + methodArgs <- .methodOptionsWith( + methodArgs, + "HibayesOptions", + Pi = c(1 - pi, pi) + ) + } + ids <- as.character(seq_len(nrow(X))) + callArgs <- list_modify( + list( + formula = y ~ 1, + data = data.frame(id = ids, y = y), + M = X, + M.id = ids, + method = .alphabetEngineMethods$hibayes[[method]], + niter = nIter, + nburn = nBurnin, + thin = thin, + seed = .sessionSeedDraw(), + threads = 1L, + verbose = FALSE ), - !!!methodArgs + !!!as.list(methodArgs) + ) + withr::with_preserve_seed(exec(hibayes::ibrm, !!!callArgs)) +} + +#' @title BayesA TWAS weights (scaled-t prior) +#' @description Fits the BayesA prior, a normal on each effect whose +#' variance is drawn per variant (a scaled-t), through +#' \code{\link{bayesAlphabetWeights}}. +#' @inheritParams bayesAlphabetWeights +#' @param backend \code{"qgg"} (default) or \code{"hibayes"}. +#' @param methodArgs Options for the backend's engine: +#' \code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +#' hibayes. \code{NULL} keeps the engine's defaults. +#' @return A numeric vector of weights, one per variant (column of +#' \code{X}); columns dropped for zero variance receive weight 0. +#' Unless \code{fitRetention = "none"} the fit is attached as +#' attribute \code{"fit"}. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' bayesAWeights(X, y) +#' @export +bayesAWeights <- function( + X, + y, + backend = c("qgg", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetWeights( + X, + y, + "bayesA", + backend = arg_match(backend), + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) +} + +#' @title BayesB TWAS weights (spike and slab, a variance per variant) +#' @description Fits the BayesB prior, a point mass at zero mixed with a +#' scaled-t slab, through \code{\link{bayesAlphabetWeights}}. +#' @inheritParams bayesAlphabetWeights +#' @param backend \code{"bglr"} (default) or \code{"hibayes"}. +#' @param pi The prior proportion of non-null effects, where each engine's +#' estimate of it starts. Default \code{0.2}. +#' @param methodArgs Options for the backend's engine: +#' \code{\link{BglrOptions}} for BGLR, \code{\link{HibayesOptions}} for +#' hibayes. \code{NULL} keeps the engine's defaults. +#' @return A numeric vector of weights, one per variant (column of +#' \code{X}); columns dropped for zero variance receive weight 0. +#' Unless \code{fitRetention = "none"} the fit is attached as +#' attribute \code{"fit"}. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' bayesBWeights(X, y) +#' @export +bayesBWeights <- function( + X, + y, + backend = c("bglr", "hibayes"), + pi = 0.2, + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetWeights( + X, + y, + "bayesB", + backend = arg_match(backend), + pi = pi, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) +} + +#' @title BayesC TWAS weights (spike and slab, one slab variance) +#' @description Fits the BayesC prior, a point mass at zero mixed with a +#' normal whose variance every variant shares, through +#' \code{\link{bayesAlphabetWeights}}. +#' @inheritParams bayesAlphabetWeights +#' @param backend \code{"qgg"} (default) or \code{"hibayes"}. +#' @param pi The prior proportion of non-null effects, where each engine's +#' estimate of it starts. Default \code{0.1}. +#' @param methodArgs Options for the backend's engine: +#' \code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +#' hibayes. \code{NULL} keeps the engine's defaults. +#' @return A numeric vector of weights, one per variant (column of +#' \code{X}); columns dropped for zero variance receive weight 0. +#' Unless \code{fitRetention = "none"} the fit is attached as +#' attribute \code{"fit"}. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' bayesCWeights(X, y) +#' @export +bayesCWeights <- function( + X, + y, + backend = c("qgg", "hibayes"), + pi = 0.1, + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetWeights( + X, + y, + "bayesC", + backend = arg_match(backend), + pi = pi, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) +} + +#' @title BayesL TWAS weights (the Bayesian LASSO) +#' @description Fits the Bayesian LASSO, a Laplace prior on each effect, +#' through \code{\link{bayesAlphabetWeights}}. qgg's form is the default; +#' BGLR's and hibayes' follow Park and Casella (2008). +#' @inheritParams bayesAlphabetWeights +#' @param backend \code{"qgg"} (default), \code{"bglr"} or +#' \code{"hibayes"}. +#' @param methodArgs Options for the backend's engine: +#' \code{\link{QggOptions}} for qgg, \code{\link{BglrOptions}} for BGLR, +#' \code{\link{HibayesOptions}} for hibayes. \code{NULL} keeps the +#' engine's defaults. +#' @return A numeric vector of weights, one per variant (column of +#' \code{X}); columns dropped for zero variance receive weight 0. +#' Unless \code{fitRetention = "none"} the fit is attached as +#' attribute \code{"fit"}. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' bayesLWeights(X, y) +#' @export +bayesLWeights <- function( + X, + y, + backend = c("qgg", "bglr", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetWeights( + X, + y, + "bayesL", + backend = arg_match(backend), + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) +} + +#' @title BayesN TWAS weights (Gaussian prior, ridge-like) +#' @description Fits a normal prior shared by every effect, whose posterior +#' mean is the BLUP, a ridge regression, through +#' \code{\link{bayesAlphabetWeights}}. +#' @inheritParams bayesAlphabetWeights +#' @param backend \code{"qgg"} (default) or \code{"hibayes"}. +#' @param methodArgs Options for the backend's engine: +#' \code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +#' hibayes. \code{NULL} keeps the engine's defaults. +#' @return A numeric vector of weights, one per variant (column of +#' \code{X}); columns dropped for zero variance receive weight 0. +#' Unless \code{fitRetention = "none"} the fit is attached as +#' attribute \code{"fit"}. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' bayesNWeights(X, y) +#' @export +bayesNWeights <- function( + X, + y, + backend = c("qgg", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetWeights( + X, + y, + "bayesN", + backend = arg_match(backend), + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) +} + +#' @title BayesR TWAS weights (a mixture of normals) +#' @description Fits the BayesR prior, a mixture of a point mass at zero and +#' normals of increasing variance, through +#' \code{\link{bayesAlphabetWeights}}. +#' @inheritParams bayesAlphabetWeights +#' @param backend \code{"qgg"} (default) or \code{"hibayes"}. +#' @param methodArgs Options for the backend's engine: +#' \code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +#' hibayes. \code{NULL} keeps the engine's defaults. +#' @return A numeric vector of weights, one per variant (column of +#' \code{X}); columns dropped for zero variance receive weight 0. +#' Unless \code{fitRetention = "none"} the fit is attached as +#' attribute \code{"fit"}. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' bayesRWeights(X, y) +#' @export +bayesRWeights <- function( + X, + y, + backend = c("qgg", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetWeights( + X, + y, + "bayesR", + backend = arg_match(backend), + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + fitRetention = arg_match(fitRetention), + methodArgs = methodArgs + ) +} + +# --- Bayesian alphabet on summary statistics -------------------------------- +# +# qgg and hibayes read the LD as a matrix: given a genotype reference, the +# matrix is formed from the panel for them. pecotmr's own sampler +# (bayesAlphabetRss(), on rss_mcmc.h) reads a genotype reference's +# factor and never forms it, and runs on nothing else; it is the default +# there, while an LD matrix defaults to the first engine .alphabetBackends +# lists. + +#' Bayesian Alphabet TWAS Weights From Summary Statistics +#' +#' Fits a Bayesian alphabet prior to marginal summary statistics and an LD +#' reference and returns the posterior mean effects. Each method runs on +#' several engines, chosen by \code{backend}: +#' \itemize{ +#' \item \code{"qgg"}: \code{qgg::gbayes} on the LD matrix, for +#' \code{bayesA}, \code{bayesC}, \code{bayesL}, \code{bayesN} and +#' \code{bayesR}. +#' \item \code{"hibayes"}: \code{hibayes::sbrm} on the LD matrix, for +#' every method. +#' \item \code{"pecotmr"}: pecotmr's own sampler, on a genotype +#' reference's factor of the LD without forming the matrix. Its priors +#' follow qgg's for \code{bayesA}, \code{bayesC}, \code{bayesN} and +#' \code{bayesR} and hibayes' for \code{bayesB}; \code{bayesL} takes +#' Park and Casella's form (hibayes') or Legarra et al.'s (qgg's +#' individual-level one), through +#' \code{\link{BayesAlphabetRssOptions}}. By default it reads the +#' statistics through SDPR's likelihood (Zhou and Zhao 2021), which +#' drops the part of the marginal effects the reference LD cannot +#' explain; \code{BayesAlphabetRssOptions(ldProjection = NULL)} turns +#' that off (see \code{ldProjection} of the internal +#' \code{bayesAlphabetRss()}). +#' } +#' \code{NULL} picks \code{"pecotmr"} for a genotype reference, and for an +#' LD matrix qgg (\code{bayesA}, \code{bayesC}, \code{bayesN}, +#' \code{bayesR}) or hibayes (\code{bayesB}, \code{bayesL}). qgg and +#' hibayes run on a genotype reference through the LD matrix formed from +#' it; pecotmr's sampler does not run on an LD matrix. +#' +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The engines receive the standardized effects +#' z / sqrt(n), with n the median of \code{n}. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. +#' @param method The prior: \code{"bayesA"}, \code{"bayesB"}, +#' \code{"bayesC"}, \code{"bayesL"}, \code{"bayesN"} or \code{"bayesR"}. +#' @param backend The engine, one the method has (see Description); +#' \code{NULL} picks the default for the LD reference. +#' @inheritParams bayesAlphabetWeights +#' @param shrinkCorr The LD shrinkage \eqn{c}: every engine reads +#' \eqn{cR + (1 - c)I}, qgg and hibayes as the matrix they are given, +#' pecotmr's sampler through the factor. Default 0.95, the LDpred2 +#' vignette's. A reference with fewer samples than the window has variants +#' lacks directions the statistics have, and without shrinkage the +#' samplers' effects can grow without bound along them (pecotmr's sampler +#' also drops those directions by default, through SDPR's likelihood; see +#' \code{\link{bayesAlphabetRssWeights}}). A small or +#' mismatched reference does better with less, down to 0.4 as the LDpred2 +#' vignette advises; the study's own genotypes as the reference need none, +#' up to 1. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} attach the engine's estimates +#' (\code{betaEst}, and where the engine gives them the inclusion +#' probabilities \code{pip}, the non-null proportion \code{pi} and the +#' residual variance), \code{backend} and the \code{shrinkCorr} used. No +#' engine keeps trimmable intermediates, so the two retaining levels +#' behave alike. +#' @param methodArgs Options for the backend's engine, built with its +#' constructor: \code{\link{QggOptions}} for qgg, +#' \code{\link{HibayesRssOptions}} for hibayes, +#' \code{\link{BayesAlphabetRssOptions}} for pecotmr's sampler. \code{NULL} +#' keeps the engine's defaults. +#' @return A numeric vector of the posterior mean effects on the +#' standardized scale, one per variant. Unless \code{fitRetention = +#' "none"}, the engine's estimates are attached as attribute \code{"fit"}. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' ss <- lapply( +#' seq_len(ncol(X)), function(j) coef(summary(lm(y ~ X[, j])))[2, 1:2]) +#' stat <- list( +#' b = vapply(ss, `[`, numeric(1), 1L), +#' seb = vapply(ss, `[`, numeric(1), 2L), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' w <- bayesAlphabetRssWeights( +#' stat, +#' LdMatrix(cor(X)), +#' "bayesN", +#' backend = "hibayes", +#' nIter = 1000, +#' nBurnin = 200 +#' ) +#' @export +bayesAlphabetRssWeights <- function( + stat, + ldReference, + method, + backend = NULL, + pi = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + fitRetention <- arg_match(fitRetention) + method <- arg_match(method, names(.alphabetBackends$sumstat)) + backend <- .rssBackend(method, backend, ldReference) + .assertMcmcSchedule(nIter, nBurnin, thin) + .alphabetAssertSampleSize(stat$n, "bayesAlphabetRssWeights") + .assertShrinkCorr(shrinkCorr) + pi <- .alphabetPi(method, pi) + methodArgs <- .backendOptions( + methodArgs, + .alphabetBackends$sumstat[[method]][[backend]], + backend + ) + fit <- exec( + .alphabetFitters$sumstat[[backend]], + stat = stat, + ldReference = ldReference, + method = method, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + pi = pi, + shrinkCorr = shrinkCorr, + methodArgs = methodArgs + ) + if (identical(fitRetention, "none")) { + return(fit$betaEst) + } + `attr<-`( + fit$betaEst, + "fit", + .withFitVariantIds( + c(fit, list(shrinkCorr = shrinkCorr)), + stat[["variantNames"]] + ) + ) +} + +# The alphabet's samplers divide by n - 1 and the matrix engines' standard +# errors by n - 2, so the sample size (the median of `n`) must exceed 2. +# @noRd +.alphabetAssertSampleSize <- function(n, label) { + assertNumeric(n, any.missing = FALSE, min.len = 1L) + if (median(n) <= 2) { + abort(glue("{label}: the sample size must exceed 2.")) + } + invisible(NULL) +} + +# The engine a summary-statistics method runs on: `backend`, or by default +# pecotmr where the method has it and a genotype reference supplies the LD, +# and otherwise the method's first engine. A pecotmr engine that reads only +# a factor of the LD (.rssFactorOnlyMethods()) refuses an LD matrix. +# @noRd +.rssBackend <- function(method, backend, ldReference) { + choices <- names(.methodBackends$sumstat[[method]]) + genotypeRef <- .ldIsGenotypeRef(ldReference) + if (is.null(backend)) { + if (genotypeRef && is_in("pecotmr", choices)) { + return("pecotmr") + } + return(choices[[1L]]) + } + backend <- .methodBackend(method, backend, "sumstat") + factorOnly <- is_in(method, .rssFactorOnlyMethods()) + if (identical(backend, "pecotmr") && factorOnly && !genotypeRef) { + others <- setdiff(choices, "pecotmr") + abort(glue( + "backend = \"pecotmr\" runs on a genotype reference's factor of ", + "the LD; with an LD matrix, use {str_flatten(others, ' or ')}." + )) + } + backend +} + +# The standardized statistics and the LD matrix the matrix engines read, +# formed from the panel for a genotype reference and shrunk to +# c R + (1 - c) I. +# @noRd +.alphabetRssDense <- function(stat, ldReference, shrinkCorr) { + R <- .rssLdMatrix(stat, ldReference, "bayesAlphabetRssWeights") + n <- median(stat$n) + bhat <- .rssMarginalCor(stat, n = n, p = nrow(R)) + .rssValidateSource(bhat, list(R = R), n) + list( + R = .rssShrunkMatrix(R, shrinkCorr), + bhat = bhat, + seb = sqrt((1 - bhat^2) / (n - 2)), + n = n, + ids = stat$variantNames + ) +} + +# qgg's summary-statistics sampler, on its in-memory LD: every variant's LD +# with every other, as the dense matrix gives it. qgg runs nit + nburn +# iterations, so nit is nIter net of the burn-in. +# @noRd +.alphabetQggRssFit <- function( + stat, + ldReference, + method, + nIter, + nBurnin, + thin, + pi, + shrinkCorr, + methodArgs +) { + if (!requireNamespace("qgg", quietly = TRUE)) { + abort("Package 'qgg' is required for backend = \"qgg\".") + } + if (!is.null(pi)) { + methodArgs <- .methodOptionsWith(methodArgs, "QggOptions", pi = pi) + } + inp <- .alphabetRssDense(stat, ldReference, shrinkCorr) + qin <- .alphabetQggInputs(inp) + callArgs <- list_modify( + list( + stat = qin$stat, + Glist = qin$Glist, + LD = qin$LD, + method = .alphabetEngineMethods$qgg[[method]], + nit = nIter - nBurnin, + nburn = nBurnin, + nthin = thin + ), + !!!as.list(methodArgs) + ) + fit <- exec(qgg::gbayes, !!!callArgs) + list( + betaEst = unname(fit$stat[inp$ids, "bm"]), + pip = unname(fit$stat[inp$ids, "dm"]), + backend = "qgg" + ) +} + +# qgg's summary statistics, map and LD for one window, built in memory: the +# statistics on the standardized scale (allele labels and frequencies are +# placeholders qgg carries but does not read), and each variant's LD with +# every other. +# @noRd +.alphabetQggInputs <- function(inp) { + m <- length(inp$bhat) + ids <- inp$ids + pos <- seq_len(m) + list( + stat = data.frame( + rsids = ids, + chr = 1L, + pos = pos, + ea = "A", + nea = "G", + eaf = 0.5, + b = inp$bhat, + seb = inp$seb, + p = 2 * pnorm(-abs(inp$bhat / inp$seb)), + n = inp$n, + row.names = ids + ), + Glist = list( + nchr = 1L, + rsidsLD = list(ids), + rsids = list(ids), + pos = list(pos), + a1 = list(rep("A", m)), + a2 = list(rep("G", m)), + af = list(rep(0.5, m)) + ), + LD = list(list( + values = set_names(as.list(asplit(inp$R, 2L)), ids), + indices = set_names(rep(list(seq_len(m) - 1L), m), ids) + )) + ) +} + +# hibayes' summary-statistics sampler on the LD matrix. Its genotype +# variances are the matrix's diagonal, so the correlation matrix and +# standardized statistics give standardized effects; it reads no allele +# frequencies, so the column carries a placeholder. sbrm() calls set.seed() +# itself, so it gets a seed drawn from R's generator and the caller's stream +# is put back afterwards. +# @noRd +.alphabetHibayesRssFit <- function( + stat, + ldReference, + method, + nIter, + nBurnin, + thin, + pi, + shrinkCorr, + methodArgs +) { + if (!requireNamespace("hibayes", quietly = TRUE)) { + abort("Package 'hibayes' is required for backend = \"hibayes\".") + } + if (!is.null(pi)) { + methodArgs <- .methodOptionsWith( + methodArgs, + "HibayesRssOptions", + Pi = c(1 - pi, pi) + ) + } + inp <- .alphabetRssDense(stat, ldReference, shrinkCorr) + callArgs <- list_modify( + list( + sumstat = data.frame( + SNP = inp$ids, + A1 = "A", + A2 = "G", + freq = 0.5, + b = inp$bhat, + se = inp$seb, + p = 2 * pnorm(-abs(inp$bhat / inp$seb)), + N = inp$n + ), + ldm = inp$R, + method = .alphabetEngineMethods$hibayes[[method]], + niter = nIter, + nburn = nBurnin, + thin = thin, + seed = .sessionSeedDraw(), + threads = 1L, + verbose = FALSE + ), + !!!as.list(methodArgs) + ) + fit <- withr::with_preserve_seed(exec(hibayes::sbrm, !!!callArgs)) + list(betaEst = as.numeric(fit$alpha), backend = "hibayes") +} + +# pecotmr's sampler, on a genotype reference's factor of the LD. +# @noRd +.alphabetPecotmrRssFit <- function( + stat, + ldReference, + method, + nIter, + nBurnin, + thin, + pi, + shrinkCorr, + methodArgs +) { + ld <- .rssLdSource(stat, ldReference, "bayesAlphabetRssWeights") + n <- median(stat$n) + bhat <- .rssMarginalCor(stat, n = n, p = .ldSourceSize(ld)) + .rssValidateSource(bhat, ld, n) + callArgs <- list_modify( + list( + bhat = bhat, + F = ld$F, + n = n, + method = method, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + pi = pi, + nPerVariant = stat$n, + shrinkCorr = shrinkCorr + ), + !!!as.list(methodArgs) + ) + c(exec(bayesAlphabetRss, !!!callArgs), list(backend = "pecotmr")) +} + +#' pecotmr's Bayesian Alphabet Sampler on a Factor of the LD +#' +#' Internal: \code{\link{bayesAlphabetRssWeights}} is the public interface; +#' its \code{backend = "pecotmr"} runs this, and +#' \code{\link{BayesAlphabetRssOptions}} sets the arguments below other +#' than the data and the wrapper's own. +#' +#' The LD is a factor F of R = F'F / (k - 1), as a genotype reference gives +#' it, and is never formed: each effect's update costs O(k). The likelihood +#' is SBayes's, X'X = W^1/2 R W^1/2 and X'y = w * bhat for per-variant +#' weights w, read by default through SDPR's projection +#' (\code{ldProjection}). The priors are qgg's (CRAN 1.1.6) for +#' \code{bayesA}, \code{bayesC}, \code{bayesN} and \code{bayesR}, +#' hibayes' for \code{bayesB} (as BayesBpi), and for \code{bayesL} either. +#' +#' @param bhat The standardized marginal effects. +#' @param F The factor of the LD (k x p). +#' @param n The sample size. +#' @param method The prior, as in \code{\link{bayesAlphabetRssWeights}}. +#' @param nIter,nBurnin,thin The chain's iterations (burn-in included), +#' burn-in and thinning. +#' @param pi For \code{bayesB} and \code{bayesC}, where the estimate of the +#' non-null proportion starts. +#' @param nPerVariant The per-variant sample sizes, read when +#' \code{perVariantWeights = TRUE}. +#' @param bayesLForm For \code{bayesL} only: \code{"parkCasella"} (the +#' default, hibayes' form, the Laplace prior scaled by the residual +#' variance) or \code{"legarra"} (Legarra et al. 2011, qgg's +#' individual-level form, unscaled). +#' @param perVariantWeights \code{FALSE} (default) weights every variant by +#' n; \code{TRUE} weights each by qgg's 1 / (se^2 + b^2 / n_j), from its +#' own sample size. +#' @param h2 The prior guess of the heritability that sets the starting +#' variances. Default \code{0.5}, qgg's and hibayes'. +#' @param shrinkCorr The LD shrinkage \eqn{c}: the sampler reads +#' \eqn{cR + (1 - c)I}. Default 1, none. +#' @param ldProjection The ridge \eqn{a} of SDPR's likelihood (Zhou and Zhao +#' 2021), under which the sampler reads the LD as +#' \eqn{R (R + aI)^{-1} R} and the marginal effects as +#' \eqn{R (R + aI)^{-1} \hat\beta}: each of R's eigen-directions keeps +#' \eqn{\lambda / (\lambda + a)} of the effects, so their part outside +#' the reference LD's span, which a reference smaller than the window or +#' unlike the study leaves, never enters. Without it the samplers' effects +#' can grow without bound along those directions. Default 0.1, SDPR's; +#' \code{NULL} reads the LD and the effects as they are. +#' @param allowJumpSign Keep a drawn effect whose sign differs from the +#' current one; \code{FALSE} sets it to zero, and out of the slab, +#' instead. Default \code{TRUE}. +#' @param raoBlackwell Report each effect's conditional posterior mean, +#' averaged over the kept iterations, rather than the draws' average. +#' Default \code{FALSE}. +#' @param nChains The number of chains, each from a seed drawn from R's +#' random number generator; they are tested for divergence and, with more +#' than one, combined as \code{\link{prsCs}}'s are. Default 1. +#' @param verbose Whether to report the chain's progress. +#' @return A list: \code{betaEst} (the posterior mean effects), \code{pip} +#' (for \code{bayesB}, \code{bayesC} and \code{bayesR}, each effect's +#' posterior probability of being non-null), \code{pi} (the non-null +#' proportion) and \code{residualVariance}. +#' @keywords internal +bayesAlphabetRss <- function( + bhat, + F, + n, + method, + nIter = 5000, + nBurnin = 1000, + thin = 5, + pi = NULL, + nPerVariant = NULL, + bayesLForm = NULL, + perVariantWeights = FALSE, + h2 = 0.5, + shrinkCorr = 1, + ldProjection = 0.1, + allowJumpSign = TRUE, + raoBlackwell = FALSE, + nChains = 1, + verbose = FALSE +) { + method <- arg_match(method, names(.alphabetBackends$sumstat)) + .alphabetRssAssert(n, h2, ldProjection, allowJumpSign) + .mcmcAssertShared(shrinkCorr, raoBlackwell, nChains) + sampler <- list( + method = method, + legarra = .alphabetLegarra(method, bayesLForm), + pi = pi %||% 0, + h2 = h2, + nIter = as.integer(nIter), + nBurnin = as.integer(nBurnin), + thin = as.integer(thin), + verbose = verbose, + shrinkCorr = shrinkCorr, + allowJumpSign = allowJumpSign, + raoBlackwell = raoBlackwell + ) + data <- .alphabetData( + bhat, + F, + n, + nPerVariant, + perVariantWeights, + ldProjection + ) + .alphabetRssChains(c(data, sampler), method, nChains, bhat) +} + +# What bayesAlphabetRss() checks besides the settings every sampler shares. +# @noRd +.alphabetRssAssert <- function(n, h2, ldProjection, allowJumpSign) { + .alphabetAssertSampleSize(n, "bayesAlphabetRss") + assertNumber(h2, lower = 0, upper = 1) + assertNumber(ldProjection, lower = 0, finite = TRUE, null.ok = TRUE) + assertFlag(allowJumpSign) + invisible(NULL) +} + +# The data pecotmr's alphabet sampler reads: the marginal effects and the +# factor of the LD, through SDPR's likelihood unless `ldProjection` is NULL +# (.alphabetProjected()), the per-variant weights, taken from the marginal +# effects as given, and n. +# @noRd +.alphabetData <- function( + bhat, + F, + n, + nPerVariant, + perVariantWeights, + ldProjection +) { + projected <- .alphabetProjected(bhat, F, ldProjection) + list( + bhat = projected$bhat, + factorR = projected$F, + weights = .alphabetRssWeightsFor( + bhat, + n, + nPerVariant, + perVariantWeights + ), + n = as.integer(n) + ) +} + +# SDPR's likelihood (Zhou and Zhao 2021, its optLlk = 1) for the alphabet +# sampler: the RSS likelihood with the marginal effects' covariance +# (R + aI) / n, under which the sampler reads R (R + aI)^-1 R as the LD and +# R (R + aI)^-1 bhat as the effects. Each eigen-direction of R keeps +# lambda / (lambda + a) of the effects, so their part outside the reference +# LD's span -- left by a reference smaller than the window, or unlike the +# study -- never enters, nor does the runaway it drives through the variance +# updates. From the thin SVD of F (.ldFactorEigen()), over the r directions +# with a positive eigenvalue, the LD is the factor +# sqrt(r) diag(lambda / sqrt(lambda + a)) V' and a zero row, so that the +# sampler's normalization by its rows less one holds. NULL `a` leaves the +# effects and F as they are. +# @noRd +.alphabetProjected <- function(bhat, F, a) { + if (is.null(a)) { + return(list(bhat = bhat, F = F)) + } + ev <- .ldFactorEigen(F) + kept <- ev$values > sqrt(.Machine$double.eps) * max(ev$values) + lambda <- ev$values[kept] + V <- ev$vectors[, kept, drop = FALSE] + list( + bhat = as.numeric(V %*% (lambda / (lambda + a) * crossprod(V, bhat))), + F = rbind(sqrt(length(lambda)) * (lambda / sqrt(lambda + a)) * t(V), 0) + ) +} + +# The chains of pecotmr's alphabet sampler, combined (.mcmcChains()); its +# divergence warning tests the effects against the marginal effects as +# given. Only bayesB, bayesC and bayesR report inclusion probabilities. +# @noRd +.alphabetRssChains <- function(settings, method, nChains, bhat) { + fit <- .mcmcChains( + ".alphabetSamplerChain", + list(settings = settings), + as.list(sample.int(.Machine$integer.max, nChains)), + c("betaEst", "pip", "pi", "residualVariance"), + "bayesAlphabetRss", + bhat + ) + if (!is_in(method, c("bayesB", "bayesC", "bayesR"))) { + fit$pip <- NULL + } + fit +} + +# One chain of pecotmr's alphabet sampler. +# @noRd +.alphabetSamplerChain <- function(settings, seed, track) { + exec(bayesAlphabetFactorCpp, !!!settings, seed = seed, track = track) +} + +# Whether bayesL takes Legarra et al.'s form; `bayesLForm` is bayesL's +# alone. +# @noRd +.alphabetLegarra <- function(method, bayesLForm) { + if (is.null(bayesLForm)) { + return(FALSE) + } + if (!identical(method, "bayesL")) { + abort(glue("`bayesLForm` applies to bayesL, not {method}.")) + } + identical(arg_match0(bayesLForm, c("parkCasella", "legarra")), "legarra") +} + +# The per-variant weights: n for every variant, or qgg's +# 1 / (se^2 + b^2 / n_j) from each one's own sample size. +# @noRd +.alphabetRssWeightsFor <- function(bhat, n, nPerVariant, perVariantWeights) { + if (!isTRUE(perVariantWeights)) { + return(rep(as.numeric(n), length(bhat))) + } + nj <- nPerVariant %||% rep(n, length(bhat)) + if (length(nj) != length(bhat)) { + abort("`nPerVariant` must give one sample size per variant.") + } + seb2 <- (1 - bhat^2) / (nj - 2) + 1 / (seb2 + bhat^2 / nj) +} + +#' @title BayesA TWAS weights from summary statistics +#' @description \code{\link{bayesAlphabetRssWeights}} with the BayesA prior. +#' @inheritParams bayesAlphabetRssWeights +#' @param backend \code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +#' \code{NULL} picks the default for the LD reference. +#' @return A numeric vector of the posterior mean effects, one per variant. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' stat <- list( +#' z = as.vector(cor(X, eqtlRegionExample$yRes)) * sqrt(nrow(X)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' bayesARssWeights(stat, LdMatrix(cor(X)), "hibayes", nIter = 1000, +#' nBurnin = 200) +#' @export +bayesARssWeights <- function( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetRssWeights( + stat, + ldReference, + "bayesA", + backend = backend, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + shrinkCorr = shrinkCorr, + fitRetention = fitRetention, + methodArgs = methodArgs + ) +} + +#' @title BayesB TWAS weights from summary statistics +#' @description \code{\link{bayesAlphabetRssWeights}} with the BayesB prior. +#' @inheritParams bayesAlphabetRssWeights +#' @param backend \code{"hibayes"} or \code{"pecotmr"}; \code{NULL} picks +#' the default for the LD reference. +#' @param pi The prior proportion of non-null effects, where each engine's +#' estimate of it starts. Default \code{0.2}. +#' @return A numeric vector of the posterior mean effects, one per variant. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' stat <- list( +#' z = as.vector(cor(X, eqtlRegionExample$yRes)) * sqrt(nrow(X)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' bayesBRssWeights(stat, LdMatrix(cor(X)), nIter = 1000, nBurnin = 200) +#' @export +bayesBRssWeights <- function( + stat, + ldReference, + backend = NULL, + pi = 0.2, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetRssWeights( + stat, + ldReference, + "bayesB", + backend = backend, + pi = pi, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + shrinkCorr = shrinkCorr, + fitRetention = fitRetention, + methodArgs = methodArgs + ) +} + +#' @title BayesC TWAS weights from summary statistics +#' @description \code{\link{bayesAlphabetRssWeights}} with the BayesC prior. +#' @inheritParams bayesAlphabetRssWeights +#' @param backend \code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +#' \code{NULL} picks the default for the LD reference. +#' @param pi The prior proportion of non-null effects, where each engine's +#' estimate of it starts. Default \code{0.1}. +#' @return A numeric vector of the posterior mean effects, one per variant. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' stat <- list( +#' z = as.vector(cor(X, eqtlRegionExample$yRes)) * sqrt(nrow(X)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' bayesCRssWeights(stat, LdMatrix(cor(X)), "hibayes", nIter = 1000, +#' nBurnin = 200) +#' @export +bayesCRssWeights <- function( + stat, + ldReference, + backend = NULL, + pi = 0.1, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetRssWeights( + stat, + ldReference, + "bayesC", + backend = backend, + pi = pi, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + shrinkCorr = shrinkCorr, + fitRetention = fitRetention, + methodArgs = methodArgs + ) +} + +#' @title BayesL TWAS weights from summary statistics +#' @description \code{\link{bayesAlphabetRssWeights}} with the Bayesian +#' LASSO. +#' @inheritParams bayesAlphabetRssWeights +#' @param backend \code{"hibayes"}, \code{"qgg"} or \code{"pecotmr"}; +#' \code{NULL} picks the default for the LD reference. +#' @return A numeric vector of the posterior mean effects, one per variant. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' stat <- list( +#' z = as.vector(cor(X, eqtlRegionExample$yRes)) * sqrt(nrow(X)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' bayesLRssWeights(stat, LdMatrix(cor(X)), nIter = 1000, nBurnin = 200) +#' @export +bayesLRssWeights <- function( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetRssWeights( + stat, + ldReference, + "bayesL", + backend = backend, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + shrinkCorr = shrinkCorr, + fitRetention = fitRetention, + methodArgs = methodArgs + ) +} + +#' @title BayesN TWAS weights from summary statistics +#' @description \code{\link{bayesAlphabetRssWeights}} with a normal prior +#' shared by every effect. +#' @inheritParams bayesAlphabetRssWeights +#' @param backend \code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +#' \code{NULL} picks the default for the LD reference. +#' @return A numeric vector of the posterior mean effects, one per variant. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' stat <- list( +#' z = as.vector(cor(X, eqtlRegionExample$yRes)) * sqrt(nrow(X)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' bayesNRssWeights(stat, LdMatrix(cor(X)), "hibayes", nIter = 1000, +#' nBurnin = 200) +#' @export +bayesNRssWeights <- function( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetRssWeights( + stat, + ldReference, + "bayesN", + backend = backend, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + shrinkCorr = shrinkCorr, + fitRetention = fitRetention, + methodArgs = methodArgs + ) +} + +#' @title BayesR TWAS weights from summary statistics +#' @description \code{\link{bayesAlphabetRssWeights}} with the BayesR prior. +#' @inheritParams bayesAlphabetRssWeights +#' @param backend \code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +#' \code{NULL} picks the default for the LD reference. +#' @return A numeric vector of the posterior mean effects, one per variant. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' stat <- list( +#' z = as.vector(cor(X, eqtlRegionExample$yRes)) * sqrt(nrow(X)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' bayesRRssWeights(stat, LdMatrix(cor(X)), "hibayes", nIter = 1000, +#' nBurnin = 200) +#' @export +bayesRRssWeights <- function( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) { + bayesAlphabetRssWeights( + stat, + ldReference, + "bayesR", + backend = backend, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + shrinkCorr = shrinkCorr, + fitRetention = fitRetention, + methodArgs = methodArgs + ) +} + +# --- LDpred2 ----------------------------------------------------------------- +# +# LDpred2-auto and LDpred2-grid run on bigsnpr, on the LD matrix written to a +# temporary file, or on pecotmr's port of its samplers (ldpred2FactorCpp()), +# on a genotype reference's factor of the LD. Both take the statistics in +# standardized units, z / sqrt(n_j) for each variant's own sample size, and +# return weights in the same units. + +#' LDpred2-auto Weights from Summary Statistics +#' +#' LDpred2-auto (Prive et al. 2020, 2023) estimates the point-normal prior's +#' proportion of causal variants \eqn{p} and the heritability \eqn{h^2} +#' within its Gibbs sampler, so nothing is tuned. One chain runs from each +#' starting \eqn{p} in \code{pInit}. As in the LDpred2 vignette, a chain +#' whose fitted correlations span less than 0.95 times the 95th percentile of +#' the chains' spans is dropped, and the rest are averaged. A chain has +#' diverged, and is dropped too, once a kept draw's squared effects sum past +#' twice the squared marginal effects; bigsnpr's own sampler tests every +#' iteration, burn-in included. +#' +#' The defaults are the LDpred2 vignette's, without the MAF-dependent prior +#' variance. +#' +#' @details +#' \code{backend = "bigsnpr"} runs bigsnpr's \code{snp_ldpred2_auto()} on the +#' LD matrix, written to a temporary file for the call; for a genotype +#' reference the matrix is formed from its genotypes. \code{"pecotmr"} runs +#' pecotmr's port of the same sampler on a genotype reference's factor of the +#' LD, never forming the matrix. bigsnpr's functions call +#' \code{foreach::registerDoSEQ()}, which replaces any foreach parallel +#' backend registered in the session. Both draw their seeds from R's random +#' number generator, so \code{set.seed()} makes the weights reproducible. +#' +#' @param stat A list of summary statistics: \code{n} (per-variant sample +#' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, +#' \code{b} with \code{seb}, or \code{b} alone, taken as already +#' standardized. The sampler reads z / sqrt(n) for each variant's own +#' sample size. +#' @param ldReference The LD reference the statistics' variants are matched +#' to by \code{stat$variantNames}: a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an +#' \code{\link{LdMatrix}}. +#' @param backend \code{"bigsnpr"} or \code{"pecotmr"}. \code{NULL} +#' (default) is pecotmr for a genotype reference and bigsnpr for an +#' \code{\link{LdMatrix}}; pecotmr's sampler reads only a genotype +#' reference. +#' @param h2Init The starting heritability. \code{NULL} (default) estimates +#' it for the window by LAVA, as \code{\link{estimateH2}} does for QTL +#' summary statistics, which reads the reference's sample size, so an +#' \code{LdMatrix} must record \code{nSamples}. Floored at 0.001, which is +#' also the start where LAVA gives no estimate. +#' @param pInit The starting proportions of causal variants, one chain each. +#' @param nIter,nBurnin Each chain's iterations, burn-in included, and its +#' burn-in. +#' @param shrinkCorr The LD shrinkage \eqn{c}: the sampler reads +#' \eqn{cR + (1 - c)I}. +#' @param allowJumpSign Keep a drawn effect whose sign differs from the +#' current one; \code{FALSE} sets it to zero instead. +#' @param pBounds The bounds on \eqn{p}. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights. \code{"none"} (default) attaches +#' nothing. \code{"slim"} keeps \code{chains}, a table with one row per +#' chain (its starting \code{pInit}, its estimates \code{p} and \code{h2}, +#' whether it \code{diverged} and whether it was \code{kept}), and the kept +#' chains' mean inclusion probabilities \code{postp}, \code{p} and +#' \code{h2}. \code{"full"} also keeps \code{beta}, each chain's effects +#' (variants x chains). +#' @return A numeric vector of weights, the kept chains' mean effects. Unless +#' \code{fitRetention = "none"}, the fit is attached as attribute +#' \code{"fit"}. +#' @examples +#' if (requireNamespace("bigsnpr", quietly = TRUE)) { +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' stat <- list( +#' cor = as.vector(cor(X, y)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' ld <- LdMatrix(cor(X), nSamples = nrow(X)) +#' set.seed(1) +#' w <- ldpred2AutoWeights(stat, ld, h2Init = 0.1, pInit = c(0.01, 0.1), +#' fitRetention = "slim") +#' attr(w, "fit")$chains +#' } +#' @export +ldpred2AutoWeights <- function( + stat, + ldReference, + backend = NULL, + h2Init = NULL, + pInit = exp(seq(log(1e-4), log(0.2), length.out = 30)), + nIter = 700, + nBurnin = 500, + shrinkCorr = 0.95, + allowJumpSign = FALSE, + pBounds = c(1e-5, 1), + fitRetention = c("none", "slim", "full") +) { + fitRetention <- arg_match(fitRetention) + label <- "ldpred2AutoWeights" + backend <- .rssBackend("ldpred2Auto", backend, ldReference) + .assertMcmcSchedule(nIter, nBurnin, 1L) + .ldpred2AssertProportions(pInit, "pInit") + .ldpred2AssertProportions(pBounds, "pBounds") + .ldpred2AssertSampler(shrinkCorr, allowJumpSign) + inp <- .rssPerVariantInput(stat, ldReference, label) + config <- list( + pInit = pInit, + h2 = .ldpred2H2(h2Init, inp, label), + nIter = nIter, + nBurnin = nBurnin, + shrinkCorr = shrinkCorr, + allowJumpSign = allowJumpSign, + pBounds = sort(pBounds) + ) + engine <- .ldpred2Engine(inp, backend) + on.exit(.bigsnprRelease(engine), add = TRUE) + .withWeightsFitIds( + .ldpred2AutoWeightsFrom( + .ldpred2RunAuto(inp, engine, config), + fitRetention, + label + ), + stat[["variantNames"]] + ) +} + +#' LDpred2-grid Weights from Summary Statistics +#' +#' LDpred2-grid (Prive et al. 2020) runs the point-normal prior's Gibbs +#' sampler at every combination of the proportion of causal variants +#' \code{p}, the heritability \code{h2} and \code{sparse}, and returns one of +#' the fits. Upstream picks it on a validation sample; here, as for the +#' penalized summary-statistics methods, it is picked on held-out summary +#' statistics by default (see Details of \code{\link{lassosumRssWeights}}). A +#' grid point has diverged, and is not picked, once a kept draw's squared +#' effects sum past twice the squared marginal effects; bigsnpr's own +#' sampler tests every iteration, burn-in included. +#' +#' @details +#' \code{backend = "bigsnpr"} runs bigsnpr's \code{snp_ldpred2_grid()} on the +#' LD matrix, written to a temporary file for the call; \code{"pecotmr"} runs +#' pecotmr's port of the same sampler on a genotype reference's factor of the +#' LD. bigsnpr's grid sampler has no LD shrinkage of its own, so for it the +#' matrix written is shrunk, \eqn{cR + (1 - c)I}, as the Bayesian alphabet's +#' matrix engines are given theirs; it always allows a drawn effect to +#' change sign, so it takes no \code{allowJumpSign}. pecotmr's sampler takes +#' both, as LDpred2-auto's does. See \code{\link{ldpred2AutoWeights}} for the +#' temporary file, the foreach backend and the seeds. +#' +#' @inheritParams ldpred2AutoWeights +#' @param p The proportions of causal variants in the grid. +#' @param h2 The heritabilities in the grid. \code{NULL} (default) is the +#' window's LAVA estimate (see \code{h2Init} of +#' \code{\link{ldpred2AutoWeights}}) times 0.3, 0.7, 1 and 1.4, as the +#' LDpred2 vignette scales LD score regression's. +#' @param sparse Whether each fit sets an effect whose inclusion probability +#' falls below \code{p} to zero; both by default. +#' @param shrinkCorr The LD shrinkage \eqn{c}: both engines read +#' \eqn{cR + (1 - c)I}. Default 0.95, as for +#' \code{\link{ldpred2AutoWeights}}; bigsnpr's grid itself has none. +#' @param allowJumpSign As for \code{\link{ldpred2AutoWeights}}; bigsnpr's +#' grid sampler takes only \code{TRUE}, the default. +#' @param selection How the returned fit is chosen: \code{"heldOut"} +#' (default) or \code{"ldQuadratic"}, as for +#' \code{\link{lassosumRssWeights}}. \code{"heldOut"} needs the +#' reference's sample size and refits the grid four times. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights. \code{"none"} (default) attaches +#' nothing. \code{"slim"} keeps \code{path}, the grid (\code{p}, +#' \code{h2}, \code{sparse}) with whether each point \code{diverged} and +#' which was \code{selected}. \code{"full"} also keeps \code{beta}, every +#' point's effects (variants x points). +#' @return A numeric vector of weights, the selected fit's effects, with the +#' selection recorded in attribute \code{"ldpred2_selection"}. Unless +#' \code{fitRetention = "none"}, the grid is attached as attribute +#' \code{"fit"}. +#' @examples +#' if (requireNamespace("bigsnpr", quietly = TRUE)) { +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' stat <- list( +#' cor = as.vector(cor(X, y)), +#' n = rep(nrow(X), ncol(X)), +#' variantNames = colnames(X) +#' ) +#' ld <- LdMatrix(cor(X), nSamples = nrow(X)) +#' set.seed(1) +#' w <- ldpred2GridWeights(stat, ld, p = c(0.01, 0.1, 1), h2 = 0.1) +#' attr(w, "ldpred2_selection") +#' } +#' @export +ldpred2GridWeights <- function( + stat, + ldReference, + backend = NULL, + p = exp(seq(log(1e-5), 0, length.out = 21)), + h2 = NULL, + sparse = c(FALSE, TRUE), + nIter = 150, + nBurnin = 50, + shrinkCorr = 0.95, + allowJumpSign = TRUE, + selection = c("heldOut", "ldQuadratic"), + fitRetention = c("none", "slim", "full") +) { + selection <- arg_match(selection) + fitRetention <- arg_match(fitRetention) + label <- "ldpred2GridWeights" + backend <- .rssBackend("ldpred2Grid", backend, ldReference) + .assertMcmcSchedule(nIter, nBurnin, 1L) + .ldpred2AssertProportions(p, "p") + .ldpred2AssertSampler(shrinkCorr, allowJumpSign) + .ldpred2CheckGridBackend(backend, allowJumpSign, label) + inp <- .rssPerVariantInput(stat, ldReference, label) + if (identical(selection, "heldOut")) { + .rssCheckHeldOutLd(inp$ld, label) + } + config <- list( + grid = .ldpred2Grid(p, .ldpred2GridH2(h2, inp, label), sparse), + nIter = nIter, + nBurnin = nBurnin, + shrinkCorr = shrinkCorr, + allowJumpSign = allowJumpSign + ) + engine <- .ldpred2Engine(inp, backend, shrinkCorr) + on.exit(.bigsnprRelease(engine), add = TRUE) + .withWeightsFitIds( + .ldpred2GridWeightsFrom( + .ldpred2RunGrid(inp, engine, config), + list(inp = inp, engine = engine, config = config), + selection, + fitRetention, + label + ), + stat[["variantNames"]] + ) +} + +# Proportions strictly between 0 and 1, the upper end included. +# @noRd +.ldpred2AssertProportions <- function(x, arg) { + assertNumeric(x, lower = 0, upper = 1, any.missing = FALSE, min.len = 1L) + if (any(x <= 0)) { + abort(glue("`{arg}` must be above 0.")) + } + invisible(NULL) +} + +# @noRd +.ldpred2AssertSampler <- function(shrinkCorr, allowJumpSign) { + .assertShrinkCorr(shrinkCorr) + assertFlag(allowJumpSign) + invisible(NULL) +} + +# bigsnpr's grid sampler has neither the LD shrinkage nor the sign rule. +# @noRd +.ldpred2CheckGridBackend <- function(backend, allowJumpSign, label) { + if (identical(backend, "bigsnpr") && !allowJumpSign) { + abort(c( + glue( + "{label}: bigsnpr's grid sampler always allows a drawn ", + "effect to change sign, so it takes no `allowJumpSign`." + ), + i = "Use backend = \"pecotmr\" with a genotype reference." + )) + } + invisible(NULL) +} + +# The statistics bigsnpr's engines and pecotmr's LDpred2 read: the LD source +# (.rssLdSource()), the standardized effects z / sqrt(n_j) and each +# variant's sample size. +# @noRd +.rssPerVariantInput <- function(stat, ldReference, label) { + ld <- .rssLdSource(stat, ldReference, label) + p <- .ldSourceSize(ld) + n <- rep_len(as.numeric(stat$n), p) + bhat <- .lassosumClampCor(.rssMarginalCor(stat, n = n, p = p)) + .rssValidateSource(bhat, ld, median(n)) + list(ld = ld, bhat = bhat, n = n) +} + +# The heritability LDpred2-auto starts from: the caller's, floored at 0.001 +# as bigsnpr floors it, else the window's LAVA estimate. +# @noRd +.ldpred2H2 <- function(h2, inp, label) { + if (is.null(h2)) { + return(.ldpred2LavaH2(inp, label)) + } + assertNumber(h2, lower = 0, upper = 1) + max(h2, 1e-3) +} + +# The heritabilities of the grid: the caller's, else the window's LAVA +# estimate times 0.3, 0.7, 1 and 1.4. +# @noRd +.ldpred2GridH2 <- function(h2, inp, label) { + if (!is.null(h2)) { + .ldpred2AssertProportions(h2, "h2") + return(h2) + } + .ldpred2LavaH2(inp, label) * c(0.3, 0.7, 1, 1.4) +} + +# The window's heritability by LAVA (.cisH2Lava(), estimateH2()'s default +# for QTL summary statistics), which reads the reference's sample size, +# floored at bigsnpr's 0.001: the start too where LAVA gives no estimate. +# @noRd +.ldpred2LavaH2 <- function(inp, label) { + if (is.na(inp$ld$nSamples)) { + abort(c( + glue( + "{label}: estimating the heritability by LAVA needs the ", + "LD reference's sample size." + ), + i = "Build the LdMatrix with `nSamples`, or give the heritability." + )) + } + h2 <- .cisH2Lava(inp$bhat * sqrt(inp$n), inp$n, inp$ld)$h2 + if (is.na(h2)) 1e-3 else max(h2, 1e-3) +} + +# Every combination of p, h2 and sparse, large p first as bigsnpr runs them. +# @noRd +.ldpred2Grid <- function(p, h2, sparse) { + assertLogical(sparse, any.missing = FALSE, min.len = 1L) + grid <- expand.grid(p = p, h2 = h2, sparse = sparse) + as_tibble(grid[order(-grid$p, grid$sparse, -grid$h2), ]) +} + +# What an LDpred2 run reads: pecotmr's sampler reads the factor in `inp`, +# bigsnpr its sparse matrix (.bigsnprEngine()), shrunk to `shrinkCorr` for a +# sampler of bigsnpr's with no shrinkage of its own (the grid's). +# @noRd +.ldpred2Engine <- function(inp, backend, shrinkCorr = 1) { + if (identical(backend, "pecotmr")) { + return(list(backend = backend)) + } + .bigsnprEngine(inp, shrinkCorr) +} + +# bigsnpr's LD: the matrix as bigsnpr's sparse matrix, written to a temporary +# file that .bigsnprRelease() deletes; for a genotype reference, formed from +# its factor; shrunk to `shrinkCorr` (.rssShrunkMatrix()). +# @noRd +.bigsnprEngine <- function(inp, shrinkCorr = 1) { + if (!requireNamespace("bigsnpr", quietly = TRUE)) { + abort("Package 'bigsnpr' is required for backend = \"bigsnpr\".") + } + R <- .rssShrunkMatrix( + inp$ld$R %||% (crossprod(inp$ld$F) / (nrow(inp$ld$F) - 1)), + shrinkCorr + ) + corr <- bigsnpr::as_SFBM( + methods::as(Matrix::Matrix(R, sparse = TRUE), "generalMatrix"), + tempfile(), + compact = TRUE + ) + list(backend = "bigsnpr", corr = corr) +} + +# The LD matrix shrunk toward the identity, c R + (1 - c) I, for an engine +# that reads the matrix and has no shrinkage of its own (qgg's and hibayes' +# samplers, bigsnpr's grid). +# @noRd +.rssShrunkMatrix <- function(R, shrinkCorr) { + if (shrinkCorr == 1) { + return(R) + } + R <- shrinkCorr * R + diag(R) <- diag(R) + (1 - shrinkCorr) + R +} + +# @noRd +.bigsnprRelease <- function(engine) { + if (!is.null(engine$corr)) { + unlink(engine$corr$sbk) + } + invisible(NULL) +} + +# bigsnpr's statistics: its rescaling sqrt(n se^2 + b^2) is then 1, so it +# reads the standardized effects as they are. +# @noRd +.bigsnprDfBeta <- function(inp) { + data.frame( + beta = inp$bhat, + beta_se = sqrt((1 - inp$bhat^2) / inp$n), + n_eff = inp$n + ) +} + +# LDpred2-auto's chains, each a list of betaEst, corrEst, postp, h2, p, +# pInit and diverged. bigsnpr seeds from R's generator, so it runs under a +# seed drawn from it, leaving the caller's stream one draw on. +# @noRd +.ldpred2RunAuto <- function(inp, engine, config) { + if (identical(engine$backend, "bigsnpr")) { + return(withr::with_seed( + .sessionSeedDraw(), + .ldpred2BigsnprAuto(inp, engine$corr, config) + )) + } + meanLd <- mean(.ldSquaredProduct(inp$ld, matrix(1, length(inp$bhat), 1L))) + map( + config$pInit, + .ldpred2PecotmrAutoChain, + inp = inp, + config = config, + meanLd = meanLd + ) +} + +# @noRd +.ldpred2BigsnprAuto <- function(inp, corr, config) { + runs <- bigsnpr::snp_ldpred2_auto( + corr, + .bigsnprDfBeta(inp), + h2_init = config$h2, + vec_p_init = config$pInit, + burn_in = config$nBurnin, + num_iter = config$nIter - config$nBurnin, + allow_jump_sign = config$allowJumpSign, + shrink_corr = config$shrinkCorr, + use_MLE = FALSE, + p_bounds = config$pBounds, + ncores = 1 + ) + map(runs, .ldpred2BigsnprChain) +} + +# @noRd +.ldpred2BigsnprChain <- function(run) { + list( + betaEst = run$beta_est, + corrEst = run$corr_est, + postp = run$postp_est, + h2 = run$h2_est, + p = run$p_est, + pInit = run$p_init, + diverged = anyNA(run$beta_est) + ) +} + +# One pecotmr chain from `pInit`; p and h2 are their means over the kept +# sweeps, as bigsnpr reports them. +# @noRd +#' @importFrom utils tail +.ldpred2PecotmrAutoChain <- function(pInit, inp, config, meanLd) { + run <- ldpred2FactorCpp( + inp$bhat, + inp$ld$F, + inp$n, + TRUE, + pInit, + config$h2, + FALSE, + config$shrinkCorr, + config$allowJumpSign, + config$pBounds[[1L]], + config$pBounds[[2L]], + meanLd, + as.integer(config$nIter), + as.integer(config$nBurnin), + FALSE, + .sessionSeedDraw() + ) + kept <- config$nIter - config$nBurnin + missing <- rep(NA_real_, length(inp$bhat)) + list( + betaEst = if (run$diverged) missing else run$betaEst, + corrEst = if (run$diverged) missing else run$corrEst, + postp = if (run$diverged) missing else run$postp, + h2 = if (run$diverged) NA_real_ else mean(tail(run$pathH2, kept)), + p = if (run$diverged) NA_real_ else mean(tail(run$pathP, kept)), + pInit = pInit, + diverged = run$diverged ) - model <- exec(qgg::gbayes, !!!callArgs) - replace(eff.wgt, keep, model$bm) } -# Shared input validation for the gbayes-backed weight fitters: qgg present, -# and matching row counts for response / genotype / covariates. +# The grid's fits, variants x points, NA for a point that diverged. # @noRd -#' @importFrom checkmate assertMatrix assertVector -.bayesAlphabetValidate <- function(X, y, Z) { - if (!requireNamespace("qgg", quietly = TRUE)) { - abort("Package 'qgg' is required for this function.") +.ldpred2RunGrid <- function(inp, engine, config) { + if (identical(engine$backend, "bigsnpr")) { + return(withr::with_seed( + .sessionSeedDraw(), + bigsnpr::snp_ldpred2_grid( + engine$corr, + .bigsnprDfBeta(inp), + as.data.frame(config$grid), + burn_in = config$nBurnin, + num_iter = config$nIter - config$nBurnin, + ncores = 1 + ) + )) } - assertVector(y, len = nrow(X)) - assertMatrix(Z, nrows = nrow(X), null.ok = TRUE) + fits <- pmap( + config$grid, + .ldpred2PecotmrGridPoint, + inp = inp, + config = config + ) + exec(cbind, !!!fits) } -#' @title BayesN TWAS weights (Gaussian prior, ridge-equivalent) -#' @description Use Gaussian distribution as prior. Posterior means will be -#' BLUP, equivalent to Ridge Regression. -#' @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 -#' silently ignored. -#' @return A numeric vector of effect-size weights, one per variant (column of -#' \code{X}); columns dropped for zero variance receive weight 0. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' y <- eqtlRegionExample$yRes -#' bayesNWeights(X, y) -#' @export -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, - h2 = h2, - nit = nit, - nburn = nburn, - nthin = nthin, - methodArgs = methodArgs + +# @noRd +.ldpred2PecotmrGridPoint <- function(p, h2, sparse, inp, config) { + run <- ldpred2FactorCpp( + inp$bhat, + inp$ld$F, + inp$n, + FALSE, + p, + h2, + sparse, + config$shrinkCorr, + config$allowJumpSign, + 1e-5, + 1, + 1, + as.integer(config$nIter), + as.integer(config$nBurnin), + FALSE, + .sessionSeedDraw() ) + if (run$diverged) rep(NA_real_, length(inp$bhat)) else run$betaEst } -#' @title BayesL TWAS weights (Laplace prior, LASSO-equivalent) -#' @description Use laplace/double exponential distribution as prior. This is -#' equivalent to Bayesian LASSO. -#' @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 -#' silently ignored. -#' @return A numeric vector of effect-size weights, one per variant (column of -#' \code{X}); columns dropped for zero variance receive weight 0. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' y <- eqtlRegionExample$yRes -#' bayesLWeights(X, y) -#' @export -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, - h2 = h2, - nit = nit, - nburn = nburn, - nthin = nthin, - methodArgs = methodArgs + +# The chains LDpred2's vignette keeps: those whose fitted correlations span +# more than 0.95 times the 95th percentile of the spans, among the chains +# that did not diverge. Every sampler with several chains is combined so. +# @noRd +#' @importFrom stats quantile +.mcmcKeptChains <- function(chains, label) { + span <- map_dbl(chains, .mcmcCorrSpan) + kept <- !is.na(span) & span > 0.95 * quantile(span, 0.95, na.rm = TRUE) + if (!any(kept)) { + abort(glue("{label}: every chain diverged.")) + } + kept +} + +# @noRd +.mcmcCorrSpan <- function(chain) { + if (chain$diverged) NA_real_ else diff(range(chain$corrEst)) +} + +# A sampler's estimates `fields` from one chain per seed in `seeds`. `run` +# names the function that runs one chain from `args`, a seed and whether to +# track it. One chain runs untracked and is returned as it is, with a +# warning when its effects outgrew the marginal effects `bhat`; several run +# tracked, so a diverging one stops, and are combined by .mcmcKeptChains(), +# their estimates averaged over the kept chains, with each chain's seed and +# fate in `chains`. +# @noRd +.mcmcChains <- function(run, args, seeds, fields, label, bhat) { + if (length(seeds) == 1L) { + one <- exec(run, !!!args, seed = seeds[[1L]], track = FALSE) + .mcmcWarnDiverged(one$betaEst, bhat, label) + return(one[fields]) + } + chains <- map(seeds, .mcmcTrackedChain, run = run, args = args) + kept <- .mcmcKeptChains(chains, label) + c( + map(set_names(fields), .mcmcMeanField, chains = chains[kept]), + list( + chains = tibble( + seed = map_dbl(seeds, .mcmcSeedValue), + diverged = map_lgl(chains, "diverged"), + kept = kept + ) + ) ) } -#' @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 -#' silently ignored. -#' @return A numeric vector of effect-size weights, one per variant (column of -#' \code{X}); columns dropped for zero variance receive weight 0. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' y <- eqtlRegionExample$yRes -#' bayesAWeights(X, y) -#' @export -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, - h2 = h2, - nit = nit, - nburn = nburn, - nthin = nthin, - methodArgs = methodArgs + +# A single chain's posterior mean effects `beta` tested as a tracked chain's +# draws are: their squares summing past twice the marginal effects'. The +# draws themselves are not tested, since one noisy draw passes that bound +# on some null windows while the chain's mean stays near zero. +# @noRd +.mcmcWarnDiverged <- function(beta, bhat, label) { + if (sum(beta^2) > 2 * sum(bhat^2)) { + warn(glue( + "{label}: the posterior mean effects' squares sum past twice ", + "the squared marginal effects, so the chain diverged and its ", + "effects are unreliable; several chains (`nChains`) drop the ", + "chains that diverge." + )) + } + invisible(NULL) +} + +# @noRd +.mcmcTrackedChain <- function(seed, run, args) { + exec(run, !!!args, seed = seed, track = TRUE) +} + +# @noRd +.mcmcMeanField <- function(field, chains) { + reduce(map(chains, field), `+`) / length(chains) +} + +# @noRd +.mcmcSeedValue <- function(seed) { + if (is.null(seed)) NA_real_ else as.numeric(seed) +} + +# The chains' seeds: `seed`, `seed + 1`, ..., or NULL for each, which the +# sampler draws itself. +# @noRd +.mcmcSeeds <- function(seed, nChains) { + if (is.null(seed)) { + return(rep(list(NULL), nChains)) + } + as.list(as.integer(seed) + seq_len(nChains) - 1L) +} + +# The options every sampler shares. +# @noRd +.mcmcAssertShared <- function(shrinkCorr, raoBlackwell, nChains) { + .assertShrinkCorr(shrinkCorr) + assertFlag(raoBlackwell) + assertCount(nChains, positive = TRUE) + invisible(NULL) +} + +# The LD shrinkage c of c R + (1 - c) I: above 0, at most 1. +# @noRd +.assertShrinkCorr <- function(shrinkCorr) { + assertNumber(shrinkCorr, lower = 0, upper = 1) + if (shrinkCorr <= 0) { + abort("`shrinkCorr` must be above 0.") + } + invisible(NULL) +} + +# The kept chains' mean effects, with the fit at the requested retention. +# @noRd +.ldpred2AutoWeightsFrom <- function(chains, fitRetention, label) { + kept <- .mcmcKeptChains(chains, label) + beta <- rowMeans(exec(cbind, !!!map(chains[kept], "betaEst"))) + if (identical(fitRetention, "none")) { + return(beta) + } + fit <- list( + chains = tibble( + pInit = map_dbl(chains, "pInit"), + p = map_dbl(chains, "p"), + h2 = map_dbl(chains, "h2"), + diverged = map_lgl(chains, "diverged"), + kept = kept + ), + postp = rowMeans(exec(cbind, !!!map(chains[kept], "postp"))), + p = mean(map_dbl(chains[kept], "p")), + h2 = mean(map_dbl(chains[kept], "h2")) ) + if (identical(fitRetention, "full")) { + fit$beta <- exec(cbind, !!!map(chains, "betaEst")) + } + `attr<-`(beta, "fit", fit) } -#' @title BayesC TWAS weights (rounded-spike prior) -#' @description Use a rounded spike prior (low-variance Gaussian). -#' @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 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 -#' silently ignored. -#' @return A numeric vector of effect-size weights, one per variant (column of -#' \code{X}); columns dropped for zero variance receive weight 0. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' y <- eqtlRegionExample$yRes -#' bayesCWeights(X, y) -#' @export -bayesCWeights <- function( - X, - y, - Z = NULL, - pi = 0.1, - h2 = NULL, - nit = 5000, - nburn = 1000, - nthin = 5, - methodArgs = QggOptions() + +# The grid's selected fit, by `selection` over the points that did not +# diverge, with the fit at the requested retention. `run` is the input, the +# engine and the configuration the grid ran with. +# @noRd +.ldpred2GridWeightsFrom <- function( + candidates, + run, + selection, + fitRetention, + label ) { - .assertMethodOptions(methodArgs, "QggOptions", "methodArgs") - # `pi` is a qgg option, not a formal of bayesAlphabetWeights, so it joins - # the option list rather than the argument list. - bayesAlphabetWeights( - X, - y, - method = "bayesC", - Z, - h2 = h2, - nit = nit, - nburn = nburn, - nthin = nthin, - methodArgs = .methodOptionsWith(methodArgs, "QggOptions", pi = pi) + diverged <- colSums(is.na(candidates)) > 0 + if (all(diverged)) { + abort(glue("{label}: every grid point diverged.")) + } + usable <- replace(candidates, is.na(candidates), 0) + sel <- .ldpred2SelectGrid(usable, run, selection) + beta <- .ldpred2SelectionRecord(sel, run$config$grid) + if (identical(fitRetention, "none")) { + return(beta) + } + fit <- list( + path = mutate( + run$config$grid, + diverged = diverged, + selected = row_number() == sel$index + ) ) + if (identical(fitRetention, "full")) { + fit$beta <- candidates + } + `attr<-`(beta, "fit", fit) } -#' @title BayesR TWAS weights (hierarchical mixture prior) -#' @description Use a hierarchical Bayesian mixture model with four Gaussian -#' components. Variances are scaled by 0, 0.0001, 0.001, and 0.01. -#' @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 -#' silently ignored. -#' @return A numeric vector of effect-size weights, one per variant (column of -#' \code{X}); columns dropped for zero variance receive weight 0. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' y <- eqtlRegionExample$yRes -#' bayesRWeights(X, y) -#' @export -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, - h2 = h2, - nit = nit, - nburn = nburn, - nthin = nthin, - methodArgs = methodArgs + +# @noRd +.ldpred2SelectGrid <- function(candidates, run, selection) { + if (identical(selection, "ldQuadratic")) { + return(.lassosumSelectLdQuadratic(candidates, run$inp$bhat, run$inp$ld)) + } + .rssSelectHeldOut( + candidates, + run$inp$bhat, + run$inp$ld, + median(run$inp$n), + list(fn = ".ldpred2RefitGrid", args = run) ) } +# The grid refit on a held-out split's training part; a point that diverges +# there is zero, so it scores -Inf. +# @noRd +.ldpred2RefitGrid <- function(trainCor, share, inp, engine, config) { + train <- list_assign(inp, bhat = trainCor, n = share * inp$n) + fits <- .ldpred2RunGrid(train, engine, config) + replace(fits, is.na(fits), 0) +} -# #' Bayesian linear regression using summary statistics -# #' -# #' @description -# #' -# #' This function is adapted from those written by Peter Sorensen in the qgg -# #' package. -# #' The following prior distributions are provided: -# #' -# #' Bayes N: Assigning a Gaussian prior to marker effects implies that the -# #' posterior means are the -# #' BLUP estimates (same as Ridge Regression). -# #' -# #' Bayes L: Assigning a double-exponential or Laplace prior is the density -# #' used in -# #' the Bayesian LASSO -# #' -# #' Bayes A: similar to ridge regression but t-distribution prior (rather than -# #' Gaussian) -# #' for the marker effects ; variance comes from an inverse-chi-square -# #' distribution instead of being fixed. Estimation -# #' via Gibbs sampling. -# #' -# #' Bayes C: uses a "rounded spike" (low-variance Gaussian) at origin many -# #' small -# #' effects can contribute to polygenic component, reduces the dimensionality -# #' of -# #' the model (makes Gibbs sampling feasible). -# #' -# #' Bayes R: Hierarchical Bayesian mixture model with 4 Gaussian components, -# #' with -# #' variances scaled by 0, 0.0001 , 0.001 , and 0.01 . -# #' -# #' @param sumstats dataframe with marker summary statistics. Required: beta -# #' coefficient (beta), standard -# #' error of the beta coefficient (se), GWAS sample size (n). Optional: -# #' variant_id or rsid, alleles (A1 -# #' and A2), minor allele frequency (maf). -# #' @param LD is a the LD matrix corresponding to the same markers as in the -# #' stat dataframe -# #' @param variant_ids is an optional character vector of variant ids or -# #' rsids, provided outside of the rss dataframe -# #' @param nit is the number of iterations -# #' @param nburn is the number of burnin iterations -# #' @param nthin is the thinning parameter -# #' @param method specifies the methods used -# #' (method="bayesN","bayesA","bayesL","bayesC","bayesR") -# #' @param vg is a scalar or matrix of genetic (co)variances -# #' @param vb is a scalar or matrix of marker (co)variances -# #' @param ve is a scalar or matrix of residual (co)variances -# #' @param ssg_prior is a scalar or matrix of prior genetic (co)variances -# #' @param ssb_prior is a scalar or matrix of prior marker (co)variances -# #' @param sse_prior is a scalar or matrix of prior residual (co)variances -# #' @param lambda is a vector or matrix of lambda values -# #' @param h2 is the trait heritability -# #' @param pi is the proportion of markers in each marker variance class -# #' @param updateB is a logical for updating marker (co)variances -# #' @param updateG is a logical for updating genetic (co)variances -# #' @param updateE is a logical for updating residual (co)variances -# #' @param updatePi is a logical for updating pi -# #' @param adjustE is a logical for adjusting residual variance -# #' @param nug is a scalar or vector of prior degrees of freedom for prior -# #' genetic (co)variances -# #' @param nub is a scalar or vector of prior degrees of freedom for marker -# #' (co)variances -# #' @param nue is a scalar or vector of prior degrees of freedom for prior -# #' residual (co)variances -# #' @param mask is a vector or matrix of TRUE/FALSE specifying if marker -# #' should be ignored -# #' @param ve_prior is a scalar or matrix of prior residual (co)variances -# #' @param vg_prior is a scalar or matrix of prior genetic (co)variances -# #' @param algorithm is the algorithm to use. Should take on values ("mcmc", -# #' "em-mcmc") -# #' @param tol is tolerance, i.e. convergence criteria used in gbayes -# #' @param nit_local is the number of local iterations -# #' @param nit_global is the number of global iterations -# #' -# #' @return Returns a list structure including -# #' \item{bm}{vector of posterior means for marker effects} -# #' \item{dm}{vector of posterior means for marker inclusion probabilities} -# #' \item{vbs}{scalar or vector (t) of posterior means for marker variances} -# #' \item{vgs}{scalar or vector (t) of posterior means for genomic variances} -# #' \item{ves}{scalar or vector (t) of posterior means for residual variances} -# #' \item{pis}{vector of probabilites for each mcmc iteration} -# #' \item{pim}{posterior distribution probabilities} -# #' \item{r}{vector of residuals} -# #' \item{b}{vector of estimates from the final mcmc iteration} -# #' \item{param}{a list current parameters (same information as item listed -# #' above) -# #' used for restart of the analysis} -# #' \item{stat}{matrix (mxt) of marker information and effects used for -# #' genomic risk scoring} -# #' \item{method}{the method used} -# #' \item{mask}{which loci were masked from analysis} -# #' \item{conv}{dataframe of convergence metrics} -# #' \item{post}{posterior parameter estimates} -# #' \item{ve}{mean residual variance} -# #' \item{vg}{mean genomic variance} -# #' -# #' @export -# gbayes_rss <- function( -# sumstats = NULL, -# LD = NULL, -# variant_ids = NULL, -# nit = 100, -# nburn = 0, -# nthin = 4, -# method = "bayesR", -# vg = NULL, -# vb = NULL, -# ve = NULL, -# ssg_prior = NULL, -# ssb_prior = NULL, -# sse_prior = NULL, -# lambda = NULL, -# h2 = NULL, -# pi = 0.001, -# updateB = TRUE, -# updateG = TRUE, -# updateE = TRUE, -# updatePi = TRUE, -# adjustE = TRUE, -# nug = 4, -# nub = 4, -# nue = 4, -# mask = NULL, -# ve_prior = NULL, -# vg_prior = NULL, -# algorithm = "mcmc", -# tol = 0.001, -# nit_local = NULL, -# nit_global = NULL -# ) { -# # Make sure qgg is installed -# if (!requireNamespace("qgg", quietly = TRUE)) { -# stop( -# paste0( -# "To use this function, please install qgg: ", -# -# ) -# ) -# } -# # Check methods -# methods <- c("bayesN", "bayesA", "bayesL", "bayesC", "bayesR") -# method <- match(method, methods) -# if (!sum(method %in% c(1:5)) == 1) { -# stop("Method specified not valid") -# } -# if (method == 0) { -# # BLUP and we do not estimate parameters -# updateB <- FALSE -# updateE <- FALSE -# } -# -# # Set algorithm -# if (algorithm == "em-mcmc") { -# algo <- 2 -# } else { -# algo <- 1 -# } -# -# # Check that LD matrix is provided and of same length as stats -# if (is.null(LD)) { -# stop("Must provide LD matrix") -# } -# if (nrow(sumstats) != nrow(LD)) { -# stop("LD matrix must correspond to summary statistics") -# } -# -# # Parameters from stat df -# if (is.data.frame(sumstats)) { -# if (!is.null(variant_ids)) { -# variant_ids <- variant_ids -# } else if (!is.null(sumstats$rsids)) { -# variant_ids <- sumstats$rsids -# } else if (!is.null(sumstats$variant_id)) { -# variant_ids <- sumstats$variant_id -# } else { -# variant_ids <- paste0("snp", 1:nrow(sumstats)) -# sumstats$variant_id <- variant_ids -# } -# -# m <- length(variant_ids) -# b <- wy <- ww <- matrix(0, nrow = nrow(sumstats), ncol = 1) -# mask <- matrix(FALSE, nrow = nrow(sumstats), ncol = 1) -# rownames(b) <- rownames(wy) <- rownames(ww) <- rownames( -# mask -# ) <- variant_ids -# -# if (is.null(sumstats$ww)) { -# sumstats$ww <- 1 / (sumstats$se^2 + sumstats$beta^2 / sumstats$n) -# } -# if (is.null(sumstats$wy)) { -# sumstats$wy <- sumstats$beta * sumstats$ww -# } -# if (!is.null(sumstats$n)) { -# n <- as.integer(median(sumstats$n)) -# } -# ww[, 1] <- sumstats$ww -# wy[, 1] <- sumstats$wy -# mask[, 1] <- FALSE -# -# if (any(is.na(wy))) { -# stop("Missing values in wy") -# } -# if (any(is.na(ww))) { -# stop("Missing values in ww") -# } -# -# b2 <- sumstats$beta^2 -# seb2 <- sumstats$se^2 -# yy <- (b2 + (n - 2) * seb2) * sumstats$ww -# yy <- median(yy) -# -# if (is.null(sumstats$A1)) { -# sumstats$A1 <- rep("Unknown", length = nrow(sumstats)) -# } -# if (is.null(sumstats$A2)) { -# sumstats$A2 <- rep("Unknown", length = nrow(sumstats)) -# } -# if (is.null(sumstats$maf)) { -# sumstats$maf <- rep("Unknown", length = nrow(sumstats)) -# af_prov <- 0 -# } else { -# af_prov <- 1 -# } -# } else { -# stop("Summary statistics must be provided in dataframe") -# } -# -# # prep LD for gbayes -# LD_values <- lapply(1:nrow(LD), function(i) as.numeric(LD[i, ])) -# names(LD_values) <- variant_ids -# -# LD_indices <- list(indices = vector("list", length = nrow(LD))) -# for (i in 1:nrow(LD)) { -# LD_indices[[i]] <- 1:nrow(LD) - 1 -# } -# -# bm <- dm <- fit <- res <- vector(length = 1, mode = "list") -# names(bm) <- names(dm) <- names(fit) <- names(res) <- 1 -# -# # Set parameters if not otherwise specified -# if (is.null(m)) { -# m <- length(LD_values) -# } -# vy <- yy / (n - 1) -# if (is.null(pi)) { -# pi <- 0.001 -# } -# if (is.null(h2)) { -# h2 <- 0.5 -# } -# if (is.null(ve)) { -# ve <- vy * (1 - h2) -# } -# if (is.null(vg)) { -# vg <- vy * h2 -# } -# if (method < 4 && is.null(vb)) { -# vb <- vg / m -# } -# if (method >= 4 && is.null(vb)) { -# vb <- vg / (m * pi) -# } -# if (is.null(lambda)) { -# lambda <- rep(ve / vb, m) -# } -# if (method < 4 && is.null(ssb_prior)) { -# ssb_prior <- ((nub - 2.0) / nub) * (vg / m) -# } -# if (method >= 4 && is.null(ssb_prior)) { -# ssb_prior <- ((nub - 2.0) / nub) * (vg / (m * pi)) -# } -# if (is.null(sse_prior)) { -# sse_prior <- ((nue - 2.0) / nue) * ve -# } -# if (is.null(b)) { -# b <- rep(0, m) -# } -# -# pi <- c(1 - pi, pi) -# gamma <- c(0, 1.0) -# if (method == 5) { -# pi <- c(0.95, 0.02, 0.02, 0.01) -# } -# if (method == 5) { -# gamma <- c(0, 0.01, 0.1, 1.0) -# } -# -# seed <- sample.int(.Machine$integer.max, 1) -# -# fit <- qgg:::sbayes_spa( -# wy = wy, -# ww = ww, -# LDvalues = LD_values, -# LDindices = LD_indices, -# b = b, -# lambda = lambda, -# mask = mask, -# yy = yy, -# pi = pi, -# gamma = gamma, -# vg = vg, -# vb = vb, -# ve = ve, -# ssb_prior = ssb_prior, -# sse_prior = sse_prior, -# nub = nub, -# nue = nue, -# updateB = updateB, -# updateE = updateE, -# updatePi = updatePi, -# updateG = updateG, -# adjustE = adjustE, -# n = n, -# nit = nit, -# nburn = nburn, -# nthin = nthin, -# algo = algo, -# method = as.integer(method), -# seed = seed -# ) -# -# names(fit[[1]]) <- names(LD_values) -# names(fit) <- c( -# "bm", -# "dm", -# "coef", -# "vbs", -# "vgs", -# "ves", -# "pis", -# "pim", -# "r", -# "b", -# "param" -# ) -# fit[3] <- NULL -# -# res <- data.frame( -# variant_id = variant_ids, -# bm = fit$bm, -# dm = fit$dm, -# pos = sumstats$pos, -# A1 = sumstats$A1, -# A2 = sumstats$A2, -# maf = sumstats$maf, -# stringsAsFactors = FALSE -# ) -# rownames(res) <- variant_ids -# -# fit$sumstats <- res -# if (af_prov == 1) { -# fit$sumstats$vm <- 2 * -# (1 - fit$sumstats$maf) * -# fit$sumstats$maf * -# fit$sumstats$bm^2 -# } -# fit$method <- methods[method] -# fit$mask <- mask -# -# zve <- coda::geweke.diag(fit$ves[nburn:length(fit$ves)])$z -# zvg <- coda::geweke.diag(fit$vgs[nburn:length(fit$vgs)])$z -# zvb <- coda::geweke.diag(fit$vbs[nburn:length(fit$vbs)])$z -# zpi <- coda::geweke.diag(fit$pis[nburn:length(fit$pis)])$z -# -# ve <- mean(fit$ves[nburn:length(fit$ves)]) -# vg <- mean(fit$vgs[nburn:length(fit$vgs)]) -# vb <- mean(fit$vbs[nburn:length(fit$vbs)]) -# pi <- 1 - fit$pim[1] -# fit$conv <- data.frame(zve = zve, zvg = zvg, zvb = zvb, zpi = zpi) -# fit$post <- data.frame(ve = ve, vg = vg, vb = vb, pi = pi) -# fit$ve <- mean(ve) -# fit$vg <- sum(vg) -# -# return(fit) -# } -# #' Extract weights from gbayes_rss function -# #' @return A numeric vector of the posterior mean of the coefficients. -# #' @export -# bayes_alphabet_rss_weights <- function(sumstats, LD, method, ...) { -# model <- gbayes_rss(sumstats = sumstats, LD = LD, method = method, ...) -# return(model$bm) -# } -# #' Use Gaussian distribution as prior. Posterior means will be BLUP, -# #' equivalent to Ridge Regression. -# #' @export -# bayes_n_rss_weights <- function(sumstats, LD, methodArgs = list()) { -# return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesN", ...)) -# } -# #' Use laplace/double exponential distribution as prior. This is equivalent -# #' to Bayesian LASSO. -# #' @export -# bayes_l_rss_weights <- function(sumstats, LD, methodArgs = list()) { -# return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesL", ...)) -# } -# #' Use t-distribution as prior. -# #' @export -# bayes_a_rss_weights <- function(sumstats, LD, methodArgs = list()) { -# return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesA", ...)) -# } -# #' Use a rounded spike prior (low-variance Gaussian). -# #' @export -# bayes_c_rss_weights <- function(sumstats, LD, methodArgs = list()) { -# return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesC", ...)) -# } -# #' Use a hierarchical Bayesian mixture model with four Gaussian components. -# #' Variances are scaled -# #' by 0, 0.0001 , 0.001 , and 0.01 . -# #' @export -# bayes_r_rss_weights <- function(sumstats, LD, methodArgs = list()) { -# return(bayes_alphabet_rss_weights(sumstats, LD, method = "bayesR", ...)) -# } +# The selected fit's effects, with its grid point recorded. +# @noRd +.ldpred2SelectionRecord <- function(sel, grid) { + point <- grid[sel$index, ] + `attr<-`( + as.numeric(sel$beta), + "ldpred2_selection", + c(mode = sel$mode, p = point$p, h2 = point$h2, sparse = point$sparse) + ) +} #' Lassosum RSS: LASSO on summary statistics with LD reference #' @@ -2419,8 +4362,23 @@ lassosumRss <- function( corInput } +# The first candidate whose score ties with the best (.rssScoreTies()). +# @noRd .lassosumFirstMax <- function(x) { - which(x == max(x, na.rm = TRUE))[1] + .rssScoreTies(x)[1L] +} + +# The candidates whose scores tie with the best to rounding, within a +# relative sqrt(eps): candidates that differ only in scale score alike under +# a correlation, but not to the last bit. Where no score is finite, those +# equal to the best. +# @noRd +.rssScoreTies <- function(score) { + best <- max(score, na.rm = TRUE) + if (!is.finite(best)) { + return(which(score == best)) + } + which(score >= best - sqrt(.Machine$double.eps) * abs(best)) } .lassosumSelectMinFbeta <- function(candidateBeta, candidateMeta) { @@ -2432,21 +4390,174 @@ lassosumRss <- function( ) } -.lassosumSelectLdQuadratic <- function(candidateBeta, corInput, ld) { - bxy <- as.numeric(crossprod(corInput, candidateBeta)) - bxxb <- .ldQuadForms(ld, candidateBeta) - positive <- is.finite(bxxb) & bxxb > 0 - scores <- replace( - rep(-Inf, length(bxy)), - positive, - bxy[positive] / sqrt(bxxb[positive]) - ) - idx <- .lassosumFirstMax(scores) - list( - beta = candidateBeta[, idx], - index = idx, - mode = "ldQuadratic" - ) +# lassosum's pseudovalidation: each candidate's in-sample score against the +# LD, with every marginal correlation first shrunk by its local false +# discovery rate, as upstream lassosum does. +# @noRd +.lassosumSelectLdQuadratic <- function(candidateBeta, corInput, ld) { + shrunkCor <- corInput * (1 - .lassosumLfdr(corInput)) + idx <- .lassosumFirstMax(.rssShrunkLdScore(candidateBeta, shrunkCor, ld, 0)) + list( + beta = candidateBeta[, idx], + index = idx, + mode = "ldQuadratic" + ) +} + +# Each marginal correlation's local false discovery rate, from fdrtool's +# correlation null, as upstream lassosum's pseudovalidate() computes it. +# @noRd +.lassosumLfdr <- function(corInput) { + if (!requireNamespace("fdrtool", quietly = TRUE)) { + abort(str_c( + "Package 'fdrtool' is required for selection = \"ldQuadratic\". ", + "Install it, or use selection = \"heldOut\"." + )) + } + fdrtool::fdrtool( + corInput, + statistic = "correlation", + plot = FALSE, + verbose = FALSE + )$lfdr +} + +# Each candidate's score against the LD shrunk toward the identity by `w`, +# c' b / sqrt((1 - w) b' R b + w b' b), and -Inf where that variance is not +# positive. At w = 0 it is lassosum's LD-quadratic score. +# @noRd +.rssShrunkLdScore <- function(candidateBeta, corInput, ld, w) { + .rssCorrelationScore(.rssShrunkLdMoments(candidateBeta, corInput, ld, w)) +} + +# Each candidate's covariance with the statistics, c' b, and its variance +# against the LD shrunk toward the identity by `w`, (1 - w) b' R b + w b' b. +# @noRd +.rssShrunkLdMoments <- function(candidateBeta, corInput, ld, w) { + list( + bxy = as.numeric(crossprod(corInput, candidateBeta)), + bxxb = (1 - w) * + .ldQuadForms(ld, candidateBeta) + + w * colSums(candidateBeta^2) + ) +} + +# The correlation c' b / sqrt(b' Sigma b) from a candidate's moments, and -Inf +# where its variance is not positive. +# @noRd +.rssCorrelationScore <- function(moments) { + positive <- is.finite(moments$bxxb) & moments$bxxb > 0 + replace( + rep(-Inf, length(moments$bxy)), + positive, + moments$bxy[positive] / sqrt(moments$bxxb[positive]) + ) +} + +# How many times held-out selection splits the statistics, and the share of +# the samples each training part keeps. +# @noRd +.rssHeldOutSplits <- function() 4L + +# @noRd +.rssHeldOutTrainShare <- function() 0.75 + +# Selection on held-out summary statistics, as PUMAS does it (Zhao et al. +# 2021). For the marginal correlations c of n samples, a training part of +# nTrain of them has c_t ~ N(c, (n - nTrain) / (n nTrain) Sigma), and its +# held-out remainder c_h = (n c - nTrain c_t) / (n - nTrain). Sigma is the +# LD shrunk toward the identity by the Schafer-Strimmer intensity for the +# reference's size: a reference smaller than the number of variants misses +# directions of the true LD, the least-penalized fits put weight exactly +# there, and draws and scores from R alone never see it. Each split refits +# the whole (s, lambda) grid on c_t and scores it on c_h; the full-data +# candidate with the best mean score is returned (.rssHeldOutPick()). +# @noRd +#' @importFrom stats rnorm +.rssSelectHeldOut <- function(candidateBeta, corInput, ld, n, refit) { + w <- .ldShrinkIntensity(ld, ld$nSamples) + share <- .rssHeldOutTrainShare() + nSplits <- .rssHeldOutSplits() + noise <- sqrt(1 - w) * + .ldSourceDraws(ld, nSplits) + + sqrt(w) * matrix(rnorm(length(corInput) * nSplits), ncol = nSplits) + scores <- map( + seq_len(nSplits), + .rssHeldOutScore, + noise = noise * sqrt((1 - share) / (share * n)), + corInput = corInput, + ld = ld, + refit = refit, + w = w + ) + idx <- .rssHeldOutPick( + rowMeans(exec(cbind, !!!map(scores, "cor"))), + rowMeans(exec(cbind, !!!map(scores, "explained"))) + ) + list(beta = candidateBeta[, idx], index = idx, mode = "heldOut") +} + +# Split `k`: the candidates refit on its training part and scored on its +# held-out part, by their correlation with it and by the variance of it they +# explain, 2 c_h' b - b' Sigma b, which unlike the correlation depends on b's +# scale. `refit` names the refitting function (`fn`) and its other +# arguments (`args`); it is given the training part's correlations and the +# share of the samples that part keeps, and returns the candidates in the +# full data's order. +# @noRd +.rssHeldOutScore <- function(k, noise, corInput, ld, refit, w) { + share <- .rssHeldOutTrainShare() + trainCor <- .lassosumClampCor(corInput + noise[, k]) + heldCor <- (corInput - share * trainCor) / (1 - share) + beta <- exec(refit$fn, trainCor = trainCor, share = share, !!!refit$args) + moments <- .rssShrunkLdMoments(beta, heldCor, ld, w) + list( + cor = .rssCorrelationScore(moments), + explained = 2 * moments$bxy - moments$bxxb + ) +} + +# The candidate with the best mean held-out correlation. Candidates that +# differ only in scale -- the ridge's at s = 1, where each fit is +# c / (1 + lambda) -- tie on it, and the one explaining the most held-out +# variance wins; the first in the grid where that ties too. +# @noRd +.rssHeldOutPick <- function(cor, explained) { + ties <- .rssScoreTies(cor) + ties[.lassosumFirstMax(explained[ties])] +} + +# The shrinkage grid refit on a held-out split's training part. +# @noRd +.rssRefitShrinkGrid <- function(trainCor, share, s, ld, n, config) { + fits <- map( + s, + .rssFitAtS, + solverInput = trainCor * sqrt(share * n), + ld = ld, + n = share * n, + config = config + ) + exec(cbind, !!!map(fits, "beta")) +} + +# Held-out selection draws the reference's sampling noise, so it needs the +# number of samples behind the LD. +# @noRd +.rssCheckHeldOutLd <- function(ld, label) { + if (is.na(ld$nSamples)) { + abort(c( + glue( + "{label}: selection = \"heldOut\" needs the LD reference's ", + "sample size." + ), + i = str_c( + "Build the LdMatrix with `nSamples`, or choose ", + "selection = \"ldQuadratic\"." + ) + )) + } + invisible(NULL) } # Validate the (bhat, R, n) inputs shared by the RSS solvers (lassosumRss / @@ -2611,15 +4722,20 @@ lassosumRss <- function( # The LD the RSS weight methods read, matched to the statistics' variants # (`stat$variantNames`): a factor of it for a genotype reference, which the # factor solvers use without forming the p x p matrix, or the matrix an -# LdMatrix holds. Matching, allele flips, standardizing and padding are the -# LD reference layer's own (.ldFactorFromRef(), .ldFromRef()). +# LdMatrix holds, unpacked once for the run: the solvers and the selection +# pass over it many times. Matching, allele flips, standardizing and padding +# are the LD reference layer's own (.ldFactorFromRef(), .ldFromRef()). The +# source also carries the number of samples behind the LD (.ldRefNoiseN(), +# NA for an LdMatrix that records none), which held-out selection needs. # @noRd .rssLdSource <- function(stat, ldReference, label) { ids <- .rssStatVariantIds(stat, label) - if (.ldIsGenotypeRef(ldReference)) { - return(list(F = .ldFactorFromRef(ldReference, ids, label))) + ld <- if (.ldIsGenotypeRef(ldReference)) { + list(F = .ldFactorFromRef(ldReference, ids, label)) + } else { + list(R = .ldFromRef(ldReference, ids, label)) } - list(R = .ldFromRef(ldReference, ids, label)) + list_assign(ld, nSamples = .ldRefNoiseN(ldReference)) } # The LD matrix itself, for the engines that take nothing else (mr.ash.rss, @@ -2676,22 +4792,26 @@ lassosumRss <- function( # (lassosumRssWeights / .penalizedRssWeights / l0learnRssWeights), run for the # statistics `stat` against the LD source `ld` (see .rssLdSource()). # Standardizes the stat -> solverInput conversion, the outer LD-shrinkage grid -# over `s`, the candidate accumulation, and the ldQuadratic / minFbeta -# selection. `config` is the run: `method` (which selection record the -# weights carry; "l0learn" also sweeps `lambda0`), the penalty `spec` -# (.rssPenalty()) and the caller's path `options`; `fitRetention` is how much -# of the search is kept. +# over `s`, the candidate accumulation, and the heldOut / ldQuadratic / +# minFbeta selection. `config` is the run: `method` (which selection record +# the weights carry; "l0learn" also sweeps `lambda0`), the penalty `spec` +# (.rssPenalty()), the caller's path `options` and its `label` for errors; +# `fitRetention` is how much of the search is kept. # @noRd .rssShrinkGridWeights <- function( stat, ld, s, config, - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full") ) { selection <- arg_match(selection) fitRetention <- arg_match(fitRetention) + if (selection == "heldOut") { + .rssCheckHeldOutLd(ld, config$label) + } + ld <- .rssSolverSource(ld, config$spec) n <- median(stat$n) p <- .ldSourceSize(ld) corInput <- .lassosumClampCor(.rssMarginalCor(stat, n = n, p = p)) @@ -2706,11 +4826,16 @@ lassosumRss <- function( ) candidateBeta <- exec(cbind, !!!map(fits, "beta")) candidateMeta <- bind_rows(map(fits, "meta")) - selectorResult <- if (selection == "ldQuadratic") { - .lassosumSelectLdQuadratic(candidateBeta, corInput, ld) - } else { - .lassosumSelectMinFbeta(candidateBeta, candidateMeta) - } + selectorResult <- .rssShrinkGridSelect( + selection, + candidateBeta, + candidateMeta, + corInput, + ld, + n, + s, + config + ) bestBeta <- as.numeric(selectorResult$beta) weights <- .rssFinalize(bestBeta, selectorResult, candidateMeta, config) .rssAttachGridFit( @@ -2718,22 +4843,56 @@ lassosumRss <- function( candidateBeta, candidateMeta, selectorResult$index, - fitRetention + fitRetention, + stat[["variantNames"]] + ) +} + +# The candidate `selection` picks from the grid: by held-out prediction, +# refitting the grid on a split of the statistics; by the LD quadratic form; +# or by the solver's smallest F-beta. +# @noRd +.rssShrinkGridSelect <- function( + selection, + candidateBeta, + candidateMeta, + corInput, + ld, + n, + s, + config +) { + switch( + selection, + heldOut = .rssSelectHeldOut( + candidateBeta, + corInput, + ld, + n, + list( + fn = ".rssRefitShrinkGrid", + args = list(s = s, ld = ld, n = n, config = config) + ) + ), + ldQuadratic = .lassosumSelectLdQuadratic(candidateBeta, corInput, ld), + minFbeta = .lassosumSelectMinFbeta(candidateBeta, candidateMeta) ) } # The search behind the grid weights as their "fit" attribute: `path`, one # row per candidate fit with the solver's diagnostics and `selected` marking # the one returned, and at fitRetention = "full" also `beta`, the candidates' -# coefficients (variants x candidates, in path's row order). Returns `weights` -# unchanged at fitRetention = "none". +# coefficients (variants x candidates, in path's row order); it names the +# variants searched over, `variantIds`. Returns `weights` unchanged at +# fitRetention = "none". # @noRd .rssAttachGridFit <- function( weights, candidateBeta, candidateMeta, index, - fitRetention + fitRetention, + variantIds = NULL ) { if (identical(fitRetention, "none")) { return(weights) @@ -2742,7 +4901,7 @@ lassosumRss <- function( list(path = mutate(candidateMeta, selected = row_number() == index)), compact(list(beta = if (fitRetention == "full") candidateBeta)) ) - `attr<-`(weights, "fit", fit) + `attr<-`(weights, "fit", .withFitVariantIds(fit, variantIds)) } #' Extract weights from lassosumRss with shrinkage grid search @@ -2750,20 +4909,39 @@ lassosumRss <- function( #' Searches over a grid of shrinkage parameters \code{s} (default: #' \code{c(0.2, 0.5, 0.9, 1.0)}, matching the original lassosum and OTTERS). #' For each \code{s}, the LD matrix is shrunk as \code{(1-s)*R + s*I}, then -#' \code{lassosumRss()} is called across the lambda path. Candidate selection -#' defaults to the LD-only quadratic pseudovalidation score -#' \deqn{\frac{c^T \beta}{\sqrt{\beta^T R \beta}}} -#' evaluated on the supplied LD matrix \code{R}. This uses the same candidate -#' beta path as \code{lassosumRss()}, but scores each candidate directly from -#' summary-statistics correlation \code{c} and LD, without requiring genotype. +#' \code{lassosumRss()} is called across the lambda path. One candidate +#' (\code{s}, lambda) is returned, by default the one that scores best on +#' held-out summary statistics. #' #' @details -#' The original lassosum pseudovalidation can be written as an LD quadratic -#' score after centering and standardizing the reference matrix columns by the -#' same per-variant scale: -#' \deqn{\mathrm{score}(\beta) = \frac{c^T \beta}{\sqrt{\beta^T R \beta}}.} -#' This implementation therefore uses the supplied LD matrix directly for -#' selection. \code{min(fbeta)} is retained only as an explicit debug option. +#' \code{selection = "heldOut"} splits the statistics four times into a +#' training part, 75\% of the samples, and its held-out remainder, drawing +#' each split from the statistics and the LD as PUMAS does (Zhao et al. +#' 2021). The path is refit on each training part, every candidate is scored +#' on the held-out part by +#' \deqn{\frac{c_h^T \beta}{\sqrt{\beta^T \hat\Sigma \beta}}, \quad +#' \hat\Sigma = (1 - w) R + w I,} +#' and the full-data fit at the (\code{s}, lambda) with the best mean score +#' is returned. \eqn{w} is the Schafer-Strimmer intensity for a correlation +#' matrix from the reference's sample size. A reference smaller than the +#' number of variants misses directions of the true LD, and the +#' least-penalized fits put weight exactly there, so scoring against +#' \eqn{R} itself would keep choosing them. The splits use R's random number +#' generator, so \code{set.seed()} makes the weights reproducible. The score +#' does not change with \eqn{\beta}'s scale, so candidates that differ only +#' in scale tie on it, as the ridge's do at \eqn{s = 1}, where each fit is +#' \eqn{c / (1 + \lambda)}. Of tied candidates, the one explaining the most +#' held-out variance, \eqn{2 c_h^T \beta - \beta^T \hat\Sigma \beta} averaged +#' over the splits, is returned, and the first in the grid where that ties +#' too. +#' +#' \code{selection = "ldQuadratic"} is lassosum's pseudovalidation (Mak et +#' al. 2017): the in-sample score +#' \eqn{\tilde c^T \beta / \sqrt{\beta^T R \beta}}, with each marginal +#' correlation shrunk by its local false discovery rate, +#' \eqn{\tilde c = c (1 - \mathrm{lfdr})}, from \code{fdrtool} as upstream +#' lassosum computes it. Of candidates tied on it, the first in the grid is +#' returned. #' #' @param stat A list of summary statistics: \code{n} (per-variant sample #' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, @@ -2775,11 +4953,35 @@ lassosumRss <- function( #' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an #' \code{\link{LdMatrix}}. A genotype reference's LD is used through its #' standardized genotypes, never formed as a matrix. -#' @param s Numeric vector of shrinkage parameters to search over. Default: -#' \code{c(0.2, 0.5, 0.9, 1.0)} following Mak et al (2017) and OTTERS. -#' @param selection Selection strategy. Default \code{"ldQuadratic"} uses -#' \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. -#' \code{"minFbeta"} is retained as an explicit alternative for debugging. +#' @param backend \code{"pecotmr"} (default), pecotmr's lassosum, or +#' \code{"bigsnpr"}, bigsnpr's lassosum2 (Prive et al. 2020) on the LD +#' matrix, written to a temporary file for the call (formed from the +#' genotypes for a genotype reference). lassosum2 fits the same objective +#' with \eqn{\delta = s / (1 - s)}; its fits are rescaled by +#' \eqn{1 + \delta} to lassosum's and recorded in lassosum's \code{s}, +#' and it traces its own lambda path down from the largest marginal +#' effect. It reports no objective, so it has no +#' \code{selection = "minFbeta"}, and its \code{"fit"} path counts each +#' fit's \code{iterations} instead of \code{fbeta}, \code{loss} and +#' \code{conv}. It is slow: \code{snp_lassosum2()} times each fit with +#' \code{system.time()}, which first runs a full garbage collection of +#' the R session, so a run costs one collection per grid point however +#' few the variants, and \code{selection = "heldOut"} runs the grid five +#' times. With the defaults that is 600 collections, minutes per call in +#' a session with pecotmr loaded. \code{"pecotmr"} fits the same +#' objective without that cost. +#' @param s Numeric vector of shrinkage parameters to search over. +#' \code{NULL} (default) is \code{c(0.2, 0.5, 0.9, 1.0)} on pecotmr, +#' following Mak et al (2017) and OTTERS, and lassosum2's own grid, +#' \eqn{\delta = 0.001, 0.01, 0.1, 1}, on bigsnpr, where every \code{s} +#' must lie strictly between 0 and 1. +#' @param selection How the returned candidate is chosen (see Details of +#' \code{\link{lassosumRssWeights}}). \code{"heldOut"} (default) scores +#' every candidate on held-out summary statistics and needs the +#' reference's sample size, so an \code{\link{LdMatrix}} must record +#' \code{nSamples}. \code{"ldQuadratic"} is lassosum's pseudovalidation and +#' needs the \code{fdrtool} package. \code{"minFbeta"} picks the smallest +#' objective, for debugging. #' @param fitRetention How much of the search is kept as the \code{"fit"} #' attribute of the returned weights. \code{"none"} (default) attaches #' nothing. \code{"slim"} keeps \code{path}, a table with one row per @@ -2788,10 +4990,13 @@ lassosumRss <- function( #' non-zero coefficients \code{nparams}, with \code{selected} marking the #' candidate returned. \code{"full"} also keeps \code{beta}, the #' candidates' coefficients (variants x candidates, in the rows' order). -#' @param methodArgs Options forwarded to the solver, -#' \code{\link{lassosumRss}}, built with \code{\link{LassosumOptions}}. A -#' bare list is refused: it cannot be checked against the engine, so a -#' misspelled option would be silently ignored. +#' @param methodArgs Options forwarded to the solver: for pecotmr, +#' \code{\link{lassosumRss}}'s, built with \code{\link{LassosumOptions}}; +#' for bigsnpr, \code{snp_lassosum2()}'s, built with +#' \code{\link{BigsnprOptions}}. \code{NULL} (default) is the backend's +#' constructor with its defaults. A bare list is refused: it cannot be +#' checked against the engine, so a misspelled option would be silently +#' ignored. #' @return A numeric vector of the posterior SNP coefficients at the best (s, #' lambda). Unless \code{fitRetention = "none"}, the search is attached as #' attribute \code{"fit"}. @@ -2807,34 +5012,194 @@ lassosumRss <- function( #' n = rep(nrow(X), ncol(X)), #' variantNames = colnames(X) #' ) -#' w <- lassosumRssWeights(stat, LdMatrix(cor(X)), fitRetention = "slim") +#' ld <- LdMatrix(cor(X), nSamples = nrow(X)) +#' set.seed(1) +#' w <- lassosumRssWeights(stat, ld, fitRetention = "slim") #' head(attr(w, "fit")$path) #' @export lassosumRssWeights <- function( stat, ldReference, - s = c(0.2, 0.5, 0.9, 1.0), - selection = c("ldQuadratic", "minFbeta"), + backend = NULL, + s = NULL, + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), - methodArgs = LassosumOptions() + methodArgs = NULL ) { - .assertMethodOptions(methodArgs, "LassosumOptions", "methodArgs") selection <- arg_match(selection) fitRetention <- arg_match(fitRetention) + backend <- .rssBackend("lasso", backend, ldReference) + methodArgs <- .backendOptions( + methodArgs, + .methodBackends$sumstat$lasso[[backend]], + backend + ) + if (identical(backend, "bigsnpr")) { + return(.lassosum2Weights( + stat, + ldReference, + s, + selection, + fitRetention, + methodArgs + )) + } .rssShrinkGridWeights( stat, .rssLdSource(stat, ldReference, "lassosumRssWeights"), - s, + s %||% c(0.2, 0.5, 0.9, 1.0), list( method = "lassosum", spec = .rssPenalty("lasso"), - options = as.list(methodArgs) + options = as.list(methodArgs), + label = "lassosumRssWeights" ), selection, fitRetention ) } +# lassosum on bigsnpr's lassosum2, which minimizes +# b'(R + delta I)b - 2 b'bhat + 2 lambda |b|_1. That is lassosum's objective +# at s = delta / (1 + delta) divided by 1 - s, with bhat and lambda both +# scaled by 1 / (1 - s); a lasso solution scales with the two together, so at +# the same lambda lassosum's is lassosum2's times 1 + delta. Each fit is +# rescaled by that and recorded in lassosum's s. +# `s` gives delta = s / (1 - s), or lassosum2's own default when NULL; the +# lambda path is lassosum2's, from the largest marginal effect, so held-out +# selection matches the candidates by their place on it. lassosum2 reports no +# objective, so it has no "minFbeta". +# @noRd +.lassosum2Weights <- function( + stat, + ldReference, + s, + selection, + fitRetention, + methodArgs +) { + label <- "lassosumRssWeights" + if (identical(selection, "minFbeta")) { + abort(glue( + "{label}: lassosum2 reports no objective, so backend = ", + "\"bigsnpr\" has no selection = \"minFbeta\"." + )) + } + inp <- .rssPerVariantInput(stat, ldReference, label) + if (identical(selection, "heldOut")) { + .rssCheckHeldOutLd(inp$ld, label) + } + engine <- .bigsnprEngine(inp) + on.exit(.bigsnprRelease(engine), add = TRUE) + config <- list(delta = .lassosum2Delta(s), options = as.list(methodArgs)) + fits <- .lassosum2Run(inp, engine, config) + .withWeightsFitIds( + .lassosum2WeightsFrom( + fits, + inp, + engine, + config, + selection, + fitRetention + ), + stat[["variantNames"]] + ) +} + +# lassosum2's delta from lassosum's s, or its own default grid. +# @noRd +.lassosum2Delta <- function(s) { + if (is.null(s)) { + return(.formalDefaults(bigsnpr::snp_lassosum2, "delta")[[1L]]) + } + assertNumeric(s, lower = 0, upper = 1, any.missing = FALSE, min.len = 1L) + if (any(s <= 0 | s >= 1)) { + abort(str_c( + "With backend = \"bigsnpr\", every `s` must lie strictly between ", + "0 and 1: lassosum2's delta = s / (1 - s) must be positive and ", + "finite." + )) + } + s / (1 - s) +} + +# lassosum2's fits, rescaled to lassosum's parametrization, with their grid +# in lassosum's s and lambda. A fit that diverged is NA. +# @noRd +.lassosum2Run <- function(inp, engine, config) { + fits <- exec( + bigsnpr::snp_lassosum2, + engine$corr, + .bigsnprDfBeta(inp), + delta = config$delta, + ncores = 1, + !!!config$options + ) + grid <- attr(fits, "grid_param") + list( + beta = sweep( + fits[, seq_len(nrow(grid)), drop = FALSE], + 2L, + 1 + grid$delta, + "*" + ), + path = tibble( + s = grid$delta / (1 + grid$delta), + lambda = grid$lambda, + iterations = grid$num_iter + ) + ) +} + +# The fit chosen by `selection`, recorded as lassosumRssWeights() records +# pecotmr's, with the search at the requested retention. +# @noRd +.lassosum2WeightsFrom <- function( + fits, + inp, + engine, + config, + selection, + fitRetention +) { + usable <- replace(fits$beta, is.na(fits$beta), 0) + sel <- if (identical(selection, "ldQuadratic")) { + .lassosumSelectLdQuadratic(usable, inp$bhat, inp$ld) + } else { + .rssSelectHeldOut( + usable, + inp$bhat, + inp$ld, + median(inp$n), + list( + fn = ".lassosum2Refit", + args = list(inp = inp, engine = engine, config = config) + ) + ) + } + weights <- `attr<-`( + as.numeric(sel$beta), + "lassosum_selection", + c( + mode = sel$mode, + index = sel$index, + s = fits$path$s[[sel$index]], + lambda = fits$path$lambda[[sel$index]] + ) + ) + path <- mutate(fits$path, nparams = as.integer(colSums(usable != 0))) + .rssAttachGridFit(weights, fits$beta, path, sel$index, fitRetention) +} + +# lassosum2 refit on a held-out split's training part; a fit that diverges +# there is zero, so it scores -Inf. +# @noRd +.lassosum2Refit <- function(trainCor, share, inp, engine, config) { + train <- list_assign(inp, bhat = trainCor, n = share * inp$n) + fits <- .lassosum2Run(train, engine, config)$beta + replace(fits, is.na(fits), 0) +} + #' Penalized Regression on RSS (Summary Statistics) Objective #' #' The RSS penalized-regression solver: LASSO with its elastic-net and ridge @@ -2842,7 +5207,10 @@ lassosumRssWeights <- function( #' objective #' \deqn{\beta^T R \beta - 2 \beta^T z + \mathrm{penalty}(\beta)} #' where \eqn{R} is a (possibly pre-shrunk) LD matrix and \eqn{z = \hat\beta / -#' \sqrt{n}}. \code{lassosumRss()} is its LASSO at \code{alpha = 1}. +#' \sqrt{n}}. \code{lassosumRss()} is its LASSO at \code{alpha = 1}. The +#' ridge (LASSO at \code{alpha = 0}) has a closed form instead, +#' \eqn{(R + \lambda I)^{-1} z}, which is read for the whole path from one +#' eigendecomposition of \eqn{R}. #' #' Internal: \code{\link{enetRssWeights}}, \code{\link{ridgeRssWeights}}, #' \code{\link{scadRssWeights}}, \code{\link{mcpRssWeights}} and @@ -2875,9 +5243,10 @@ lassosumRssWeights <- function( #' @param lambda0 L0 penalty weight (number of non-zeros). Required for L0 #' variants; ignored otherwise. Default 0. #' @param lambda2 L2 penalty weight for L0L2 variant. Default 0. -#' @param thr Convergence threshold. Default 1e-4. +#' @param thr Convergence threshold. Default 1e-4. The ridge, solved +#' exactly, does not use it. #' @param maxiter Maximum coordinate descent iterations per lambda. Default -#' 10000. +#' 10000. The ridge, solved exactly, does not use it. #' @param maxSwaps Maximum swap rounds for L0 variants. Default 100. Set to 0 to #' disable swaps. #' @@ -3027,8 +5396,8 @@ penalizedRss <- function( #' (\code{l0learnRssWeights()} uses the lower-level \code{.rssShrinkGridWeights} #' scaffold directly, since it sweeps an additional \code{lambda0} path.) #' Searches over a shrinkage grid \code{s} (LD matrix shrinkage \code{(1-s)R + -#' sI}) and selects the best candidate via LD-quadratic pseudovalidation or -#' minimum penalized objective. +#' sI}) and selects the best candidate on held-out summary statistics, by +#' lassosum's pseudovalidation, or by the minimum penalized objective. #' #' @param stat,ldReference,s,selection See the public wrappers for details. #' @param spec The penalty, built by the calling wrapper from its own @@ -3046,7 +5415,7 @@ penalizedRss <- function( ldReference, spec, s = c(0.2, 0.5, 0.9, 1.0), - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions(), label = str_c(str_to_lower(spec$penalty), "RssWeights") @@ -3061,7 +5430,8 @@ penalizedRss <- function( list( method = "penalized", spec = spec, - options = as.list(methodArgs) + options = as.list(methodArgs), + label = label ), selection, fitRetention @@ -3071,8 +5441,8 @@ penalizedRss <- function( #' Compute SCAD-Penalized Weights from Summary Statistics #' #' Fits SCAD-penalized regression on the RSS objective, searching over a -#' shrinkage grid \code{s} and lambda path. Model selection uses LD-quadratic -#' pseudovalidation by default. +#' shrinkage grid \code{s} and lambda path. Model selection uses held-out +#' summary statistics by default (see \code{\link{lassosumRssWeights}}). #' #' @param stat A list of summary statistics: \code{n} (per-variant sample #' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, @@ -3090,8 +5460,6 @@ penalizedRss <- function( #' @param alpha Elastic-net mixing in \code{(0, 1]}: the SCAD share of #' the penalty, the rest a ridge term, as \code{\link{penalizedRss}} #' mixes them. Default 1, no ridge term. -#' @param selection Selection strategy: \code{"ldQuadratic"} (default) or -#' \code{"minFbeta"}. #' @param methodArgs Options forwarded to the solver, #' \code{\link{penalizedRss}}, built with #' \code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot @@ -3113,7 +5481,7 @@ penalizedRss <- function( #' n = rep(nrow(X), ncol(X)), #' variantNames = colnames(X) #' ) -#' scadRssWeights(stat, LdMatrix(cor(X))) +#' scadRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) #' @importFrom checkmate assertList assertNumeric assertNumber #' @export scadRssWeights <- function( @@ -3122,7 +5490,7 @@ scadRssWeights <- function( s = c(0.2, 0.5, 0.9, 1.0), gamma = 3.7, alpha = 1.0, - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { @@ -3146,8 +5514,8 @@ scadRssWeights <- function( #' Compute MCP-Penalized Weights from Summary Statistics #' #' Fits MCP-penalized regression on the RSS objective, searching over a -#' shrinkage grid \code{s} and lambda path. Model selection uses LD-quadratic -#' pseudovalidation by default. +#' shrinkage grid \code{s} and lambda path. Model selection uses held-out +#' summary statistics by default (see \code{\link{lassosumRssWeights}}). #' #' @param stat A list of summary statistics: \code{n} (per-variant sample #' sizes) and the marginal effects as \code{cor} (standardized), \code{z}, @@ -3165,8 +5533,6 @@ scadRssWeights <- function( #' @param alpha Elastic-net mixing in \code{(0, 1]}: the MCP share of #' the penalty, the rest a ridge term, as \code{\link{penalizedRss}} #' mixes them. Default 1, no ridge term. -#' @param selection Selection strategy: \code{"ldQuadratic"} (default) or -#' \code{"minFbeta"}. #' @param methodArgs Options forwarded to the solver, #' \code{\link{penalizedRss}}, built with #' \code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot @@ -3188,7 +5554,7 @@ scadRssWeights <- function( #' n = rep(nrow(X), ncol(X)), #' variantNames = colnames(X) #' ) -#' mcpRssWeights(stat, LdMatrix(cor(X))) +#' mcpRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) #' @importFrom checkmate assertList assertNumeric assertNumber #' @export mcpRssWeights <- function( @@ -3197,7 +5563,7 @@ mcpRssWeights <- function( s = c(0.2, 0.5, 0.9, 1.0), gamma = 3.0, alpha = 1.0, - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { @@ -3222,8 +5588,8 @@ mcpRssWeights <- function( #' #' Fits the elastic net on the RSS objective -- the lasso penalty mixed with #' a ridge term, as glmnet mixes them -- searching over a shrinkage grid -#' \code{s} and a lambda path. Model selection uses LD-quadratic -#' pseudovalidation by default. +#' \code{s} and a lambda path. Model selection uses held-out summary +#' statistics by default (see \code{\link{lassosumRssWeights}}). #' #' \code{alpha} is the L1 share of the penalty: with \eqn{l_1 = \lambda #' \alpha} and \eqn{l_2 = \lambda (1 - \alpha)} the penalty is @@ -3257,9 +5623,9 @@ mcpRssWeights <- function( #' n = rep(nrow(X), ncol(X)), #' variantNames = colnames(X) #' ) -#' enetRssWeights(stat, LdMatrix(cor(X))) +#' enetRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) #' # A larger ridge share: -#' enetRssWeights(stat, LdMatrix(cor(X)), alpha = 0.2) +#' enetRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X)), alpha = 0.2) #' @importFrom checkmate assertList assertNumeric #' @export enetRssWeights <- function( @@ -3267,7 +5633,7 @@ enetRssWeights <- function( ldReference, alpha = 0.5, s = c(0.2, 0.5, 0.9, 1.0), - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { @@ -3295,7 +5661,16 @@ enetRssWeights <- function( #' at \code{alpha = 0}: the penalty is \eqn{\lambda \beta^T \beta}, and the #' default lambda path runs from 0.1 to 100. Searches over a shrinkage grid #' \code{s} as well, whose own ridge term \eqn{s \beta^T \beta} adds to it; -#' model selection uses LD-quadratic pseudovalidation by default. +#' model selection uses held-out summary statistics by default (see +#' \code{\link{lassosumRssWeights}}). +#' +#' Every fit is exact: the ridge has the closed form +#' \eqn{((1 - s) R + (s + \lambda) I)^{-1} z}, read from one +#' eigendecomposition of the window's LD that every shrinkage level, lambda +#' and held-out refit shares (for a genotype reference, from the singular +#' value decomposition of its standardized genotypes, never forming the LD). +#' The coordinate-descent settings \code{thr} and \code{maxiter} in +#' \code{methodArgs} therefore do not apply. #' #' @inheritParams scadRssWeights #' @inheritParams lassosumRssWeights @@ -3314,14 +5689,14 @@ enetRssWeights <- function( #' n = rep(nrow(X), ncol(X)), #' variantNames = colnames(X) #' ) -#' ridgeRssWeights(stat, LdMatrix(cor(X))) +#' ridgeRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) #' @importFrom checkmate assertList assertNumeric #' @export ridgeRssWeights <- function( stat, ldReference, s = c(0.2, 0.5, 0.9, 1.0), - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) { @@ -3345,7 +5720,8 @@ ridgeRssWeights <- function( #' #' Fits L0-penalized regression (with optional L1/L2 components) on the RSS #' objective, searching over a shrinkage grid \code{s} and lambda0 path. Model -#' selection uses LD-quadratic pseudovalidation by default. +#' selection uses held-out summary statistics by default (see +#' \code{\link{lassosumRssWeights}}). #' #' The swap optimization from L0Learn is included: after coordinate descent #' converges, non-zero coefficients are tested for swaps with zero ones to @@ -3370,8 +5746,6 @@ ridgeRssWeights <- function( #' @param lambda Numeric vector of L1 penalty values (for L0L1). Default: #' \code{c(0)} (no L1 unless L0L1 is used). #' @param lambda2 L2 penalty weight (for L0L2). Default 0. -#' @param selection Selection strategy: \code{"ldQuadratic"} (default) or -#' \code{"minFbeta"}. #' @param maxSwaps Maximum swap rounds per lambda. Default 100. #' @param fitRetention How much of the search is kept as the \code{"fit"} #' attribute of the returned weights. \code{"none"} (default) attaches @@ -3386,6 +5760,7 @@ ridgeRssWeights <- function( #' \code{\link{PenalizedRssOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be silently #' ignored. +#' @inheritParams lassosumRssWeights #' @return A numeric vector of SNP coefficient weights. Unless #' \code{fitRetention = "none"}, the search is attached as attribute #' \code{"fit"}. @@ -3401,7 +5776,7 @@ ridgeRssWeights <- function( #' n = rep(nrow(X), ncol(X)), #' variantNames = colnames(X) #' ) -#' l0learnRssWeights(stat, LdMatrix(cor(X))) +#' l0learnRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) #' @export l0learnRssWeights <- function( stat, @@ -3411,7 +5786,7 @@ l0learnRssWeights <- function( lambda0 = exp(seq(log(0.001), log(1), length.out = 10)), lambda = NULL, lambda2 = 0, - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), maxSwaps = 100, fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() @@ -3429,16 +5804,7 @@ l0learnRssWeights <- function( # The L0 penalty, lambda0 left to the sweep over its grid. spec <- .rssPenalty(penalty, lambda2 = lambda2, maxSwaps = maxSwaps) assertNumeric(lambda0, lower = 0, finite = TRUE, any.missing = FALSE) - - # Default lambda (L1 component) depends on variant - if (is.null(lambda)) { - lambda <- if (penalty == "L0L1") { - exp(seq(log(0.0001), log(0.1), length.out = 10)) - } else { - c(0) - } - } - + lambda <- .l0learnRssLambda(lambda, penalty) .rssShrinkGridWeights( stat, .rssLdSource(stat, ldReference, "l0learnRssWeights"), @@ -3447,13 +5813,28 @@ l0learnRssWeights <- function( method = "l0learn", spec = spec, lambda0 = lambda0, - options = list_assign(as.list(methodArgs), lambda = lambda) + options = list_assign(as.list(methodArgs), lambda = lambda), + label = "l0learnRssWeights" ), selection, fitRetention ) } +# The L1 component's grid: the caller's, else ten values on a log scale for +# L0L1 and none for the penalties without one. +# @noRd +.l0learnRssLambda <- function(lambda, penalty) { + if (!is.null(lambda)) { + return(lambda) + } + if (penalty == "L0L1") { + exp(seq(log(0.0001), log(0.1), length.out = 10)) + } else { + 0 + } +} + #' Compute Weights Using ncvreg with SCAD or MCP Penalty #' #' Internal helper that fits an `ncvreg` model with the specified non-convex @@ -3467,11 +5848,21 @@ l0learnRssWeights <- function( #' @param y A numeric response vector. #' @param penalty Either "SCAD" or "MCP". #' @param nfolds Number of cross-validation folds. Default is 5. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing; \code{"slim"} the selected fit, as a list of its coefficients +#' (\code{coef}, over the variants fitted), \code{intercept}, +#' \code{lambda} and cross-validated error there (\code{cve}, +#' \code{cvse}); \code{"full"} the whole \code{cv.ncvreg} object, with +#' every \code{lambda}'s coefficients but without its copy of \code{X}. +#' Either names the variants it was fitted on. #' @param methodArgs Options forwarded to \code{ncvreg::cv.ncvreg}, built #' with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of length `ncol(X)` of variant weights. +#' @return A numeric vector of length `ncol(X)` of variant weights, with the +#' fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @importFrom stats coef #' @keywords internal #' @importFrom checkmate assertCount @@ -3480,10 +5871,12 @@ ncvregWeights <- function( y, penalty, nfolds = 5, + fitRetention = c("none", "slim", "full"), methodArgs = NcvregOptions() ) { .assertMethodOptions(methodArgs, "NcvregOptions", "methodArgs") assertCount(nfolds, positive = TRUE) + fitRetention <- arg_match(fitRetention) if (!requireNamespace("ncvreg", quietly = TRUE)) { abort("Package 'ncvreg' is required for this function.") } @@ -3496,10 +5889,40 @@ ncvregWeights <- function( penalty = penalty, nfolds = nfolds ), - !!!methodArgs + !!!as.list(methodArgs) ) fit <- exec(ncvreg::cv.ncvreg, !!!callArgs) - replace(eff.wgt, keep, coef(fit, lambda = fit$lambda.min)[-1]) + coefs <- as.numeric(coef(fit, lambda = fit$lambda.min)) + weights <- replace(eff.wgt, keep, coefs[-1L]) + if (identical(fitRetention, "none")) { + return(weights) + } + kept <- if (identical(fitRetention, "full")) { + `[[<-`(fit, "fit", .withoutFields(fit$fit, "X")) + } else { + .ncvregSlimFit(fit, coefs) + } + `attr<-`(weights, "fit", .withFitVariantIds(kept, colnames(X)[keep])) +} + +# The fit cv.ncvreg selected: its coefficients over the variants fitted, the +# intercept, its lambda and the cross-validated error there. +# @noRd +.ncvregSlimFit <- function(cvFit, coefs) { + list( + coef = coefs[-1L], + intercept = coefs[[1L]], + lambda = cvFit$lambda.min, + cve = cvFit$cve[[cvFit$min]], + cvse = cvFit$cvse[[cvFit$min]] + ) +} + +# `fit` without its `fields`, keeping its class: an engine object's copies of +# the data it was given, which a stored fit has no use for. +# @noRd +.withoutFields <- function(fit, fields) { + `class<-`(fit[setdiff(names(fit), fields)], class(fit)) } #' Compute Weights Using SCAD-Penalized Regression @@ -3514,20 +5937,30 @@ ncvregWeights <- function( #' with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of length `ncol(X)` of variant weights. +#' @inheritParams ncvregWeights +#' @return A numeric vector of length `ncol(X)` of variant weights, with the +#' fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' scadWeights(X, y) #' @export -scadWeights <- function(X, y, nfolds = 5, methodArgs = NcvregOptions()) { +scadWeights <- function( + X, + y, + nfolds = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NcvregOptions() +) { .assertMethodOptions(methodArgs, "NcvregOptions", "methodArgs") ncvregWeights( X, y, penalty = "SCAD", nfolds = nfolds, + fitRetention = arg_match(fitRetention), methodArgs = methodArgs ) } @@ -3544,20 +5977,30 @@ scadWeights <- function(X, y, nfolds = 5, methodArgs = NcvregOptions()) { #' with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of length `ncol(X)` of variant weights. +#' @inheritParams ncvregWeights +#' @return A numeric vector of length `ncol(X)` of variant weights, with the +#' fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' mcpWeights(X, y) #' @export -mcpWeights <- function(X, y, nfolds = 5, methodArgs = NcvregOptions()) { +mcpWeights <- function( + X, + y, + nfolds = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NcvregOptions() +) { .assertMethodOptions(methodArgs, "NcvregOptions", "methodArgs") ncvregWeights( X, y, penalty = "MCP", nfolds = nfolds, + fitRetention = arg_match(fitRetention), methodArgs = methodArgs ) } @@ -3575,11 +6018,21 @@ mcpWeights <- function(X, y, nfolds = 5, methodArgs = NcvregOptions()) { #' @param penalty Type of regularization: "L0", "L0L1", or "L0L2". Default is #' "L0". #' @param nFolds Number of cross-validation folds. Default is 5. +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing; \code{"slim"} the selected fit, as a list of its coefficients +#' (\code{coef}, over the variants fitted), \code{intercept}, +#' \code{gamma}, \code{lambda} and cross-validated error there +#' (\code{cvMean}, \code{cvSd}); \code{"full"} the whole +#' \code{L0Learn.cvfit} object, with every candidate's coefficients. +#' Either names the variants it was fitted on, in \code{variantIds}. #' @param methodArgs Options forwarded to \code{L0Learn::L0Learn.cvfit}, built #' with \code{\link{L0learnOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of length `ncol(X)` of variant weights. +#' @return A numeric vector of length `ncol(X)` of variant weights, with the +#' fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] @@ -3591,9 +6044,11 @@ l0learnWeights <- function( y, penalty = "L0", nFolds = 5, + fitRetention = c("none", "slim", "full"), methodArgs = L0learnOptions() ) { .assertMethodOptions(methodArgs, "L0learnOptions", "methodArgs") + fitRetention <- arg_match(fitRetention) if (!requireNamespace("L0Learn", quietly = TRUE)) { abort("Package 'L0Learn' is required for this function.") } @@ -3606,19 +6061,42 @@ l0learnWeights <- function( penalty = penalty, nFolds = nFolds ), - !!!methodArgs + !!!as.list(methodArgs) ) fit <- exec(L0Learn::L0Learn.cvfit, !!!callArgs) - # Find (gamma, lambda) minimizing CV error across the entire path. - cvMins <- map_dbl(fit$cvMeans, .rssMinNumeric) - gammaIdx <- which.min(cvMins) - lambdaIdx <- which.min(as.numeric(fit$cvMeans[[gammaIdx]])) - bestGamma <- fit$fit$gamma[gammaIdx] - bestLambda <- fit$fit$lambda[[gammaIdx]][lambdaIdx] - raw <- as.numeric(coef(fit, lambda = bestLambda, gamma = bestGamma)) - # If intercept was included, drop it (first row). - coefs <- if (length(raw) == sum(keep) + 1L) raw[-1L] else raw - replace(eff.wgt, keep, coefs) + best <- .l0learnBest(fit) + raw <- as.numeric(coef(fit, lambda = best$lambda, gamma = best$gamma)) + # If intercept was included, it is the first row. + hasIntercept <- length(raw) == sum(keep) + 1L + coefs <- if (hasIntercept) raw[-1L] else raw + weights <- replace(eff.wgt, keep, coefs) + if (identical(fitRetention, "none")) { + return(weights) + } + kept <- if (identical(fitRetention, "full")) { + fit + } else { + c( + list(coef = coefs, intercept = if (hasIntercept) raw[[1L]] else 0), + best + ) + } + `attr<-`(weights, "fit", .withFitVariantIds(kept, colnames(X)[keep])) +} + +# The (gamma, lambda) pair minimizing the cross-validation error across the +# whole path, with that error and its standard deviation. +# @noRd +.l0learnBest <- function(fit) { + gammaIdx <- which.min(map_dbl(fit$cvMeans, .rssMinNumeric)) + cvMeans <- as.numeric(fit$cvMeans[[gammaIdx]]) + lambdaIdx <- which.min(cvMeans) + list( + gamma = fit$fit$gamma[[gammaIdx]], + lambda = fit$fit$lambda[[gammaIdx]][[lambdaIdx]], + cvMean = cvMeans[[lambdaIdx]], + cvSd = as.numeric(fit$cvSDs[[gammaIdx]])[[lambdaIdx]] + ) } #' Compute Weights Using a BGLR Linear Regression Model @@ -3637,11 +6115,18 @@ l0learnWeights <- function( #' @param thin Thinning interval. #' @param etaArgs Optional named list of additional arguments included in the #' `ETA` linear-term specification (e.g. `list(probIn = 0.05)` for BayesB). +#' @param fitRetention How much of the fit is kept as the \code{"fit"} +#' attribute of the returned weights: \code{"none"} (default) attaches +#' nothing, \code{"slim"} and \code{"full"} the fitted \code{BGLR} object, +#' which keeps no copy of the data, so the two retaining levels behave +#' alike here. #' @param methodArgs Options forwarded to \code{BGLR::BGLR}, built #' with \code{\link{BglrOptions}}. A bare list is refused: it cannot be #' checked against the engine, so a misspelled option would be #' silently ignored. -#' @return A numeric vector of length `ncol(X)` of variant weights. +#' @return A numeric vector of length `ncol(X)` of variant weights, with the +#' fit attached as attribute \code{"fit"} unless +#' \code{fitRetention = "none"}. #' @keywords internal bglrWeights <- function( X, @@ -3651,9 +6136,11 @@ bglrWeights <- function( burnIn, thin, etaArgs = list(), + fitRetention = c("none", "slim", "full"), methodArgs = BglrOptions() ) { .assertMethodOptions(methodArgs, "BglrOptions", "methodArgs") + fitRetention <- arg_match(fitRetention) if (!requireNamespace("BGLR", quietly = TRUE)) { abort("Package 'BGLR' is required for this function.") } @@ -3676,118 +6163,14 @@ bglrWeights <- function( saveAt = saveAt, verbose = FALSE ), - !!!methodArgs + !!!as.list(methodArgs) ) fit <- exec(BGLR::BGLR, !!!callArgs) - replace(eff.wgt, keep, as.numeric(fit$ETA[[1]]$b)) -} - -#' Compute Weights Using BayesB -#' -#' Fits a BayesB linear regression model via `BGLR::BGLR` and returns the -#' posterior mean of the marker effects. BayesB places a "spike-and-slab" -#' mixture prior on each marker effect, with a scaled-t slab. -#' -#' Defaults for `nIter`, `burnIn`, and `thin` are larger than BGLR's package -#' defaults to better accommodate the high LD typical of cis-eQTL windows; see -#' Kim et al. (2022) which observed that the BGLR defaults can be inadequate -#' under correlated predictors. Override these arguments to recover the package -#' defaults if desired. -#' -#' @param X A numeric matrix of predictors. -#' @param y A numeric response vector. -#' @param nIter Number of MCMC iterations. Default is 10000. -#' @param burnIn Number of burn-in iterations. Default is 2000. -#' @param thin Thinning interval. Default is 5. -#' @param probIn Prior inclusion probability for each marker. Default is 0.2. -#' @param methodArgs Options forwarded to \code{BGLR::BGLR}, built -#' with \code{\link{BglrOptions}}. A bare list is refused: it cannot be -#' checked against the engine, so a misspelled option would be -#' silently ignored. -#' @return A numeric vector of length `ncol(X)` of variant weights. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' y <- eqtlRegionExample$yRes -#' bayesBWeights(X, y) -#' @importFrom checkmate assertCount assertNumber -#' @export -bayesBWeights <- function( - X, - y, - nIter = 10000, - burnIn = 2000, - thin = 5, - probIn = 0.2, - methodArgs = BglrOptions() -) { - .assertMethodOptions(methodArgs, "BglrOptions", "methodArgs") - assertCount(nIter, positive = TRUE) - assertCount(burnIn) - assertCount(thin, positive = TRUE) - assertNumber(probIn, lower = 0, upper = 1) - bglrWeights( - X, - y, - model = "BayesB", - nIter = nIter, - burnIn = burnIn, - thin = thin, - etaArgs = list(probIn = probIn), - methodArgs = methodArgs - ) -} - -#' Compute Weights Using the Bayesian LASSO (BGLR) -#' -#' Fits a Bayesian LASSO linear regression model via `BGLR::BGLR` (the "BL" -#' model, Park & Casella 2008) and returns the posterior mean of the marker -#' effects. This is the same "B-Lasso" implementation benchmarked in Kim et al. -#' (2022). Note that this is distinct from `bayesLWeights`, which uses a -#' different Bayesian LASSO implementation backed by `qgg`. -#' -#' Defaults for `nIter`, `burnIn`, and `thin` are larger than BGLR's package -#' defaults to better accommodate high-LD cis-eQTL windows; override to recover -#' the package defaults. -#' -#' @param X A numeric matrix of predictors. -#' @param y A numeric response vector. -#' @param nIter Number of MCMC iterations. Default is 10000. -#' @param burnIn Number of burn-in iterations. Default is 2000. -#' @param thin Thinning interval. Default is 5. -#' @param methodArgs Options forwarded to \code{BGLR::BGLR}, built -#' with \code{\link{BglrOptions}}. A bare list is refused: it cannot be -#' checked against the engine, so a misspelled option would be -#' silently ignored. -#' @return A numeric vector of length `ncol(X)` of variant weights. -#' @examples -#' data(eqtlRegionExample) -#' X <- eqtlRegionExample$X[, 1:30] -#' y <- eqtlRegionExample$yRes -#' bLassoWeights(X, y) -#' @importFrom checkmate assertCount -#' @export -bLassoWeights <- function( - X, - y, - nIter = 10000, - burnIn = 2000, - thin = 5, - methodArgs = BglrOptions() -) { - .assertMethodOptions(methodArgs, "BglrOptions", "methodArgs") - assertCount(nIter, positive = TRUE) - assertCount(burnIn) - assertCount(thin, positive = TRUE) - bglrWeights( - X, - y, - model = "BL", - nIter = nIter, - burnIn = burnIn, - thin = thin, - methodArgs = methodArgs - ) + weights <- replace(eff.wgt, keep, as.numeric(fit$ETA[[1]]$b)) + if (identical(fitRetention, "none")) { + return(weights) + } + `attr<-`(weights, "fit", .withFitVariantIds(fit, colnames(X)[keep])) } #' Compute Weights Using Dirichlet Process Regression (RcppDPR) @@ -3813,9 +6196,9 @@ bLassoWeights <- function( #' silently ignored. #' @param fitRetention How much of the fit is kept as the \code{"fit"} #' attribute of the returned weights: \code{"none"} (default) attaches -#' nothing, \code{"slim"} and \code{"full"} attach the fitted model. This -#' engine keeps no trimmable intermediates, so the two retaining levels -#' behave alike here. +#' nothing, \code{"slim"} the fitted model without its copy of the +#' genotypes (\code{x}), \code{"full"} the whole fitted model. Either +#' names the variants it was fitted on. #' @param nK Integer. Number of variational mixture components for the VB fit #' (\code{dprVbWeights}). Default \code{8}. #' @param sStep Integer. Number of Gibbs sampling steps for the Gibbs fit @@ -3850,14 +6233,19 @@ dprWeights <- function( rotate_variables = FALSE, fitting_method = fittingMethod ), - !!!methodArgs + !!!as.list(methodArgs) ) fit <- exec(RcppDPR::fit_model, !!!callArgs) eff.wgt <- replace(zeros, keep, as.numeric(fit$beta + fit$alpha)) if (identical(fitRetention, "none")) { return(eff.wgt) } - `attr<-`(eff.wgt, "fit", fit) + kept <- if (identical(fitRetention, "full")) { + fit + } else { + .withoutFields(fit, "x") + } + `attr<-`(eff.wgt, "fit", .withFitVariantIds(kept, colnames(X)[keep])) } #' @rdname dprWeights @@ -4029,11 +6417,11 @@ dprAdaptiveGibbsWeights <- function( #' steps as well as the fit, so it is set here rather than in #' \code{methodArgs}. #' @param BPPARAM A \code{BiocParallelParam}. The univariate glmnet fits that -#' initialise the coefficients run on its workers, and mr.mash's own -#' threads (the summary statistics and the fit) number its workers when -#' they run on this machine (\code{SerialParam}, \code{MulticoreParam}); -#' for other backends mr.mash runs on one thread. Default -#' \code{SerialParam()}. +#' initialise the coefficients run on its workers, and the summary +#' statistics use as many cores as it has workers when they run on this +#' machine (\code{SerialParam}, \code{MulticoreParam}); for other backends +#' they use one. The mr.mash fit itself always runs on one thread (see +#' \code{\link{MrmashOptions}}). Default \code{SerialParam()}. #' @param methodArgs Options forwarded to \code{mr.mashr::mr.mash} under its #' own names, built with \code{\link{MrmashOptions}} #' (\code{update_w0}, \code{max_iter}, \code{tol}, \code{w0_threshold}, @@ -4122,7 +6510,6 @@ mrmashWrapper <- function( X = X, Y = Y, standardize = standardize, - threads = threads, updateVMethod = updateVMethod, methodArgs = methodArgs ) @@ -4276,7 +6663,6 @@ mrmashWrapper <- function( X, Y, standardize, - threads, updateVMethod, methodArgs ) { @@ -4290,7 +6676,8 @@ mrmashWrapper <- function( update_V_method = updateVMethod, mu1_init = bInit, standardize = standardize, - nthreads = threads + # One thread: see .mrmashUnavailable(). + nthreads = 1L ) user <- as.list(methodArgs) clash <- intersect(names(user), names(derived)) @@ -4798,8 +7185,9 @@ buildMrmashPriorMatrices <- function( # ---- map/apply helpers (lambda-free callbacks) --------------------------- # `.rssSolvePath` solver for the penalized RSS path (lasso and its elastic-net -# and ridge mixtures, MCP, SCAD, L0...), on the LD matrix or on a factor of it -# (never forming R). +# mixtures, MCP, SCAD, L0...) by coordinate descent, on the LD matrix or on a +# factor of it (never forming R); a ridge in its closed form +# (.rssRidgeSolve()). # @noRd .rssPenalizedSolve <- function( z, @@ -4814,6 +7202,9 @@ buildMrmashPriorMatrices <- function( maxiter, maxSwaps ) { + if (.rssIsRidge(penalty, alpha)) { + return(.rssRidgeSolve(z, lam, ld)) + } settings <- list( lambdaR = lam, penaltyStr = penalty, @@ -4843,6 +7234,65 @@ buildMrmashPriorMatrices <- function( ) } +# Whether a penalty is a ridge: the lasso's at alpha = 0, its L2 term alone. +# @noRd +.rssIsRidge <- function(penalty, alpha) { + identical(penalty, "lasso") && alpha == 0 +} + +# The LD source as the penalty's solver reads it. A ridge is solved from R's +# eigendecomposition (.rssRidgeSolve()), which the source then carries, +# computed here once for every shrinkage level, lambda and held-out refit of +# the grid; any other penalty reads the source as it is. +# @noRd +.rssSolverSource <- function(ld, spec) { + if (!.rssIsRidge(spec$penalty, spec$alpha) || !is.null(ld$eigen)) { + return(ld) + } + list_assign(ld, eigen = .ldSourceEigen(ld)) +} + +# The ridge's path in closed form. Its objective beta'R_s beta - 2 beta'z + +# lambda beta'beta, for R_s = (1 - s) R + s I, has the minimizer +# (R_s + lambda I)^-1 z, read for every lambda from R's eigendecomposition +# R = V D V' (.ldSourceEigen(); a factor's thin SVD leaves V narrower than +# R, which is zero off V's span): with t = s + lambda, +# beta = V (V'z / ((1 - s) D + t)) + (z - V V'z) / t. Where (1 - s) D + t +# vanishes (s = lambda = 0 on an LD of less than full rank) beta is the +# minimum-norm minimizer. Returns what penalizedRssCpp() returns, each fit +# exact. +# @noRd +.rssRidgeSolve <- function(z, lam, ld) { + ev <- .ldSourceEigen(ld) + s <- ld$shrink %||% 0 + proj <- as.numeric(crossprod(ev$vectors, z)) + rest <- z - as.numeric(ev$vectors %*% proj) + top <- (1 - s) * max(ev$values, 0) + s + lam + coef <- proj * + .rssInverseAbove(outer((1 - s) * ev$values, s + lam, "+"), top) + restCoef <- as.numeric(.rssInverseAbove(matrix(s + lam, 1L), top)) + restSq <- sum(rest^2) + bb <- colSums(coef^2) + restSq * restCoef^2 + zb <- colSums(proj * coef) + restSq * restCoef + loss <- (1 - s) * colSums(ev$values * coef^2) + s * bb - 2 * zb + list( + beta = ev$vectors %*% coef + outer(rest, restCoef), + lambda = lam, + conv = rep(1L, length(lam)), + loss = loss, + fbeta = loss + lam * bb + ) +} + +# 1 / x for a spectrum `x`, one column per lambda, and 0 where an entry is +# zero to rounding: at most sqrt(machine epsilon) of its column's largest +# eigenvalue `top`, as MASS::ginv() cuts a pseudo-inverse. +# @noRd +.rssInverseAbove <- function(x, top) { + kept <- x > rep(sqrt(.Machine$double.eps) * top, each = nrow(x)) + replace(array(0, dim(x)), kept, 1 / x[kept]) +} + # One L0Learn fit at lambda0 = `l0Val`: penalizedRss over the lambda path. # @noRd .rssL0LambdaFit <- function(l0Val, solverInput, ld, n, sVal, config) { diff --git a/R/resultWriters.R b/R/resultWriters.R index ac80dc369..f923db973 100644 --- a/R/resultWriters.R +++ b/R/resultWriters.R @@ -269,15 +269,18 @@ NULL # from range(x) when no `region` column was recorded, and a variant-less row # contributes no range -- so the derived vector would be SHORTER than the # collection and indexing it by row number would read a neighbour's window. +# +# `labels` names the incomplete units (rows of a fine-mapping result, entries +# of a TwasWeights) out of `total` of them. # @noRd -.pubRequireFullFit <- function(x, incomplete, what) { - if (length(incomplete) == 0L) { - return(invisible(x)) +.pubRequireFullFit <- function(labels, total, what, unit) { + if (length(labels) == 0L) { + return(invisible(NULL)) } abort(glue( - "{what}: {length(incomplete)} of {nrow(x)} row(s) carry no ", + "{what}: {length(labels)} of {total} {unit} carry no ", "full-data fit, only cross-validation results -- ", - "{str_flatten(.pubRowLabels(x, incomplete), ', ')}. Fold-level ", + "{str_flatten(labels, ', ')}. Fold-level ", "results cannot be published (fold membership is sample-level ", "information), so refit with ", "`CrossValidationParam(fitFullData = TRUE)` and export that. ", @@ -285,18 +288,24 @@ NULL )) } -# Rows of a TwasWeights with no full-data weights: a CV-only row has an empty -# element AND no `weight` metadata column (TwasWeightsRow() drops the column -# when `weights` is NULL). +# Refuse a TwasWeights with an entry that has no full-data weights: a CV-only +# entry has no variants, or no weights (TwasWeightsRow() takes `weights = +# NULL`). # @noRd -.twbIncompleteRows <- function(x) { - which( - lengths(x) == 0L | !map_lgl(seq_len(nrow(x)), .twbRowHasWeights, x = x) +.twbRequireFullFit <- function(view, what) { + incomplete <- which(!map_lgl(view$entries, .twbCellHasWeights)) + .pubRequireFullFit( + .twbCellLabels(view$cells, incomplete), + nrow(view$cells), + what, + "entries" ) } # @noRd -.twbRowHasWeights <- function(i, x) !is.null(mcols(x[[i]])$weight) +.twbCellHasWeights <- function(entry) { + length(variants(entry)) > 0L && !is.null(weights(entry)) +} # Rows of a fine-mapping result with no fitted variants: what a # cross-validation only run (CrossValidationParam(fitFullData = FALSE)) leaves @@ -313,6 +322,52 @@ NULL str_replace_all(keys[rows], "\r", "|") } +# ---- shared: TWAS entries --------------------------------------------------- + +# What both TWAS formats publish: one entry per (row, method) of the +# collection. `cells` is .twasCells() -- each entry's row and identity -- +# and `entries` holds each one as a TwasWeightsRow, whose variants carry that +# method's weight. +# @noRd +.twbCellView <- function(x) { + cells <- .twasCells(x) + list( + cells = cells, + entries = map2(cells$row, cells$method, .twrCellParts, x = x) + ) +} + +# Identity labels for the named entries, for an error message. +# @noRd +.twbCellLabels <- function(cells, idx) { + parts <- map(as.list(cells[idx, .PUB_ROW_COLS]), .pubKeyPart) + exec(str_c, !!!parts, sep = "|") +} + +# Indices of the entries whose identity equals every supplied selector. A +# method may be given in either spelling (susie_inf or susieInf). +# @noRd +.twbMatchingCells <- function(cells, studyName, context, trait, method) { + selectors <- compact(list( + study = studyName, + context = context, + trait = trait, + method = if (!is.null(method)) .twasMethodToken(method) + )) + reduce( + names(selectors), + .twbNarrowCells, + cells = cells, + selectors = selectors, + .init = seq_len(nrow(cells)) + ) +} + +# @noRd +.twbNarrowCells <- function(idx, axis, cells, selectors) { + idx[is_in(cells[[axis]][idx], selectors[[axis]])] +} + # ---- shared: genomic order -------------------------------------------------- #' Order rows by genomic position, with chromosomes sorted naturally @@ -1498,27 +1553,38 @@ setMethod( method = NULL ) { .vcfRequireVariantAnnotation() - .pubRequireFullFit(obj, .twbIncompleteRows(obj), "writeGwasVcf") - rows <- .pubMatchingRows(obj, studyName, context, trait, method) - if (length(rows) == 0L) { - abort("writeGwasVcf: no rows match the supplied selectors.") + view <- .twbCellView(obj) + .twbRequireFullFit(view, "writeGwasVcf") + cells <- .twbMatchingCells( + view$cells, + studyName, + context, + trait, + method + ) + if (length(cells) == 0L) { + abort("writeGwasVcf: no entries match the supplied selectors.") } # The same rule the BED path applies, and for the same reason: a # fine-mapping method's "weights" are the posterior re-expressed, so # the fine-mapping result says strictly more. This path used to publish # them, which made the two formats disagree about what a weights file # contains. - rows <- intersect(rows, .twbExportableRows(obj, "writeGwasVcf")) - if (length(rows) == 0L) { + cells <- intersect( + cells, + .twbExportableCells(view$cells, "writeGwasVcf") + ) + if (length(cells) == 0L) { abort(str_c( - "writeGwasVcf: every selected row is fine-mapping-derived, so ", - "there is nothing to write as weights. Write the ", + "writeGwasVcf: every selected entry is fine-mapping-derived, ", + "so there is nothing to write as weights. Write the ", "fine-mapping result." )) } .twvWriteSamples( obj, - .twvSampleSpecs(obj, rows), + view, + .twvSampleSpecs(view, cells), sampleName, filename ) @@ -1534,12 +1600,12 @@ setMethod( # a dozen methods for one gene -- a dozen near-identical files would be the # wrong shape for the same information. # @noRd -.twvWriteSamples <- function(x, samples, sampleName, outputPath) { - gr <- .twvVariantUnion(x, samples) +.twvWriteSamples <- function(x, view, samples, sampleName, outputPath) { + gr <- .twvVariantUnion(view, samples) ids <- .grVariantIds(gr) mc <- mcols(gr) - wgt <- .twvWeightMatrix(x, samples, ids) - meta <- .twbRowMetadata(x) + wgt <- .twvWeightMatrix(view, samples, ids) + meta <- .twbCellMetadata(x, view) sn <- .twvSampleNames(samples, meta, sampleName) .writeVcfImpl( chrom = as.character(seqnames(gr)), @@ -1588,11 +1654,15 @@ setMethod( # @noRd .twvSampleMetaRow <- function(j, samples, meta, nWeighted, x) { s <- samples[[j]] - ident <- slice(meta, s$row) + ident <- slice(meta, s$cell) fields <- .pubPerFitFields(x, s$row, NULL) - # A weight-matrix column is a member of a joint fit, so `trait` names the - # member while `joint_traits` keeps the membership. Assigned rather than - # bound, so there is one `trait` field and not a repaired duplicate. + # The method, its scale and its data type belong to the entry, not to the + # row. A weight-matrix column is a member of a joint fit, so `trait` names + # the member while `joint_traits` keeps the membership. Assigned rather + # than bound, so each field appears once and not as a repaired duplicate. + fields$method <- ident$method + fields$data_type <- ident$dataType + fields$weight_standardized <- ident$standardized fields$trait <- .twbTraitOf(s$label, ident$trait) bind_cols(tibble(total_variants = nWeighted[[j]]), as_tibble(fields)) } @@ -1619,41 +1689,49 @@ setMethod( ) } -# One sample spec per (collection row, weight column): the row it reads, which -# weight column, and that column's label. A plain weight vector contributes one -# sample; a weight MATRIX (fSuSiE collapses a functional fit to variants x -# features) contributes one per column. +# One sample spec per (entry, weight column): the entry it reads (`cell`, in +# the view), the collection row that entry sits on, which weight column, and +# that column's label. A plain weight vector contributes one sample; a weight +# MATRIX (fSuSiE collapses a functional fit to variants x features) +# contributes one per column. # @noRd -.twvSampleSpecs <- function(x, rows) { - list_flatten(map(rows, .twvRowSampleSpecs, x = x)) +.twvSampleSpecs <- function(view, cells) { + list_flatten(map(cells, .twvCellSampleSpecs, view = view)) } # @noRd -.twvRowSampleSpecs <- function(i, x) { - # .pubRequireFullFit() has already established that every row has weights. - labels <- .twbWeightLabels(mcols(x[[i]])$weight) - map(seq_along(labels), .twvOneSampleSpec, row = i, labels = labels) +.twvCellSampleSpecs <- function(cell, view) { + # .twbRequireFullFit() has already established that every entry has + # weights. + labels <- .twbWeightLabels(weights(view$entries[[cell]])) + map( + seq_along(labels), + .twvOneSampleSpec, + cell = cell, + row = view$cells$row[[cell]], + labels = labels + ) } # @noRd -.twvOneSampleSpec <- function(k, row, labels) { - list(row = row, column = k, label = labels[[k]]) +.twvOneSampleSpec <- function(k, cell, row, labels) { + list(cell = cell, row = row, column = k, label = labels[[k]]) } # The union of every selected model's variants, in genomic order. The weight -# mcols is dropped first: it is numeric on one row and a matrix on another, and -# c() on GRanges requires one mcols schema. +# mcols is dropped first: it is numeric on one entry and a matrix on another, +# and c() on GRanges requires one mcols schema. # @noRd -.twvVariantUnion <- function(x, samples) { - rows <- unique(map_int(samples, "row")) - all <- exec(c, !!!map(rows, .twvRowAlleles, x = x)) +.twvVariantUnion <- function(view, samples) { + cells <- unique(map_int(samples, "cell")) + all <- exec(c, !!!map(view$entries[cells], .twvCellAlleles)) gr <- all[!duplicated(.grVariantIds(all))] gr[genomicOrder(as.character(seqnames(gr)), start(gr))] } # @noRd -.twvRowAlleles <- function(i, x) { - gr <- x[[i]] +.twvCellAlleles <- function(entry) { + gr <- variants(entry) S4Vectors::`mcols<-`( gr, value = mcols(gr)[, c("A1", "A2"), drop = FALSE] @@ -1663,16 +1741,16 @@ setMethod( # The nVariant x nSample weight matrix: one column per model, placed onto the # union by variant id. # @noRd -.twvWeightMatrix <- function(x, samples, unionIds) { +.twvWeightMatrix <- function(view, samples, unionIds) { exec( cbind, - !!!map(samples, .twvSampleColumn, x = x, unionIds = unionIds) + !!!map(samples, .twvSampleColumn, view = view, unionIds = unionIds) ) } # @noRd -.twvSampleColumn <- function(s, x, unionIds) { - gr <- x[[s$row]] +.twvSampleColumn <- function(s, view, unionIds) { + gr <- variants(view$entries[[s$cell]]) out <- rep(NA_real_, length(unionIds)) out[match(.grVariantIds(gr), unionIds)] <- .twbWeightColumn(s$column, mcols(gr)$weight) @@ -1692,7 +1770,7 @@ setMethod( # @noRd .twvSampleLabel <- function(s, meta) { - ident <- slice(meta, s$row) + ident <- slice(meta, s$cell) tags <- c(ident$study, ident$context, ident$trait, ident$method) if (!is.na(s$label)) { tags <- c(tags, s$label) @@ -2632,7 +2710,12 @@ setMethod( schema <- arg_match(schema) levels <- arg_match(levels, multiple = TRUE) assertString(filename) - .pubRequireFullFit(obj, .fmbIncompleteRows(obj), "writeBed") + .pubRequireFullFit( + .pubRowLabels(obj, .fmbIncompleteRows(obj)), + nrow(obj), + "writeBed", + "row(s)" + ) if (identical(schema, "fsusie")) { return(.pubWriteTable( .fmbFsusieTable(obj, columns, levels, coverage), @@ -2666,15 +2749,16 @@ setMethod( # @noRd .TWB_WEIGHT_SOURCE <- c("A1", "A2", "weight") -# A zero-row frame naming every variant-level column ANY row's variants carry. -# `columns` resolves against this rather than against one row, because the -# published schema must not vary row by row: a column one row has and another -# lacks has to become an NA cell, not a column that appears halfway down. +# A zero-row frame naming every variant-level column ANY entry's variants +# carry. `columns` resolves against this rather than against one entry, +# because the published schema must not vary entry by entry: a column one +# has and another lacks has to become an NA cell, not a column that appears +# halfway down. # @noRd -.twbVariantColumns <- function(x) { +.twbVariantColumns <- function(view) { nms <- unique(list_c(c( list(character(0)), - map(seq_len(nrow(x)), .twbRowVariantColumns, x = x) + map(view$entries, .twbCellVariantColumns) ))) as_tibble( set_names(rep(list(character()), length(nms)), nms), @@ -2683,67 +2767,43 @@ setMethod( } # @noRd -.twbRowVariantColumns <- function(i, x) colnames(mcols(x[[i]])) +.twbCellVariantColumns <- function(entry) colnames(mcols(variants(entry))) -# Per-row identity and payload provenance, as a tibble parallel to the -# collection's rows. The identity axes are mcols columns on a TwasWeights, not -# element fields, so they are read through `.tupleColumn()`. +# Per-entry identity and payload provenance, as a tibble parallel to the +# view's entries. The method, its scale and its data type are the entry's; +# the data source and the joint membership are its row's. # @noRd -.twbRowMetadata <- function(x) { +.twbCellMetadata <- function(x, view) { + rows <- view$cells$row tibble( - study = .pubTupleColumn("study", x), - trait = .pubTupleColumn("trait", x), - context = .pubTupleColumn("context", x), - method = .pubTupleColumn("method", x), - standardized = .twbColumnOr(x, "standardized", as.logical, NA), - dataType = .twbListColumn(x, "dataType"), - dataSource = .pubDataSourceOf(x), - jointStudies = .twbColumnOr( - x, - "jointStudies", - as.character, - NA_character_ - ), - jointContexts = .twbColumnOr( - x, - "jointContexts", - as.character, - NA_character_ - ), - jointTraits = .twbColumnOr( - x, - "jointTraits", - as.character, - NA_character_ - ) + study = view$cells$study, + trait = view$cells$trait, + context = view$cells$context, + method = view$cells$method, + standardized = map_lgl(view$entries, weightStandardized), + dataType = map_chr(view$entries, .twbCellDataType), + dataSource = .pubDataSourceOf(x)[rows], + jointStudies = .twbColumnOr(x, "jointStudies")[rows], + jointContexts = .twbColumnOr(x, "jointContexts")[rows], + jointTraits = .twbColumnOr(x, "jointTraits")[rows] ) } -# An mcols column read through `coerce`, or a recycled default when the -# collection does not carry it. +# A character mcols column, or NA for every row when the collection does not +# carry it. # @noRd -.twbColumnOr <- function(x, nm, coerce, default) { +.twbColumnOr <- function(x, nm) { if (!is_in(nm, .tupleColumnNames(x))) { - return(rep(default, nrow(x))) + return(rep(NA_character_, nrow(x))) } - coerce(.tupleColumn(x, nm)) -} - -# A per-row List column flattened to one string per row. -# -# No absent-column branch, unlike `.twbColumnOr()` above: this is only ever -# asked for `dataType`, which `TwasWeights()` materializes for every row even -# when no row declares one -- and that constructor is the only way to build -# the class, so the column is always there. -# @noRd -.twbListColumn <- function(x, nm) { - map_chr(as.list(.tupleColumn(x, nm)), .twbScalarChr) + as.character(.tupleColumn(x, nm)) } -# One List cell as a single string: an absent value becomes NA, and a -# multi-value cell is ";"-packed rather than silently truncated. +# An entry's data type as one string: absent becomes NA, and several values +# are ";"-packed rather than silently truncated. # @noRd -.twbScalarChr <- function(v) { +.twbCellDataType <- function(entry) { + v <- weightsDataType(entry) if (length(v) == 0L) NA_character_ else .pubPack(v) } @@ -2768,30 +2828,30 @@ setMethod( # Fine-mapping methods have no business in a weights export: their "weights" # are the fine-mapping posterior re-expressed, so the fine-mapping result says -# strictly more. Those rows are skipped with a message rather than written. -# @noRd -.TWB_FINE_MAPPING_METHODS <- c( - "susie", - "susie_inf", - "susie_ash", - "mvsusie", - "fsusie" -) +# strictly more. Those entries are skipped with a message rather than written. +# A method may be named by token (susieInf, as a pipeline labels it) or by +# snake key (susie_inf, as learnTwasWeights() takes it), so both are matched. +# @noRd +.twbIsFineMappingMethod <- function(methods) { + !is.na(map_chr(as.character(methods), .twasFmTokenFor)) +} +# Indices of the entries `cells` (.twasCells()) that are not fine-mapping +# derived. # @noRd -.twbExportableRows <- function(x, label = "writeBed") { - methods <- .pubTupleColumn("method", x) - skip <- which(is_in(methods, .TWB_FINE_MAPPING_METHODS)) +.twbExportableCells <- function(cells, label = "writeBed") { + skip <- which(.twbIsFineMappingMethod(cells$method)) if (length(skip) > 0L) { inform(glue( "{label}: skipping {length(skip)} fine-mapping-derived ", - "row(s) ({str_flatten(unique(methods[skip]), ', ')}). Those ", + "{if (length(skip) == 1L) 'entry' else 'entries'} ", + "({str_flatten(unique(cells$method[skip]), ', ')}). Those ", "weights are the fine-mapping posterior re-expressed -- export ", "the fine-mapping result instead, which carries the posterior, ", "its standard error and the credible sets." )) } - setdiff(seq_len(nrow(x)), skip) + setdiff(seq_len(nrow(cells)), skip) } # One (row, weight column) block of the weights table: every variant of the @@ -2853,10 +2913,13 @@ setMethod( if (is.na(label)) trait else label } +# The blocks of entry `cell` of the view. Its window and its LD reference are +# its row's. # @noRd -.twbWeightRows <- function(i, x, meta, regions, regionIds, schema, added) { - gr <- x[[i]] +.twbWeightRows <- function(cell, view, x, meta, regions, schema, added) { + gr <- variants(view$entries[[cell]]) w <- mcols(gr)$weight + i <- view$cells$row[[cell]] labels <- .twbWeightLabels(w) list_rbind(map( seq_along(labels), @@ -2864,11 +2927,11 @@ setMethod( gr = gr, w = w, labels = labels, - ident = slice(meta, i), + ident = slice(meta, cell), win = list( - id = .pubRegionIds(regions)[[i]], - start = start(regions)[[i]] - 1L, - end = end(regions)[[i]] + id = regions$id[[i]], + start = start(regions$ranges)[[i]] - 1L, + end = end(regions$ranges)[[i]] ), af = .twbVariantAf(.rowLdRef(x, i), gr), schema = schema, @@ -2893,26 +2956,26 @@ setMethod( } # @noRd -.twbWeightsTable <- function(x, columns, coverage) { - rows <- .twbExportableRows(x) - if (length(rows) == 0L) { +.twbWeightsTable <- function(x, columns, coverage, view = .twbCellView(x)) { + cells <- .twbExportableCells(view$cells) + if (length(cells) == 0L) { abort(str_c( - "writeBed: every row is fine-mapping-derived, so there is ", + "writeBed: every entry is fine-mapping-derived, so there is ", "nothing to write as weights. Export the fine-mapping result." )) } schema <- .pubSchema(.pubCsColumns(tibble(), coverage)) regions <- genomicRegion(x) pieces <- compact(map( - rows, + cells, .twbWeightRows, + view = view, x = x, - meta = .twbRowMetadata(x), - regions = regions, - regionIds = .pubRegionIds(regions), + meta = .twbCellMetadata(x, view), + regions = list(ranges = regions, id = .pubRegionIds(regions)), schema = schema, added = .pubViewColumns( - .twbVariantColumns(x), + .twbVariantColumns(view), columns, .TWB_WEIGHT_SOURCE ) @@ -2940,9 +3003,10 @@ setMethod( extraColumns = NULL ) { assertString(filename) - .pubRequireFullFit(obj, .twbIncompleteRows(obj), "writeBed") + view <- .twbCellView(obj) + .twbRequireFullFit(view, "writeBed") .pubWriteTable( - .twbWeightsTable(obj, columns, coverage), + .twbWeightsTable(obj, columns, coverage, view), filename, naString = "NA", index = TRUE, diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 9798ae604..73d9c51af 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -42,7 +42,13 @@ NULL } else { as_tibble(x) } - select(df, all_of(c("chrom", "pos", "alt", "ref"))) + # Alleles in upper case, so the two sources' keys meet whatever case + # each was given in. + mutate( + select(df, all_of(c("chrom", "pos", "alt", "ref"))), + alt = .canonAllele(.data$alt), + ref = .canonAllele(.data$ref) + ) } # Canonical per-variant key from sorted alleles, so strand/allele flips collide. @@ -245,10 +251,7 @@ resolveLdInput <- function( # One window's LD: the matrix's diagonal block, or the factor's columns. # @noRd .dentistLdSlice <- function(ld, idx) { - if (is.null(ld$F)) { - return(list(R = ld$R[idx, idx, drop = FALSE])) - } - list(F = ld$F[, idx, drop = FALSE]) + .ldSourceSubset(ld, idx) } # The LD a DENTIST run reads, with the sample size it needs. Genotypes under @@ -483,11 +486,7 @@ dentist <- function( return(list(zScore = zScore, ld = ld, dedupRes = NULL)) } rThreshold <- round(sqrt(duprThreshold) * 1000) / 1000 - dedupRes <- if (is.null(ld$F)) { - .findDuplicateVariants(zScore, ld$R, rThreshold) - } else { - .findDuplicateVariantsFactor(zScore, ld$F, rThreshold) - } + dedupRes <- .findDuplicateVariants(zScore, ld, rThreshold) numDup <- sum(dedupRes$dupBearer != -1) if (numDup > 0) { nZ <- length(zScore) @@ -499,11 +498,7 @@ dentist <- function( } list( zScore = dedupRes$filteredZ, - ld = if (is.null(ld$F)) { - list(R = dedupRes$filteredLD) - } else { - list(F = dedupRes$filteredFactor) - }, + ld = dedupRes$filteredLd, dedupRes = dedupRes ) } @@ -636,27 +631,64 @@ dentistSingleWindow <- function( ) { .assertBpparam(BPPARAM) ld <- .dentistLdInput(R, X, nSample, ldMethod) - nSample <- ld$nSample + .dentistOnSource( + zScore, + ld, + ld$nSample, + list( + pValueThreshold = pValueThreshold, + propSVD = propSVD, + gcControl = gcControl, + nIter = nIter, + gPvalueThreshold = gPvalueThreshold, + duprThreshold = duprThreshold, + BPPARAM = BPPARAM, + correctChenEtAlBug = correctChenEtAlBug, + seed = seed + ) + ) +} + +# dentistSingleWindow()'s tuning arguments, the settings .dentistOnSource() +# reads. +# @noRd +.dentistSettingNames <- function() { + c( + "pValueThreshold", + "propSVD", + "gcControl", + "nIter", + "gPvalueThreshold", + "duprThreshold", + "BPPARAM", + "correctChenEtAlBug", + "seed" + ) +} + +# dentistSingleWindow() on an LD source (.ldSourceRows()) whose reference has +# `nSample` samples, under `settings` (.dentistSettingNames()). +# @noRd +.dentistOnSource <- function(zScore, ld, nSample, settings) { .dentistValidateInput(zScore, ld) p <- list( - pValueThreshold = pValueThreshold, - propSVD = propSVD, - gcControl = gcControl, - nIter = nIter, - gPvalueThreshold = gPvalueThreshold, - threads = .bpLocalThreads(BPPARAM, "dentistSingleWindow"), - correctChenEtAlBug = correctChenEtAlBug, - seed = seed - ) - orgZscore <- zScore - dedup <- .dentistDedup(zScore, ld, duprThreshold) + pValueThreshold = settings$pValueThreshold, + propSVD = settings$propSVD, + gcControl = settings$gcControl, + nIter = settings$nIter, + gPvalueThreshold = settings$gPvalueThreshold, + threads = .bpLocalThreads(settings$BPPARAM, "dentistSingleWindow"), + correctChenEtAlBug = settings$correctChenEtAlBug, + seed = settings$seed + ) + dedup <- .dentistDedup(zScore, ld, settings$duprThreshold) imputed <- .dentistRunImpute(dedup$ld, nSample, dedup$zScore, p) - res <- if (duprThreshold < 1.0) { - addDupsBackDentist(orgZscore, imputed, dedup$dedupRes) + res <- if (settings$duprThreshold < 1.0) { + addDupsBackDentist(zScore, imputed, dedup$dedupRes) } else { imputed } - .dentistOutlierStat(res, pValueThreshold) + .dentistOutlierStat(res, settings$pValueThreshold) } # --- addDupsBackDentist helpers --------------------------------------------- @@ -1316,24 +1348,38 @@ mergeWindows <- function(dentistResultByWindow, windowDividedRes) { # --- slalom helpers --------------------------------------------------------- -# Lead-variant LD column. From genotypes under the sample estimator it is read -# off X's LD factor -- crossprod(F, F[, lead]) / (n - 1), computeLd()'s column -# exactly -- without forming the p x p matrix. The population and GCTA -# estimators treat missing calls their own way, so they still build it -# through resolveLdInput(), as dentist does. +# The LD slalom() reads. From genotypes under the sample estimator it is X's +# LD factor, from which the lead's column is read without forming the p x p +# matrix. The population and GCTA estimators treat missing calls their own +# way, so they still build the matrix through resolveLdInput(), as dentist +# does. #' @importFrom checkmate assertMatrix -.slalomLeadR <- function(zScore, R, X, leadIdx, ldMethod) { +.slalomLdSource <- function(zScore, R, X, ldMethod) { if (is.null(R) && identical(ldMethod, "sample")) { factor <- .ldFactorFromDosage(as.matrix(X)) assertMatrix(factor, ncols = length(zScore)) - lead <- crossprod(factor, factor[, leadIdx, drop = FALSE]) - # The lead's correlation with itself is 1 exactly, as on the - # matrix's unit diagonal, not 1 give or take rounding. - return(replace(drop(lead) / (nrow(factor) - 1), leadIdx, 1)) + return(list(F = factor)) } R <- resolveLdInput(R = R, X = X, ldMethod = ldMethod)$R assertMatrix(R, nrows = length(zScore), ncols = length(zScore)) - R[, leadIdx] + list(R = R) +} + +# The lead variant's LD column: a matrix's own column, or read off a packed +# triangle or a factor -- crossprod(F, F[, lead]) / (n - 1), computeLd()'s +# column exactly -- without forming the rest. +# @noRd +.slalomLeadColumn <- function(ld, leadIdx) { + if (!is.null(ld$R)) { + return(ld$R[, leadIdx]) + } + lead <- drop(.ldSourceRows(ld, leadIdx)) + if (is.null(ld$F)) { + return(lead) + } + # The lead's correlation with itself is 1 exactly, as on the matrix's + # unit diagonal, not 1 give or take rounding. + replace(lead, leadIdx, 1) } # DENTIST-S outlier statistic against the lead variant. @@ -1450,6 +1496,29 @@ slalom <- function( ldMethod = "sample" ) { .ldRequireOneSource(R, X) + .slalomOnSource( + zScore, + .slalomLdSource(zScore, R, X, ldMethod), + standardError, + abfPriorVariance, + nlog10pDentistSThreshold, + r2Threshold, + leadVariantChoice + ) +} + +# slalom() on an LD source (.ldSourceRows()), of which it reads the lead +# variant's column only. +# @noRd +.slalomOnSource <- function( + zScore, + ld, + standardError, + abfPriorVariance, + nlog10pDentistSThreshold, + r2Threshold, + leadVariantChoice +) { # One-sided p-value matching the original Python (stats.norm.cdf): lead is # the most negative z-score when leadVariantChoice == "pvalue". pvalue <- pnorm(zScore) @@ -1466,7 +1535,7 @@ slalom <- function( } else { which.max(prob) } - rLead <- .slalomLeadR(zScore, R, X, leadIdx, ldMethod) + rLead <- .slalomLeadColumn(ld, leadIdx) ds <- .slalomDentistS( zScore, rLead, @@ -2037,14 +2106,20 @@ raissSingleMatrixFromX <- function( .qcRaissKnownZ(.entryGrangesToDf(knownZscores)) } -# A table handed to raiss() with its `chrom` column in UCSC style, so its rows -# meet the reference's and each other's on equal labels. NULL stays NULL. +# A table handed to raiss() in pecotmr's spelling -- `chrom` in UCSC style, +# alleles in upper case -- so its rows meet the reference's and each other's +# on equal labels. `variant_id` is a label (an rsID, or a file's own spelling +# of chrom:pos:A2:A1) and stays as given. NULL stays NULL. # @noRd -.raissUcscChrom <- function(df) { +.raissCanon <- function(df) { if (is.null(df) || is.null(df[["chrom"]])) { return(df) } - `[[<-`(df, "chrom", value = withChrPrefix(df[["chrom"]])) + reduce( + intersect(c("A1", "A2"), names(df)), + .withCanonAlleleCol, + .init = `[[<-`(df, "chrom", value = withChrPrefix(df[["chrom"]])) + ) } # The genotypes' LD factor for refPanel's variants (see .ldRefFactor()), the @@ -2147,8 +2222,8 @@ raiss <- function( if (is.null(genotypes) && is.null(ldMatrix)) { abort("Provide either ldMatrix or genotypes.") } - knownZscores <- .raissUcscChrom(.raissKnownTable(knownZscores)) - refPanel <- .raissUcscChrom(refPanel) + knownZscores <- .raissCanon(.raissKnownTable(knownZscores)) + refPanel <- .raissCanon(refPanel) ref <- .raissReferenceOf(ldMatrix, genotypes) if (!is.null(ref)) { refPanel <- refPanel %||% .raissRefPanelOf(ref, knownZscores) @@ -2441,19 +2516,20 @@ mergeRaissDf <- function(raissDf, knownZscores) { # Remove the extra columns produced by the join (z.x, z.y). select(-all_of(c("z.x", "z.y"))) |> arrange(.data$pos) - # Imputed variants' beta / se are NA to avoid confusion, since they are not - # imputed. Both are optional (knownZscores may omit them), so guard on - # column presence explicitly rather than relying on a data.frame silently - # creating an all-NA column on `$col[mask] <- NA`. - observed <- resolved$Var == -1 + # Imputed variants' beta / se are NA to avoid confusion, since only z is + # imputed; an observed variant (Var == -1) keeps its own. Both are + # optional (knownZscores may omit them), so guard on column presence + # explicitly rather than relying on a data.frame silently creating an + # all-NA column on `$col[mask] <- NA`. + imputed <- resolved$Var != -1 mutate( resolved, !!!compact(list( beta = if (is_in("beta", colnames(resolved))) { - replace(resolved$beta, observed, NA) + replace(resolved$beta, imputed, NA) }, se = if (is_in("se", colnames(resolved))) { - replace(resolved$se, observed, NA) + replace(resolved$se, imputed, NA) } )) ) @@ -2785,14 +2861,7 @@ ldMismatchQc <- function( method = c("slalom", "dentist"), ldMethod = "sample" ) { - # `method` carries both the choice and its options: a bare name resolves - # to that engine with no options set, a constructor result to that engine - # configured. One value, so the two cannot disagree. - chosen <- .resolveEngineChoice( - if (is.character(method)) method[[1L]] else method, - names(.ldMismatchCtors()), - "method" - ) + chosen <- .ldMismatchEngine(method) engineParam <- chosen$args if (chosen$engine == "dentist") { callArgs <- list_modify( @@ -2811,19 +2880,64 @@ ldMismatchQc <- function( list(zScore, R = R, X = X, ldMethod = ldMethod), !!!engineParam ) - qcResults <- exec(slalom, !!!callArgs) - # Standardize output: slalom uses "outliers", rename to "outlier" for - # consistency - raw <- qcResults$data - renameOutliers <- is_in("outliers", colnames(raw)) && - !is_in("outlier", colnames(raw)) - result <- if (renameOutliers) { - rename(raw, outlier = "outliers") - } else { - raw - } - return(result) + return(.slalomOutliers(exec(slalom, !!!callArgs))) + } +} + +# The mismatch QC engine `method` names: a bare name resolves to that engine +# with no options set, a constructor result to that engine configured. One +# value carries both, so the two cannot disagree. +# @noRd +.ldMismatchEngine <- function(method) { + .resolveEngineChoice( + if (is.character(method)) method[[1L]] else method, + names(.ldMismatchCtors()), + "method" + ) +} + +# slalom()'s table with its "outliers" column named "outlier", as +# ldMismatchQc() reports both methods. +# @noRd +.slalomOutliers <- function(qcResults) { + raw <- qcResults$data + renameOutliers <- is_in("outliers", colnames(raw)) && + !is_in("outlier", colnames(raw)) + if (renameOutliers) rename(raw, outlier = "outliers") else raw +} + +# ldMismatchQc() on an LD source (.ldSourceRows()) rather than a matrix or +# genotypes: summaryStatsQc hands it a genotype reference's factor or an +# LdMatrix's packed block. SLALOM reads one column of it; DENTIST passes over +# it many times, so a packed block is unpacked once for the run. Each +# method's settings not given in `method` take its own defaults. +# @noRd +.ldMismatchQcOn <- function(zScore, ld, nSample, method) { + chosen <- .ldMismatchEngine(method) + if (chosen$engine == "dentist") { + settings <- list_modify( + .formalDefaults(dentistSingleWindow, .dentistSettingNames()), + !!!chosen$args + ) + whole <- if (is.null(ld$F)) list(R = .ldSourceMatrix(ld)) else ld + return(.dentistOnSource(zScore, whole, nSample, settings)) } + settings <- list_modify( + c( + list(standardError = rep(1, length(zScore))), + .formalDefaults( + slalom, + c( + "abfPriorVariance", + "nlog10pDentistSThreshold", + "r2Threshold", + "leadVariantChoice" + ) + ) + ), + !!!chosen$args + ) + .slalomOutliers(exec(.slalomOnSource, zScore, ld, !!!settings)) } #' Effective sample size for a case/control study @@ -2939,10 +3053,10 @@ effectiveN <- function(nCase, nControl) { "z_supplied" ) use <- intersect(c(baseCols, optCols), colnames(df)) - S4Vectors::`mcols<-`( + .canonAlleleMcols(S4Vectors::`mcols<-`( gr, value = S4Vectors::DataFrame(select(df, all_of(use))) - ) + )) } # ----------------------------------------------------------------------------- @@ -3140,35 +3254,21 @@ effectiveN <- function(nCase, nControl) { ) } -# Internal: identify LD-correlated duplicate variants. Walks the LD -# matrix left-to-right, marking each variant as either a unique anchor -# (dupBearer == -1) or a duplicate of an earlier anchor (dupBearer == k, -# the anchor's index). Returns filtered z / LD plus per-variant -# bookkeeping that DENTIST's addDupsBackDentist uses to splice the -# dropped variants back into the output. +# Internal: identify LD-correlated duplicate variants. Walks the LD source +# `ld` (.ldSourceRows()) left-to-right, marking each variant as either a +# unique anchor (dupBearer == -1) or a duplicate of an earlier anchor +# (dupBearer == k, the anchor's index). The walk reads the LD a stripe of +# rows at a time, so a packed triangle or a factor never forms the p x p +# matrix. Returns the filtered z and LD source plus per-variant bookkeeping +# that DENTIST's addDupsBackDentist uses to splice the dropped variants back +# into the output. .findDuplicateVariants <- function(z, ld, rThreshold) { - walk <- .dupWalk(z, rThreshold, list(R = ld)) - kept <- walk$dupBearer == -1 - c( - list( - filteredZ = z[kept], - filteredLD = ld[kept, kept, drop = FALSE] - ), - walk - ) -} - -# .findDuplicateVariants() from a factor of the LD: the same walk, its LD rows -# computed a stripe at a time from the factor, so the p x p matrix is never -# formed; the duplicates are dropped from the factor's columns. -# @noRd -.findDuplicateVariantsFactor <- function(z, factor, rThreshold) { - walk <- .dupWalk(z, rThreshold, list(F = factor)) + walk <- .dupWalk(z, rThreshold, ld) kept <- walk$dupBearer == -1 c( list( filteredZ = z[kept], - filteredFactor = factor[, kept, drop = FALSE] + filteredLd = .ldSourceSubset(ld, which(kept)) ), walk ) @@ -3702,17 +3802,18 @@ effectiveN <- function(nCase, nControl) { # leaves the drop to onMissing here, so they are dropped here (keeping df # aligned with the returned LD) rather than aborting the run. # -# Returns list(R, X, df, dropped): a genotype reference gives X, the factor of -# its LD (.ldFactorFromRef()), which the mismatch QC reads directly; an -# LdMatrix gives the matrix R. Both are NULL when no variant is -# panel-supported, and `df` is empty then -- each caller shapes its own empty -# result. .qcPanelLdMatrix() turns either into the matrix for a step that -# needs one. +# Returns list(ld, df, dropped): `ld` is the LD source (.ldSourceRows()) the +# checks read -- a genotype reference's factor (.ldFactorFromRef()), or an +# LdMatrix's packed block (.ldPackedFromRef()), which each check unpacks +# only if it passes over it many times. It is NULL when no variant is +# panel-supported, and `df` is empty then -- each caller shapes its own +# empty result. +# .qcPanelLdMatrix() forms the matrix for a step that needs one. # @noRd .qcPanelSupportedLd <- function(df, ldReference, label) { nIn <- nrow(df) isFactor <- .ldIsGenotypeRef(ldReference) - ldFrom <- if (isFactor) .ldFactorFromRef else .ldFromRef + ldFrom <- if (isFactor) .ldFactorFromRef else .ldPackedFromRef raw <- ldFrom(ldReference, df$SNP, label = label, onMissing = "drop") if (is.null(raw)) { return(list(df = df[0L, , drop = FALSE], dropped = nIn)) @@ -3727,14 +3828,14 @@ effectiveN <- function(nCase, nControl) { dropped = nIn - length(keptIds) ) } - c(if (isFactor) list(X = ld) else list(R = ld), supported) + c(list(ld = if (isFactor) list(F = ld) else ld), supported) } -# The LD matrix of a .qcPanelSupportedLd() result, formed from its factor -# when that is what the reference gave. +# The LD matrix of a .qcPanelSupportedLd() result, for a step that takes +# nothing else (kriging_rss). # @noRd .qcPanelLdMatrix <- function(panel) { - panel$R %||% (crossprod(panel$X) / (nrow(panel$X) - 1)) + .ldSourceMatrix(panel$ld) } # DENTIST truncates its SVD at a rank bounded by the panel's real size, so it @@ -3759,7 +3860,7 @@ effectiveN <- function(nCase, nControl) { ldReference, "summaryStatsQc: ldMismatchQcMethod" ) - if (is.null(panel$R) && is.null(panel$X)) { + if (is.null(panel$ld)) { return(list( df = panel$df, outliers = 0L, @@ -3769,14 +3870,13 @@ effectiveN <- function(nCase, nControl) { } df <- panel$df variantIds <- df$SNP - # A genotype reference's factor goes in as X: SLALOM reads only the lead - # column of it. - qc <- ldMismatchQc( - zScore = df$Z, - R = panel$R, - X = panel$X, - nSample = .qcMismatchNSample(ldReference, method), - method = method + # The panel's LD source goes in as it is: SLALOM reads only the lead's + # column of it, and DENTIST reads it a block at a time. + qc <- .ldMismatchQcOn( + df$Z, + panel$ld, + .qcMismatchNSample(ldReference, method), + method ) # slalom / dentist can leave NA in the outlier column when their # per-variant statistic is undefined (e.g. a degenerate dentist @@ -4533,7 +4633,7 @@ effectiveN <- function(nCase, nControl) { ldReference, "summaryStatsQc: kriging prefilter" ) - if (is.null(panel$R) && is.null(panel$X)) { + if (is.null(panel$ld)) { return(list( df = panel$df, count = 0L, @@ -5161,13 +5261,12 @@ effectiveN <- function(nCase, nControl) { } # Match on the (chrom, pos, allele) tuple rather than the raw id string. # The entry ids have just been canonicalized to chr:pos:A2:A1 by the QC - # above, while panel ids are passed through verbatim by - # `.repairVariantIds()` whenever their allele fields are already valid DNA - # -- so a panel keyed chr:pos:A1:A2 (which is how a PLINK .bim writes ids; - # a .pvar writes REF:ALT and is therefore already canonical) matches - # nothing under string equality and the panel is silently emptied. This is - # the matcher `.ldFromRefMatch()` and every other LD lookup already use. - panelIds <- .ldRefMatchIds(ldReference) + # above, and the panel is keyed the same way, rendered from its ranges + # and alleles however its file labelled them: a PLINK .bim writes + # chr:pos:A1:A2, and an rsID names no position at all, so under string + # equality either would match nothing and the panel would be silently + # emptied. Entries that carry labels (rsIDs) are matched by label. + panelIds <- .ldRefKeysFor(ldReference, unique(ids)) matched <- matchVariants( panelIds, unique(ids), @@ -5335,7 +5434,7 @@ effectiveN <- function(nCase, nControl) { .ssqcRunEntry <- function(i, sumstats, opts, refs, keys, isQtl, bounds) { .runEntrySummaryStatsQc( gr = .collectionEntry(sumstats, i), - ldReference = .ldRefForKey(keys[[i]], refs), + ldReference = .dictEntryFor(keys[[i]], refs), opts = list_assign( .ssqcEntryOpts(opts, sumstats, i), raissBounds = bounds[[i]] @@ -5875,7 +5974,7 @@ summaryStatsQc <- function( entries = res$newEntries, keys = res$keys ) - perRow <- map(res$keys, .ldRefForKey, refs = trimmed) + perRow <- map(res$keys, .dictEntryFor, entries = trimmed) .ssqcRebuild(sumstats, res$newEntries, perRow, qcOptions, res$entryAudits) } diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 3b2f642b2..28eceeed4 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -99,15 +99,17 @@ x[[i]] } -# Every row's payload (.collectionEntry()) as a plain list. +# Every row's payload (.collectionEntry()) as a plain list; for TWAS weights, +# every cell's -- one per (row, method), as .twasCells() lists them. # @noRd .collectionEntries <- function(x) { - # Weight and fine-mapping rows are rebuilt one by one: their elements - # alone are bare GRanges, without the fits. - if ( - methods::is(x, "TwasWeights") || - methods::is(x, "FineMappingResultBase") - ) { + if (methods::is(x, "TwasWeights")) { + cells <- .twasCells(x) + return(map2(cells$row, cells$method, .twrCellParts, x = x)) + } + # Fine-mapping rows are rebuilt one by one: their elements alone are bare + # GRanges, without the fits. + if (methods::is(x, "FineMappingResultBase")) { return(map(seq_len(nrow(x)), .collectionEntry, x = x)) } as.list(x) @@ -987,17 +989,19 @@ # unioned, and a collection lacking an optional column (e.g. jointContexts or # region) is padded with `.naLikeColumn` -- so adding a column to a class flows # through combines automatically rather than being hand-listed at each site. -# Preserves the concrete class and rebuilds the LD references: every row keeps -# its own (.ldRefCombine()), unless `ldReference` names one for all of them. +# Preserves the concrete class and rebuilds its row dictionaries: every row +# keeps its own LD reference (.ldRefCombine()), unless `ldReference` names one +# for all of them, and its own CV partition (.cvPartitionCombine()); a class +# that holds none (CtwasResult, H2Estimate) gets none. # Returns NULL when given no inputs. Every collection is a RangedTupleList now, # so this only drops the NULL parts and hands off; the old DFrame path went # with the rebase onto GRangesList. # # `slots` carries the collection-level state a concrete subclass adds beyond -# `ldReference` (SumStatsBase's `genome` / `qcOptions`). It is passed in rather -# than read off `parts[[1L]]` because those slots describe the WHOLE collection, -# so merging them is the caller's decision -- first-wins would silently drop the -# other parts' QC audit. +# its row dictionaries (SumStatsBase's `genome` / `qcOptions`). It is passed in +# rather than read off `parts[[1L]]` because those slots describe the WHOLE +# collection, so merging them is the caller's decision -- first-wins would +# silently drop the other parts' QC audit. .rbindCollections <- function( parts, ldReference = NULL, @@ -1009,8 +1013,23 @@ if (length(parts) == 0L) { return(NULL) } - dict <- .ldRefCombine(parts, ldReference, fn) - .rbindRangedCollections(parts, dict, slots, genome) + # A gene's methods from different parts share its row. + if (methods::is(parts[[1L]], "TwasWeights")) { + return(.twasCombine(parts, ldReference)) + } + cls <- class(parts[[1L]])[[1L]] + dicts <- compact(list( + ldReference = if (methods::.hasSlot(parts[[1L]], "ldReference")) { + .ldRefCombine(parts, ldReference, fn) + }, + cvPartition = if (is_in("cvPartition", methods::slotNames(cls))) { + .cvPartitionCombine(parts) + }, + fits = if (is_in("fits", methods::slotNames(cls))) { + .fmrFitCombine(parts) + } + )) + .rbindRangedCollections(parts, dicts, slots, genome) } # Internal: aggregate a per-entry accessor across every row of a @@ -1150,21 +1169,24 @@ # @noRd .rbindRangedCollections <- function( parts, - dict, + dicts = list(), slots = list(), genome = NULL ) { cls <- class(parts[[1L]])[[1L]] allCols <- reduce(map(parts, .tupleColumnNames), union) - # Each part keyed its rows into its own references, so the bound rows take - # the keys the combined references were built with. + combined <- set_names(map(allCols, .rbindColumn, parts = parts), allCols) + # Each part keyed its rows into its own dictionaries, so the bound rows + # take the keys the combined dictionaries were built with, in the column + # each names (its slot's own name unless it says otherwise). + keyCols <- map2_chr(dicts, names(dicts), .dictKeyColOf) combined <- list_assign( - set_names(map(allCols, .rbindColumn, parts = parts), allCols), - ldReference = dict$keys + combined, + !!!set_names(map(dicts, "keys"), keyCols) ) md <- exec( S4Vectors::DataFrame, - !!!c(combined, list(check.names = FALSE)) + !!!c(map(combined, .rbindAsDataFrameColumn), list(check.names = FALSE)) ) # Joining the parts merges each part's seqinfo, so a part whose elements # never had a build set would leave the result carrying both the real @@ -1172,7 +1194,26 @@ # seqinfo single-valued, which validity requires. built <- .withGenomeBuild(.rtlJoinParts(parts), !is.null(genome), genome) grl <- .rtlNamed(S4Vectors::`mcols<-`(built, value = md)) - exec(methods::new, cls, grl, !!!c(list(ldReference = dict$refs), slots)) + exec( + methods::new, + cls, + .rtlStored(cls, grl), + !!!c(map(dicts, "entries"), slots) + ) +} + +# @noRd +#' @importFrom purrr map2_chr +.dictKeyColOf <- function(dict, slot) { + dict$keyCol %||% slot +} + +# A bound column as DataFrame() takes it: a bare list (a cTWAS run's tables, +# an H2Estimate's enrichment tables) as one list column, which DataFrame() +# would otherwise refuse or spread into columns. +# @noRd +.rbindAsDataFrameColumn <- function(v) { + if (is.list(v) && !is.object(v)) I(v) else v } # Concatenate column `cn` across all parts (NA-filling parts that lack it). @@ -1214,8 +1255,11 @@ } else { .fmrGatherVariants(x, idx) }, - susieFit = md$susieFit[[first]], - cvResult = md$cvResult[[first]], + susieFit = .fitEntry(md$susieFit[[first]], x), + cvResult = .cvJoinPartition( + md$cvResult[[first]], + .mdCvPartition(x, md, first) + ), derivedColumns = .mdDerivedColumns(md, idx) ) } @@ -1294,7 +1338,7 @@ # row holding all of its fit, so no id is rendered. # @noRd .fmrRowDerivedColumns <- function(i, x, record) { - fit <- mcols(x, use.names = FALSE)$susieFit[[i]] + fit <- .fitEntry(mcols(x, use.names = FALSE)$susieFit[[i]], x) pip <- if (is.list(fit)) fit[["pip"]] if (!is.numeric(pip)) { return(NULL) @@ -1321,18 +1365,6 @@ .fmRowRestoredVariants(.fmrRowParts(x, i)) } -# The variants the fits of TWAS rows `idx` were made with, in their order: -# the first row's, as the fit payload is, since rows split from one entry -# repeat both. None for a collection saved before rows recorded them. -# @noRd -.mdFitVariants <- function(md, idx) { - fv <- md$fitVariants - if (is.null(fv)) { - return(character(0)) - } - as.character(fv[[idx[[1L]]]]) -} - # @noRd .fmrPartsVariantIds <- function(parts) { variantIds(.asFmRowPayload(parts)) @@ -1497,23 +1529,22 @@ list(variantIds = vids[ok], weights = w[ok]) } -# The stored payload of one TwasWeights row. Mirrors .fmrRowParts: weights are -# the element's inner mcols, the rest is outer mcols. +# The payload of method `method` of TwasWeights row `idx` (a TwasWeightsRow, +# .twrCellParts()). A row holding a single method needs none named. # @noRd -.twrRowParts <- function(x, idx) { - md <- mcols(x, use.names = FALSE) - first <- idx[[1L]] - gr <- .rtlGatherElements(x, idx) - new( - "TwasWeightsRow", - variants = gr, - weights = mcols(gr, use.names = FALSE)$weight, - methodFits = md$fits[[first]], - cvResult = md$cvResult[[first]], - weightStandardized = isTRUE(md$standardized[[first]]), - weightsDataType = md$dataType[[first]], - fitVariants = .mdFitVariants(md, idx) - ) +.twrRowParts <- function(x, idx, method = NULL) { + row <- idx[[1L]] + methods <- as.character(mcols(x, use.names = FALSE)$methods[[row]]) + if (is.null(method)) { + if (length(methods) != 1L) { + abort(glue( + "TwasWeights row {row} holds {length(methods)} methods; name ", + "the one to read." + )) + } + method <- methods + } + .twrCellParts(x, row, method) } # @noRd @@ -1522,7 +1553,8 @@ } # The weight vector aligned to the row's variant ids -- what resolveWeights -# produced from a TwasWeightsRow. +# produced from a TwasWeightsRow. A weight matrix (variants x K) keeps its +# columns. # @noRd .twrRowResolveWeights <- function(parts) { empty <- list(variantIds = character(0), weights = numeric(0)) @@ -1531,6 +1563,9 @@ if (length(vids) == 0L || is.null(raw)) { return(empty) } + if (is.matrix(raw)) { + return(.twrResolveMatrix(vids, raw, empty)) + } w <- as.numeric(raw) if (length(w) != length(vids)) { return(empty) @@ -1542,6 +1577,23 @@ list(variantIds = vids[ok], weights = w[ok]) } +# A weight matrix's rows aligned to the variant ids, its columns kept; a row +# with a missing id or weight is dropped. +# @noRd +.twrResolveMatrix <- function(vids, raw, empty) { + if (nrow(raw) != length(vids)) { + return(empty) + } + ok <- !is.na(vids) & rowSums(is.na(raw)) == 0L + if (!any(ok)) { + return(empty) + } + list( + variantIds = vids[ok], + weights = `rownames<-`(raw[ok, , drop = FALSE], NULL) + ) +} + # ---- fit coverage ------------------------------------------------------------ # A row keeps the fit it was built with when its variants are narrowed (to # those a GWAS also carries, say). The fit, and everything read off it, still @@ -1723,10 +1775,12 @@ rep(starts[ks], counts[ks]) + sequence(counts[ks]) } -# The fits of rows `idx` of a fine-mapping collection, as a list. +# The fits of rows `idx` of a fine-mapping collection, as a list, from the +# fits dictionary its rows key into. # @noRd .fmrFitsAt <- function(x, idx) { - as.list(mcols(x, use.names = FALSE)$susieFit[idx]) + keys <- as.list(mcols(x, use.names = FALSE)$susieFit[idx]) + map(keys, .fitEntry, x = x) } # @noRd @@ -1843,39 +1897,48 @@ # The labels of the rows of `x` that hold fewer variants than their stored # fit was made with: for fine-mapping rows, those shorter than their fit, -# which needs no ids; for TWAS rows, those missing some of the variants they -# recorded. None when `x` has no fits to compare, or is not a collection at -# all: an optional input left NULL, or one the caller has yet to validate, -# which this advisory check must not pre-empt. +# which needs no ids; for TWAS weights, the (gene, method) cells missing some +# of the variants their fits name. None when `x` has no fits to compare, or +# is not a collection at all: an optional input left NULL, or one the caller +# has yet to validate, which this advisory check must not pre-empt. # @noRd .narrowedRowLabels <- function(x) { if (!methods::is(x, "RangedTupleList") || length(x) == 0L) { return(character(0)) } + if (methods::is(x, "TwasWeights")) { + return(.twasNarrowedCellLabels(x)) + } md <- mcols(x, use.names = FALSE) - if (.isFineMappingPayload(x)) { - if (is.null(md$susieFit)) { - return(character(0)) - } - width <- map_int(as.list(md$susieFit), .fitWidth) - short <- which(!is.na(width) & lengths(x) < width) - } else { - fv <- md$fitVariants - if (is.null(fv)) { - return(character(0)) - } - lost <- map_int(seq_along(x), .rowLostFitVariants, x = x, fv = fv) - short <- which(lost > 0L) + if (!.isFineMappingPayload(x) || is.null(md$susieFit)) { + return(character(0)) } + width <- map_int(.fmrFitsAt(x, seq_along(x)), .fitWidth) + short <- which(!is.na(width) & lengths(x) < width) if (length(short) == 0L) { return(character(0)) } .pubRowLabels(x, short) } +# The labels of the cells of TWAS weights `x` whose method holds fewer +# variants than its stored fit names (.twasFitVariantIds()). +# @noRd +#' @importFrom purrr map2_int +.twasNarrowedCellLabels <- function(x) { + cells <- .twasCells(x) + lost <- map2_int(cells$row, cells$method, .twasCellLostFitVariants, x = x) + short <- cells[lost > 0L, ] + str_c(short$study, "|", short$context, "|", short$trait, "|", short$method) +} + # @noRd -.rowLostFitVariants <- function(i, x, fv) { - .lostFitVariantCount(as.character(fv[[i]]), .grVariantIds(x[[i]])) +.twasCellLostFitVariants <- function(row, method, x) { + parts <- .twrCellParts(x, row, method) + .lostFitVariantCount( + .twasFitVariantIds(methodFits(parts)), + .grVariantIds(variants(parts)) + ) } # `expr` with its fit-coverage warnings muffled, for a caller that has @@ -1924,6 +1987,20 @@ .fmrRowResolveWeights(parts) } +# Resolved `weights` as one weight per variant: a vector as it is, a +# one-column matrix its column; NULL for a matrix of several columns (one per +# feature or outcome), which gives no single weight per variant. +# @noRd +.singleWeightColumn <- function(weights) { + if (!is.matrix(weights)) { + return(weights) + } + if (ncol(weights) != 1L) { + return(NULL) + } + weights[, 1L] +} + # The cross-validated / per-method fits of one row, or NULL for a # fine-mapping row. # @@ -2027,19 +2104,6 @@ variantIds(e) } -# The non-variant half of each TWAS row payload, as outer mcols columns. -# Objects of arbitrary shape (fits, cvResult, dataType) ride in SimpleLists. -# @noRd -.twRowPayloadCols <- function(entry) { - list( - fits = S4Vectors::SimpleList(map(entry, methodFits)), - cvResult = S4Vectors::SimpleList(map(entry, cvResult)), - standardized = map_lgl(entry, .twPayloadStandardized), - dataType = S4Vectors::SimpleList(map(entry, weightsDataType)), - fitVariants = IRanges::CharacterList(map(entry, .twRowFitVariants)) - ) -} - # ============================================================================= # Combining summary-statistics collections # ----------------------------------------------------------------------------- @@ -2079,14 +2143,18 @@ invisible(NULL) } -# The collection-level slots BEYOND ldReference that a combine has to merge, for -# whatever concrete class `parts` are. A slot describes the whole collection, +# The collection-level slots BEYOND the row dictionaries (ldReference, +# cvPartition) that a combine has to merge, for whatever concrete class `parts` +# are. A slot describes the whole collection, # so first-wins would silently drop the other parts' state; each gets its own # rule and an unrecognised slot is an error rather than a quiet default, so # adding one to a class cannot slip through a combine unnoticed. # @noRd .rtlExtraSlots <- function(parts, fn) { - own <- setdiff(.rtlOwnSlots(parts[[1L]]), "ldReference") + own <- setdiff( + .rtlOwnSlots(parts[[1L]]), + c("ldReference", "cvPartition", "fits") + ) # discard(is.null), not compact(): parts no QC has run on merge to an # empty qcOptions, which is a merged value -- compact() would drop it and # report the slot as having no merge rule. @@ -2216,6 +2284,222 @@ identical(qcOptions(x)$options, first) } +# ----------------------------------------------------------------------------- +# Row dictionaries +# ----------------------------------------------------------------------------- +# A value several rows of a collection share -- an LD reference, a joint fit, +# a cross-validation fold partition -- is kept ONCE, in a named list in a +# collection-level slot, and every row names its entry in an mcols column (NA +# for a row with none). The key travels with the rows on subsetting as every +# per-row value does, and a bind re-keys the rows into one combined list, so +# no row holds its own copy. A dictionary is described by a spec: a list of +# the slot, the key column, and the prefix its entry names are numbered +# after. + +# Each distinct value among `perRow` once, named 1, 2, ... in +# order of first use, and every row's key into them (NA for a NULL row). +# @noRd +.dictBuild <- function(perRow, prefix) { + present <- which(!map_lgl(perRow, is.null)) + ids <- .dictIdentities(perRow[present]) + firstIdx <- which(!duplicated(ids)) + names <- str_c(prefix, seq_along(firstIdx)) + keys <- replace( + rep(NA_character_, length(perRow)), + present, + names[match(ids, ids[firstIdx])] + ) + entries <- if (length(firstIdx) == 0L) { + list() + } else { + set_names(perRow[present[firstIdx]], names) + } + list(entries = entries, keys = keys) +} + +# A content identity per value, so equal values -- the same object handed to +# every row, or two equal copies -- collapse to one entry. Hashed once per +# distinct object rather than per row: a large value shared by every row is +# read once, not once per row. +# @noRd +#' @importFrom rlang hash obj_address +.dictIdentities <- function(values) { + if (length(values) == 0L) { + return(character(0)) + } + addresses <- map_chr(values, obj_address) + firstOfAddress <- !duplicated(addresses) + hashes <- map_chr(values[firstOfAddress], hash) + hashes[match(addresses, addresses[firstOfAddress])] +} + +# Each row's key into dictionary `spec` (NA for a row with no entry); for a +# key column holding several keys a row, as TWAS weights hold one per method, +# every key. +# @noRd +.dictKeys <- function(x, spec) { + keys <- mcols(x, use.names = FALSE)[[spec$keyCol]] + if (is.null(keys)) { + return(rep(NA_character_, length(x))) + } + if (methods::is(keys, "List")) { + return(unlist(keys, use.names = FALSE)) + } + keys +} + +# The entries of `entries` some key in `keys` names: what a collection +# reports, so a subset does not report the entries its rows left behind. +# @noRd +.dictUsed <- function(entries, keys) { + used <- entries[is_in(names(entries), keys)] + if (length(used) == 0L) list() else used +} + +# The entry `key` names in `entries`, NULL for a row with none (NA). +# @noRd +.dictEntryFor <- function(key, entries) { + if (is.na(key)) NULL else entries[[key]] +} + +# `x` with dictionary `spec` rebuilt from `perRow`, one value (or NULL) per +# row. The slot is written first and the keys second, so the object is only +# validated once the two agree. +# @noRd +#' @importFrom methods slot<- +.withRowDict <- function(x, spec, perRow) { + dict <- .dictBuild(perRow, spec$prefix) + md <- mcols(x, use.names = FALSE) + md[[spec$keyCol]] <- dict$keys + methods::slot(x, spec$slot, check = FALSE) <- dict$entries + S4Vectors::`mcols<-`(x, value = md) +} + +# What is wrong with a dictionary's entries and the keys pointing into them, +# or NULL. An entry's name is what a key points at, so an unnamed, blank or +# repeated one leaves a row pointing at nothing, or at two entries. +# @noRd +.dictProblems <- function(entries, keys, slot, what) { + .dictNameProblem(entries, slot) %||% + .dictKeyProblem(entries, keys, slot, what) +} + +# @noRd +.dictNameProblem <- function(entries, slot) { + if (length(entries) == 0L) { + return(NULL) + } + nms <- names(entries) + if ( + is.null(nms) || anyNA(nms) || any(nms == "") || anyDuplicated(nms) > 0L + ) { + return(str_c(slot, " entries must have unique, non-empty names")) + } + NULL +} + +# @noRd +.dictKeyProblem <- function(entries, keys, slot, what) { + unknown <- setdiff(keys[!is.na(keys)], names(entries)) + if (length(unknown) == 0L) { + return(NULL) + } + str_c( + "rows name ", + what, + " not in ", + slot, + ": ", + str_flatten(unknown, ", ") + ) +} + +# ----------------------------------------------------------------------------- +# Fits in a collection +# ----------------------------------------------------------------------------- +# A collection keeps every fit its rows hold once per distinct value, in its +# `fits` dictionary, and each row names its entry: a fine-mapping row in its +# `susieFit` column, a TWAS row per method in `fits` (the full-data fit) and +# `foldFits` (its cross-validation's per-fold fits). The rows of a joint fit +# hold the same fit, so it is stored once rather than once per condition. + +# @noRd +.FIT_DICT_PREFIX <- "fit" + +# A collection's fits; none for one saved before the slot existed, whose +# rows still hold their own. +# @noRd +.fitDict <- function(x) { + if (!methods::.hasSlot(x, "fits")) { + return(list()) + } + x@fits +} + +# The fit `key` names in `x`'s dictionary, NULL for a row with none (NA). +# @noRd +.fitEntry <- function(key, x) { + .dictEntryFor(key, .fitDict(x)) +} + +# What is wrong with a collection's fits and the keys its columns `keyCols` +# hold into them, or NULL. +# @noRd +.fitProblems <- function(x, keyCols) { + keys <- list_c(c( + list(character(0)), + map(keyCols, .fitKeysIn, x = x) + )) + .dictProblems(.fitDict(x), keys, "fits", "fit(s)") +} + +# @noRd +.fitKeysIn <- function(keyCol, x) { + .fitKeysOfColumn(keyCol, mcols(x, use.names = FALSE)) +} + +# The keys column `keyCol` of mcols `md` holds. A column holding fits rather +# than keys -- a collection saved before rows shared them, which +# updateObject() folds -- holds none. +# @noRd +.fitKeysOfColumn <- function(keyCol, md) { + col <- md[[keyCol]] + if (methods::is(col, "CharacterList")) { + return(unlist(col, use.names = FALSE)) + } + if (is.character(col)) col else character(0) +} + +# The entries of a fits dictionary `entries` the rows with mcols `md` name: +# what a subset keeps, so it holds its own rows' fits and not every row's. +# @noRd +.fitsInUse <- function(entries, md) { + if (length(entries) == 0L || is.null(md)) { + return(entries) + } + keyCols <- intersect(c("susieFit", "fits", "foldFits"), colnames(md)) + keys <- list_c(c( + list(character(0)), + map(keyCols, .fitKeysOfColumn, md = md) + )) + .dictUsed(entries, keys) +} + +# The fits dictionary of fine-mapping collections `parts`, row-bound: each +# row keeps the fit it had, and equal fits are stored once. +# @noRd +.fmrFitCombine <- function(parts) { + perRow <- list_flatten(map(parts, .fmrRowFits)) + c(.dictBuild(perRow, .FIT_DICT_PREFIX), list(keyCol = "susieFit")) +} + +# Every row's fit, NULL for a row with none. +# @noRd +.fmrRowFits <- function(x) { + keys <- as.character(mcols(x, use.names = FALSE)$susieFit) + map(keys, .fitEntry, x = x) +} + # The LD references of `parts`, row-bound: each row keeps the reference it # had, and a reference that is a view of another is stored as that one # (.ldRefMergeViews()). `override`, when given, is every row's reference @@ -2242,7 +2526,7 @@ # first row's reference. # @noRd .ldRefMergeViews <- function(dict, fn) { - refs <- dict$refs + refs <- dict$entries if (length(refs) <= 1L) { return(dict) } @@ -2264,7 +2548,7 @@ ) keys <- str_c("ld", seq_along(merged)) list( - refs = set_names(merged, keys), + entries = set_names(merged, keys), keys = keys[group[match(dict$keys, names(refs))]] ) } @@ -2319,58 +2603,78 @@ } # One panel standing for `panels`, which read the same files over the same -# samples: a handle union keeps the first handle and widens its snpInfo, each -# row's `fileIdx` addressing a position in THAT file, and a panel union binds -# the parts over the first one's samples. +# samples: their rows, each once, in genomic order, over the first panel's +# samples. A variant is told by the id rendered from its position and +# alleles, as file labels need not be unique. Parts that hold the same +# variants union to the first. # @noRd .unionPanelRefs <- function(panels, fn) { + panels <- map(panels, .ssAsPanel) chromPaths <- .ssUnionChromPaths(panels, fn) + ranges <- map(panels, SummarizedExperiment::rowRanges) + ids <- map(ranges, .grVariantIds) + if (all(map_lgl(ids, identical, ids[[1L]]))) { + return(panels[[1L]]) + } + rr <- .bindPanelRanges(ranges) + kept <- which(!duplicated(list_c(ids))) + ord <- kept[order(as.character(seqnames(rr)[kept]), start(rr)[kept])] + first <- panels[[1L]] + md <- S4Vectors::metadata(first) + if (!is.null(md$genotypeSource)) { + md$genotypeSource$chromPaths <- chromPaths + } + SummarizedExperiment::SummarizedExperiment( + assays = list(dosage = .ssUnionDosage(panels, ord, chromPaths)), + rowRanges = rr[ord], + colData = SummarizedExperiment::colData(first), + metadata = md + ) +} + +# A bare GenotypeHandle, which an LD reference was before it was a panel, +# as the panel over it; a panel as it is. +# @noRd +.ssAsPanel <- function(x) { + if (methods::is(x, "GenotypeHandle")) .asLdRef(x) else x +} + +# The dosages of a union: rows `ord` of the parts' rows in turn, over the +# first part's samples. Parts that each read through a handle are read +# through one, the first handle with a variant table of those rows' reading +# columns (each `fileIdx` addresses a position in THAT file). Other parts -- +# a VCF, GDS or PLINK1 panel, or a per-chromosome set of them -- have their +# assays bound, not read. +# @noRd +.ssUnionDosage <- function(panels, ord, chromPaths) { handles <- map(panels, .ldRefHandle) - if (any(map_lgl(handles, is.null))) { - return(.ssUnionPanels(panels, chromPaths)) + seedRows <- map(panels, .panelSeedRows) + if ( + !all(map_lgl(handles, .ssRowsAddressFile)) || + any(map_lgl(seedRows, is.null)) + ) { + bound <- exec(BiocGenerics::rbind, !!!unname(map(panels, .seDosage))) + return(bound[ord, , drop = FALSE]) } handle <- methods::initialize( handles[[1L]], - snpInfo = .ssUnionSnpInfo(handles), + snpInfo = list_rbind(map2(handles, seedRows, .ssReadRows))[ord, ], chromPaths = chromPaths ) - .asLdRef(handle) + genotypeDelayedArray(handle)[, colnames(panels[[1L]]), drop = FALSE] } -# The union of panels from one source that read through no handle -- a VCF, -# GDS or PLINK1 panel, or a per-chromosome set of them: their rows, each -# once, in genomic order, over the first panel's samples. The parts' assays -# are bound, not read. Parts that are all the same panel union to it. +# TRUE for a handle whose variant table records each variant's position in +# its file, so its rows can be moved into another handle's table. # @noRd -.ssUnionPanels <- function(panels, chromPaths) { - first <- panels[[1L]] - if (all(map_lgl(map(panels, rownames), identical, rownames(first)))) { - return(first) - } - rr <- suppressWarnings( - exec(c, !!!unname(map(panels, SummarizedExperiment::rowRanges))) - ) - stacked <- SummarizedExperiment::SummarizedExperiment( - assays = list( - dosage = exec( - BiocGenerics::rbind, - !!!unname(map(panels, .seDosage)) - ) - ), - rowRanges = rr, - colData = SummarizedExperiment::colData(first), - metadata = S4Vectors::metadata(first) - ) - kept <- which(!duplicated(names(rr))) - ord <- kept[order( - as.character(seqnames(rr)[kept]), - start(rr)[kept] - )] - md <- S4Vectors::metadata(stacked) - if (!is.null(md$genotypeSource)) { - md$genotypeSource$chromPaths <- chromPaths - } - S4Vectors::`metadata<-`(stacked[ord, ], value = md) +.ssRowsAddressFile <- function(handle) { + !is.null(handle) && is_in("fileIdx", names(snpInfo(handle))) +} + +# Rows `rows` of a handle's variant table. +# @noRd +.ssReadRows <- function(handle, rows) { + as_tibble(slice(snpInfo(handle), rows)) } # TRUE when every variant of `x` is in `by`, coded the same way. @@ -2455,29 +2759,3 @@ .ssSampleIds <- function(x) { if (methods::is(x, "GenotypeHandle")) sampleIds(x) else colnames(x) } - -# The parts' snpInfo rows, de-duplicated by variant id and returned in genomic -# order so the unioned panel reads like one built over the whole span. The -# first handle's data-frame class is preserved: a handle built with a base -# data.frame keeps one, because some downstream readers index snpInfo -# positionally and a tibble column is a one-column list there. -# @noRd -.ssUnionSnpInfo <- function(handles) { - 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) { - deduped <- combined[!duplicated(combined$SNP), , drop = FALSE] - deduped[ - order(deduped$CHR, as.integer(deduped$BP)), - , - drop = FALSE - ] - } else { - combined - } - if (inherits(first, "tbl_df")) si else as.data.frame(si) -} - -# @noRd -.ssHandleSnpInfo <- function(h) as_tibble(snpInfo(h)) diff --git a/R/twasWeights.R b/R/twasWeights.R index 4a43c4d2e..3968aeeb0 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -23,10 +23,11 @@ # ============================================================================= # TwasWeights S4 class # ----------------------------------------------------------------------------- -# RangedTupleList collection keyed by the identity tuple (study, context, -# trait, method). Each element is one row's variants, with their weights as -# its `weight` mcols column; the fits, cross-validation and scale are columns -# of the collection's own mcols. Class-level slots: +# RangedTupleList collection keyed by (study, context, trait[, joint*]): one +# row per gene, holding every method fitted for it (see "Per-gene rows" +# below). Each element is the union of the row's methods' variants; the +# weights, fits, cross-validation and scale are columns of the collection's +# own mcols, kept per method. Class-level slots: # * ldReference the LD references RSS-derived weights used, each stored # once; the ldReference mcols column names each row's (NA # for weights learned from individual-level data). @@ -39,45 +40,62 @@ NULL #' @title TWAS Weights Collection #' @description S4 collection of TWAS weights, one row per -#' \code{(study, context, trait, method)}: one method's weights for one -#' trait, context and study. Each element is a row's variants: a -#' \code{GRanges} whose \code{weight} column holds the weights. +#' \code{(study, context, trait)} -- a gene -- holding the weights of every +#' method fitted for it. Each element is the union of the row's methods' +#' variants; a method fitted on fewer of them, or in another order, keeps +#' its own. The weights form a variants x methods x weight-column tensor, +#' stored dense for the methods most of whose weights are nonzero and +#' sparse for the rest. One method of one gene is what a +#' \code{\link{TwasWeightsRow}} holds: the constructor takes one per +#' \code{(study, context, trait, method)}, and the accessors select one by +#' \code{method}. #' -#' Required \code{mcols()} columns: the identity tuple \code{study}, -#' \code{context}, \code{trait} and \code{method}, and each row's payload: -#' its stored fits (\code{fits}), \code{cvResult}, \code{standardized} and -#' \code{dataType}. The constructor also records \code{fitVariants}, the -#' variants the weights were fitted on. +#' Required \code{mcols()} columns: the identity \code{study}, +#' \code{context} and \code{trait}, and each row's \code{methods} with +#' their weights (\code{weightTensor}), fits (\code{fits}, and the +#' per-fold fits of their cross-validation in \code{foldFits}), +#' \code{cvResult}, \code{standardized} and \code{dataType}. #' #' Optional columns \code{jointStudies}, \code{jointContexts}, -#' \code{jointTraits} appear when the collection contains rows produced by a -#' \code{jointSpecification}-driven joint fit. For such a row, the corresponding -#' identity-tuple column carries the sentinel \code{"joint"} and the joint -#' column lists the semicolon-joined members of the joined axis. For non-joint -#' rows the joint columns are \code{NA_character_}. Tuple uniqueness is enforced -#' jointly across the identity-tuple columns and any present joint columns. +#' \code{jointTraits} appear when the collection holds weights from a +#' \code{jointSpecification}-driven joint fit: they list the semicolon-joined +#' members of the joined axis, \code{NA_character_} for a row from no joint +#' fit. A row is unique on its identity together with any joint columns, so +#' one gene's weights from a joint fit and from fits of its own are two rows. #' @slot ldReference A named list of the LD references the weights were #' derived against, each a genotype panel, a \code{GenotypeMixture} or an #' \code{LdMatrix}, stored once apiece; the \code{ldReference} column of #' \code{mcols} names the entry each row used (\code{NA} for weights #' learned from individual-level data). Used downstream to check that the #' rows a pipeline combines share an LD reference. -#' @section Narrowed rows: Each row records in its \code{fitVariants} column -#' the ids of the variants its weights were fitted on (none for a row -#' without a fit payload). A row narrowed since keeps its fits as they -#' were, so \code{cvResult()} and \code{methodFits()} warn, with condition -#' class \code{pecotmrFitCoverage}, when a row holds fewer variants than -#' they describe. So do the pipelines that read them: +#' @slot cvPartition A named list of the cross-validation fold partitions the +#' rows' results share, each with the order of the samples its out-of-fold +#' predictions are held for, stored once apiece; the \code{cvPartition} +#' column of \code{mcols} names the entry each row's result used +#' (\code{NA} for a row without one). \code{cvResult()} returns a row's +#' result with its partition and sample names in place. +#' @slot fits A named list of the methods' fits, and of the per-fold fits +#' of their cross-validation, stored once apiece: the rows of a joint fit +#' all name one entry. The \code{fits} and \code{foldFits} columns of +#' \code{mcols} name each method's entries (\code{NA} for none); +#' \code{methodFits()} and \code{cvResult()} return them in place. +#' @section Narrowed rows: A row's stored fit names the variants its weights +#' were fitted on, where its engine keeps them or in a \code{variantIds} +#' element. A row narrowed since keeps its fits as they were, so +#' \code{cvResult()} and \code{methodFits()} warn, with condition class +#' \code{pecotmrFitCoverage}, when a row holds fewer variants than they +#' describe. So do the pipelines that read them: #' \code{causalInferencePipeline()} when it selects weights by their #' cross-validation, and \code{ctwasPipeline()} for rows whose SuSiE fit #' renormalizes their weights. The weights themselves are narrowed with -#' the row and do not warn. +#' the row and do not warn, and a row kept without a fit +#' (\code{fitRetention = "none"}) has nothing to compare them with. #' @export setClass( "TwasWeights", contains = "RangedTupleList", - representation(ldReference = "list"), - prototype(ldReference = list()), + representation(ldReference = "list", cvPartition = "list", fits = "list"), + prototype(ldReference = list(), cvPartition = list(), fits = list()), validity = function(object) .validateTwasWeights(object) ) @@ -90,7 +108,7 @@ setClass( coll <- makeAssertCollection() assertNames( .tupleColumnNames(object), - must.include = c("study", "context", "trait", "method"), + must.include = c("study", "context", "trait"), what = "colnames", .var.name = "mcols", add = coll @@ -117,16 +135,42 @@ setClass( .validateRegionColumn(object), .twasValidateJointCols(object, jointCols), .twasValidateKeyUniqueness(object, jointCols), - .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) + .twasValidateMethods(object), + .ldRefDictProblems(object@ldReference, .ldRefKeys(object)), + .cvPartitionProblems(object), + .fitProblems(object, c("fits", "foldFits")) ) } +# A row holds each of its methods once. +# @noRd +.twasValidateMethods <- function(object) { + methods <- map(as.list(.tupleColumn(object, "methods")), as.character) + if (any(map_lgl(methods, .twasHasDuplicate))) { + return("a row holds one set of weights per method") + } + character() +} + +# @noRd +.twasHasDuplicate <- function(v) { + anyDuplicated(v) > 0L +} + # The per-entry payload columns. The variants and their weights are the # elements now, so what is left to check is that the payload columns are # present and parallel to them. # @noRd .twasValidateEntries <- function(object) { - payload <- c("fits", "cvResult", "standardized", "dataType") + payload <- c( + "methods", + "weightTensor", + "fits", + "foldFits", + "cvResult", + "standardized", + "dataType" + ) missingCols <- setdiff(payload, .tupleColumnNames(object)) if (length(missingCols) > 0L) { return(str_c( @@ -144,10 +188,10 @@ setClass( map_chr(bad, .twasBadColMsg, object = object) } -# (study, context, trait, method[, joint*]) tuple uniqueness. +# (study, context, trait[, joint*]) uniqueness: one row per gene. # @noRd .twasValidateKeyUniqueness <- function(object, jointCols) { - keyCols <- c("study", "context", "trait", "method", jointCols) + keyCols <- c("study", "context", "trait", jointCols) # Read column by column: `[` takes no column index on a collection. keyTbl <- as_tibble(set_names( map(keyCols, .twasColumn, object = object), @@ -155,8 +199,8 @@ setClass( )) if (nrow(distinct(keyTbl)) < nrow(keyTbl)) { str_c( - "(study, context, trait, method[, joint*]) tuple uniqueness ", - "violated" + "(study, context, trait[, joint*]) uniqueness violated: one row ", + "per gene" ) } else { character() @@ -166,37 +210,40 @@ setClass( # ============================================================================= #' @title Create a TwasWeights Collection Object -#' @description Construct a \code{TwasWeights} collection from per-tuple -#' vectors and a list of \code{TwasWeightsRow} payloads (one per tuple). -#' @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. -#' @param trait Character vector of trait identifiers. Use \code{"joint"} for -#' rows produced by a cross-trait joint fit. -#' @param method Character vector of TWAS weight method names. +#' @description Construct a \code{TwasWeights} collection from per-entry +#' vectors and a list of \code{TwasWeightsRow} payloads, one per (study, +#' context, trait, method) entry. The entries of one gene -- one (study, +#' context, trait) and joint group -- become one row, its methods an axis. +#' @param studyName Character vector of study identifiers. A joint fit's +#' entries keep their own study, context and trait, and record the group in +#' \code{jointStudies}, \code{jointContexts} or \code{jointTraits}. +#' @param context Character vector of context labels. +#' @param trait Character vector of trait identifiers. +#' @param method Character vector of TWAS weight method names. A snake_case +#' name is stored as its camelCase token (\code{susie_inf} as +#' \code{susieInf}); a gene holds one entry per method. #' @param entry List / \code{SimpleList} of \code{TwasWeightsRow} objects. -#' @param jointStudies Optional character vector (length \code{length(study)}) -#' listing the semicolon-joined studies participating in each row's -#' cross-study joint fit, or \code{NA_character_} for non-joint rows. When -#' \code{NULL} (default) the column is omitted. +#' @param jointStudies Optional character vector (one per entry) listing the +#' semicolon-joined studies participating in each entry's cross-study joint +#' fit, or \code{NA_character_} for non-joint entries. When \code{NULL} +#' (default) the column is omitted. #' @param jointContexts Optional character vector for cross-context joints. Same #' shape as \code{jointStudies}. #' @param jointTraits Optional character vector for cross-trait joints. Same #' shape as \code{jointStudies}. #' @param ldReference The LD reference the weights were derived against -- #' a genotype panel (see \code{\link{readGenotypes}}), a -#' \code{GenotypeMixture} or an \code{LdMatrix} -- used for every row, or -#' a list with one per row; \code{NULL} for individual-level fits. Each -#' distinct reference is stored once. -#' @param traitPos Optional per-row trait genomic anchor (a \code{GRanges} or -#' \code{NULL}), carried forward as provenance; not part of the identity key. -#' \code{NULL} (default) omits the column. -#' @param region Optional per-row analysis WINDOW (a \code{GRanges} or -#' \code{NULL}) -- the interval each row's fit was run over, carried -#' forward as provenance; not part of the identity key. \code{NULL} -#' (default) omits the column, and \code{\link{genomicRegion}} then -#' derives the window from the span of the variants present. +#' \code{GenotypeMixture} or an \code{LdMatrix} -- used for every entry, +#' or a list with one per entry; \code{NULL} for individual-level fits. +#' Each distinct reference is stored once, and a gene's methods share one. +#' @param traitPos Optional per-entry trait genomic anchor (a \code{GRanges} +#' or \code{NULL}), carried forward as provenance; not part of the +#' identity key. \code{NULL} (default) omits the column. +#' @param region Optional per-entry analysis WINDOW (a \code{GRanges} or +#' \code{NULL}) -- the interval each fit was run over, carried forward as +#' provenance; not part of the identity key. A gene's methods share one. +#' \code{NULL} (default) omits the column, and \code{\link{genomicRegion}} +#' then derives the window from the span of the variants present. #' @param metadata A list of free-form metadata about the collection, #' as \code{metadata()} holds on any Bioconductor vector. Default #' \code{list()}. @@ -238,23 +285,25 @@ TwasWeights <- function( n <- .twasCheckRowLengths(studyName, context, trait, method, entry) entry <- map(entry, .asTwRowPayload) .checkRowPayloads(entry, "TwasWeightsRow", "TWAS-weight") - cols <- .twasMetadataCols( - studyName, - context, - trait, - method, - entry, - jointStudies, - jointContexts, - jointTraits, - traitPos, - region, - n - ) - .withMetadata( - .rtlNewValidated("TwasWeights", entry, cols, ldReference), - metadata + cells <- list( + keys = .twasCellKeys( + studyName, + context, + trait, + list( + jointStudies = jointStudies, + jointContexts = jointContexts, + jointTraits = jointTraits + ), + n + ), + method = .twasMethodToken(as.character(method)), + entry = entry, + traitPos = .twasCheckedRanges(traitPos, n, "traitPos"), + region = .twasCheckedRanges(region, n, "region"), + ldRefs = .ldRefPerTuple(ldReference, n) ) + .withMetadata(.twasNewValidated(cells), metadata) } # The identity and joint-axis arguments, checked. Mirrors @@ -280,96 +329,1027 @@ TwasWeights <- function( checkClass(entry, "SimpleList"), .var.name = "entry" ) - assertCharacter(jointStudies, null.ok = TRUE) - assertCharacter(jointContexts, null.ok = TRUE) - assertCharacter(jointTraits, null.ok = TRUE) + assertCharacter(jointStudies, null.ok = TRUE) + assertCharacter(jointContexts, null.ok = TRUE) + assertCharacter(jointTraits, null.ok = TRUE) +} + +# Every cell's identity: study, context and trait, and the joint axes +# supplied (each one value per cell). +# @noRd +.twasCellKeys <- function(studyName, context, trait, joints, n) { + supplied <- compact(joints) + walk2(names(supplied), supplied, .twasCheckJointColLength, n = n) + as_tibble(c( + list( + study = as.character(studyName), + context = as.character(context), + trait = as.character(trait) + ), + map(supplied, as.character) + )) +} + +# A per-cell range argument (`traitPos`, `region`): NULL, or a GRanges with +# one range per cell. +# @noRd +.twasCheckedRanges <- function(gr, n, what) { + if (is.null(gr)) { + return(NULL) + } + if (!methods::is(gr, "GRanges")) { + abort(glue("`{what}` must be a GRanges (one range per row) or NULL.")) + } + if (length(gr) != n) { + abort(glue("`{what}` must have the same length as `study`.")) + } + gr +} + +# Require study/context/trait/method/entry to share one length; returns it. +# @noRd +.twasCheckRowLengths <- function(studyName, context, trait, method, entry) { + n <- length(studyName) + if ( + length(context) != n || + length(trait) != n || + length(method) != n || + length(entry) != n + ) { + msg <- glue( + "`studyName`, `context`, `trait`, `method`, and `entry` must all ", + "have the same length." + ) + abort(msg) + } + n +} + +# Each joint-provenance column must be one value per row. +# @noRd +.twasCheckJointColLength <- function(nm, val, n) { + if (length(val) == n) { + return(invisible(NULL)) + } + msg <- glue("`{nm}` must have the same length as `study`.") + abort(msg) +} + +# ============================================================================= +# Per-gene rows +# ----------------------------------------------------------------------------- +# A TwasWeights row is one (study, context, trait[, joint*]) -- a gene -- and +# holds every method fitted for it. Its element is the union of its methods' +# variants. Their weights form a variants x methods x K tensor, K being a +# method's weight columns (one for a weight vector), held in two parts: a +# dense array for the methods most of whose weights are nonzero, an +# SVT_SparseArray for the rest, each method placed by its measured density. A +# method fitted on other variants than the union, or in another order, +# records its own as positions in the union. Fits, cross-validation, scale +# and data type are kept per method. One method of one row -- a cell -- is +# what a TwasWeightsRow holds, what the constructor takes and what the +# accessors read (.twrCellParts()). +# ============================================================================= + +# Weight methods are named by their camelCase token (susieInf, bayesR), the +# one spelling a row's method axis holds; a snake_case label such as +# learnTwasWeights() derives from a method function (susie_inf) maps onto it. +# @noRd +.twasMethodToken <- function(method) { + str_replace_all(method, "_[a-z0-9]", .twasUpperTail) +} + +# @noRd +.twasUpperTail <- function(x) { + str_to_upper(str_sub(x, 2L)) +} + +# `expr`, without the warning SparseArray raises after its calls on builds +# linked to LLVM's libomp: it pauses the OpenMP runtime after every call, and +# libomp reports a pause of a runtime already paused as a failure. Nothing +# else is muffled. +# @noRd +.svtQuiet <- function(expr) { + withCallingHandlers(expr, warning = .svtMuffleOmpPause) +} + +# @noRd +.svtMuffleOmpPause <- function(w) { + if (str_detect(conditionMessage(w), "omp_pause_resource\\(\\) failed")) { + invokeRestart("muffleWarning") + } +} + +# ---- building rows from cells ------------------------------------------------ + +# The collection the cells `cells` build: one row per distinct identity, in +# order of first appearance. `cells` holds, one per cell, the identity +# (`keys`), the method, the TwasWeightsRow (`entry`), the trait position and +# region (GRanges, or NULL for none) and the LD reference (`ldRefs`). +# @noRd +.twasNewValidated <- function(cells) { + byRow <- unname(split( + seq_along(cells$method), + as.integer(vctrs::vec_group_id(cells$keys)) + )) + .twasRefuseRepeatedMethods(byRow, cells) + first <- map_int(byRow, .twasFirstCell) + stores <- map( + byRow, + .twasRowStore, + entries = cells$entry, + methods = cells$method + ) + .twasRefuseMultiChromosome(stores) + fitted <- .twasStoredFits( + map(cells$entry, methodFits), + map(cells$entry, cvResult) + ) + cv <- .cvStoredColumn(fitted$cv) + dict <- .ldRefDict(.twasRowLdRefs(cells$ldRefs, byRow, first)) + cols <- c( + .twasRowCols(cells, byRow, first, stores, cv, fitted), + list(ldReference = dict$keys, check.names = FALSE) + ) + grl <- S4Vectors::`mcols<-`( + .rtlBindElements(map(stores, "variants")), + value = exec(S4Vectors::DataFrame, !!!cols) + ) + new( + "TwasWeights", + .rtlNamed(grl), + ldReference = dict$entries, + cvPartition = cv$entries, + fits = fitted$entries + ) +} + +# The cells' fits `fits` and the per-fold fits of their CV `cvs` as the fits +# dictionary holds them, each distinct one once, with each cell's keys into +# it; and the cells' CV without the per-fold fits, which the dictionary now +# holds. +# @noRd +.twasStoredFits <- function(fits, cvs) { + folds <- map(cvs, .cvFoldFits) + dict <- .dictBuild(c(fits, folds), .FIT_DICT_PREFIX) + n <- length(fits) + list( + fits = dict$keys[seq_len(n)], + foldFits = dict$keys[n + seq_len(n)], + entries = dict$entries, + cv = map2(cvs, folds, .cvWithoutFoldFits) + ) +} + +# A CV payload's per-fold fits (mr.mash keeps them), NULL for none. +# @noRd +.cvFoldFits <- function(cv) { + if (is.list(cv) && !is.data.frame(cv)) cv[["foldFits"]] +} + +# @noRd +.cvWithoutFoldFits <- function(cv, folds) { + if (is.null(folds)) cv else list_assign(cv, foldFits = zap()) +} + +# @noRd +.twasFirstCell <- function(idx) { + idx[[1L]] +} + +# A gene holds one set of weights per method. +# @noRd +.twasRefuseRepeatedMethods <- function(byRow, cells) { + repeated <- keep(byRow, .twasHasRepeatedMethod, methods = cells$method) + if (length(repeated) == 0L) { + return(invisible(NULL)) + } + i <- repeated[[1L]][[1L]] + key <- str_flatten(discard(map_chr(cells$keys, i), is.na), "|") + abort(glue( + "TwasWeights: '{key}' has more than one set of weights for one ", + "method; a (study, context, trait, method[, joint*]) holds one." + )) +} + +# @noRd +.twasHasRepeatedMethod <- function(idx, methods) { + anyDuplicated(methods[idx]) > 0L +} + +# One gene's store: its methods' union of variants, their weights as a +# tensor, and their scale and data type by method. +# @noRd +.twasRowStore <- function(idx, entries, methods) { + rowEntries <- set_names(entries[idx], methods[idx]) + union <- .twasUnionVariants(rowEntries) + ids <- .grVariantIds(union) + placed <- map(rowEntries, .twasPlacedWeights, ids = ids) + list( + variants = union, + tensor = .twasTensor(placed, length(ids)), + standardized = map_lgl(rowEntries, weightStandardized), + dataType = map(rowEntries, weightsDataType) + ) +} + +# The variants of every method of a row, each once, in order of first +# appearance, carrying their identity columns only. +# @noRd +.twasUnionVariants <- function(rowEntries) { + grs <- map(unname(rowEntries), .twasIdentityVariants) + flat <- suppressWarnings(exec(c, !!!grs)) + flat[!duplicated(.grVariantIds(flat))] +} + +# @noRd +.twasIdentityVariants <- function(e) { + gr <- variants(e) + md <- mcols(gr, use.names = FALSE) + S4Vectors::`mcols<-`( + gr, + value = md[, colnames(md) != "weight", drop = FALSE] + ) +} + +# One method's weights on the row's variants `ids`: its own variants' rows +# filled and zero elsewhere, with what reading them back needs. `positions` +# is NULL when the method holds the row's variants in their order. +# @noRd +.twasPlacedWeights <- function(e, ids) { + own <- .grVariantIds(variants(e)) + hit <- match(own, ids) + w <- .unnamedWeights(weights(e)) + list( + w = if (is.null(w)) NULL else .twasFillRows(w, hit, length(ids)), + positions = if (identical(hit, seq_along(ids))) NULL else hit, + isMatrix = is.matrix(w), + columns = colnames(w) + ) +} + +# The row's methods' weights as a tensor in two parts, and where each method +# sits in it: `part` ("dense", "sparse", or "none" for a method without +# weights), `slice` along the method axis of that part, and `K`. +# @noRd +#' @importClassesFrom SparseArray SVT_SparseArray +.twasTensor <- function(placed, n) { + K <- map_int(placed, .twasPlacedK) + part <- rep("none", length(K)) + part[K > 0L] <- "sparse" + part[K > 0L & map_lgl(placed, .twasIsDense)] <- "dense" + slice <- integer(length(K)) + slice[part == "dense"] <- seq_len(sum(part == "dense")) + slice[part == "sparse"] <- seq_len(sum(part == "sparse")) + list( + dense = .twasPartArray(placed[part == "dense"], n), + sparse = .twasSparsePart(placed[part == "sparse"], n), + part = unname(part), + slice = unname(slice), + K = unname(K), + isMatrix = unname(map_lgl(placed, "isMatrix")), + columns = discard(map(placed, "columns"), is.null), + variants = discard(map(placed, "positions"), is.null) + ) +} + +# `w` (a vector or a variants x K matrix) as rows `hit` of an n x K matrix of +# zeros. +# @noRd +.twasFillRows <- function(w, hit, n) { + m <- if (is.matrix(w)) w else matrix(w, ncol = 1L) + full <- matrix(0, n, ncol(m)) + full[hit, ] <- m + full +} + +# @noRd +.twasPlacedK <- function(p) { + if (is.null(p$w)) 0L else ncol(p$w) +} + +# Dense when at least two thirds of the weights are nonzero: a stored +# nonzero costs about 12 bytes in an SVT_SparseArray, a dense one 8. +# @noRd +.twasIsDense <- function(p) { + nonzero <- sum(p$w != 0 | is.na(p$w)) + 3 * nonzero >= 2 * length(p$w) +} + +# The methods `placed` as one variants x methods x K array, K padded with +# zeros to the widest; NULL for none. +# @noRd +.twasPartArray <- function(placed, n) { + if (length(placed) == 0L) { + return(NULL) + } + K <- max(map_int(placed, .twasPlacedK)) + arr <- array(0, c(n, length(placed), K)) + for (j in seq_along(placed)) { + arr[, j, seq_len(ncol(placed[[j]]$w))] <- placed[[j]]$w + } + arr +} + +# @noRd +.twasSparsePart <- function(placed, n) { + arr <- .twasPartArray(placed, n) + if (is.null(arr)) { + return(NULL) + } + .svtQuiet(methods::as(arr, "SVT_SparseArray")) +} + +# Each row's LD reference: the one its cells share. A gene's methods were fit +# against one reference; cells on different ones are refused. +# @noRd +.twasRowLdRefs <- function(ldRefs, byRow, first) { + ids <- .dictIdentities(ldRefs) + ids[map_lgl(ldRefs, is.null)] <- NA_character_ + mixed <- keep(byRow, .twasRowDisagrees, values = ids) + if (length(mixed) > 0L) { + abort(glue( + "TwasWeights: the methods of one (study, context, trait) were fit ", + "against different LD references; a row holds one." + )) + } + ldRefs[first] +} + +# @noRd +.twasRowDisagrees <- function(idx, values) { + length(unique(values[idx])) > 1L +} + +# The outer columns of the rows `byRow` groups the cells into: the identity of +# each row's first cell, its methods and their payloads, and the trait +# position and region its cells share. +# @noRd +.twasRowCols <- function(cells, byRow, first, stores, cv, fitted) { + n <- length(byRow) + payload <- list( + methods = IRanges::CharacterList( + map(byRow, .twasPick, values = cells$method) + ), + weightTensor = S4Vectors::SimpleList(map(stores, "tensor")), + fits = IRanges::CharacterList( + map(byRow, .twasPick, values = fitted$fits) + ), + foldFits = IRanges::CharacterList( + map(byRow, .twasPick, values = fitted$foldFits) + ), + cvResult = S4Vectors::SimpleList( + map(byRow, .twasRowCv, cv = cv, methods = cells$method) + ), + cvPartition = IRanges::CharacterList( + map(byRow, .twasPick, values = cv$keys) + ), + standardized = S4Vectors::SimpleList(map(stores, "standardized")), + dataType = S4Vectors::SimpleList(map(stores, "dataType")) + ) + # Assigned, not listed: a NULL in the list would still name a column. + payload$jointIndex <- .twasRowJointIndex(cells$jointIndex, byRow) + traitPos <- .twasRowRanges(cells$traitPos, byRow, "traitPos") + region <- .twasRowRanges(cells$region, byRow, "region") + c(as.list(cells$keys[first, ]), payload) |> + .appendTraitPosCol(traitPos, n) |> + .appendRegionCol(region, n) +} + +# The rows' cells' joint-fit positions, or NULL (no column) when no cell is +# from a joint fit. +# @noRd +.twasRowJointIndex <- function(jointIndex, byRow) { + if (is.null(jointIndex) || all(is.na(jointIndex))) { + return(NULL) + } + IRanges::IntegerList(map(byRow, .twasPick, values = jointIndex)) +} + +# @noRd +.twasPick <- function(idx, values) { + values[idx] +} + +# A row's stored CV, by method. +# @noRd +.twasRowCv <- function(idx, cv, methods) { + set_names(as.list(cv$cvResult)[idx], methods[idx]) +} + +# The range a row's cells share for `what` (trait position or region): the +# placeholder of a cell given none is unknown, and the cells that know one +# must agree. NULL when no cell has the column. +# @noRd +.twasRowRanges <- function(gr, byRow, what) { + if (is.null(gr)) { + return(NULL) + } + known <- !.twasIsPlaceholder(gr) + labels <- replace(as.character(gr), !known, NA_character_) + mixed <- keep(byRow, .twasRowDisagreesKnown, values = labels) + if (length(mixed) > 0L) { + abort(glue( + "TwasWeights: the methods of one (study, context, trait) carry ", + "different `{what}` values; a row holds one." + )) + } + gr[map_int(byRow, .twasFirstKnown, known = known)] +} + +# The placeholder range a combine pads a missing range column with. +# @noRd +.twasIsPlaceholder <- function(gr) { + as.character(GenomicRanges::seqnames(gr)) == "chrUn" & width(gr) == 0L +} + +# @noRd +.twasRowDisagreesKnown <- function(idx, values) { + length(unique(discard(values[idx], is.na))) > 1L +} + +# @noRd +.twasFirstKnown <- function(idx, known) { + hit <- idx[known[idx]] + if (length(hit) == 0L) idx[[1L]] else hit[[1L]] +} + +# ---- reading cells ----------------------------------------------------------- + +# Every cell of `x`, one per (row, method), in row order: its row, its method +# and its row's identity columns. +# @noRd +.twasCells <- function(x) { + md <- mcols(x, use.names = FALSE) + methods <- map(as.list(md$methods), as.character) + rows <- rep(seq_along(methods), lengths(methods)) + ident <- intersect(.TWAS_KEY_COLUMNS, colnames(md)) + tibble( + row = rows, + method = list_c(methods, ptype = character()), + !!!set_names(map(ident, .twasRowValues, md = md, rows = rows), ident) + ) +} + +# The identity columns a row is keyed by. +# @noRd +.TWAS_KEY_COLUMNS <- c( + "study", + "context", + "trait", + "jointStudies", + "jointContexts", + "jointTraits" +) + +# @noRd +.twasRowValues <- function(cn, md, rows) { + as.character(md[[cn]])[rows] +} + +# One cell as a TwasWeightsRow: the method's variants and weights, and its +# fit, cross-validation, scale and data type. +# @noRd +.twrCellParts <- function(x, row, method) { + md <- mcols(x, use.names = FALSE) + tensor <- md$weightTensor[[row]] + union <- .rtlGatherElements(x, row) + positions <- tensor$variants[[method]] %||% seq_along(union) + k <- match(method, as.character(md$methods[[row]])) + w <- .twasCellWeights(tensor, k, method, positions) + gr <- union[positions] + new( + "TwasWeightsRow", + variants = S4Vectors::`mcols<-`( + gr, + value = `[[<-`(mcols(gr, use.names = FALSE), "weight", value = w) + ), + weights = w, + methodFits = .fitEntry(md$fits[[row]][[k]], x), + cvResult = .twasCellCv(x, md, row, k), + weightStandardized = isTRUE(md$standardized[[row]][[method]]), + weightsDataType = md$dataType[[row]][[method]] + ) +} + +# Method `method`'s weights (the k-th of its row) on its own variants: a +# vector, or a variants x K matrix when that is what it was given. K = 0 is +# either no weights (NULL) or a matrix with no columns, such as a joint fit +# that kept no conditions. +# @noRd +.twasCellWeights <- function(tensor, k, method, positions) { + K <- tensor$K[[k]] + if (K == 0L) { + if (!tensor$isMatrix[[k]]) { + return(NULL) + } + return(matrix(numeric(0), length(positions), 0L)) + } + j <- tensor$slice[[k]] + block <- if (identical(tensor$part[[k]], "dense")) { + tensor$dense[positions, j, seq_len(K), drop = FALSE] + } else { + .svtQuiet(methods::as( + tensor$sparse[positions, j, seq_len(K), drop = FALSE], + "array" + )) + } + w <- matrix(as.numeric(block), length(positions), K) + if (!tensor$isMatrix[[k]]) { + return(as.numeric(w)) + } + `colnames<-`(w, tensor$columns[[method]]) +} + +# The k-th method of row `row`'s cross-validation, its shared partition and +# per-fold fits put back. +# @noRd +.twasCellCv <- function(x, md, row, k) { + stored <- md$cvResult[[row]][[k]] + key <- md$cvPartition[[row]][[k]] + cv <- .cvJoinPartition(stored, .dictEntryFor(key, .cvPartitionDict(x))) + folds <- .fitEntry(md$foldFits[[row]][[k]], x) + if (is.null(folds)) cv else list_assign(cv, foldFits = folds) +} + +# ---- selecting cells --------------------------------------------------------- + +# The cell (a row of .twasCells()) a (study, context, trait, method) selector +# pins. All four are needed unless `x` holds a single cell; the first match +# wins, and the joint axes do not select, as for any collection. +# @noRd +#' @importFrom checkmate assertVector +.twrSelectCell <- function(x, studyName, context, trait, method) { + cells <- .twasCells(x) + if (nrow(cells) == 0L) { + abort("TwasWeights has no rows.") + } + selectors <- list(studyName, context, trait, method) + if (any(map_lgl(selectors, is.null))) { + if (nrow(cells) == 1L) { + return(cells[1L, ]) + } + abort(glue( + "TwasWeights has {nrow(cells)} entries. Pass `studyName`, ", + "`context`, `trait`, and `method` to select one." + )) + } + walk(selectors, assertVector, len = 1L) + hit <- .twasCellIndex(cells, studyName, context, trait, method) + if (length(hit) == 0L) { + abort(glue( + "No entry for (study='{studyName}', context='{context}', ", + "trait='{trait}', method='{method}')." + )) + } + cells[hit[[1L]], ] +} + +# Indices of the cells (rows of .twasCells()) a (study, context, trait, +# method) selector matches, the method in either spelling; empty for none. +# @noRd +.twasCellIndex <- function(cells, studyName, context, trait, method) { + which( + cells$study == studyName & + cells$context == context & + cells$trait == trait & + cells$method == .twasMethodToken(method) + ) +} + +# The constructor's inputs for cells `cells` of `x` (rows of .twasCells()). +# @noRd +.twasCellInputs <- function(x, cells) { + md <- mcols(x, use.names = FALSE) + rows <- cells$row + list( + keys = cells[intersect(.TWAS_KEY_COLUMNS, names(cells))], + method = cells$method, + entry = map2(rows, cells$method, .twrCellParts, x = x), + traitPos = if (is_in("traitPos", colnames(md))) md$traitPos[rows], + region = if (is_in("region", colnames(md))) md$region[rows], + ldRefs = .rowLdRefs(x)[rows], + jointIndex = .twasCellJointIndex(md, cells) + ) +} + +# Each cell's position in its joint fit's condition axis (NA for a cell from +# no joint fit), or NULL when no row of the collection is from one. +# @noRd +.twasCellJointIndex <- function(md, cells) { + if (!is_in("jointIndex", colnames(md))) { + return(NULL) + } + map2_int(cells$row, cells$method, .twasCellJointIndexAt, md = md) +} + +# @noRd +.twasCellJointIndexAt <- function(row, method, md) { + k <- match(method, as.character(md$methods[[row]])) + as.integer(md$jointIndex[[row]][[k]]) +} + +# `x` cut to its cells `cells`, rebuilt so each row keeps only those. +# @noRd +.twasKeepCells <- function(x, cells) { + .withMetadata( + .twasNewValidated(.twasCellInputs(x, cells)), + S4Vectors::metadata(x) + ) +} + +# `x` with only the methods `methods` (camelCase tokens). +# @noRd +.twasKeepMethods <- function(x, methods) { + cells <- .twasCells(x) + .twasKeepCells(x, cells[is_in(cells$method, methods), ]) +} + +# ---- combining --------------------------------------------------------------- + +# Collections `parts` as one: their cells regrouped, so the methods one gene +# has in different parts share its row. A non-NULL `ldReference` is every +# row's reference instead. +# @noRd +.twasCombine <- function(parts, ldReference) { + inputs <- map(parts, .twasAllCellInputs) + joined <- list( + keys = bind_rows(map(inputs, "keys")), + method = list_c(map(inputs, "method"), ptype = character()), + entry = list_flatten(map(inputs, "entry")), + traitPos = .twasJoinRanges(map(inputs, "traitPos"), inputs), + region = .twasJoinRanges(map(inputs, "region"), inputs), + ldRefs = list_flatten(map(inputs, "ldRefs")), + jointIndex = .twasJoinJointIndex(inputs) + ) + if (!is.null(ldReference)) { + joined$ldRefs <- .ldRefPerTuple(ldReference, length(joined$method)) + } + .withMetadata(.twasNewValidated(joined), S4Vectors::metadata(parts[[1L]])) +} + +# The parts' cells' joint-fit positions joined, NA for a part's cells from no +# joint fit; NULL when no part has any. +# @noRd +.twasJoinJointIndex <- function(inputs) { + if (all(map_lgl(map(inputs, "jointIndex"), is.null))) { + return(NULL) + } + list_c(map(inputs, .twasInputJointIndex), ptype = integer()) +} + +# @noRd +.twasInputJointIndex <- function(input) { + input$jointIndex %||% rep(NA_integer_, length(input$method)) +} + +# @noRd +.twasAllCellInputs <- function(x) { + .twasCellInputs(x, .twasCells(x)) +} + +# The parts' range columns joined, a part without the column padded with +# placeholders as a combine pads it; NULL when no part has it. +# @noRd +.twasJoinRanges <- function(grs, inputs) { + if (all(map_lgl(grs, is.null))) { + return(NULL) + } + n <- map_int(inputs, .twasInputCells) + padded <- map2(grs, n, .twasRangesOrPlaceholder) + suppressWarnings(exec(c, !!!unname(padded))) +} + +# @noRd +.twasInputCells <- function(input) { + length(input$method) +} + +# @noRd +.twasRangesOrPlaceholder <- function(gr, n) { + gr %||% .placeholderRanges(n) +} + +# ---- rebuilt elements -------------------------------------------------------- + +# `md` (the outer columns of rows `keep` of `x`) with each row's tensor +# realigned to its rebuilt element in `bare`: weights follow their variants by +# id, a variant the element no longer holds drops out of every method, and one +# it gained has no weight. +# @noRd +.twasRealignedMcols <- function(x, md, bare, keep) { + old <- map(keep, .twasElementIds, grl = x) + new <- map(seq_along(bare), .twasElementIds, grl = bare) + md$weightTensor <- S4Vectors::SimpleList(pmap( + list( + as.list(md$weightTensor), + map(as.list(md$methods), as.character), + old, + new + ), + .twasRealignTensor + )) + md +} + +# @noRd +.twasElementIds <- function(i, grl) { + .grVariantIds(grl[[i]]) +} + +# One row's tensor, its methods `methods`, on variants `new` instead of +# `old`. +# @noRd +.twasRealignTensor <- function(tensor, methods, old, new) { + if (identical(old, new)) { + return(tensor) + } + at <- match(new, old) + dense <- .twasTakeRows(tensor$dense, at) + sparse <- .twasTakeRows(.twasDensePart(tensor$sparse), at) + list_assign( + tensor, + dense = dense, + sparse = if (is.null(sparse)) { + NULL + } else { + .svtQuiet(methods::as(sparse, "SVT_SparseArray")) + }, + variants = discard( + map( + set_names(methods), + .twasRemappedPositions, + tensor = tensor, + n = length(old), + at = at + ), + is.null + ) + ) +} + +# @noRd +.twasDensePart <- function(part) { + if (is.null(part)) NULL else .svtQuiet(methods::as(part, "array")) +} + +# Rows `at` of array `arr` (zero where `at` is NA). +# @noRd +.twasTakeRows <- function(arr, at) { + if (is.null(arr)) { + return(NULL) + } + d <- dim(arr) + out <- array(0, c(length(at), d[[2L]], d[[3L]])) + kept <- which(!is.na(at)) + out[kept, , ] <- arr[at[kept], , , drop = FALSE] + out +} + +# Method `method`'s positions among a row's new variants: its old ones (all +# `n`, in order, when it held the row's variants as they were) mapped through +# `at`, those dropped gone; NULL when it holds the new variants in order. +# @noRd +.twasRemappedPositions <- function(method, tensor, n, at) { + old <- tensor$variants[[method]] %||% seq_len(n) + moved <- match(old, at) + moved <- moved[!is.na(moved)] + if (identical(moved, seq_along(at))) NULL else moved +} + +# ---- flat views -------------------------------------------------------------- + +# `x` as flattenTupleRanges() hands a TwasWeights out: one range per (variant, +# method, weight column), carrying that weight, the row's identity columns +# (dotted) and `.method`. `.weightColumn` names a weight-matrix column (an +# fSuSiE feature, an outcome) and is NA for a plain weight vector. +# @noRd +.twasFlatten <- function(x) { + md <- mcols(x, use.names = FALSE) + cells <- .twasCells(x) + blocks <- list_flatten(map2( + cells$row, + cells$method, + .twasFlatCell, + x = x, + md = md, + keyCols = .rtlTupleKeyCols(x) + )) + if (length(blocks) == 0L) { + return(.rtlGatherElements(x, seq_len(length(x)))) + } + suppressWarnings(exec(c, !!!unname(blocks))) +} + +# @noRd +.twasFlatCell <- function(row, method, x, md, keyCols) { + gr <- variants(.twrCellParts(x, row, method)) + w <- mcols(gr, use.names = FALSE)$weight + labels <- .twbWeightLabels(w) + ident <- set_names( + map(keyCols, .twasRowValue, md = md, row = row), + map_chr(keyCols, .rtlDotName) + ) + map( + seq_along(labels), + .twasFlatBlock, + gr = gr, + w = w, + labels = labels, + ident = ident, + method = method + ) } -# The outer-mcols columns for a TwasWeights: the four identity columns, the -# per-row payload columns, then the optional joint axes and trait position. # @noRd -.twasMetadataCols <- function( - studyName, - context, - trait, - method, - entry, - jointStudies, - jointContexts, - jointTraits, - traitPos, - region, - n -) { - baseCols <- c( +.twasRowValue <- function(nm, md, row) { + md[[nm]][[row]] +} + +# One weight column of one entry as flat ranges. +# @noRd +.twasFlatBlock <- function(k, gr, w, labels, ident, method) { + n <- length(gr) + own <- mcols(gr, use.names = FALSE) + added <- c( list( - study = as.character(studyName), - context = as.character(context), - trait = as.character(trait), - method = as.character(method) + weight = if (is.null(w)) { + rep(NA_real_, n) + } else { + .twbWeightColumn(k, w) + } ), - .twRowPayloadCols(entry) + map(ident, rep, length.out = n), + list(.method = rep(method, n), .weightColumn = rep(labels[[k]], n)) ) - withJoint <- .twasAppendJointCols( - baseCols, - jointStudies, - jointContexts, - jointTraits, - n + `mcols<-`( + gr, + value = cbind( + own[, colnames(own) != "weight", drop = FALSE], + DataFrame(added, check.names = FALSE) + ) ) - .appendRegionCol(.appendTraitPosCol(withJoint, traitPos, n), region, n) } +# The columns a flat TwasWeights needs to be nested back, beyond the +# identity columns: the weights and where they belong. +# @noRd +.TWAS_FLAT_COLUMNS <- c("weight", ".method", ".weightColumn") + +# `flat` (a flattened `template`, possibly filtered or mutated) nested back +# into `template`'s entries: each entry keeps the ranges carrying its row's +# identity and its method, with their weights. An entry left with none is +# kept, with no variants. # @noRd -.twPayloadStandardized <- function(p) { - weightStandardized(p) +.twasNest <- function(flat, template) { + md <- mcols(template, use.names = FALSE) + keyCols <- .rtlTupleKeyCols(template) + cells <- .twasCells(template) + fmd <- mcols(flat, use.names = FALSE) + wanted <- str_c( + .rtlTupleKeys(md, keyCols, length(template))[cells$row], + cells$method, + sep = "\r" + ) + have <- str_c( + .rtlTupleKeys(fmd, map_chr(keyCols, .rtlDotName), length(flat)), + as.character(fmd$.method), + sep = "\r" + ) + inputs <- .twasCellInputs(template, cells) + inputs$entry <- map2( + inputs$entry, + wanted, + .twasNestCell, + flat = flat, + have = have, + drop = c(map_chr(keyCols, .rtlDotName), .TWAS_FLAT_COLUMNS) + ) + .withMetadata(.twasNewValidated(inputs), S4Vectors::metadata(template)) } -# Require study/context/trait/method/entry to share one length; returns it. +# Entry `entry` rebuilt from its ranges in `flat`, its payload kept. # @noRd -.twasCheckRowLengths <- function(studyName, context, trait, method, entry) { - n <- length(studyName) - if ( - length(context) != n || - length(trait) != n || - length(method) != n || - length(entry) != n - ) { - msg <- glue( - "`studyName`, `context`, `trait`, `method`, and `entry` must all ", - "have the same length." - ) - abort(msg) +.twasNestCell <- function(entry, key, flat, have, drop) { + picked <- flat[which(have == key)] + pmd <- mcols(picked, use.names = FALSE) + ids <- .grVariantIds(picked) + first <- !duplicated(ids) + gr <- `mcols<-`( + picked[first], + value = pmd[first, setdiff(colnames(pmd), drop), drop = FALSE] + ) + w <- .twasNestWeights(weights(entry), pmd, ids, first) + new( + "TwasWeightsRow", + variants = `mcols<-`( + gr, + value = `[[<-`(mcols(gr, use.names = FALSE), "weight", value = w) + ), + weights = w, + methodFits = methodFits(entry), + cvResult = cvResult(entry), + weightStandardized = weightStandardized(entry), + weightsDataType = weightsDataType(entry) + ) +} + +# An entry's weights from its flat ranges, in the shape `shape` (its weights +# before flattening) had. A matrix weight a predicate dropped from one column +# while the variant kept another is 0, as a method's weight is wherever it +# has none. +# @noRd +.twasNestWeights <- function(shape, pmd, ids, first) { + if (is.null(shape)) { + return(NULL) } - n + if (is.null(dim(shape))) { + return(as.numeric(pmd$weight[first])) + } + labels <- .twbWeightLabels(shape) + kept <- ids[first] + w <- matrix(0, length(kept), length(labels)) + w[cbind(match(ids, kept), match(pmd$.weightColumn, labels))] <- pmd$weight + `colnames<-`(w, colnames(shape)) } -# Append any supplied joint* provenance columns (each length n) as character. +# ---- saved collections ------------------------------------------------------- + +# A collection saved with one row per (study, context, trait, method), its +# methods folded into gene rows; one saved per gene is left as it is. # @noRd -.twasAppendJointCols <- function( - cols, - jointStudies, - jointContexts, - jointTraits, - n -) { - supplied <- compact(list( - jointStudies = jointStudies, - jointContexts = jointContexts, - jointTraits = jointTraits - )) - walk2(names(supplied), supplied, .twasCheckJointColLength, n = n) - c(cols, map(supplied, as.character)) +.twasFoldMethodRows <- function(object) { + cols <- .tupleColumnNames(object) + if (!is_in("method", cols) || is_in("methods", cols)) { + return(object) + } + .withMetadata( + .twasNewValidated(.twasLegacyCellInputs(object)), + S4Vectors::metadata(object) + ) } -# Each joint-provenance column must be one value per row. +# The constructor's inputs for a saved per-method collection, one cell per +# saved row. # @noRd -.twasCheckJointColLength <- function(nm, val, n) { - if (length(val) == n) { +.twasLegacyCellInputs <- function(object) { + md <- mcols(object, use.names = FALSE) + keyCols <- intersect(.TWAS_KEY_COLUMNS, colnames(md)) + list( + keys = as_tibble(set_names( + map(keyCols, .twasMdCharacter, md = md), + keyCols + )), + method = .twasMethodToken(as.character(md$method)), + entry = map(seq_along(object), .twasLegacyRow, x = object, md = md), + traitPos = if (is_in("traitPos", colnames(md))) md$traitPos, + region = if (is_in("region", colnames(md))) md$region, + ldRefs = .rowLdRefs(object) + ) +} + +# @noRd +.twasMdCharacter <- function(cn, md) { + as.character(md[[cn]]) +} + +# Saved row `i` as the TwasWeightsRow it was built from: its weights the +# element's `weight` column, its payload the row's columns. +# @noRd +.twasLegacyRow <- function(i, x, md) { + gr <- .rtlGatherElements(x, i) + mc <- mcols(gr, use.names = FALSE) + w <- .unnamedWeights(mc$weight) + new( + "TwasWeightsRow", + variants = S4Vectors::`mcols<-`( + gr, + value = `[[<-`(mc, "weight", value = w) + ), + weights = w, + methodFits = md$fits[[i]], + cvResult = .cvJoinPartition(md$cvResult[[i]], .mdCvPartition(x, md, i)), + weightStandardized = isTRUE(md$standardized[[i]]), + weightsDataType = md$dataType[[i]] + ) +} + +# A gene's methods sit on one chromosome: its row is one element. +# @noRd +.twasRefuseMultiChromosome <- function(stores) { + spans <- map_int(stores, .twasChromosomeCount) + if (all(spans <= 1L)) { return(invisible(NULL)) } - msg <- glue("`{nm}` must have the same length as `study`.") - abort(msg) + abort(glue( + "TwasWeights: row {which(spans > 1L)[[1L]]} holds variants on more ", + "than one chromosome; a (study, context, trait) is one cis fit." + )) +} + +# @noRd +.twasChromosomeCount <- function(store) { + n_distinct(as.character(GenomicRanges::seqnames(store$variants))) } #' @rdname traitPosition @@ -384,13 +1364,16 @@ setMethod("traitPosition", "TwasWeights", function(x) { # 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. +#' @description Return one \code{(study, context, trait, method)} entry of a +#' \code{TwasWeights} collection: its gene's row, cut to that method. #' @param x A \code{TwasWeights} object. #' @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. +#' required when the collection holds more than one entry; optional when +#' it holds one. The method may be given in snake_case +#' (\code{susie_inf}). +#' @return A \code{TwasWeights} holding that one entry; read it with +#' \code{\link[=weights-methods]{weights}}, \code{\link{methodFits}} or +#' \code{\link{cvResult}}. #' @examples #' twe <- TwasWeightsRow( #' variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), @@ -426,40 +1409,22 @@ setMethod( trait = NULL, method = NULL ) { - x[.twrSelectRowIndex(x, studyName, context, trait, method)] + .twasKeepCells( + x, + .twrSelectCell(x, studyName, context, trait, method) + ) } ) -# The weights of one row, read straight off that element's mcols. -# @noRd -.twasRowWeights <- function(i, x) { - mcols(x[[i]])$weight -} - -# The row a (study, context, trait, method) selector pins. -# @noRd -.twrSelectRowIndex <- function(x, studyName, context, trait, method) { - .tupleSelectRow( - x, - studyName, - context, - trait, - method, - cls = "TwasWeights" - ) -} - -# The row payload that selector pins. +# The cell payload that selector pins. # # 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. +# single-cell collection, so routing the per-field accessors through it +# would dispatch straight back into them. # @noRd .twrSelectRowParts <- function(x, studyName, context, trait, method) { - .twrRowParts( - x, - .twrSelectRowIndex(x, studyName, context, trait, method) - ) + cell <- .twrSelectCell(x, studyName, context, trait, method) + .twrCellParts(x, cell$row, cell$method) } #' @rdname resolveWeights @@ -564,10 +1529,12 @@ setMethod( } ) -# Before rows recorded the variants their weights were fitted on, a -# collection had no `fitVariants` column; a row saved then records the -# variants it holds, and a row with no fit payload records none. The -# inherited update runs either way, for the updates every collection shares. +# A collection saved with one row per (study, context, trait, method) holds +# a gene's methods in rows of their own; they are folded into its row +# (.twasFoldMethodRows()), which also drops what saved rows carried that rows +# no longer do -- variant ids on the weights, a `fitVariants` column, each +# row's own CV partition. The inherited update runs either way, for the +# updates every collection shares. #' @rdname updateObject-methods #' @export setMethod( @@ -577,21 +1544,48 @@ setMethod( if (isTRUE(verbose)) { message("updateObject(object = 'TwasWeights')") } - if (!is_in("fitVariants", .tupleColumnNames(object))) { - held <- map(seq_along(object), .twrBackfillFitVariants, x = object) - object <- `$<-`(object, "fitVariants", IRanges::CharacterList(held)) - } - methods::callNextMethod(object, ..., verbose = verbose) + # A collection saved with one row per method is rebuilt per gene, + # which stores everything as rows now hold it. Its LD references are + # brought up to date first, as the rebuild reads them, and the + # inherited update then runs on the rebuilt collection. + folded <- .twasFoldMethodRows(.updateRowLdRefs(object)) + methods::callNextMethod(.twasShareFits(folded), ..., verbose = verbose) } ) +# A collection saved one row per gene before rows shared their fits holds +# each method's fit in its `fits` cell and mr.mash's per-fold fits in its +# cvResult. Both move to the fits dictionary, where the rows of a joint fit +# share one entry. +# @noRd +#' @importFrom methods slot<- +.twasShareFits <- function(object) { + md <- mcols(object, use.names = FALSE) + if (!is_in("methods", colnames(md)) || is_in("foldFits", colnames(md))) { + return(object) + } + n <- lengths(md$methods) + rowOf <- rep(seq_along(n), n) + fitted <- .twasStoredFits( + list_flatten(map(as.list(md$fits), unname)), + list_flatten(map(as.list(md$cvResult), unname)) + ) + md$fits <- .twasKeysByRow(fitted$fits, rowOf) + md$foldFits <- .twasKeysByRow(fitted$foldFits, rowOf) + md$cvResult <- S4Vectors::SimpleList(map2( + unname(split(fitted$cv, rowOf)), + as.list(md$methods), + set_names + )) + cols <- colnames(md) + order <- append(setdiff(cols, "foldFits"), "foldFits", match("fits", cols)) + methods::slot(object, "fits", check = FALSE) <- fitted$entries + S4Vectors::`mcols<-`(object, value = md[, order]) +} + # @noRd -.twrBackfillFitVariants <- function(i, x) { - md <- mcols(x, use.names = FALSE) - if (length(md$fits[[i]]) == 0L && is.null(md$cvResult[[i]])) { - return(character(0)) - } - .grVariantIds(x[[i]]) +.twasKeysByRow <- function(keys, rowOf) { + IRanges::CharacterList(unname(split(keys, rowOf))) } #' @rdname weightStandardized @@ -675,19 +1669,23 @@ setMethod("traitNames", "TwasWeights", function(x) { #' @rdname methodNames #' @export setMethod("methodNames", "TwasWeights", function(x) { - unique(as.character(x$method)) + unique(.twasCells(x)$method) }) #' @rdname show-methods #' @export setMethod("show", "TwasWeights", function(object) { - cat(glue("TwasWeights: {nrow(object)} entries\n", .trim = FALSE)) + cells <- .twasCells(object) + cat(glue( + "TwasWeights: {nrow(object)} genes, {nrow(cells)} entries\n", + .trim = FALSE + )) if (nrow(object) > 0L) { cat(glue( - " {n_distinct(object$study)} studies, ", - "{n_distinct(object$context)} contexts, ", - "{n_distinct(object$trait)} traits, ", - "{n_distinct(object$method)} methods\n", + " {n_distinct(cells$study)} studies, ", + "{n_distinct(cells$context)} contexts, ", + "{n_distinct(cells$trait)} traits, ", + "{n_distinct(cells$method)} methods\n", .trim = FALSE )) } @@ -775,7 +1773,7 @@ setMethod("show", "TwasWeights", function(object) { ), bayesL = list( fn = "bayes_l_weights", - impl = "bLassoWeights", + impl = "bayesLWeights", args = list() ), bayesA = list( @@ -798,11 +1796,6 @@ setMethod("show", "TwasWeights", function(object) { impl = "bayesNWeights", args = list() ), - bLasso = list( - fn = "b_lasso_weights", - impl = "bLassoWeights", - args = list() - ), dprVb = list( fn = "dpr_vb_weights", impl = "dprVbWeights", @@ -933,13 +1926,12 @@ setMethod("show", "TwasWeights", function(object) { "buildMrmashPriorMatrices", "mr.mashr::mr.mash" ), - bayesA = c("bayesAWeights", "bayesAlphabetWeights", "qgg::gbayes"), - bayesC = c("bayesCWeights", "bayesAlphabetWeights", "qgg::gbayes"), - bayesN = c("bayesNWeights", "bayesAlphabetWeights", "qgg::gbayes"), - bayesR = c("bayesRWeights", "bayesAlphabetWeights", "qgg::gbayes"), - bayesB = c("bayesBWeights", "bglrWeights", "BGLR::BGLR"), - bayesL = c("bLassoWeights", "bglrWeights", "BGLR::BGLR"), - bLasso = c("bLassoWeights", "bglrWeights", "BGLR::BGLR"), + bayesA = .alphabetChains("bayesA", "individual"), + bayesB = .alphabetChains("bayesB", "individual"), + bayesC = .alphabetChains("bayesC", "individual"), + bayesL = .alphabetChains("bayesL", "individual"), + bayesN = .alphabetChains("bayesN", "individual"), + bayesR = .alphabetChains("bayesR", "individual"), dprVb = c("dprVbWeights", "dprWeights", "RcppDPR::fit_model"), dprGibbs = c( "dprGibbsWeights", @@ -966,42 +1958,38 @@ setMethod("show", "TwasWeights", function(object) { # @noRd .twasMethodChainsSumstat <- function() { list( - scad = c( - "scadRssWeights", - ".penalizedRssWeights", - ".rssShrinkGridWeights", - ".penalizedRssPath" - ), - mcp = c( - "mcpRssWeights", - ".penalizedRssWeights", - ".rssShrinkGridWeights", - ".penalizedRssPath" - ), + scad = .penalizedRssChain("scadRssWeights"), + mcp = .penalizedRssChain("mcpRssWeights"), l0learn = c( "l0learnRssWeights", ".rssShrinkGridWeights", ".penalizedRssPath" ), - lasso = c( - "lassosumRssWeights", - ".rssShrinkGridWeights", - ".penalizedRssPath" - ), - enet = c( - "enetRssWeights", - ".penalizedRssWeights", - ".rssShrinkGridWeights", - ".penalizedRssPath" - ), - ridge = c( - "ridgeRssWeights", - ".penalizedRssWeights", - ".rssShrinkGridWeights", - ".penalizedRssPath" + lasso = list( + pecotmr = c( + "lassosumRssWeights", + ".rssShrinkGridWeights", + ".penalizedRssPath" + ), + bigsnpr = c( + "lassosumRssWeights", + ".lassosum2Weights", + "bigsnpr::snp_lassosum2" + ) ), + enet = .penalizedRssChain("enetRssWeights"), + ridge = .penalizedRssChain("ridgeRssWeights"), prsCs = c("prsCsWeights", ".prsCsRun"), + # LDpred2's settings are all its wrappers' own arguments. + ldpred2Auto = "ldpred2AutoWeights", + ldpred2Grid = "ldpred2GridWeights", dprGibbs = c("sdprWeights", ".sdprRun"), + bayesA = .alphabetChains("bayesA", "sumstat"), + bayesB = .alphabetChains("bayesB", "sumstat"), + bayesC = .alphabetChains("bayesC", "sumstat"), + bayesL = .alphabetChains("bayesL", "sumstat"), + bayesN = .alphabetChains("bayesN", "sumstat"), + bayesR = .alphabetChains("bayesR", "sumstat"), mrash = c("mrashRssWeights", "susieR::mr.ash.rss"), mrmash = c( "mrmashRssWeights", @@ -1011,20 +1999,98 @@ setMethod("show", "TwasWeights", function(object) { ) } +# A penalized RSS method's chain: its wrapper, the shared penalized dispatcher, +# the shrinkage grid and the path every penalty solves. +# @noRd +.penalizedRssChain <- function(wrapper) { + c( + wrapper, + ".penalizedRssWeights", + ".rssShrinkGridWeights", + ".penalizedRssPath" + ) +} + +# A Bayesian alphabet method's chains on one data path, one per backend: +# the method's wrapper, the shared dispatcher, the engine's adapter and the +# engine. +# @noRd +.alphabetChains <- function(method, path) { + backends <- names(.alphabetBackends[[path]][[method]]) + set_names( + map(backends, .alphabetChain, method = method, path = path), + backends + ) +} + +# @noRd +.alphabetChain <- function(backend, method, path) { + c( + .twasMethodCapabilities[[method]][[str_c(path, "Impl")]], + .alphabetDispatchers[[path]], + .alphabetFitters[[path]][[backend]], + .alphabetEngineCallees[[path]][[backend]] + ) +} + +# The function every alphabet method's wrapper hands its fit to, per path. +# @noRd +.alphabetDispatchers <- c( + individual = "bayesAlphabetWeights", + sumstat = "bayesAlphabetRssWeights" +) + +# The engine each backend's adapter reaches, with any pecotmr hop between, +# per data path. +# @noRd +.alphabetEngineCallees <- list( + individual = list( + qgg = "qgg::gbayes", + bglr = c("bglrWeights", "BGLR::BGLR"), + hibayes = "hibayes::ibrm" + ), + sumstat = list( + qgg = "qgg::gbayes", + hibayes = "hibayes::sbrm", + pecotmr = "bayesAlphabetRss" + ) +) + # The chain for one token and input class, or NULL when the token has no path -# for that class. +# for that class. A method with several backends has a chain per backend, +# and this is its default backend's. # @noRd .twasMethodChainFor <- function(token, inputKind) { + chains <- .twasMethodChainsOf(token, inputKind) + if (!is.list(chains)) { + return(chains) + } + chains[[1L]] +} + +# Every chain a token has on one input class: a vector for a method with one +# implementation, a list keyed by backend for one with several. +# @noRd +.twasMethodChainsOf <- function(token, inputKind) { chains <- .twasMethodChains() side <- if (identical(inputKind, "QtlDataset")) "individual" else "sumstat" chains[[side]][[token]] } +# Names twasWeightsPipeline() sets for each method from its own arguments. +# Refused as method options even where a `...` hop leaves the rest of a +# method's bundle unchecked (see .methodsEntryNameProblem). +# @noRd +.twasPipelineOwnedArgs <- function() { + "backend" +} + # Argument names that are data or plumbing rather than settable options, so # naming one is not a user choice the check should endorse. # @noRd .twasChainDataArgs <- function() { c( + .twasPipelineOwnedArgs(), "X", "Y", "y", @@ -1075,10 +2141,12 @@ setMethod("show", "TwasWeights", function(object) { } # Every name legal for a token on one input class: the union of formals along -# its chain. NULL when a hop takes `...`, since anything then reaches it. +# its chain, or along every backend's chain for a method with several, whose +# own constructors check a record exactly. NULL when a hop takes `...`, since +# anything then reaches it. # @noRd .twasChainAccepted <- function(token, inputKind) { - chain <- .twasMethodChainFor(token, inputKind) + chain <- unique(unlist(.twasMethodChainsOf(token, inputKind))) if (is.null(chain)) { return(NULL) } @@ -1119,7 +2187,24 @@ setMethod("show", "TwasWeights", function(object) { # summary statistics, dprGibbs is RcppDPR then SDPR -- so a hand-written # registry has to restate a pairing the implementation already declares. # @noRd -.twasImplCtorName <- function(impl) { +# +# An implementation that runs on several engines (the Bayesian alphabet) +# defaults `methodArgs` to NULL and has a constructor per backend, from +# .alphabetBackends: this answers `backend`'s, or the default's when NULL. +# @noRd +.twasImplCtorName <- function(impl, backend = NULL) { + nms <- .twasImplCtorNames(impl) + if (length(nms) <= 1L) { + return(nms) + } + unname(nms[[backend %||% names(nms)[[1L]]]]) +} + +# Every Options constructor an implementation takes: the one its `methodArgs` +# default names, or one per backend, keyed by backend. NULL for an +# implementation that takes none. +# @noRd +.twasImplCtorNames <- function(impl) { if (is.null(impl)) { return(NULL) } @@ -1131,10 +2216,47 @@ setMethod("show", "TwasWeights", function(object) { return(NULL) } default <- formals(fn)$methodArgs - if (!is.call(default)) { + if (is.call(default)) { + return(as.character(default[[1L]])) + } + .twasImplBackendCtors(impl) +} + +# The constructors of an implementation with several backends, keyed by +# backend: found through the method and data path whose implementation it +# is. NULL for any other implementation. +# @noRd +.twasImplBackendCtors <- function(impl) { + found <- compact(map( + c("individual", "sumstat"), + .twasPathBackendCtors, + impl = impl + )) + if (length(found) == 0L) NULL else found[[1L]] +} + +# The backend constructors of the method whose implementation on `path` is +# `impl`, or NULL. +# @noRd +.twasPathBackendCtors <- function(path, impl) { + caps <- .twasMethodCapabilities + hit <- names(caps)[map_lgl( + caps, + .twasCapUsesImpl, + field = str_c(path, "Impl"), + impl = impl + )] + if (length(hit) == 0L) { return(NULL) } - as.character(default[[1L]]) + ctors <- .methodBackends[[path]][[hit[[1L]]]] + # A method whose engines take no Options constructor (LDpred2). + if (all(is.na(ctors))) NULL else ctors +} + +# @noRd +.twasCapUsesImpl <- function(cap, field, impl) { + identical(cap[[field]], impl) } # The constructor itself. Deliberately separate from the name: the @@ -1152,13 +2274,20 @@ setMethod("show", "TwasWeights", function(object) { ) } -# One method's Options constructor on one input path; NULL when the method -# does not run on that path at all. +# One method's Options constructor on one input path -- its default +# backend's, for a method with several; NULL when the method does not run on +# that path at all. # @noRd .twasMethodCtorFor <- function(token, inputKind) { .twasImplCtor(.twasMethodImplFor(token, inputKind)) } +# Every Options constructor one method takes on one input path, by name. +# @noRd +.twasMethodCtorNamesFor <- function(token, inputKind) { + .twasImplCtorNames(.twasMethodImplFor(token, inputKind)) +} + # Every TWAS weight method that runs on one input path: the configurable # ones with an implementation there, plus the fit-derived ones, whose # availability is not ours to state -- a fit can only be extracted from @@ -1209,6 +2338,37 @@ setMethod("show", "TwasWeights", function(object) { NULL } +# `backend` given as a method option. The pipeline owns it, keyed by method +# (.twasPipelineOwnedArgs), so the refusal says where it goes. The example +# uses the caller's own choice when it is one of the method's backends on +# this input. +# @noRd +.twasBackendArgHint <- function(token, entry, inputKind) { + if (!is_in("backend", names(entry))) { + return("") + } + side <- if (identical(inputKind, "QtlDataset")) "individual" else "sumstat" + choices <- names(.methodBackends[[side]][[token]]) + if (length(choices) == 0L) { + return(glue( + " `backend` is twasWeightsPipeline()'s own argument, and {token} ", + "has one implementation on {inputKind}, so there is no backend ", + "to choose." + )) + } + given <- entry$backend + example <- if (length(given) == 1L && is_in(given, choices)) { + given + } else { + choices[[1L]] + } + glue( + " Choose it with twasWeightsPipeline()'s own `backend` argument, ", + "keyed by method: backend = c({token} = \"{example}\"). ", + "{token} on {inputKind} offers {str_flatten(choices, ', ')}." + ) +} + # Map short method names and presets to weightMethods lists. # @param methods A character vector of short method names, or a preset string # ("default" or "fastDefault"). @@ -1436,14 +2596,17 @@ setMethod("show", "TwasWeights", function(object) { } # The canonical fine-mapping token behind a weight-method name, accepting the -# token itself (`susieInf`), its camelCase weight function (`susieInfWeights`) -# and its snake_case registry key (`susie_inf_weights`). Stripping the suffix -# is not enough on its own: that turns `susie_inf_weights` into `susie_inf`, -# which is not the registry's token. +# token itself (`susieInf`), its camelCase weight function (`susieInfWeights`), +# its snake_case registry key (`susie_inf_weights`) and that key's row label +# (`susie_inf`). Stripping the suffix is not enough on its own: that turns +# `susie_inf_weights` into `susie_inf`, which is not the registry's token. # @noRd .twasFmTokenFor <- function(method) { methodKeys <- map_chr(.twasFineMappingMethodAdapters, "methodKey") - hit <- names(methodKeys)[methodKeys == method] + rowLabels <- str_remove(methodKeys, "_weights$") + hit <- names(methodKeys)[which( + methodKeys == method | rowLabels == method + )] if (length(hit) == 1L) { return(hit) } @@ -1479,21 +2642,21 @@ setMethod("show", "TwasWeights", function(object) { weightMethods[[nm]] } -# The per-fold fits supplied for `token`, under any of its spellings. The gate -# and `.twasFoldFit()` must agree on this, or the gate can refuse fits the -# fold lookup would have found. +# The per-fold weights supplied for `token`, under any of its spellings. The +# gate and .twasFoldWeightsW() must agree on this, or the gate can refuse +# weights the fold lookup would have found. # @noRd -.twasFoldFitsFor <- function(fittedModelsCv, token) { - if (is.null(fittedModelsCv)) { +.twasFoldWeightsFor <- function(foldWeights, token) { + if (is.null(foldWeights)) { return(NULL) } adapter <- .twasFineMappingMethodAdapters[[token]] spellings <- c(token, adapter$methodKey, adapter$weightFn) - hit <- spellings[is_in(spellings, names(fittedModelsCv))] + hit <- spellings[is_in(spellings, names(foldWeights))] if (length(hit) == 0L) { return(NULL) } - fittedModelsCv[[hit[[1]]]] + foldWeights[[hit[[1]]]] } # The SuSiE-family methods requested in `weightMethods`, as canonical tokens. @@ -1536,73 +2699,6 @@ setMethod("show", "TwasWeights", function(object) { abort(msg) } -# Resolve the incoming susie / susieInf fits for the weight run: prefer a fit -# carried on the method args, else one from `fittedModels`, tagging each with -# its fine-mapping class. Returns list(susieFit, susieInfFit, hasSusie, -# hasSusieInf, susieName, susieInfName) -- the names being the spellings the -# caller actually used, so the write-back lands where the fitter will look. -# @noRd -.twasResolveSusieFits <- function(weightMethods, fittedModels) { - susieName <- .twasMethodNameFor(weightMethods, "susie") - susieInfName <- .twasMethodNameFor(weightMethods, "susieInf") - hasSusie <- !is.na(susieName) - hasSusieInf <- !is.na(susieInfName) - argSusie <- if (hasSusie) { - weightMethods[[susieName]][["susieFit"]] - } else { - NULL - } - argSusieInf <- if (hasSusieInf) { - weightMethods[[susieInfName]][["susieInfFit"]] - } else { - NULL - } - # A fit the caller passed in the method arguments wins; otherwise the - # pipeline's already-fitted model, if it produced one. - susieRaw <- argSusie %||% fittedModels[["susie"]] - susieInfRaw <- argSusieInf %||% fittedModels[["susieInf"]] - susieFit <- if (is.null(susieRaw)) { - NULL - } else { - .setFinemappingFitClass(susieRaw, "susie") - } - susieInfFit <- if (is.null(susieInfRaw)) { - NULL - } else { - .setFinemappingFitClass(susieInfRaw, "susieInf") - } - list( - susieFit = susieFit, - susieInfFit = susieInfFit, - hasSusie = hasSusie, - hasSusieInf = hasSusieInf, - susieName = susieName, - susieInfName = susieInfName - ) -} - -# Write the resolved susie / susieInf fits back onto the method args. Deriving -# susie's arguments from a susieInf fit belongs to fine-mapping, not here: it -# prepares a susie *fit* (model_init, unmappable_effects), which -# `susieWeights()` neither accepts nor runs. -# @noRd -.twasWriteBackSusieFits <- function(weightMethods, r) { - withInf <- if (!is.null(r$susieInfFit) && r$hasSusieInf) { - .twasSetMethodArg( - weightMethods, - r$susieInfName, - "susieInfFit", - r$susieInfFit - ) - } else { - weightMethods - } - if (is.null(r$susieFit) || !r$hasSusie) { - return(withInf) - } - .twasSetMethodArg(withInf, r$susieName, "susieFit", r$susieFit) -} - # One method's argument list with `arg` set, leaving every other method and # every other argument of that method untouched. # @noRd @@ -1614,17 +2710,40 @@ setMethod("show", "TwasWeights", function(object) { list_assign(weightMethods, !!!set_names(list(updated), method)) } -# Resolve the supplied susie / susieInf fits onto the method args. This never -# fine-maps: the SuSiE-family weight methods extract from a fit that -# fineMappingPipeline() produced, and a missing one is an error, not a cue to -# fit here. +# Resolve the supplied fine-mapping fits onto the method args, for every +# token with an adapter. This never fine-maps: the SuSiE-family weight methods +# extract from a fit that fineMappingPipeline() produced, and a missing one is +# an error, not a cue to fit here. # @noRd .prepareSusieWeightMethods <- function(weightMethods, fittedModels = NULL) { - if (is.null(fittedModels)) { - fittedModels <- list() + reduce( + names(.twasFineMappingMethodAdapters), + .twasResolveTokenFit, + fittedModels = fittedModels %||% list(), + .init = weightMethods + ) +} + +# One token's fit on its method's args, tagged with its fine-mapping class: a +# fit the caller put there wins, else the one in `fittedModels`. It is written +# under the spelling the caller used, where the extractor will look. +# @noRd +.twasResolveTokenFit <- function(weightMethods, token, fittedModels) { + nm <- .twasMethodNameFor(weightMethods, token) + if (is.na(nm)) { + return(weightMethods) + } + fitArg <- .twasFineMappingMethodAdapters[[token]]$fitArg + fit <- weightMethods[[nm]][[fitArg]] %||% fittedModels[[token]] + if (is.null(fit)) { + return(weightMethods) } - r <- .twasResolveSusieFits(weightMethods, fittedModels) - .twasWriteBackSusieFits(weightMethods, r) + .twasSetMethodArg( + weightMethods, + nm, + fitArg, + .setFinemappingFitClass(fit, token) + ) } # Per-fold TWAS weight fit for the CV engine. `ctx` carries weightMethods, @@ -1675,13 +2794,7 @@ setMethod("show", "TwasWeights", function(object) { # Per-fold priors bound to a multivariate fitter's camelCase args (mr.mash # data-driven matrices / mvsusie reweighted mixture prior for fold `j`). # @noRd -.twasFoldPriors <- function( - args, - method, - j, - dataDrivenPriorMatricesCv, - reweightedMixturePriorCv -) { +.twasFoldPriors <- function(args, method, j, dataDrivenPriorMatricesCv) { list_assign( args, !!!compact(list( @@ -1690,47 +2803,59 @@ setMethod("show", "TwasWeights", function(object) { is_in(method, c("mrmash_weights", "mrmashWeights")) ) { dataDrivenPriorMatricesCv[[j]] - }, - prior_variance = if ( - !is.null(reweightedMixturePriorCv) && - is_in(method, c("mvsusie_weights", "mvsusieWeights")) - ) { - reweightedMixturePriorCv[[j]] } )) ) } -# Inject the fold's own fine-mapping fit for a SuSiE-family method. Those -# weight wrappers extract from a supplied fit and never fine-map, so a fold -# can only be scored if fineMappingPipeline's CV retained that fold's fit -# (`fittedModelsCv`, keyed method -> fold_). +# A SuSiE-family method's weights for fold `j`, from fineMappingPipeline's CV +# (`foldWeights`: method -> variants x folds, rows named by variant, or +# variants x folds x outcomes): those methods extract from a fit and never +# fine-map, so a fold can only be scored with the weights its own fit gave. +# Aligned to the fold's training variants (zero where the fit had none), one +# column per outcome, or NULL when the method is not a fine-mapping one or +# has no weights for the fold. # @noRd -.twasFoldFit <- function(args, method, j, fittedModelsCv) { - if (is.null(fittedModelsCv)) { - return(args) - } +.twasFoldWeightsW <- function(method, j, Xtr, Ytr, foldWeights) { mk <- .twasFmTokenFor(method) - if (is.na(mk)) { - return(args) - } - adapter <- .twasFineMappingMethodAdapters[[mk]] - perFold <- .twasFoldFitsFor(fittedModelsCv, mk) - if (is.null(perFold)) { - return(args) - } + fw <- if (is.na(mk)) NULL else .twasFoldWeightsFor(foldWeights, mk) key <- str_c("fold_", j) - fit <- if (is_in(key, names(perFold))) { - perFold[[key]] - } else if (length(perFold) >= j) { - perFold[[j]] - } else { - NULL + if (is.null(fw) || !is_in(key, colnames(fw))) { + return(NULL) } - if (is.null(fit)) { - return(args) + if (is.null(rownames(fw))) { + abort(glue( + "twasWeightsCv: the per-fold weights for '{mk}' do not name their ", + "variants, so they cannot be aligned to X. Take them through ", + "cvResult(), which names them." + )) + } + perOutcome <- .twasFoldOutcomeWeights(fw, key, Ytr, mk) + hit <- match(rownames(fw), colnames(Xtr)) + W <- matrix(0, ncol(Xtr), ncol(Ytr), dimnames = list(colnames(Xtr), NULL)) + W[hit[!is.na(hit)], ] <- perOutcome[!is.na(hit), , drop = FALSE] + W +} + +# Fold `key`'s weights as variants x outcomes. A variants x folds matrix +# holds one weight per variant, which every outcome shares, as it does for a +# univariate fit; a variants x folds x outcomes array, as mvSuSiE gives, holds +# each outcome's own, matched to the columns of Y by name. +# @noRd +.twasFoldOutcomeWeights <- function(fw, key, Ytr, mk) { + if (length(dim(fw)) != 3L) { + return(matrix(fw[, key], nrow(fw), ncol(Ytr))) + } + outcomes <- colnames(Ytr) + missing <- setdiff(outcomes, dimnames(fw)[[3L]]) + if (length(missing) > 0L) { + missingStr <- str_flatten(missing, ", ") + abort(glue( + "twasWeightsCv: the per-fold weights for '{mk}' have no outcome ", + "{missingStr}. Name the third axis by the columns of Y." + )) } - list_assign(args, !!!set_names(list(fit), adapter$fitArg)) + matrix(fw[, key, outcomes], nrow(fw), length(outcomes)) } # One fold's multivariate weight fit; returns list(W, fit). @@ -1740,11 +2865,9 @@ setMethod("show", "TwasWeights", function(object) { args, method, j, - ctx$dataDrivenPriorMatricesCv, - ctx$reweightedMixturePriorCv + ctx$dataDrivenPriorMatricesCv ) - retaining <- !identical(ctx$fitRetention, "none") && - is_in("fitRetention", names(formals(fnName))) + retaining <- !identical(ctx$fitRetention, "none") fitArgs <- list_assign( withPriors, !!!compact(list( @@ -1782,9 +2905,12 @@ setMethod("show", "TwasWeights", function(object) { # path. Returns list(mk, W, fit) keyed by the canonical method key `mk`. # @noRd .twasFoldMethodWeights <- function(method, args, Xtr, Ytr, j, ctx) { - fnName <- .resolveMethodFunction(method, args) - args <- .twasFoldFit(args, method, j, ctx$fittedModelsCv) mk <- str_remove(method, "_weights$|Weights$") + given <- .twasFoldWeightsW(method, j, Xtr, Ytr, ctx$foldWeights) + if (!is.null(given)) { + return(list(mk = mk, W = given, fit = NULL)) + } + fnName <- .resolveMethodFunction(method, args) fit <- if (is_in(method, ctx$multivariateWeightMethods)) { .twasFoldMultivariate(method, fnName, args, Xtr, Ytr, j, ctx) } else { @@ -1831,23 +2957,29 @@ setMethod("show", "TwasWeights", function(object) { #' @param fitRetention How much of each per-method fit is kept on the result: #' \code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed #' payload downstream needs, \code{"full"} keeps the whole fitted object. -#' Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; -#' for every other method the two behave alike. +#' Every method keeps a fit, which names the variants it was fitted on. +#' \code{"slim"} and \code{"full"} differ for mr.mash, glmnet +#' (\code{lasso}, \code{enet}, \code{ridge}), ncvreg (\code{scad}, +#' \code{mcp}), \code{l0learn}, the Bayesian alphabet, \code{mrash} +#' and the DPR methods; for the others the two behave alike. #' @param seed Integer or \code{NULL}. When supplied, seeds both the #' main-process RNG (fold partitioning, variant sub-sampling) and the #' streams the folds draw from (see \code{BPPARAM}). The main-process seed #' is scoped to the call, so the session RNG is left as it was found. #' \code{NULL} (default) seeds neither. -#' @param fittedModelsCv Optional per-fold fine-mapping fits, as -#' \code{method -> fold_ -> fit}, from a \code{fineMappingPipeline()} -#' run with \code{cvFolds > 1}. SuSiE-family weight wrappers extract from a -#' supplied fit and never fine-map, so this is what makes cross-validating -#' them possible; it must have been produced on \code{samplePartitions}, -#' since a fit trained on different folds would leak held-out samples. +#' @param foldWeights Optional per-fold weights of fine-mapping methods, as +#' \code{method -> variants x folds} matrix (rows named by variant, columns +#' \code{fold_}): the \code{foldWeights} of the \code{cvResult} a +#' \code{fineMappingPipeline()} run with \code{cvFolds > 1} records. Every +#' column of \code{Y} shares those weights; a method with weights of its own +#' for each outcome, such as mvSuSiE, takes a variants x folds x outcomes +#' array instead, its third axis named by the columns of \code{Y}. +#' SuSiE-family weight wrappers extract from a fit and never fine-map, so a +#' fold's own weights are what make cross-validating them possible; they +#' must have been produced on \code{samplePartitions}, since weights +#' trained on different folds would leak held-out samples. #' @param dataDrivenPriorMatricesCv Optional list, one element per fold, of #' data-driven prior matrices for the mr.mash learner. -#' @param reweightedMixturePriorCv Optional list, one element per fold, of -#' reweighted mixture priors for the mvSuSiE learner. #' @return A list with the following components: #' \itemize{ #' \item `samplePartition`: A dataframe showing the sample partitioning used @@ -1880,8 +3012,9 @@ setMethod("show", "TwasWeights", function(object) { #' X <- multiTraitData$X[, 1:80] #' Y <- multiTraitData$Y #' # A cross-validated method is refit on each fold's training rows. The -#' # SuSiE family never fine-maps, so it needs each fold's own fit, passed -#' # as `fittedModelsCv` from a fineMappingPipeline() run with cvFolds > 1. +#' # SuSiE family never fine-maps, so it needs each fold's own weights, +#' # passed as `foldWeights` from a fineMappingPipeline() run with +#' # cvFolds > 1. #' twasWeightsCv(X, Y[, 1, drop = FALSE], fold = 3, #' weightMethods = list(lasso_weights = list())) #' @importFrom checkmate assertDataFrame assertNumber assertInt @@ -1900,8 +3033,7 @@ twasWeightsCv <- function( fitRetention = c("none", "slim", "full"), seed = NULL, dataDrivenPriorMatricesCv = NULL, - reweightedMixturePriorCv = NULL, - fittedModelsCv = NULL + foldWeights = NULL ) { # X / Y / fold are asserted downstream in .cvPrepareData; these are the # arguments nothing else checks. @@ -1928,8 +3060,7 @@ twasWeightsCv <- function( fitRetention = fitRetention, seed = seed, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, - reweightedMixturePriorCv = reweightedMixturePriorCv, - fittedModelsCv = fittedModelsCv + foldWeights = foldWeights ) } @@ -1952,26 +3083,26 @@ twasWeightsCv <- function( # fingerprint (see .cvPartitionKey); a fit carrying none is refused too, since # it cannot be shown to match. # @noRd -.twasCheckFoldFitPartition <- function(fittedModelsCv, samplePartitions) { - if (is.null(fittedModelsCv) || length(fittedModelsCv) == 0L) { +.twasCheckFoldWeightsPartition <- function(foldWeights, samplePartitions) { + if (is.null(foldWeights) || length(foldWeights) == 0L) { return(invisible(NULL)) } if (is.null(samplePartitions)) { msg <- glue( - "twasWeightsCv: `fittedModelsCv` needs the fold partition those ", - "fits were trained on. Pass the fine-mapping CV's ", + "twasWeightsCv: `foldWeights` needs the fold partition those ", + "weights were trained on. Pass the fine-mapping CV's ", "`samplePartition` as `samplePartitions`; a freshly drawn ", - "partition would score each fold with a fit that saw its ", + "partition would score each fold with weights that saw its ", "held-out samples." ) abort(msg) } want <- .cvPartitionKey(samplePartitions) - for (m in names(fittedModelsCv)) { - got <- attr(fittedModelsCv[[m]], "partitionKey") + for (m in names(foldWeights)) { + got <- attr(foldWeights[[m]], "partitionKey") if (is.null(got)) { msg <- glue( - "twasWeightsCv: the per-fold fits for '{m}' carry no ", + "twasWeightsCv: the per-fold weights for '{m}' carry no ", "partition fingerprint, so they cannot be shown to match ", "`samplePartitions`. Take them from a fineMappingPipeline() ", "run with cvFolds > 1." @@ -1980,9 +3111,9 @@ twasWeightsCv <- function( } if (!identical(got, want)) { msg <- glue( - "twasWeightsCv: the per-fold fits for '{m}' were trained on ", - "a different fold partition than the one being scored. Use ", - "the fine-mapping CV's own `samplePartition`." + "twasWeightsCv: the per-fold weights for '{m}' were trained ", + "on a different fold partition than the one being scored. ", + "Use the fine-mapping CV's own `samplePartition`." ) abort(msg) } @@ -1996,8 +3127,7 @@ twasWeightsCv <- function( .twasCvFoldCtx <- function( weightMethods, dataDrivenPriorMatricesCv, - reweightedMixturePriorCv, - fittedModelsCv, + foldWeights, fitRetention, verbose ) { @@ -2008,8 +3138,7 @@ twasWeightsCv <- function( weightMethods = weightMethods, multivariateWeightMethods = .twasCvMultivariateMethods, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, - reweightedMixturePriorCv = reweightedMixturePriorCv, - fittedModelsCv = fittedModelsCv, + foldWeights = foldWeights, fitRetention = fitRetention, verbose = verbose ) @@ -2031,12 +3160,11 @@ twasWeightsCv <- function( fitRetention, seed, dataDrivenPriorMatricesCv, - reweightedMixturePriorCv, - fittedModelsCv + foldWeights ) { weightMethods <- .twasCvResolveMethods( weightMethods, - fittedModelsCv, + foldWeights, samplePartitions, seed, verbose @@ -2053,8 +3181,7 @@ twasWeightsCv <- function( fitFoldCtx = .twasCvFoldCtx( weightMethods, dataDrivenPriorMatricesCv, - reweightedMixturePriorCv, - fittedModelsCv, + foldWeights, fitRetention, verbose ), @@ -2074,22 +3201,23 @@ twasWeightsCv <- function( # @noRd .twasCvResolveMethods <- function( weightMethods, - fittedModelsCv, + foldWeights, samplePartitions, seed, verbose ) { - .twasCheckFoldFitPartition(fittedModelsCv, samplePartitions) + .twasCheckFoldWeightsPartition(foldWeights, samplePartitions) .twasRequireSusieFits( weightMethods, - available = .twasFoldFitAvailable, + available = .twasFoldWeightsAvailable, fnLabel = "twasWeightsCv", how = str_c( - "Cross-validation refits on each fold, so it needs that fold's ", - "own fit: pass `fittedModelsCv = list( = )` ", - "from a fineMappingPipeline() run with cvFolds > 1." + "Cross-validation refits on each fold, so it needs the weights ", + "that fold's own fit gave: pass `foldWeights = list( = ", + ")` from a fineMappingPipeline() run with ", + "cvFolds > 1." ), - fittedModelsCv = fittedModelsCv + foldWeights = foldWeights ) if (is.null(seed) && !exists(".Random.seed") && verbose >= 1) { inform(str_c( @@ -2100,10 +3228,10 @@ twasWeightsCv <- function( .twasAsMethodRecord(weightMethods) } -# Whether `fittedModelsCv` carries per-fold fits for `tk`. +# Whether `foldWeights` carries per-fold weights for `tk`. # @noRd -.twasFoldFitAvailable <- function(tk, fittedModelsCv) { - !is.null(.twasFoldFitsFor(fittedModelsCv, tk)) +.twasFoldWeightsAvailable <- function(tk, foldWeights) { + !is.null(.twasFoldWeightsFor(foldWeights, tk)) } # Fit one TWAS weight method by name against the filtered design matrix, @@ -2119,11 +3247,7 @@ twasWeightsCv <- function( } userArgs <- weightMethods[[methodName]] fnName <- .resolveMethodFunction(methodName, userArgs) - fitArgs <- .twasApplyRetainFit( - userArgs, - fnName, - ctx$fitRetention - ) + fitArgs <- .twasApplyRetainFit(userArgs, ctx$fitRetention) fit <- .twasFitWeightsMatrix(fnName, fitArgs, ctx, methodName) embedded <- .embedWeights( fit$weights, @@ -2159,17 +3283,13 @@ twasWeightsCv <- function( "fsusieWeights" ) -# Pass the retention level down to the target weight function, when it takes -# one and the caller is keeping fits at all. A target that does not take -# `fitRetention` keeps nothing, which is what "no such argument" means. +# Pass the retention level down to the target weight function when the caller +# is keeping fits at all; every weight method takes `fitRetention`. # @noRd -.twasApplyRetainFit <- function(args, fnName, fitRetention) { +.twasApplyRetainFit <- function(args, fitRetention) { if (identical(fitRetention, "none")) { return(args) } - if (!is_in("fitRetention", names(formals(fnName)))) { - return(args) - } list_assign(args, fitRetention = args$fitRetention %||% fitRetention) } @@ -2366,8 +3486,11 @@ twasWeightsCv <- function( #' @param fitRetention How much of each per-method fit is kept on the result: #' \code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed #' payload downstream needs, \code{"full"} keeps the whole fitted object. -#' Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; -#' for every other method the two behave alike. +#' Every method keeps a fit, which names the variants it was fitted on. +#' \code{"slim"} and \code{"full"} differ for mr.mash, glmnet +#' (\code{lasso}, \code{enet}, \code{ridge}), ncvreg (\code{scad}, +#' \code{mcp}), \code{l0learn}, the Bayesian alphabet, \code{mrash} +#' and the DPR methods; for the others the two behave alike. #' @param verbose Integer controlling verbosity level: 0 = suppress all #' messages, 1 = suppress external package messages (default), 2 = show all #' messages including those from external packages. @@ -2388,8 +3511,10 @@ twasWeightsCv <- function( #' RNG and the streams the methods draw from (see \code{BPPARAM}). The #' main-process seed is scoped to the call, so the session RNG is left as it #' was found. \code{NULL} (default) seeds neither. -#' @return A list where each element is named after a method and contains the -#' weight matrix produced by that method. +#' @return A \code{TwasWeights} with one row, for the (\code{studyName}, +#' \code{context}, \code{trait}) gene, holding each method's weights, fit +#' and cross-validation. Its methods are named by camelCase token: a +#' method given as \code{susie_inf_weights} is \code{"susieInf"}. #' #' @examples #' data(multiTraitData) @@ -2650,15 +3775,13 @@ twasPredict <- function(X, weightsList) { .var.name = "weightsList" ) if (is(weightsList, "TwasWeights")) { - # Per-row weights vector/matrix payloads. Use the method name as key - # for compatibility with the legacy snake_case "_predicted" - # convention; ensembleWeights() rebinds the suffix. - methodNames <- as.character(weightsList$method) - # The per-row weights live in each element's mcols, so read them off - # the elements. + # Every (gene, method) cell's weights, keyed by the method name for + # the legacy "_predicted" convention; ensembleWeights() + # rebinds the suffix. + cells <- .twasCells(weightsList) wl <- set_names( - map(seq_len(nrow(weightsList)), .twasRowWeights, x = weightsList), - str_c(methodNames, "_weights") + map2(cells$row, cells$method, .twasCellWeightsAt, x = weightsList), + str_c(cells$method, "_weights") ) } else { wl <- weightsList @@ -2676,8 +3799,8 @@ twasPredict <- function(X, weightsList) { #' at zero (spike) plus continuous components (slab), and learns the mixture #' proportions via variational EM. The sparsity estimate \code{1 - pi[1]} is the #' empirical Bayes estimate of the non-null proportion, which can be used as a -#' data-driven prior for the inclusion probability parameters (\code{pi} for -#' bayesC, \code{probIn} for BayesB) of spike-and-slab Bayesian methods. +#' data-driven prior for the inclusion probability, \code{pi}, of the +#' spike-and-slab Bayesian methods (bayesB and bayesC). #' #' @param weightResults Named list of weight vectors or matrices as returned by #' \code{\link{learnTwasWeights}}. The mr.ash element should have a @@ -2694,8 +3817,8 @@ estimateSparsity <- function(weightResults) { if (is(weightResults, "TwasWeights")) { # Method names on the new TwasWeights collection are bare tokens # ("mrash"), not the snake_case _weights suffix form. - methods <- as.character(weightResults$method) - idx <- which(methods == "mrash") + cells <- .twasCells(weightResults) + idx <- which(cells$method == "mrash") if (length(idx) == 0L) { msg <- glue( "mr.ash entry not found in TwasWeights. Run ", @@ -2705,7 +3828,9 @@ estimateSparsity <- function(weightResults) { ) abort(msg) } - fit <- methodFits(.twrRowParts(weightResults, idx[[1L]])) + fit <- methodFits( + .twrCellParts(weightResults, cells$row[[idx[[1L]]]], "mrash") + ) if (is.null(fit) || is.null(fit$pi)) { msg <- glue( "mr.ash fit object not found. Run learnTwasWeights() with ", @@ -2848,6 +3973,12 @@ estimateSparsity <- function(weightResults) { `attr<-`(named, "fit", fit) } +# The weights of method `method` of row `row` of `x`. +# @noRd +.twasCellWeightsAt <- function(row, method, x) { + weights(.twrCellParts(x, row, method)) +} + # X %*% w for one weight vector/matrix (coerced to a 1-column matrix if needed). # @noRd .twasPredictOne <- function(w, X) { diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index a603e3453..833fa605b 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -181,9 +181,11 @@ combineTwasWeights <- function(..., ldReference = NULL) { # multivariate Whether the method requires multi-trait / multi-context # structure (mvsusie / mrmash / mvsusieRss / mrmashRss). # -# Per the design: BGLR / qgg "Bayes alphabet" methods (bayes_a/b/c/l/n/r, -# b_lasso) are individual-only until the qgg CRAN release adds qBayes -# sumstat support. dpr_gibbs has the SDPR sumstat counterpart; +# The Bayesian alphabet (bayesA/B/C/L/N/R) runs on several engines per data +# path, and so do the lasso and LDpred2 on summary statistics; their +# implementations take `backend`, and .methodBackends records which engines +# and Options constructors each method has. dpr_gibbs has the +# SDPR sumstat counterpart; # dpr_vb / dpr_adaptive_gibbs remain individual-only. lasso, enet and ridge # are glmnet on individual data and the penalized RSS solver on summary # statistics, at alpha = 1, 0.5 (or the caller's) and 0. prsCs has no @@ -252,40 +254,35 @@ combineTwasWeights <- function(..., ldReference = NULL) { sumstatImpl = NULL, multivariate = FALSE ), - # qgg Bayes alphabet -- individual-only until qgg CRAN release. + # The Bayesian alphabet: several engines per path (.alphabetBackends). bayesA = list( individualImpl = "bayesAWeights", - sumstatImpl = NULL, + sumstatImpl = "bayesARssWeights", multivariate = FALSE ), bayesB = list( individualImpl = "bayesBWeights", - sumstatImpl = NULL, + sumstatImpl = "bayesBRssWeights", multivariate = FALSE ), bayesC = list( individualImpl = "bayesCWeights", - sumstatImpl = NULL, + sumstatImpl = "bayesCRssWeights", multivariate = FALSE ), bayesL = list( - individualImpl = "bLassoWeights", - sumstatImpl = NULL, + individualImpl = "bayesLWeights", + sumstatImpl = "bayesLRssWeights", multivariate = FALSE ), bayesN = list( individualImpl = "bayesNWeights", - sumstatImpl = NULL, + sumstatImpl = "bayesNRssWeights", multivariate = FALSE ), bayesR = list( individualImpl = "bayesRWeights", - sumstatImpl = NULL, - multivariate = FALSE - ), - bLasso = list( - individualImpl = "bLassoWeights", - sumstatImpl = NULL, + sumstatImpl = "bayesRRssWeights", multivariate = FALSE ), # Sumstat-only Bayesian shrinkage (no individual-level analogue). @@ -293,6 +290,18 @@ combineTwasWeights <- function(..., ldReference = NULL) { individualImpl = NULL, sumstatImpl = "prsCsWeights", multivariate = FALSE + ), + # LDpred2, on summary statistics only, on bigsnpr or pecotmr's sampler + # (.methodBackends). + ldpred2Auto = list( + individualImpl = NULL, + sumstatImpl = "ldpred2AutoWeights", + multivariate = FALSE + ), + ldpred2Grid = list( + individualImpl = NULL, + sumstatImpl = "ldpred2GridWeights", + multivariate = FALSE ) ) @@ -413,7 +422,6 @@ combineTwasWeights <- function(..., ldReference = NULL) { "bayesB", "bayesC", "bayesN", - "bLasso", "dprVb", "dprGibbs", "dprAdaptiveGibbs", @@ -446,7 +454,6 @@ combineTwasWeights <- function(..., ldReference = NULL) { bayesB = "bayesB", bayesC = "bayesC", bayesN = "bayesN", - bLasso = "bLasso", dprVb = "dprVb", dprGibbs = "dprGibbs", dprAdaptiveGibbs = "dprAdaptiveGibbs", @@ -456,13 +463,24 @@ combineTwasWeights <- function(..., ldReference = NULL) { mvsusie = "mvsusie", mrmash = "mrmash", prsCs = "prsCs", + ldpred2Auto = "ldpred2Auto", + ldpred2Grid = "ldpred2Grid", fsusie = "fsusie" ) - unname(map_chr( + # Every method's own list key too (bayes_r_weights -> bayesR), read off + # .twasMethodMap and matched whole: the table above spells the + # multi-word tokens only in camelCase, so the keys .twasMethodLookup() + # itself writes for them came back as unknown tokens ("bayes_r"), while + # a bare snake_case token stays unknown. + canonical <- map_chr( snake, .twasCanonicalMethod, snakeToCanonical = snakeToCanonical - )) + ) + fromMap <- set_names(names(.twasMethodMap), map_chr(.twasMethodMap, "fn")) + hit <- is_in(names(methodList), names(fromMap)) + canonical[hit] <- fromMap[names(methodList)[hit]] + unname(canonical) } # Enforce input-class / method compatibility against the TWAS @@ -908,19 +926,16 @@ combineTwasWeights <- function(..., ldReference = NULL) { if (!is(twasWeights, "TwasWeights")) { return(NULL) } - idx <- .matchTupleRows( - twasWeights, - list( - study = studyName, - context = context, - trait = trait, - method = method - ) - ) - if (length(idx) == 0L) { + cells <- .twasCells(twasWeights) + hit <- .twasCellIndex(cells, studyName, context, trait, method) + if (length(hit) == 0L) { return(NULL) } - .twrRowParts(twasWeights, idx[[1L]]) + .twrCellParts( + twasWeights, + cells$row[[hit[[1L]]]], + cells$method[[hit[[1L]]]] + ) } # Convert a fine-mapping result (single-method susie/susie_inf row matched @@ -1091,11 +1106,16 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' (require at least two traits OR at least two contexts). #' \item \code{prsCs} runs only on summary statistics, so it is rejected #' on \code{QtlDataset} input. -#' \item \code{dprVb}, \code{dprAdaptiveGibbs} and the Bayesian alphabet -#' (\code{bayesA}, \code{bayesB}, \code{bayesC}, \code{bayesL}, -#' \code{bayesN}, \code{bayesR}, \code{bLasso}) run only on -#' individual-level data, so they are rejected on \code{QtlSumStats} -#' input. +#' \item \code{dprVb} and \code{dprAdaptiveGibbs} run only on +#' individual-level data, so they are rejected on +#' \code{QtlSumStats} input. +#' \item The Bayesian alphabet (\code{bayesA}, \code{bayesB}, +#' \code{bayesC}, \code{bayesL}, \code{bayesN}, \code{bayesR}) +#' runs on both, each method on several engines chosen with +#' \code{backend}: see \code{\link{bayesAlphabetWeights}} and +#' \code{\link{bayesAlphabetRssWeights}}. On summary statistics +#' a row with a genotype reference defaults to pecotmr's own +#' sampler, which reads its factor of the LD. #' \item \code{lasso}, \code{enet} and \code{ridge} are glmnet on #' individual-level data and the penalized RSS solver on summary #' statistics. \code{enet} mixes the two penalties at @@ -1136,6 +1156,18 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' default is \code{c("lasso", "prsCs", "dprGibbs")}, which there run #' lassosum, PRS-CS and SDPR; the fine-mapping methods are not in it, and #' are requested by name together with a \code{fineMappingResult}. +#' @param backend The engine a method with several runs on, as a named +#' character vector keyed by method, e.g. +#' \code{c(bayesR = "hibayes", bayesL = "bglr")}; \code{NULL} (the +#' default) leaves every method on its default. The Bayesian alphabet +#' methods have several (see \code{\link{bayesAlphabetWeights}}), and on +#' summary statistics so do \code{lasso} (\code{"pecotmr"} or +#' \code{"bigsnpr"}, which is slow: see \code{\link{lassosumRssWeights}}) +#' and \code{ldpred2Auto} and \code{ldpred2Grid} +#' (\code{"bigsnpr"} or \code{"pecotmr"}). Naming a +#' method that is not being run, one with a single implementation, or an +#' engine the method lacks on the input is an error, and so is a +#' \code{backend} inside a \code{methods} entry. #' @param contexts Optional context selection; \code{NULL} (the default) #' uses every context. A character vector applies to every study: a context #' no study has is an error, and one only some studies lack is skipped for @@ -1216,14 +1248,15 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' so a row narrowed since its fit warns (condition class #' \code{pecotmrFitCoverage}). #' @param twasWeights Optional \code{\link{TwasWeights}} resume cache. For each -#' requested \code{(study, context, trait, method)} tuple already present in -#' this collection, the cached \code{TwasWeightsRow} is copied through and -#' the corresponding weight fit is skipped. Only the un-cached method subset -#' is fit; the cached and fresh entries are concatenated in the returned -#' collection. Per-tuple matching mirrors the \code{fineMappingResult} cache -#' in \code{\link{fineMappingPipeline}}. Multivariate dispatch -#' (\code{mvsusie}, \code{mr.mash}) is unaffected because those methods -#' produce one fit jointly across multiple \code{(context, trait)} columns. +#' requested \code{(study, context, trait, method)} entry already present in +#' this collection, the cached entry is copied through and the +#' corresponding weight fit is skipped. Only the un-cached methods are fit; +#' the cached and fresh entries are combined in the returned collection. +#' Per-entry matching mirrors the \code{fineMappingResult} cache in +#' \code{\link{fineMappingPipeline}}. A multivariate method +#' (\code{mvsusie}, \code{mr.mash}) fits a group of contexts together, so +#' its group is resumed only when the cache holds every context's entry; +#' otherwise the whole group is refit. #' @param mashPrior Optional \code{\link{MashPrior}} (or coercible) supplying #' data-driven prior matrices for mr.mash weight methods; \code{NULL} to skip. #' @param usePCA Logical (length 1). Individual-level data only: a @@ -1245,12 +1278,22 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' takes, which has no \code{"none"} --- its \code{susieFit} slot is part #' of the returned object's contract. #' -#' \code{"full"} is honoured by the mr.mash engines and, on summary -#' statistics, by \code{lasso}, \code{enet}, \code{ridge}, \code{scad}, -#' \code{mcp} and \code{l0learn}, whose full fit also keeps every candidate's -#' coefficients; every other method keeps its fit whole or not at all. -#' Requesting \code{"full"} for a run where no method can honour it is an -#' error, and a mixed run warns rather than dropping it in silence. +#' Every method keeps a fit, and the fit names the variants it was fitted +#' on. \code{"full"} is honoured by the mr.mash engines; on summary +#' statistics also by \code{lasso}, \code{enet}, \code{ridge}, \code{scad}, +#' \code{mcp} and \code{l0learn}, whose full fit keeps every candidate's +#' coefficients; and on individual-level data by \code{lasso}, \code{enet}, +#' \code{ridge}, \code{scad}, \code{mcp}, \code{l0learn}, the Bayesian +#' alphabet, \code{mrash} and the DPR methods, whose full fit is the +#' engine's whole object where the slim one keeps the selected fit or the +#' posterior summaries, without any copy of the data. Every other method +#' keeps its fit whole or not at all, except the fine-mapping methods +#' (\code{susie}, \code{susieInf}, \code{susieAsh}, \code{mvsusie}, +#' \code{fsusie}), whose rows keep none: their weights come from the +#' \code{fineMappingResult}'s fit, which is where \code{ctwasPipeline()} +#' reads it. Requesting \code{"full"} for a run where no method can honour +#' it is an error, and a mixed run warns rather than dropping it in +#' silence. #' @param phenotypeFilterParam The run's phenotype QC, built with #' \code{\link{PhenotypeFilterParam}}: how missing phenotype values are #' handled (unset drops the affected samples; \code{"impute"} fills each @@ -1330,9 +1373,10 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' governs the main-process draws. #' @param ... Reserved for method-specific arguments. #' -#' @return A \code{\link{TwasWeights}} collection keyed by \code{(study, -#' context, trait, method)}. Each row's LD reference is none for -#' individual-level fits and that of the input row(s) for RSS-derived fits. +#' @return A \code{\link{TwasWeights}} collection with one row per gene -- +#' \code{(study, context, trait)} and joint group -- holding its methods. +#' Each row's LD reference is none for individual-level fits and that of +#' the input row(s) for RSS-derived fits. #' Its \code{seqinfo()} names the genome build the inputs name; inputs #' naming different builds are refused. #' @examples @@ -1516,6 +1560,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { .twasPipelineQtlDataset <- function( data, methods = "default", + backend = NULL, contexts = NULL, traitId = NULL, region = NULL, @@ -1582,6 +1627,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { resolvedTokens <- .twasQdsResolveTokens( jointSpecification, methods, + backend, fineMappingResult, .cvResolve(crossValidationParam), data @@ -1762,6 +1808,7 @@ setMethod( .twasQdsResolveTokens <- function( jointSpecification, methods, + backend, fineMappingResult, cvCfg, data @@ -1773,6 +1820,7 @@ setMethod( .twasMethodListArgs(norm$methodList), "QtlDataset" ) + .twasCheckBackend(backend, norm$tokens, "individual") .twasCheckFineMappingMethods( norm$tokens, fineMappingResult, @@ -1780,9 +1828,77 @@ setMethod( cvFolds = cvCfg$folds, fitFullData = cvCfg$fitFullData ) + norm$methodList <- .twasInjectBackends(norm$methodList, backend) list(parsedJointSpec = parsedJointSpec, norm = norm) } +# Check the pipeline's `backend`: a named character vector keyed by the +# methods being run, each naming an engine that method has on `path`. +# @noRd +.twasCheckBackend <- function(backend, tokens, path) { + if (is.null(backend)) { + return(invisible(NULL)) + } + if (!is.character(backend) || !is_named(backend)) { + abort(str_c( + "`backend` must be a named character vector keyed by method, ", + "e.g. c(bayesR = \"hibayes\")." + )) + } + stray <- setdiff(names(backend), tokens) + if (length(stray) > 0L) { + abort(glue( + "`backend` names methods that are not being run: ", + "{str_flatten(stray, ', ')}." + )) + } + walk(names(backend), .twasCheckOneBackend, backend = backend, path = path) + invisible(NULL) +} + +# One `backend` entry: the method must have several engines on `path`, and +# the entry must name one of them. +# @noRd +.twasCheckOneBackend <- function(token, backend, path) { + choices <- names(.methodBackends[[path]][[token]]) + if (length(choices) == 0L) { + abort(glue( + "`backend`: {token} has one implementation on this input, so ", + "there is no backend to choose." + )) + } + if (!is_in(backend[[token]], choices)) { + abort(glue( + "`backend` for {token} must be one of ", + "{str_flatten(choices, ', ')} on this input." + )) + } + invisible(NULL) +} + +# The pipeline's `backend` choices, added to the arguments of the methods +# they name. Done after the caller's own arguments are checked, which refuse +# a `backend` there. +# @noRd +.twasInjectBackends <- function(methodList, backend) { + if (is.null(backend)) { + return(methodList) + } + reduce( + names(backend), + .twasInjectOneBackend, + backend = backend, + .init = methodList + ) +} + +# @noRd +.twasInjectOneBackend <- function(methodList, token, backend) { + key <- .twasMethodMap[[token]]$fn + methodList[[key]]$backend <- backend[[token]] + methodList +} + # TWAS's phenotype QC: a weight fit cannot take a missing phenotype, so an # unset naAction drops the affected samples and "keep" is refused. # @noRd @@ -2114,6 +2230,7 @@ setMethod( function( data, methods = NULL, + backend = NULL, contexts = NULL, traitId = NULL, cisWindow = NULL, @@ -2141,6 +2258,7 @@ setMethod( res <- .twasPipelineQtlSumStats( data = data, methods = methods, + backend = backend, contexts = contexts, traitId = traitId, cisWindow = cisWindow, @@ -2212,6 +2330,7 @@ setMethod( .twasPipelineQtlSumStats <- function( data, methods, + backend, contexts, traitId, cisWindow, @@ -2228,6 +2347,7 @@ setMethod( # both need, so each names them once. jointCfg <- list( data = inputs$data, + backend = backend, contexts = inputs$contexts, traitId = inputs$traitId, weightsDataType = weightsDataType, @@ -2382,8 +2502,59 @@ setMethod( tm <- .twasSumStatsMethodTokens(methods) .twasCheckMethodCapabilities(tm$tokens, "QtlSumStats") .twasCheckMethodArgsForInput(tm$methodArgs, "QtlSumStats") + .twasCheckBackend(cfg$backend, tm$tokens, "sumstat") + .twasCheckPecotmrLd(cfg$backend, cfg$data) .twasCheckFineMappingMethods(tm$tokens, fineMappingResult, "QtlSumStats") - .twasQssJointPhase(parsedJointSpec, tm$tokens, tm$methodArgs, cfg) + methodArgs <- .twasInjectTokenBackends(tm$methodArgs, cfg$backend) + .twasQssJointPhase(parsedJointSpec, tm$tokens, methodArgs, cfg) +} + +# pecotmr's samplers for the alphabet and LDpred2 read only a genotype +# reference's factor of the LD (.rssFactorOnlyMethods()), so a `backend` +# naming one is refused when any of the input's LD references is an LD +# matrix, before any row runs. The lasso's pecotmr engine reads either. +# @noRd +.twasCheckPecotmrLd <- function(backend, data) { + chosen <- intersect( + names(backend)[backend == "pecotmr"], + .rssFactorOnlyMethods() + ) + if (length(chosen) == 0L) { + return(invisible(NULL)) + } + refs <- ldReference(data) + if (all(map_lgl(refs, .ldIsGenotypeRef))) { + return(invisible(NULL)) + } + abort(glue( + "`backend` = \"pecotmr\" for {str_flatten(chosen, ', ')} reads a ", + "genotype reference's factor of the LD, but this input has an LD ", + "matrix among its LD references." + )) +} + +# The pipeline's `backend` choices added to the summary-statistics methods' +# arguments, which are keyed by method. +# @noRd +.twasInjectTokenBackends <- function(methodArgs, backend) { + if (is.null(backend)) { + return(methodArgs) + } + reduce( + names(backend), + .twasInjectTokenBackend, + backend = backend, + .init = methodArgs + ) +} + +# @noRd +.twasInjectTokenBackend <- function(methodArgs, token, backend) { + methodArgs[[token]] <- list_assign( + as.list(methodArgs[[token]] %||% list()), + backend = backend[[token]] + ) + methodArgs } # Resolve the selected rows, partition tokens into univariate vs multivariate, @@ -2532,19 +2703,28 @@ setMethod( ) } -# The pipeline's fitRetention for a summary-statistics weight function that -# takes one, unless the caller set it for that method; a function without the -# argument keeps no fit. "none" is passed on too, unlike on the -# individual-level path: the fine-mapping adapters here keep a slim fit -# unless told otherwise, so leaving it unset would not drop it. +# The pipeline's fitRetention for a summary-statistics weight function, unless +# the caller set it for that method; every weight method takes one. "none" is +# passed on too, unlike on the individual-level path: the fine-mapping +# adapters here keep a slim fit unless told otherwise, so leaving it unset +# would not drop it. # @noRd -.twasQssRetainArgs <- function(args, fnName, fitRetention) { - if (!is_in("fitRetention", names(formals(fnName)))) { - return(args) - } +.twasQssRetainArgs <- function(args, fitRetention) { list_assign(args, fitRetention = args$fitRetention %||% fitRetention) } +# The retention level of `token`'s TWAS rows. A fine-mapping method's weights +# are extracted from the fineMappingResult's fit, so its rows keep none +# rather than a second copy of it; cTWAS reads it from the fine-mapping +# result. +# @noRd +.twasRowRetention <- function(token, fitRetention) { + if (isTRUE(is_in(token, names(.twasFineMappingMethodAdapters)))) { + return("none") + } + fitRetention +} + # Run a weight function, warning (with `errPrefix`) and returning NULL on error. # @noRd #' @importFrom rlang try_fetch @@ -2810,6 +2990,17 @@ setMethod( list_assign(baseArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) } +# A method with several engines on summary statistics runs a row on the +# pipeline's choice, else on the default for the row's LD reference: set +# here, before the row's options are built with that engine's constructor. +# @noRd +.twasQssRowBackend <- function(userArgs, tk, ldReference) { + if (is.null(.methodBackends$sumstat[[tk]]) || !is.null(userArgs$backend)) { + return(userArgs) + } + list_assign(userArgs, backend = .rssBackend(tk, NULL, ldReference)) +} + # Fit one univariate method for one entry -> a row record, or NULL on skip. # @noRd .twasQssUnivariateFitOne <- function( @@ -2838,11 +3029,12 @@ setMethod( if (is.null(userArgs)) { return(NULL) } + userArgs <- .twasQssRowBackend(userArgs, tk, fitCtx$ldReference) weights <- .twasTryWeights( spec$fn, fitCtx$stat, fitCtx$ldReference, - .twasQssRetainArgs(userArgs, spec$fn, fitRetention), + .twasQssRetainArgs(userArgs, .twasRowRetention(tk, fitRetention)), .twasFitErrUniv(tk, st, ctx, tr) ) if (is.null(weights)) { @@ -3139,15 +3331,15 @@ setMethod( fitRetention, fineMappingResult ) { + rowRetention <- .twasRowRetention(tk, fitRetention) baseArgs <- .twasQssRetainArgs( .twasMrmashRetainDefaults( .twasUserArgs(methodArgs, tk), spec$adapter, tk, - fitRetention + rowRetention ), - spec$fn, - fitRetention + rowRetention ) if (is.null(spec$adapter)) { return(baseArgs) @@ -3293,9 +3485,8 @@ setMethod( ) } -# One row record per context from a fitted multivariate weight matrix. The -# underlying joint fit is shared on the first row only; the remaining rows -# reference it by leaving fits NULL. +# One row record per context from a fitted multivariate weight matrix. Every +# context's row keeps the joint fit, which the collection stores once. # @noRd .twasMvContextRows <- function( weights, @@ -3373,6 +3564,7 @@ setMethod( jointSpecification = NULL, fitRetention = cfg$fitRetention, methods = cfg$methods, + backend = cfg$backend, contexts = .selectedContexts(cfg$contexts, s), traitId = .studyTraitIdArg(cfg$traitId, s), region = cfg$region, @@ -3416,6 +3608,7 @@ setMethod( jointSpecification = NULL, fitRetention = cfg$fitRetention, methods = cfg$methods, + backend = cfg$backend, contexts = NULL, traitId = NULL, cisWindow = cfg$cisWindow, @@ -3462,15 +3655,36 @@ setMethod( } # The methods whose "full" fit keeps more than their "slim" one, on one input -# path: mr.mash's whole fit, and on summary statistics the shrinkage-grid +# path. On summary statistics: mr.mash's whole fit and the shrinkage-grid # methods' candidate coefficients (lassosumRssWeights() and the penalized -# RSS weights). +# RSS weights). On individual-level data: the engines' whole fitted objects, +# where "slim" keeps the selected fit or the posterior summaries (glmnet, +# ncvreg, L0Learn, the Bayesian alphabet), or drops a copy of the data +# (mr.ash, DPR); and mr.mash's whole fit. # @noRd .twasFullDetailTokens <- function(inputKind) { if (identical(inputKind, "QtlSumStats")) { return(c("mrmash", "lasso", "enet", "ridge", "scad", "mcp", "l0learn")) } - "mrmash" + c( + "mrmash", + "lasso", + "enet", + "ridge", + "scad", + "mcp", + "l0learn", + "mrash", + "dprGibbs", + "dprVb", + "dprAdaptiveGibbs", + "bayesA", + "bayesB", + "bayesC", + "bayesL", + "bayesN", + "bayesR" + ) } # ---- MultiStudyQtlDataset pipeline worker + phase helpers ------------------ @@ -3535,6 +3749,7 @@ setMethod( .twasPipelineMultiStudy <- function( data, methods = "default", + backend = NULL, contexts = NULL, traitId = NULL, region = NULL, @@ -3577,8 +3792,9 @@ setMethod( jointRegions, "twasWeightsPipeline(MultiStudyQtlDataset)" ) - cfg <- .twasMsCfg( + cfg <- list( methods = methods, + backend = backend, contexts = parseContexts(contexts, data), traitId = parseTraitIds(traitId, data), region = region, @@ -3623,7 +3839,8 @@ setMethod( } # The MultiStudyQtlDataset joint record, derived from the record the -# per-component recursion receives (`cfg`, .twasMsCfg()): the settings each +# per-component recursion receives (`cfg`, which .twasPipelineMultiStudy() +# builds): the settings each # component's own QtlDataset run fits under (.twasJointCfg()), plus the # collection and the two filters the components apply. Deriving it, rather # than re-listing the settings, keeps the per-study joint fits on exactly the @@ -3736,8 +3953,9 @@ setMethod( } # Run the per-study / per-component recursion via the shared multi-study driver. -# `cfg` is the `.twasMsCfg()` record of the settings each component re-runs -# with. +# `cfg` is the record of the settings each component re-runs with, which +# .twasPipelineMultiStudy() builds and the driver hands to .twasPerStudy / +# .twasSumStats. # @noRd .twasMsDriver <- function(data, jointResult, cfg) { .multiStudyPipelineDriver( @@ -3753,60 +3971,6 @@ setMethod( ) } -# The settings the per-study / per-component recursion re-runs each component -# with, as the record .multiStudyPipelineDriver() hands to .twasPerStudy / -# .twasSumStats. -# @noRd -.twasMsCfg <- function( - methods, - contexts, - traitId, - region, - cisWindow, - jointRegions, - fineMappingResult, - twasWeights, - phenotypeFilterParam, - verbose, - crossValidationParam, - ensembleParam, - seed, - genotypeFilterParam, - panelFilterParam, - mashPrior, - estimatePi, - usePCA, - nPCs, - fitRetention, - weightsDataType, - residualizationParam -) { - list( - methods = methods, - contexts = contexts, - traitId = traitId, - region = region, - cisWindow = cisWindow, - jointRegions = jointRegions, - fineMappingResult = fineMappingResult, - twasWeights = twasWeights, - phenotypeFilterParam = phenotypeFilterParam, - verbose = verbose, - crossValidationParam = crossValidationParam, - ensembleParam = ensembleParam, - seed = seed, - genotypeFilterParam = genotypeFilterParam, - panelFilterParam = panelFilterParam, - mashPrior = mashPrior, - estimatePi = estimatePi, - usePCA = usePCA, - nPCs = nPCs, - fitRetention = fitRetention, - weightsDataType = weightsDataType, - residualizationParam = residualizationParam - ) -} - # ============================================================================= # SR-TWAS ensemble stacking solvers (used by ensembleWeights, the primitive the # engine's .twasEnsembleLayer calls per context) @@ -4531,17 +4695,26 @@ ensembleWeights <- function( .ensembleAccumulateWeights(wtList, wtKeys, matched, zeta) } -# Coerce a weight vector/matrix to a (variants x contexts) matrix. +# Coerce a weight vector/matrix to a (variants x contexts) matrix, a vector's +# names becoming its rownames. # @noRd .ensembleAsMatrix <- function(w) { - if (is.matrix(w)) w else matrix(w, ncol = 1) + if (is.matrix(w)) { + return(w) + } + matrix(w, ncol = 1, dimnames = list(names(w), NULL)) } -# One method's zeta-scaled contribution, or NULL when its weight matrix does -# not line up with the first one's shape. +# One method's zeta-scaled contribution, in the first method's variant order +# (`ids`), or NULL when its weight matrix does not line up with the first +# one's shape. # @noRd -.ensembleWeightTerm <- function(i, wtList, wtKeys, zeta, shape) { - wMat <- .ensembleAsMatrix(wtList[[wtKeys[i]]]) +.ensembleWeightTerm <- function(i, wtList, wtKeys, zeta, shape, ids) { + wMat <- .ensembleAlignWeights( + .ensembleAsMatrix(wtList[[wtKeys[i]]]), + ids, + wtKeys[i] + ) if (!identical(dim(wMat), shape)) { wtKey <- wtKeys[i] msg <- glue( @@ -4554,6 +4727,24 @@ ensembleWeights <- function( zeta[i] * wMat } +# `wMat` in the variant order `ids`, when both name their variants: adding +# by position would add one variant's weight to another's. Weights on other +# variants are refused; unnamed ones can only be taken in the order given. +# @noRd +.ensembleAlignWeights <- function(wMat, ids, key) { + own <- rownames(wMat) + if (is.null(ids) || is.null(own)) { + return(wMat) + } + if (anyDuplicated(own) > 0L || !setequal(own, ids)) { + abort(glue( + "ensembleWeights: the weights of '{key}' are on other variants ", + "than the first method's; give every method the same variants." + )) + } + wMat[ids, , drop = FALSE] +} + # Zeta-weighted sum of the matched weight matrices; univariate -> named vector. # @noRd .ensembleAccumulateWeights <- function(wtList, wtKeys, matched, zeta) { @@ -4568,7 +4759,8 @@ ensembleWeights <- function( wtList = wtList, wtKeys = wtKeys, zeta = zeta, - shape = shape + shape = shape, + ids = rownames(firstWt) )), `+`, .init = matrix( @@ -4758,9 +4950,8 @@ ensembleWeights <- function( .twasCacheLookup(twasWeights, st, ctx, tr, tk) } -# One context row (`kk`) of a fitted multivariate weight matrix. The shared -# joint -# fit rides on the first row only; later rows leave fits NULL. +# One context row (`kk`) of a fitted multivariate weight matrix, with the +# shared joint fit. # @noRd .twasMvContextRow <- function( kk, @@ -4781,7 +4972,7 @@ ensembleWeights <- function( TwasWeightsRow( variantIds = mvStat$variantIds, weights = as.numeric(weights[, kk]), - methodFits = if (kk == 1L) fitAttr else NULL, + methodFits = fitAttr, cvResult = NULL, weightStandardized = TRUE, weightsDataType = weightsDataType diff --git a/R/twasWeightsRow.R b/R/twasWeightsRow.R index ca37ac5ed..58f37563d 100644 --- a/R/twasWeightsRow.R +++ b/R/twasWeightsRow.R @@ -19,11 +19,6 @@ NULL #' @slot cvResult Cross-validation payload, or \code{NULL}. #' @slot weightStandardized Whether the weights are on the standardized scale. #' @slot weightsDataType Optional data-type label. -#' @slot fitVariants The ids of the variants the weights were fitted on, in -#' the fit's own order, recorded when the row is built; empty for a row with -#' no fit payload. A row narrowed to fewer variants keeps them, which is how -#' reading its fits can tell they describe more variants than the row now -#' holds. #' @section Coercion: \code{as(x, "GRanges")} gives the row's variants with #' their \code{weight} column: the element a collection stores for it. #' @seealso \code{\link{TwasWeightsRow}}, @@ -37,16 +32,14 @@ setClass( methodFits = "ANY", cvResult = "ANY", weightStandardized = "logical", - weightsDataType = "ANY", - fitVariants = "character" + weightsDataType = "ANY" ), prototype( weights = NULL, methodFits = NULL, cvResult = NULL, weightStandardized = FALSE, - weightsDataType = NULL, - fitVariants = character(0) + weightsDataType = NULL ) ) @@ -110,7 +103,7 @@ TwasWeightsRow <- function( ) { vids <- as.character(variantIds) gr <- .variantIdsToGRanges(vids, "variantIds") - w <- weights + w <- .unnamedWeights(weights) if (!is.null(w) && is.null(dim(w)) && length(w) != length(gr)) { msg <- glue( "length(weights) is {length(w)} but {length(gr)} variants were ", @@ -129,7 +122,6 @@ TwasWeightsRow <- function( gr, value = `[[<-`(mcols(gr, use.names = FALSE), "weight", value = w) ) - fitted <- length(methodFits) > 0L || !is.null(cvResult) new( "TwasWeightsRow", variants = withWeight, @@ -137,11 +129,29 @@ TwasWeightsRow <- function( methodFits = methodFits, cvResult = cvResult, weightStandardized = isTRUE(weightStandardized), - weightsDataType = weightsDataType, - fitVariants = if (fitted) .grVariantIds(gr) else character(0) + weightsDataType = weightsDataType ) } +# A row saved while rows recorded the variants their weights were fitted on +# carries a `fitVariants` slot; the fits name their variants now, so the slot +# is dropped. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "TwasWeightsRow", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message("updateObject(object = 'TwasWeightsRow')") + } + if (!is.null(attr(object, "fitVariants", exact = TRUE))) { + object <- `attr<-`(object, "fitVariants", NULL) + } + methods::callNextMethod(object, ..., verbose = verbose) + } +) + # ---- field accessors -------------------------------------------------------- @@ -153,7 +163,35 @@ setMethod("variantIds", "TwasWeightsRow", function(x) { #' @rdname weights-methods #' @export -setMethod("weights", "TwasWeightsRow", function(object, ...) object@weights) +setMethod("weights", "TwasWeightsRow", function(object, ...) { + .namedWeights(object@weights, .grVariantIds(object@variants)) +}) + +# Weights as a row stores them: without the variant ids as names, which the +# row's variants already hold -- every id would otherwise be stored a third +# time. A matrix keeps its column labels (conditions, or fSuSiE's features). +# @noRd +.unnamedWeights <- function(w) { + if (is.null(w)) { + return(w) + } + if (is.null(dim(w))) { + return(unname(w)) + } + `rownames<-`(w, NULL) +} + +# Stored weights named by their variants again, as the accessors return them. +# @noRd +.namedWeights <- function(w, ids) { + if (is.null(w)) { + return(w) + } + if (is.null(dim(w))) { + return(if (length(w) == length(ids)) set_names(w, ids) else w) + } + if (nrow(w) == length(ids)) `rownames<-`(w, ids) else w +} #' @rdname methodFits #' @export @@ -163,8 +201,76 @@ setMethod("methodFits", "TwasWeightsRow", function(x) x@methodFits) #' @export setMethod("cvResult", "TwasWeightsRow", function(x) x@cvResult) +# The variants a row's stored fit was made on, read off the fit itself; none +# for a row kept without a fit. +# @noRd +.twRowFitVariants <- function(x) .twasFitVariantIds(x@methodFits) + +# ---- the variants a stored fit was made on ---------------------------------- + +# The variants a TWAS method's stored fit was made on. A fit records them once: +# where its engine already names them, or in the `variantIds` element +# .withFitVariantIds() gives a fit that names none. A row joined from several +# regions stores a list of the regions' fits, whose variants run on in turn. +# None for no fit, or one that names nothing. # @noRd -.twRowFitVariants <- function(x) x@fitVariants +.twasFitVariantIds <- function(fit) { + if (!is.list(fit)) { + return(character(0)) + } + ids <- .twasFitOwnIds(fit) + if (length(ids) > 0L || !all(map_lgl(fit, is.list))) { + return(ids) + } + list_c(map(unname(fit), .twasFitOwnIds), ptype = character()) +} + +# One fit's variants: its `variantIds`, else where its engine names them -- +# glmnet's and ncvreg's coefficient paths, qgg's and BGLR's effect vectors, +# mr.ash's and DPR's copies of the genotypes, a SuSiE-family fit's own names. +# @noRd +.twasFitOwnIds <- function(fit) { + ids <- fit[["variantIds"]] %||% + rownames(pluck(fit, "glmnet.fit", "beta")) %||% + .twasNcvregFitIds(fit) %||% + names(fit[["bm"]]) %||% + names(pluck(fit, "ETA", 1L, "b")) %||% + colnames(pluck(fit, "data", "X")) %||% + colnames(fit[["x"]]) + if (is.null(ids)) { + return(.fitNamedVariants(fit)) + } + as.character(ids) +} + +# ncvreg names its coefficient path's rows, the intercept's among them. +# @noRd +.twasNcvregFitIds <- function(fit) { + ids <- rownames(pluck(fit, "fit", "beta")) + ids[ids != "(Intercept)"] +} + +# `fit` naming the variants it was made on: as it is when its engine already +# names them (or it is no list to name them in, or there are no ids to give +# it), else with `ids` as one `variantIds` element -- a single copy, however +# many per-variant values the fit holds. +# @noRd +.withFitVariantIds <- function(fit, ids) { + if (!is.list(fit) || is.null(ids) || length(.twasFitOwnIds(fit)) > 0L) { + return(fit) + } + `[[<-`(fit, "variantIds", value = as.character(ids)) +} + +# Weights `w` with the fit they carry, if any, naming its variants. +# @noRd +.withWeightsFitIds <- function(w, ids) { + fit <- attr(w, "fit", exact = TRUE) + if (is.null(fit)) { + return(w) + } + `attr<-`(w, "fit", .withFitVariantIds(fit, ids)) +} #' @rdname weightStandardized #' @export diff --git a/R/variantId.R b/R/variantId.R index 306fbae50..fe46cf96f 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -78,6 +78,16 @@ withChrPrefix <- function(x) { # @noRd .STANDARD_CHROMS <- c(as.character(seq_len(22L)), "X", "Y", "MT") +# Allele letters in upper case, the one spelling pecotmr holds, as UCSC style +# is for chromosomes: every allele that enters -- read from a file, parsed +# from a variant id, or given in a constructor's table -- comes through here +# once, so alleles and the ids rendered from them compare exactly. Allele +# fields only: a variant label such as an rsID keeps its file's spelling. +# @noRd +.canonAllele <- function(x) { + str_to_upper(as.character(x)) +} + # `gr` with its chromosomes in UCSC style, for ranges entering from outside: # a constructor's ranges, a range argument. Strand, metadata columns and the # genome build are kept, and ranges already in UCSC style come back as they @@ -109,11 +119,38 @@ withChrPrefix <- function(x) { .withGenome(out, .oneBuild(gr)) } -# A collection constructor's `entry` list with every element's chromosomes in -# UCSC style; a NULL element stays NULL. +# A collection constructor's `entry` list in pecotmr's one spelling: every +# element's chromosomes in UCSC style and its alleles in upper case; a NULL +# element stays NULL. +# @noRd +.canonEntries <- function(entry) { + map(map(as.list(entry), .ucscRanges), .canonAlleleMcols) +} + +# `gr` with its A1 / A2 metadata columns in upper case. Anything but ranges +# carrying them passes through. +# @noRd +.canonAlleleMcols <- function(gr) { + if (!methods::is(gr, "GenomicRanges")) { + return(gr) + } + mc <- S4Vectors::mcols(gr) + cols <- intersect(c("A1", "A2"), colnames(mc)) + if (length(cols) == 0L) { + return(gr) + } + S4Vectors::`mcols<-`( + gr, + value = reduce(cols, .withCanonAlleleCol, .init = mc) + ) +} + +# `tbl` with allele column `nm` in upper case. `value =` named: tibble's +# `[[<-` method carries an extra `j` formal, so a third POSITIONAL argument +# binds to `j` and the write silently misfires. # @noRd -.ucscEntries <- function(entry) { - map(as.list(entry), .ucscRanges) +.withCanonAlleleCol <- function(tbl, nm) { + `[[<-`(tbl, nm, value = .canonAllele(tbl[[nm]])) } # A context or genotype experiment with its rowRanges in UCSC style, so a @@ -133,6 +170,22 @@ withChrPrefix <- function(x) { ) } +# An experiment in pecotmr's one spelling: rowRanges in UCSC style and, for a +# genotype panel, its A1 / A2 columns in upper case. A panel read by pecotmr +# is already so; one built outside it may not be. +# @noRd +.canonExperiment <- function(se) { + ucsc <- .ucscExperiment(se) + if (!methods::is(ucsc, "RangedSummarizedExperiment")) { + return(ucsc) + } + rr <- SummarizedExperiment::rowRanges(ucsc) + if (!any(is_in(c("A1", "A2"), colnames(S4Vectors::mcols(rr))))) { + return(ucsc) + } + SummarizedExperiment::`rowRanges<-`(ucsc, value = .canonAlleleMcols(rr)) +} + #' Order key for chromosome identifiers. #' #' Returns an ordered factor placing autosomes 1..22 first, then X, Y, XY, MT, @@ -280,7 +333,12 @@ detectVariantConvention <- function(ids) { # Detect allele separator: check if variant uses underscores between allele # fields This catches both full underscore ("1_100_A_G") and mixed # ("chr1:100_A_G") formats - alleleSep <- if (str_detect(idClean, "_[ATCGID*]+_[ATCGID*]+$")) { + alleleSep <- if ( + str_detect( + idClean, + regex("_[ATCGID*]+_[ATCGID*]+$", ignore_case = TRUE) + ) + ) { "_" } else { ":" @@ -329,8 +387,8 @@ parseVariantId <- function(ids) { data <- tibble( chrom = withChrPrefix(m[, 2L]), pos = as.integer(m[, 3L]), - A2 = m[, 4L], - A1 = m[, 5L] + A2 = .canonAllele(m[, 4L]), + A1 = .canonAllele(m[, 5L]) ) `attr<-`(data, "convention", convention) } @@ -345,15 +403,21 @@ parseVariantId <- function(ids) { str_match(normalized, "^([^:]+):([^:]+):([^:]+):([^:]+)") } -# `[[<-` rather than mutate(): callers hand this frame straight through from -# a user-supplied table, which may carry NA or "" column names -- and -# dplyr refuses to transform such a frame at all. +# The variant key of a table in pecotmr's spelling: chromosome in UCSC style, +# integer position, alleles in upper case. `[[<-` rather than mutate(): +# callers hand this frame straight through from a user-supplied table, which +# may carry NA or "" column names -- and dplyr refuses to transform such a +# frame at all. # @noRd -.withCanonicalCoords <- function(ids) { +.withCanonicalKey <- function(ids) { # `value =` named: tibble's `[[<-` method carries an extra `j` formal, so a # third POSITIONAL argument binds to `j` and the write silently misfires. coerced <- `[[<-`(ids, "chrom", value = withChrPrefix(ids$chrom)) - `[[<-`(coerced, "pos", value = as.integer(ids$pos)) + reduce( + intersect(c("A2", "A1"), names(coerced)), + .withCanonAlleleCol, + .init = `[[<-`(coerced, "pos", value = as.integer(ids$pos)) + ) } # Parse a data.frame of already-split ids: resolve the 4 identity columns @@ -382,7 +446,7 @@ parseVariantId <- function(ids) { hasBuild = FALSE, example = NA_character_ ) - `attr<-`(.withCanonicalCoords(named), "convention", conv) + `attr<-`(.withCanonicalKey(named), "convention", conv) } #' Format variant ID strings from component columns @@ -399,8 +463,8 @@ parseVariantId <- function(ids) { #' #' @param chrom Integer or character chromosome (e.g., 1 or "chr1"). #' @param pos Integer position. -#' @param A2 Character reference allele. -#' @param A1 Character alternate/effect allele. +#' @param A2 Character reference allele (written in upper case). +#' @param A1 Character alternate/effect allele (written in upper case). #' @param chrPrefix Logical. \code{TRUE} (default) spells the chromosome in UCSC #' style (\code{chr1}, \code{chrX}, \code{chrM}); \code{FALSE} writes it #' bare (\code{1}, \code{X}, \code{MT}). Ignored if \code{convention} is @@ -443,7 +507,17 @@ formatVariantId <- function( labels <- unique(chrom) canonChrom(labels)[match(chrom, labels)] } - str_c(chromOut, ":", pos, alleleSep, A2, alleleSep, A1) + # Alleles upper case as everywhere in pecotmr, so an id rendered from a + # file's lowercase alleles names the variant as the parsed one does. + str_c( + chromOut, + ":", + pos, + alleleSep, + .canonAllele(A2), + alleleSep, + .canonAllele(A1) + ) } #' Re-format variant IDs to a chosen output convention @@ -518,12 +592,12 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { } # The ids normalizeVariantId() returns unchanged in its default convention: a -# UCSC chromosome, a position without leading zeros, and two alleles, with -# no build suffix and no underscore. +# UCSC chromosome, a position without leading zeros, and two alleles in upper +# case (.canonAllele()), with no build suffix and no underscore. # @noRd .CANONICAL_VARIANT_ID <- str_c( "^chr(1[0-9]|2[0-2]|[1-9]|X|Y|M)", - ":[1-9][0-9]*:[^:_]+:[^:_]+$" + ":[1-9][0-9]*:[^:_a-z]+:[^:_a-z]+$" ) # Complement a DNA allele string (A<->T, C<->G) for strand flipping. @@ -564,13 +638,13 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { #' frequency like \code{af}. Default \code{character()} does no complementing, #' so non-RSS callers are unchanged. Distinct from \code{colToFlip}: #' frequencies are complemented, signed effects are sign-flipped. -#' @param matchMinProp Minimum proportion of variants in the smallest data to be -#' matched, otherwise stops with an error. Default is 20%. -#' @param removeDups Whether to remove duplicates, default is TRUE. +#' @param matchMinProp The harmonized result must hold at least this +#' proportion of \code{refVariants}' rows, otherwise it stops with an +#' error. Default is 20%. +#' @param removeDups Whether to drop duplicate (chrom, pos, variant ID) rows +#' after matching, keeping the first with a warning. Default is +#' \code{FALSE}; duplicates that remain are an error. #' @param removeIndels Whether to remove INDELs, default is FALSE. -#' @param flip Whether the alleles must be flipped: A <--> T & C <--> G, in -#' which case corresponding `colToFlip` are multiplied by -1. Default is -#' `TRUE`. #' @param removeStrandAmbiguous Whether to drop a strand-ambiguous match (A/T #' or C/G alleles, where a strand flip and an allele swap look the same). #' Each target-reference pair is judged on its own, whatever else is being diff --git a/_pkgdown.yml b/_pkgdown.yml index 69040be7b..128ff156d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -442,7 +442,6 @@ reference: - heritabilityEstimateSe - heritabilityIntercept - heritabilityInterceptSe - - localH2Blocks - methodNames - nSnps - scoreStats @@ -657,9 +656,17 @@ reference: - bayesLWeights - bayesNWeights - bayesRWeights - - bLassoWeights + - bayesAlphabetRssWeights + - bayesARssWeights + - bayesBRssWeights + - bayesCRssWeights + - bayesLRssWeights + - bayesNRssWeights + - bayesRRssWeights - prsCsWeights - sdprWeights + - ldpred2AutoWeights + - ldpred2GridWeights - dprWeights - subtitle: "mr.mash / mr.ash" diff --git a/data/ctwasEstExample.rda b/data/ctwasEstExample.rda index d4c11e0626129bd1ee97e35a63b43591bc20d82d..0eaf6bf7ea826204be3e4b466400fffbeac4ed0e 100644 GIT binary patch delta 101109 zcmV(rK<>ZTjt{)J29Ov9;p*@2|FIoX6n|HOzTLEJD6UZtHhdL0hp#3yBtyd5M-2)F zmiAFgpW5_$pn;{#1Fx_MqEB68kSaa*>noh|BCk4y^jQI`)qsSs&8_;V^dkE<67@2360iX zmo2AQm!_?husm+*q1m!Zhh5HrSq~8X1aL%!sP;zeAlGIwRI!k_r;`4wMdo@AbTl->r?RYLP8Jc{5>P*-kq5Lw7DmUT3aM!!x^rs zkW2ptw``UO^>0Fdo>+*HIDePW%HtjgK!IqdcAaTs^2$WtDU&OVa#8(&?Hu~YwDD4d z5|Jc$Vt>GX*8h`N_ch@EI;wWBRni&I*adC93Bl&ekpD-b1i}opPK(n|_Zc%(gGVJp z&PWvl=y&A;2@5hKzg#n;yUr}#@~JTYJfKDF>_2AZtJcZ(H}x9-5PvP4H~VCvsh z8G(O0z4K3_M*}AI;klVb_gKv93QPpLE=sh!pcpW4^SqY>k86OC@qD+d(t$%_|c1ajotl6Y9V5$pJ z!l^$0D(Huk;g6Lj!>BiGF-!GXolmpQA^#8miCrpN=nZ*nT`RN2`L)^V+X&2WT}WqL z*2ZKd)s;*l$l&4k*$C(`27E8&hW2+mA$177EG9-f67$QSU0#jr@=_}ix=%|B>h9h@ z?d49Qgs(ke;eVoAKBlk&J^t&r1<*Zj09UIHALC443L9AGEYp%d!(fO<9j<-?uip1) z)~E?#&WW-*R6qsKmBy@Q%g!igg1DdOWwjX(Zk35z!RSo34rytatlbP}9iv~u{aXZk z7M-uT0?(hDgcG+9fh`7MPSZ_Oj5yHT)hJTApP+QX!+(X6HX>oHj1^jueILSi1OZ#+ zBI8_z6`+5r*naV|7ykf+g)yTT)nAsJ55=MBhfhf2?a9lJe6>)m-;=oR|7s0sMf5zPg2dtNDuz$6la-?z&7(+nlXw$i4;ALqtE6LfYQ-9E-&FVH556cY}HZu zF?*a@HaBeo|6Vse0hZ&#t=5GW$m~4>qdXwK^M7>r$xbyA5ngFQ9??Qx^upK!%M#79 zuP7WSmDR-_qvd@=Uy8!FBHrk6m%|0%PNEelvqAH#RWg?eSC&!iB=sElR5B6N{yH61 z&^&-Qp&fo_;B3?a&|G@zJmN-m)kWKHJz}@rqydUuBuk(VG)YnL?`_>Vqy?no@}Dc7 zHGe$c%;d>SpnW~q)~c^F?k$MUv?Q#2APn;1y+w;se@sOU5Abh|&&kmpp0tZ#2zXu! zG01Q1t8j~jWXm~7215u;sD0k_7%JpvsDi|35a5s(qW={KOmN}6y**9KbR!EZGq}fI z5Y1$!HyZZvW;ZGSeah2>9$k7|>RRstrkxr~57h0lXnFb!?z zURX_BTvi^v5Y#Ss9I8`dIsRyIJ4%99Lu7kaN{jtQNA`G7)lxeGA3I`Zn85RDw%X>& zZx%+5XBO&3U_$k&Ho3TaJeP#}JuGY^7N+i*-E)hF&H}LhNBY(DBc?7ua6rD`ApPaY^^HH;wHeu~&lni6&{$RBd z=Vu(8YVc~E>KVqR59CJGF6xfd@M%SH(uH4ogeRIuv+8}h{hEZ$=N-V=k2ns4Y5!1F zW@8PNAt32hpmh{PzI&Jniy3g#)&qB|@I~6OeF)~SkJi`^+unx3K?rxCs(+dlb=hm6 z(o5iDLJ5_Z7lYD#NF{BtZWb3aS$moX!DDxh`uHPn=U10=yPg)2t1dH={=&|j!BgLu z<=_Dg7on1bNJ_g{+?`ZxbA0A{6zqm^oPuX5CtBsiS^NM#Dx!lum35t@6K*a--!Yfm3fxHCG^q_4(33 z2`o!5GpEONFU^g#g-2>;zH*0--PE)fuLm5oo{rTuZZc;_|P$Pa!2MZa@4>4Rl@)u8%SPJFnHZ z8dkoAIyed2|B1_f*kl&q9Ly2xO%;ax43A;rQolj_62Aa4I$`7x4 zaDq$Bfq=`I2fN*aaS~x0E3{L}G7^_iG_oH-kaoFds(-GUJyo&h**XhsS?4&Y9ieD# zUhhWvYozoWtGOzh8@oPzjv}GCN)2DvCZtM|KANUJeALTYQ}0Jou2KKL3J#6FbY%Bc zjN48rFQUA}M--!=+Q-);%Or$lx6=dg0IRp_rS!Tp=2C0Z7%zC!MMYQuP^Mm-qRvyN z`ERnQz#DZBTJPw zEJ5kKnu=`mJ8=aLqz3gAWEHDB_nB#Z-}rX@seh^TLVgaPGdHpOda&5{RAF2!^A!%e z$)DP>vt*9gA1_G;!2Rs{_YVM`C!;dr=nD9X+Xx3AL8GzH98d zdFG&*q36oK`gFT+WxCEBYoHos-Oc6L-+V|5)8*pjKLgrQJM-7~q3>X!BR7~qV*3#q z-AJ&!uI|GH=T^22U(0_BnTVJvB!)064~R1Y zVL+~iWOa!k{LwS}#Du^b&KxVB{j67yNOMl~| zWgYbOd|JnJb2UWW^rm8b-;CCFCU