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/environment/pixi.toml b/.github/environment/pixi.toml index e6c463477..82986a885 100644 --- a/.github/environment/pixi.toml +++ b/.github/environment/pixi.toml @@ -14,7 +14,7 @@ codecov = "cd $GITHUB_WORKSPACE; R -e 'covr::codecov(quiet = FALSE)'" rcmdcheck = "cd $GITHUB_WORKSPACE; R -e 'rcmdcheck::rcmdcheck(error_on = \"error\", args = c(\"--no-manual\", \"--no-build-vignettes\"))'" bioccheck_git_clone = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheckGitClone(\"quit-with-status\" = TRUE)'" bioccheck = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheck(\"quit-with-status\" = FALSE)'" -goodpractice = "cd $GITHUB_WORKSPACE; R -e 'goodpractice::gp(\".\")'" +goodpractice = "cd $GITHUB_WORKSPACE; R -e 'goodpractice::gp(\".\", checks = stringr::str_subset(goodpractice::all_checks(), \"^(covr|rcmdcheck_)\", negate = TRUE))'" use_major_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"major\", push = FALSE)'" use_minor_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"minor\", push = FALSE)'" use_patch_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"patch\", push = FALSE)'" 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..78677a385 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,6 @@ Encoding: UTF-8 Type: Package Package: pecotmr Version: 0.9.4 -Date: 2026-02-28 Title: Post-GWAS enrichment, colocalization, TWAS and Mendelian Randomization to integrate molecular QTL and GWAS Description: The majority of the statistical models in pecotmr are based on fine-mapped single effects described in Wang G et al (2020) JRSS-B. It also incorporates wrappers to a series of useful TWAS methods as well as utility functions for QTL and GWAS integration. URL: https://statfungen.github.io/pecotmr, https://github.com/StatFunGen/pecotmr @@ -12,7 +11,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 +51,7 @@ Imports: Rsamtools, S4Arrays, S4Vectors, + SparseArray, stringr, SummarizedExperiment, susieR (>= 0.16.4), @@ -74,6 +75,7 @@ Suggests: ctwas, DBI, ebnm, + fdrtool, flashier, fsusieR, GBJ, @@ -81,6 +83,7 @@ Suggests: gdsfmt, glmnet, harmonicmeanp, + hibayes, igraph, knitr, L0Learn, @@ -138,8 +141,6 @@ Collate: 'CtwasResult.R' 'GenotypeDosageSeed.R' 'GwasFineMappingResult.R' - 'MethodOptions.R' - 'MethodParam.R' 'H2Estimate.R' 'JointGroup.R' 'LdBlocks.R' @@ -147,6 +148,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..e25866c44 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, @@ -817,11 +841,13 @@ importFrom(stats, optimize, pcauchy, pchisq, + pf, pnorm, predict, pt, qnorm, quantile, + rnorm, sd, setNames, var @@ -874,7 +900,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..2cf21c934 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. @@ -107,7 +119,8 @@ methods::setValidity("SumStatsBase", function(object) { md <- mcols(object) tupleKey <- map(tupleCols, .ssKeyColumn, md = md) rangeKey <- .keyEmptyElements(object, .rtlRangeKeys(object)) - keys <- exec(str_c, !!!c(tupleKey, list(rangeKey)), sep = "|") + keyParts <- c(tupleKey, list(rangeKey)) + keys <- exec(str_c, !!!keyParts, sep = "|") anyDuplicated(keys) > 0L } @@ -164,6 +177,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 +673,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 +688,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 +1194,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 +1228,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 +1307,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 +1512,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 +1524,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 +1659,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 +1943,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..ca0db0b5a 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,94 @@ 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( - S4Vectors::DataFrame, - !!!c(as.list(v[keep]), list(check.names = FALSE)) + 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" ) - S4Vectors::`mcols<-`( - gr, - value = cbind(mcols(gr, use.names = FALSE), extra) + 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)) + dataFrameArgs <- c( + as.list(pairs[groups$first, shared, drop = FALSE]), + list(check.names = FALSE) + ) + md <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) + # 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" + ) + dataFrameArgs <- c( + as.list(pairs[ord, own, drop = FALSE]), + set_names( + map(perVariant, .crPerVariantList, tables = tables[ord]), + perVariant + ), + list(check.names = FALSE) + ) + flat <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) + 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 +391,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 +401,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 +551,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 +616,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 +624,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 +747,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 +808,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 +837,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 +885,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..eea7bebbb 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]] @@ -189,19 +231,17 @@ CtwasResult <- function( walk2(names(supplied), supplied, .ctwasCheckJointColLength, n = n) entries <- as.list(entry) walk(seq_along(entries), .ctwasAssertEntry, entries = entries) - identity <- exec( - S4Vectors::DataFrame, - !!!c( - list( - gwasStudy = as.character(gwasStudy), - study = as.character(studyName), - context = as.character(context), - method = as.character(method) - ), - map(supplied, as.character), - list(check.names = FALSE) - ) + dataFrameArgs <- c( + list( + gwasStudy = as.character(gwasStudy), + study = as.character(studyName), + context = as.character(context), + method = as.character(method) + ), + map(supplied, as.character), + list(check.names = FALSE) ) + identity <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) .withMetadata( .ctwasNewResult(identity, map(entries, .ctwasSplitRun)), metadata @@ -323,16 +363,14 @@ CtwasResult <- function( reps <- rep(seq_along(runs), map_int(runs, .ctwasRunSize)) pieces <- c("susieAlpha", "regionInfo", "groupPriors") payload <- set_names(map(pieces, .ctwasPayloadColumn, runs = runs), pieces) + dataFrameArgs <- c( + list(blockId = list_c(map(runs, "blockId")) %||% character(0)), + payload, + list(check.names = FALSE) + ) md <- cbind( identity[reps, , drop = FALSE], - exec( - S4Vectors::DataFrame, - !!!c( - list(blockId = list_c(map(runs, "blockId")) %||% character(0)), - payload, - list(check.names = FALSE) - ) - ) + exec(S4Vectors::DataFrame, !!!dataFrameArgs) ) elements <- list_flatten(map(runs, "elements")) grl <- S4Vectors::`mcols<-`(.rtlBindElements(unname(elements)), value = md) @@ -406,7 +444,8 @@ setMethod("contexts", "CtwasResult", function(x) { if (length(parts) == 0L) { return(GenomicRanges::GRanges()) } - ranges <- exec(c, !!!map(unname(parts), GenomicRanges::granges)) + partRanges <- map(unname(parts), GenomicRanges::granges) + ranges <- exec(c, !!!partRanges) out <- S4Vectors::`mcols<-`( ranges, value = S4Vectors::DataFrame( @@ -429,6 +468,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..02d0580a8 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -133,14 +133,13 @@ setMethod("show", "GenotypeHandle", function(object) { #' @param pgen,pvar,psam Explicit paths to the PLINK2 triplet, or all #' \code{NULL}. #' @param ldMeta Path to an LD-meta TSV file (columns \code{chrom}, -#' \code{start}, \code{end}, \code{path}; the \code{path} column may be -#' comma-separated as \code{ld_file,bim_file}). Requires \code{block}. The -#' constructor resolves the row covering \code{block}, then delegates to the -#' appropriate file-based handler. When the resolved row points at PLINK2 -#' or BGEN files, the corresponding reader is used; a row pointing -#' at a pre-computed LD matrix (\code{.cor.xz}) is refused, as pecotmr reads -#' no pre-computed LD from disk -- wrap such a matrix in an -#' \code{\link{LdMatrix}} instead. +#' \code{start}, \code{end}, \code{path}, each path a genotype file). +#' Requires \code{block}. The constructor resolves the row covering +#' \code{block}, then delegates to the appropriate file-based handler. When +#' the resolved row points at PLINK2 or BGEN files, the corresponding reader +#' is used; a row pointing at a pre-computed LD matrix (\code{.cor.xz}) is +#' refused, as pecotmr reads no pre-computed LD from disk -- wrap such a +#' matrix in an \code{\link{LdMatrix}} instead. #' @param block The \code{GRanges} window to look up in \code{ldMeta}; the #' whole file of the row covering it is opened. #' @param genoMeta One-file-per-chromosome specification: a path to a @@ -285,7 +284,7 @@ GenotypeHandle <- function( # erroring on no-coverage, multi-row spans, or a pre-computed .cor(.xz) matrix. # @noRd .ghResolveLdPath <- function(ldMeta, region) { - ldPaths <- regionalLdMeta(ldMeta, region)$intersections$LD_file_paths + ldPaths <- regionalLdMeta(ldMeta, region)$intersections$paths if (length(ldPaths) == 0L) { regionStr <- str_flatten(as.character(region), ", ") msg <- glue( @@ -832,9 +831,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 +863,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 +887,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 +914,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..875470213 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.") } @@ -217,7 +217,8 @@ GenotypeMixture <- function(panels, mixtureWeights) { # One row per sample of every panel, recording its cohort. # @noRd .gmColData <- function(experiments) { - exec(rbind, !!!unname(imap(experiments, .gmColDataPart))) + colDataParts <- unname(imap(experiments, .gmColDataPart)) + exec(rbind, !!!colDataParts) } # @noRd @@ -232,7 +233,8 @@ GenotypeMixture <- function(panels, mixtureWeights) { # The sampleMap: each panel's samples under their cohort-prefixed names. # @noRd .gmSampleMap <- function(experiments) { - exec(rbind, !!!unname(imap(experiments, .gmSampleMapPart))) + sampleMapParts <- unname(imap(experiments, .gmSampleMapPart)) + exec(rbind, !!!sampleMapParts) } # @noRd @@ -311,6 +313,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()). @@ -380,14 +394,17 @@ setMethod("show", "GenotypeMixture", function(object) { # panel's allele coding relative to the first's. # @noRd .gmSign <- function(x) { - exec(cbind, !!!unname(map(.gmComponents(x), .gmComponentSign))) + componentSigns <- unname(map(.gmComponents(x), .gmComponentSign)) + exec(cbind, !!!componentSigns) } # The mixture's variants: the first panel's ranges, with the SNP / A1 / A2 # 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 +440,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 } @@ -442,9 +460,11 @@ setMethod("show", "GenotypeMixture", function(object) { needMissing = needMissing, step = step ) + mafs <- unname(map(each, "maf")) + missRates <- unname(map(each, "missRate")) list( - maf = exec(pmin, !!!unname(map(each, "maf"))), - missRate = if (needMissing) exec(pmax, !!!unname(map(each, "missRate"))) + maf = exec(pmin, !!!mafs), + missRate = if (needMissing) exec(pmax, !!!missRates) ) } @@ -484,11 +504,12 @@ setMethod("show", "GenotypeMixture", function(object) { # @noRd .gmFactor <- function(x, idx) { blocks <- map(seq_along(.gmComponents(x)), .gmFactorBlock, x = x, idx = idx) - stacked <- exec( - rbind, - !!!blocks, - !!!map2(blocks, unname(mixtureWeights(x)), .gmMonomorphicRows) + monomorphicRows <- map2( + blocks, + unname(mixtureWeights(x)), + .gmMonomorphicRows ) + stacked <- exec(rbind, !!!blocks, !!!monomorphicRows) stacked * sqrt(nrow(stacked) - 1) } 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..1b726735d 100644 --- a/R/H2Estimate.R +++ b/R/H2Estimate.R @@ -1,74 +1,175 @@ # ============================================================================= # 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) { + dataFrameArgs <- c(values, map(objects, I), list(check.names = FALSE)) + md <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) + 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 +177,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 +276,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 +287,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 +345,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..458f92e66 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) } @@ -527,7 +522,7 @@ setMethod( if (!is.null(block$eigen)) { return(block$eigen[c("vectors", "values")]) } - list(F = .ldRefFactor(ldReference, block$rows)) + list(ldFactor = .ldRefFactor(ldReference, block$rows)) } # A block's eigendecomposition, keeping the leading components that carry diff --git a/R/MethodOptions.R b/R/MethodOptions.R index 786feca76..673f26740 100644 --- a/R/MethodOptions.R +++ b/R/MethodOptions.R @@ -72,6 +72,12 @@ NULL #' @export setClass("MethodOptions", contains = "SimpleList") +# A record is spliced into an engine call as a list bound on the line before +# -- `user <- as.list(record)`, then `!!!user` -- 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 +228,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 @@ -456,7 +462,8 @@ setClass("MethodOptions", contains = "SimpleList") # error rather than a silent override. # @noRd .methodOptionsWith <- function(x, ctor, ...) { - exec(match.fun(ctor), ..., !!!as.list(x)) + settings <- as.list(x) + exec(match.fun(ctor), ..., !!!settings) } # --- character-or-constructor selection ------------------------------------ diff --git a/R/MethodParam.R b/R/MethodParam.R index 42d60062a..1c8eab5a5 100644 --- a/R/MethodParam.R +++ b/R/MethodParam.R @@ -543,7 +543,8 @@ setValidity("MethodsSelectionParam", function(object) { merged <- shared for (nm in names(own)) { merged[[nm]] <- if (is.list(own[[nm]]) && is.list(shared[[nm]])) { - list_modify(shared[[nm]], !!!own[[nm]]) + ownSettings <- own[[nm]] + list_modify(shared[[nm]], !!!ownSettings) } else { own[[nm]] } @@ -904,11 +905,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 +960,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 +979,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..ecf0095db 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, @@ -596,7 +597,8 @@ setMethod("longForm", "QtlDataset", function(object, ..., genotype = FALSE) { # @noRd .qtlSampleMap <- function(experiments) { parts <- imap(experiments, .qtlSampleMapPart) - exec(rbind, !!!unname(parts)) + sampleMapParts <- unname(parts) + exec(rbind, !!!sampleMapParts) } # One experiment's slice of the sampleMap. @@ -1401,8 +1403,9 @@ CovMcdOptions <- function(...) { inform(msg) return(fallback) } + user <- as.list(outlierArgs) mcd <- try_fetch( - exec(robustbase::covMcd, Y, !!!as.list(outlierArgs)), + exec(robustbase::covMcd, Y, !!!user), error = function(cnd) { msg <- glue( "outlier detection: robustbase's MCD estimator failed; ", 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..6c00b672f 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -286,7 +286,8 @@ setMethod("genomicRegion", "RangedTupleList", function(x) { if (length(cols) == 0L || length(grl) == 0L) { return(NULL) } - parts <- exec(cbind, !!!map(cols, .rtlNameColumn, md = md)) + namedCols <- map(cols, .rtlNameColumn, md = md) + parts <- exec(cbind, !!!namedCols) keys <- apply(parts, 1L, .rtlJoinNameParts) shared <- is_in(keys, keys[duplicated(keys)]) if (!any(shared)) { @@ -331,7 +332,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 +357,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 +429,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 +546,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 +793,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 +811,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 +870,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 } # ----------------------------------------------------------------------------- @@ -804,7 +887,8 @@ setMethod( # @noRd .rtlGrlWithMetadata <- function(payloads, cols) { split <- .rtlSplitBySeqname(map(payloads, variants)) - md <- exec(S4Vectors::DataFrame, !!!c(cols, list(check.names = FALSE))) + dataFrameArgs <- c(cols, list(check.names = FALSE)) + md <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) S4Vectors::`mcols<-`( .rtlBindElements(split$entry), value = md[split$fromIdx, , drop = FALSE] @@ -819,16 +903,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 +1035,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 +1062,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 +1071,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 +1470,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 +1493,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 +1505,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 +1555,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 +1581,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 +1683,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 @@ -1477,7 +1700,8 @@ nestTupleRanges <- function(flat, template) { if (length(present) == 0L) { return(rep("", n)) } - exec(str_c, !!!map(present, .rtlKeyPart, md = md), sep = "\r") + keyParts <- map(present, .rtlKeyPart, md = md) + exec(str_c, !!!keyParts, sep = "\r") } # NA is mapped to a sentinel rather than left alone: str_c() propagates NA, so @@ -1609,10 +1833,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..ff1c8dc16 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 @@ -1310,9 +1312,11 @@ colocPipeline <- function( sm <- .colocRenameNsnps( as.data.frame(pairRes$summary, stringsAsFactors = FALSE) ) + identityCols <- .colocRowIdentity(q, gInfo) + enrichmentCols <- .colocEnrichmentCols(useEnrichment, p12Info) mutate( sm, - !!!.colocRowIdentity(q, gInfo), + !!!identityCols, # idx1 / idx2 index the LBF rows handed to coloc.bf_bf, which is # exactly what retainedMass runs parallel to -- so the mass reported # here is the mass of the two effects this row actually scores, not a @@ -1343,7 +1347,7 @@ colocPipeline <- function( fill = NA_integer_ ), blockId = gInfo$blockId %||% NA_character_, - !!!.colocEnrichmentCols(useEnrichment, p12Info) + !!!enrichmentCols ) } @@ -1433,8 +1437,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 +1495,7 @@ colocPipeline <- function( if (ncol(lbfMatrix) == 0L) { return(NULL) } + effectIndex <- .fitEffectIndex(fit, nrow(allRows)) list( lbf = lbfMatrix, variantIds = colnames(lbfMatrix), @@ -1497,10 +1503,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 +1564,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( @@ -1760,9 +1770,10 @@ colocPipeline <- function( map_chr(recs, "blockId"), unlist(.rtlBindElements(map(recs, "region"))) ) + paddedLbf <- map(recs, .colocPadLbf, ids = ids) list_assign( recs[[1L]], - lbf = exec(rbind, !!!map(recs, .colocPadLbf, ids = ids)), + lbf = exec(rbind, !!!paddedLbf), retainedMass = list_c(map(recs, "retainedMass")), effect = list_c(map2(recs, offsets, .colocShiftEffects)), nEffects = sum(map_int(recs, "nEffects")), @@ -1878,7 +1889,8 @@ colocPipeline <- function( qtlRetainedMass = numeric(0), gwasRetainedMass = numeric(0) ) - ColocResult(mutate(base, !!!.colocEnrichmentCols(enriched, NULL)), list()) + enrichmentCols <- .colocEnrichmentCols(enriched, NULL) + ColocResult(mutate(base, !!!enrichmentCols), list()) } # Look up this pair's enrichment factor in the user-supplied enrichment table. @@ -1974,7 +1986,8 @@ colocPipeline <- function( ), colnames(sm) ) - mutate(sm, !!!set_names(map(missing, .colocMissingColumn), missing)) + missingCols <- set_names(map(missing, .colocMissingColumn), missing) + mutate(sm, !!!missingCols) } # @noRd diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index f3fca1a38..c4e0d8600 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -945,12 +945,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { variant = keptIds, stringsAsFactors = FALSE ) - mutate( - ss, - !!!compact(list( - var_y = if (!is.null(varY) && !is.na(varY)) varY - )) - ) + varYCol <- compact(list( + var_y = if (!is.null(varY) && !is.na(varY)) varY + )) + mutate(ss, !!!varYCol) } # Resolve a sumstat entry's variant ids, falling back to the canonical @@ -1349,14 +1347,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # slot no analysis filled keeps the skeleton's own (empty) value. # @noRd .cbMergeRuns <- function(empty, runs) { + runResults <- map(runs, "result") + runTimes <- map(runs, "time") list_assign( - list_assign(empty, !!!map(runs, "result")), + list_assign(empty, !!!runResults), computing_time = list_assign( empty$computing_time, - Analysis = list_assign( - empty$computing_time$Analysis, - !!!map(runs, "time") - ) + Analysis = list_assign(empty$computing_time$Analysis, !!!runTimes) ) ) } @@ -2040,13 +2037,14 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { )) parsed <- parseVariantId(ids) ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) + pairRanges <- unname(map(compact(map(qtlPairs, "span")), .locusRanges)) placed <- exec( c, GenomicRanges::GRanges( parsed$chrom[ok], IRanges::IRanges(parsed$pos[ok], width = 1L) ), - !!!unname(map(compact(map(qtlPairs, "span")), .locusRanges)) + !!!pairRanges ) if (length(placed) == 0L) { return(NULL) @@ -2108,7 +2106,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 @@ -2589,19 +2587,17 @@ setMethod( if (length(combinedX) == 0L) { return(NULL) } + shiftedDicts <- map( + seq_along(subs), + .cbShiftStudyDict, + subs = subs, + xOffsets = xOffsets, + yOffsets = yOffsets + ) list( X = combinedX, Y = .cbConcat(map(subs, "Y")), - dict_YX = exec( - rbind, - !!!map( - seq_along(subs), - .cbShiftStudyDict, - subs = subs, - xOffsets = xOffsets, - yOffsets = yOffsets - ) - ), + dict_YX = exec(rbind, !!!shiftedDicts), outcomeNames = .cbConcat(map(subs, "outcomeNames")), outcomeInfo = bind_rows(map(subs, "outcomeInfo")) ) 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..e5e99a66d 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) }, @@ -1395,17 +1440,18 @@ mergeCtwasBoundaryRegions <- function( # ctwas actually returned). # @noRd .ctwasApplyMergeResult <- function(finemapResult, res) { + regionUpdates <- compact(list( + region_data = res$updated_region_data, + region_info = res$updated_region_info, + LD_map = res$updated_LD_map, + snp_map = res$updated_snp_map + )) list_assign( finemapResult, finemap_res = res$updated_finemap_res, susie_alpha_res = res$updated_susie_alpha_res, merge_res = res, - !!!compact(list( - region_data = res$updated_region_data, - region_info = res$updated_region_info, - LD_map = res$updated_LD_map, - snp_map = res$updated_snp_map - )) + !!!regionUpdates ) } @@ -1551,7 +1597,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 +1666,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 +1914,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 +2434,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 +2543,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 +2702,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 +2726,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 +2876,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) ) prepared <- compact(map( - seq_len(nrow(twasWeights)), + .ctwasWeightUnits(twasWeights), .ctwasGenePrepared, twasWeights = twasWeights, ctx = ctx @@ -2832,10 +2887,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 +2946,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 +2973,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 +3010,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 +3174,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 +3214,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) { @@ -3078,7 +3267,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { map_dbl(prepared, .ctwasWeightVariance, ld = ld) } -# The block's LD over `vids`, for weight variances: list(F = ) holding a +# The block's LD over `vids`, for weight variances: list(ldFactor = ) holding a # genotype reference's factor (.ldRefFactor()), or list(R = ) holding the # matrix a panel already carries -- a caller who computed it, or a payload it # travelled with -- or an LdMatrix's. @@ -3097,7 +3286,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } if (.ldIsGenotypeRef(ldPanel$sketch)) { factor <- .ldRefFactor(ldPanel$sketch, idx) - return(list(F = `colnames<-`(factor, vids))) + return(list(ldFactor = `colnames<-`(factor, vids))) } list(R = .ctwasPanelLdFor(ldPanel, idx, vids)) } @@ -3105,8 +3294,8 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # One gene's weight variance w'Rw from .ctwasPanelWeightLd()'s LD. # @noRd .ctwasWeightVariance <- function(g, ld) { - if (!is.null(ld$F)) { - f <- ld$F[, g$vids, drop = FALSE] + if (!is.null(ld$ldFactor)) { + f <- ld$ldFactor[, g$vids, drop = FALSE] return(sum((f %*% g$w)^2) / (nrow(f) - 1)) } r <- ld$R[g$vids, g$vids, drop = FALSE] @@ -3150,9 +3339,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 +3605,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 the run's GWAS study `gwasStudyName` -- named apart from +# the rows' gwasStudy column, which the filter reads. One with no gwasStudy +# column, or a run whose GWAS names no study but whose twasZ holds just one, +# is used whole. +# @noRd +.ctwasTwasZForStudy <- function(rows, gwasStudyName) { + if (!is_in("gwasStudy", names(rows))) { + return(rows) + } + studies <- unique(as.character(rows$gwasStudy)) + if (is.na(gwasStudyName) && 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(gwasStudyName)) { + return(rows) + } + filter(rows, .data$gwasStudy == gwasStudyName) +} + +# 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 +3789,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 +3811,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..696eea3ee 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -586,23 +586,21 @@ 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) } - list_assign( - methodArgs, - !!!set_names( - map( - seeded, - .fmSeedTokenDefaults, - methodArgs = methodArgs, - maxNumSingleEffects = maxNumSingleEffects, - maxNumSingleEffectsGreedy = maxNumSingleEffectsGreedy - ), - seeded - ) + seededArgs <- set_names( + map( + seeded, + .fmSeedTokenDefaults, + methodArgs = methodArgs, + maxNumSingleEffects = maxNumSingleEffects, + maxNumSingleEffectsGreedy = maxNumSingleEffectsGreedy + ), + seeded ) + list_assign(methodArgs, !!!seededArgs) } # One token's kwargs with L / L_greedy filled in where the caller left them @@ -1712,33 +1710,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 +1760,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 +1784,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 @@ -2025,13 +2024,11 @@ combineFineMappingResults <- function(..., ldReference = NULL) { if (length(present) == 0L) { return(tl) } - mutate( - tl, - !!!set_names( - map(present, .fmRelabelColumn, tl = tl, offsets = offsets, i = i), - present - ) + relabelledCols <- set_names( + map(present, .fmRelabelColumn, tl = tl, offsets = offsets, i = i), + present ) + mutate(tl, !!!relabelledCols) } # Renumber per-region credible-set columns so region-local cs indices do not @@ -2068,19 +2065,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 @@ -2092,7 +2104,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { if (length(userArgs) == 0L) { return(baseArgs) } - list_modify(baseArgs, !!!compact(userArgs)) + givenArgs <- compact(userArgs) + list_modify(baseArgs, !!!givenArgs) } # .fmFitSusieIndiv / .fmFitSusieRss / .fmFitSusieSer (single SuSiE fits) now @@ -2206,28 +2219,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 +2237,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. @@ -2259,14 +2249,9 @@ combineFineMappingResults <- function(..., ldReference = NULL) { list(X = Xtr, Y = Ytr, pos = pos, covLev = coverage), 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")) + fitFsusieArgs <- .splitMethodArgs(fitFsusie, fsArgs) + fit <- exec(fitFsusie, !!!fitFsusieArgs) + as.matrix(fsusieWeights(fsusieFit = fit, variantIds = colnames(Xtr))) } # Per-fold fine-mapping fit for the CV engine. `ctx` carries mvPrior, mvPriorCv, @@ -2303,16 +2288,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 +2305,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { j, verbose ) { - w <- try_fetch( + try_fetch( .fmFoldWeights( tk, Xtr, @@ -2347,13 +2327,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 +2378,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 +2416,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 +2659,94 @@ 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) + pcFits <- set_names(fits, pcNames[pass]) + list_assign(skipped, !!!pcFits) +} + +# 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 +2775,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 +3835,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..6e9e89912 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. @@ -1343,18 +1334,16 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { alpha <- .adjustPipsRenormAlpha(spec$alpha, cols) nKeep <- length(keepIdx) varAlpha <- alpha[, seq_len(nKeep), drop = FALSE] - subset <- list_assign( - fit, - !!!compact(list( - alpha = alpha, - pip = as.numeric(1 - apply(1 - varAlpha, 2L, prod)), - null_index = if (length(spec$nullIdx) > 0L) nKeep + 1L, - # Recorded BEFORE renormalization: after it every row sums to 1, - # so the share that survived is only knowable at this point. This - # is the §3.6 diagnostic -- always reported, never a filter. - retained_mass = .adjustPipsRetainedMass(spec$alpha, cols) - )) - ) + subsetFields <- compact(list( + alpha = alpha, + pip = as.numeric(1 - apply(1 - varAlpha, 2L, prod)), + null_index = if (length(spec$nullIdx) > 0L) nKeep + 1L, + # Recorded BEFORE renormalization: after it every row sums to 1, + # so the share that survived is only knowable at this point. This + # is the §3.6 diagnostic -- always reported, never a filter. + retained_mass = .adjustPipsRetainedMass(spec$alpha, cols) + )) + subset <- list_assign(fit, !!!subsetFields) .adjustPipsRebuildAllSets( .adjustPipsSubsetVariantSlots(subset, keepIdx, cols, nVariants), varAlpha @@ -1482,28 +1471,26 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { p <- list(keepIdx = keepIdx, cols = cols, nVariants = nVariants) # compact(): a slot the fit never carried subsets to NULL, and adding it # back as an explicit NULL element is not the same as leaving it out. - list_assign( - fit, - !!!compact(list( - lbf_variable = .adjustPipsCols( - fit[["lbf_variable"]], - p, - "lbf_variable" - ), - mu = .adjustPipsCols(fit[["mu"]], p, "mu"), - mu2 = .adjustPipsCols(fit[["mu2"]], p, "mu2"), - mu2_diag = .adjustPipsCols(fit[["mu2_diag"]], p, "mu2_diag"), - clfsr = .adjustPipsCols(fit[["clfsr"]], p, "clfsr"), - coef = .adjustPipsRows(fit[["coef"]], p, "coef"), - X_column_scale_factors = .adjustPipsVec( - fit[["X_column_scale_factors"]], - p, - "X_column_scale_factors" - ), - XtXr = .adjustPipsVec(fit[["XtXr"]], p, "XtXr"), - pi = .adjustPipsVec(fit[["pi"]], p, "pi") - )) - ) + adjustedFields <- compact(list( + lbf_variable = .adjustPipsCols( + fit[["lbf_variable"]], + p, + "lbf_variable" + ), + mu = .adjustPipsCols(fit[["mu"]], p, "mu"), + mu2 = .adjustPipsCols(fit[["mu2"]], p, "mu2"), + mu2_diag = .adjustPipsCols(fit[["mu2_diag"]], p, "mu2_diag"), + clfsr = .adjustPipsCols(fit[["clfsr"]], p, "clfsr"), + coef = .adjustPipsRows(fit[["coef"]], p, "coef"), + X_column_scale_factors = .adjustPipsVec( + fit[["X_column_scale_factors"]], + p, + "X_column_scale_factors" + ), + XtXr = .adjustPipsVec(fit[["XtXr"]], p, "XtXr"), + pi = .adjustPipsVec(fit[["pi"]], p, "pi") + )) + list_assign(fit, !!!adjustedFields) } # Index set for a slot measured along its variant axis: `nVariants` selects the @@ -1568,31 +1555,31 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # stale. # @noRd .adjustPipsRebuildAllSets <- function(fit, varAlpha) { - list_assign( - fit, - !!!compact(list( - sets = if (!is.null(fit[["sets"]])) { - .adjustPipsCsAtCoverage( - varAlpha, - fit[["V"]], - .adjustPipsCoverage(fit[["sets"]]) - ) - }, - sets_secondary = if (!is.null(fit[["sets_secondary"]])) { - map( - fit[["sets_secondary"]], - .adjustPipsRebuildSecondary, - varAlpha = varAlpha, - V = fit[["V"]] - ) - } - )) - ) + csFields <- compact(list( + sets = if (!is.null(fit[["sets"]])) { + .adjustPipsCsAtCoverage( + varAlpha, + fit[["V"]], + .adjustPipsCoverage(fit[["sets"]]), + .fitEffectIndex(fit, nrow(varAlpha)) + ) + }, + sets_secondary = if (!is.null(fit[["sets_secondary"]])) { + map( + fit[["sets_secondary"]], + .adjustPipsRebuildSecondary, + varAlpha = varAlpha, + V = fit[["V"]], + effectIndex = .fitEffectIndex(fit, nrow(varAlpha)) + ) + } + )) + list_assign(fit, !!!csFields) } # 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 +1588,8 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { sets = .adjustPipsCsAtCoverage( varAlpha, V, - .adjustPipsCoverage(entry$sets) + .adjustPipsCoverage(entry$sets), + effectIndex ) ) } @@ -1623,16 +1611,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 +1721,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 +1739,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,22 +1796,21 @@ 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, - posterior_mean = posteriorMean, - !!!compact(list( - posterior_sd = if ( - !is.null(mu2Mat) && all(dim(alphaMat) == dim(mu2Mat)) - ) { - as.numeric(sqrt(pmax( - colSums(alphaMat * mu2Mat) - posteriorMean^2, - 0 - ))) - } - )) - ) + sdCol <- compact(list( + posterior_sd = if ( + !is.null(mu2Mat) && all(dim(alphaMat) == dim(mu2Mat)) + ) { + as.numeric( + .susiePosteriorSd(alphaMat, muMat, mu2Mat) / scaleFactors + ) + } + )) + mutate(newTopLoci, posterior_mean = posteriorMean, !!!sdCol) } @@ -1878,7 +1880,8 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { logBF = .tlCol(tl, "logBF", "numeric") ) extras <- .projectPosteriorExtraCols(tl) - mutate(out, !!!set_names(map(extras, .tlColumnOf, tl = tl), extras)) + extraCols <- set_names(map(extras, .tlColumnOf, tl = tl), extras) + mutate(out, !!!extraCols) } # @noRd @@ -1999,13 +2002,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 +2018,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 +2115,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 +2142,160 @@ 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 = "")) + } + alignedWeights <- map(named, .alignFoldWeights, on = on) + W <- `dimnames<-`( + exec(cbind, !!!alignedWeights), + 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..fd31a2a14 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -183,22 +183,23 @@ prepareSusieFromInfArgs <- function( ) { unmappableEffects <- arg_match(unmappableEffects) L <- args[["L"]] %||% length(susieInfFit$V) + missingDefaults <- compact(list( + refine = if (is.null(args[["refine"]])) refineDefault, + convergence_method = if (unmappableEffects == "ash") { + args[["convergence_method"]] %||% "pip" + }, + # Clamped, not passed through raw: a caller's L_greedy above the + # number of inf effects would ask susie for effects it cannot warm- + # start. + L_greedy = if (!is.null(args[["L_greedy"]])) { + min(length(susieInfFit$V), L) + } + )) list_assign( args, unmappable_effects = unmappableEffects, model_init = susieInfFit, - !!!compact(list( - refine = if (is.null(args[["refine"]])) refineDefault, - convergence_method = if (unmappableEffects == "ash") { - args[["convergence_method"]] %||% "pip" - }, - # Clamped, not passed through raw: a caller's L_greedy above the - # number of inf effects would ask susie for effects it cannot warm- - # start. - L_greedy = if (!is.null(args[["L_greedy"]])) { - min(length(susieInfFit$V), L) - } - )) + !!!missingDefaults ) } @@ -208,7 +209,8 @@ prepareSusieFromInfArgs <- function( # works on lists, not on the S4 SimpleList a constructor returns. # @noRd .fmChainStageArgs <- function(shared, stage) { - list_modify(as.list(shared), !!!compact(as.list(stage))) + stageSettings <- compact(as.list(stage)) + list_modify(as.list(shared), !!!stageSettings) } # The three argument bundles of a two-stage chain, each checked against the @@ -830,6 +832,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)) @@ -1021,7 +1054,8 @@ computeCsTable <- function( } else { list(X = dataX) } - sets <- exec(susie_get_cs, !!!c(list(fit), csArgs, ldArg)) + getCsArgs <- c(list(fit), csArgs, ldArg) + sets <- exec(susie_get_cs, !!!getCsArgs) list(sets = sets, pip = fit$pip) } @@ -1321,7 +1355,8 @@ setMethod( scale = scale, alphaOnly = alphaOnly ) - mutate(cols, !!!.fmwConcat(perEffect)) + effectCols <- .fmwConcat(perEffect) + mutate(cols, !!!effectCols) } # Concatenate per-item lists, empty-safe. @@ -1827,11 +1862,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 +1904,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 +1919,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 +1943,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 +2012,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 +2442,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) @@ -2409,19 +2454,29 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { # Optional slots common to susie/mvsusie: column scales, posterior mu/mu2 # (L x p, or L x p x R for multivariate), theta, omega_weights. .trimAddCommon <- function(trimmed, fit, effectIdx) { - withCommon <- list_assign( - trimmed, - !!!compact(list( - X_column_scale_factors = fit$X_column_scale_factors, - mu = .trimEffectSlice(fit$mu, effectIdx), - mu2 = .trimEffectSlice(fit$mu2, effectIdx), - theta = fit$theta, - omega_weights = fit$omega_weights - )) - ) + commonFields <- compact(list( + X_column_scale_factors = .storedScaleFactors( + fit[["X_column_scale_factors"]] + ), + mu = .trimEffectSlice(fit$mu, effectIdx), + mu2 = .trimEffectSlice(fit$mu2, effectIdx), + theta = fit$theta, + omega_weights = fit$omega_weights + )) + withCommon <- list_assign(trimmed, !!!commonFields) .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 +2514,23 @@ 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)) + namedValue <- set_names(list(value), nm) + list_assign(trimmed, !!!namedValue) } -# 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 @@ -2496,24 +2557,33 @@ trimFinemappingFit <- function(fit, effectIdx, method, csTables) { ), names(populated) ) - list_assign(trimmed, !!!populated[keep]) + keptFields <- populated[keep] + list_assign(trimmed, !!!keptFields) } +# 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] - } - )) - ) + mvFields <- compact(list( + coef = if (requireNamespace("mvsusieR", quietly = TRUE)) { + mvsusieR::coef.mvsusie(fit)[-1, , drop = FALSE] + }, + clfsr = .trimEffectArray(fit$conditional_lfsr, effectIdx) + )) + list_assign(trimmed, !!!mvFields) +} + +# 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 @@ -2732,6 +2802,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 +2832,27 @@ 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) + user <- as.list(methodArgs) 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 + !!!user ) exec(mvsusieR::mvsusie, !!!callArgs) } @@ -2782,6 +2868,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 +2896,29 @@ 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) + user <- as.list(methodArgs) 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 + !!!user ) exec(mvsusieR::mvsusie_rss, !!!callArgs) } @@ -2959,6 +3055,7 @@ buildMvsusieMixturePrior <- function( "methodArgs" ) arm <- .mvMixtureArm(R, conditionNames, mixtureMatrices, mixtureWeights) + user <- as.list(methodArgs) callArgs <- list_modify( c( arm, @@ -2967,7 +3064,7 @@ buildMvsusieMixturePrior <- function( weights_tol = weightsTol )) ), - !!!methodArgs + !!!user ) exec(mvsusieR::create_mixture_prior, !!!callArgs) } @@ -3025,9 +3122,10 @@ fitFsusie <- function( cov_lev = covLev, min_purity = minPurity )) + user <- as.list(methodArgs) callArgs <- list_modify( c(list(X = X, Y = Y, pos = pos), owned), - !!!methodArgs + !!!user ) exec(fsusieR::susiF, !!!callArgs) } @@ -3042,7 +3140,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 +3195,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 +3239,7 @@ serWeights <- function( .susieExtractWeights( serFit, X, - requiredFields = c("alpha", "mu", "X_column_scale_factors"), + requiredFields = c("alpha", "mu"), token = "ser", fitRetention = fitRetention ) @@ -3175,7 +3277,7 @@ susieWeights <- function( .susieExtractWeights( susieFit, X, - requiredFields = c("alpha", "mu", "X_column_scale_factors"), + requiredFields = c("alpha", "mu"), token = "susie", fitRetention = fitRetention ) @@ -3213,7 +3315,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 +3364,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 +3378,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 +3407,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 +3456,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 +3499,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 +3542,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 +3580,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 +3595,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 +3659,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 +3741,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 +3758,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 +3797,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 +3985,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; @@ -4343,15 +4522,17 @@ extractTopPipInfo <- function(fmRow, sumstats) { refineDefault = if (token == "susie") TRUE else NULL, unmappableEffects = if (token == "susieAsh") "ash" else "none" ) + chainedSettings <- compact(chainedArgs) list_assign( - list_modify(baseArgs, !!!compact(chainedArgs)), + list_modify(baseArgs, !!!chainedSettings), X = X, y = y, coverage = coverage ) } else { + tokenDefaults <- .fmSusieTokenDefaults(token) .fmMergeUserArgs( - list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), + list_assign(baseArgs, !!!tokenDefaults), userArgs ) } @@ -4469,8 +4650,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { refineDefault = if (token == "susie") TRUE else NULL, unmappableEffects = if (token == "susieAsh") "ash" else "none" ) + chainedSettings <- compact(chainedArgs) list_assign( - list_modify(baseArgs, !!!compact(chainedArgs)), + list_modify(baseArgs, !!!chainedSettings), z = z, !!!ldArgs, n = n, @@ -4480,8 +4662,9 @@ extractTopPipInfo <- function(fmRow, sumstats) { # Non-chained fit: token-specific defaults then the user methodArgs merge. .fmRssNonChainedArgs <- function(baseArgs, token, userArgs) { + tokenDefaults <- .fmSusieTokenDefaults(token) .fmMergeUserArgs( - list_assign(baseArgs, !!!.fmSusieTokenDefaults(token)), + list_assign(baseArgs, !!!tokenDefaults), userArgs ) } @@ -5113,14 +5296,12 @@ extractTopPipInfo <- function(fmRow, sumstats) { } else if (identical(keepFullFit, "all")) { f$fit } - sf <- list_assign( - .fmrPartsSusieFit(ent), - !!!compact(list( - R_reliability_flag = f$flag, - serFallbackUsed = isTRUE(f$flag), - multiEffectFit = multiEffectFit - )) - ) + fallbackFields <- compact(list( + R_reliability_flag = f$flag, + serFallbackUsed = isTRUE(f$flag), + multiEffectFit = multiEffectFit + )) + sf <- list_assign(.fmrPartsSusieFit(ent), !!!fallbackFields) # A row is immutable: rebuild it with the amended fit rather than # assigning into it. The variants and topLoci are unchanged, so this # round-trips them through the same builder the caller used. @@ -5541,15 +5722,13 @@ extractTopPipInfo <- function(fmRow, sumstats) { mvPrior$priorVariance } ) - withPrior <- list_assign( - baseArgs, - !!!compact(list(residual_variance = mvPrior$residualVariance)) - ) + priorArgs <- compact(list(residual_variance = mvPrior$residualVariance)) + withPrior <- list_assign(baseArgs, !!!priorArgs) mvArgs <- .fmMergeUserArgs(withPrior, userArgs) - fit <- exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, mvArgs)) + fitMvsusieArgs <- .splitMethodArgs(fitMvsusie, mvArgs) + fit <- exec(fitMvsusie, !!!fitMvsusieArgs) 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 @@ -5755,12 +5934,13 @@ krigingOutlierQc <- function( } # susieR kriging RSS diagnostic (kriging_rss(z, R, n)): s defaults to # estimate_s_rss(); logLR matches susieR's allele-switch selection. + user <- as.list(methodArgs) cd <- exec( susieR::kriging_rss, z = zScore, R = R, n = n, - !!!as.list(methodArgs) + !!!user )$conditional_dist condMean <- as.numeric(cd$condmean) zStdDiff <- as.numeric(cd$z_std_diff) diff --git a/R/genotypeIo.R b/R/genotypeIo.R index 1f0253b10..9a419fb3f 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,74 @@ 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) { + labelledRanges <- unname(map(grs, .withPanelLabels)) + .dropRedundantLabels( + suppressWarnings(exec(c, !!!labelledRanges)) + ) +} + +# `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 +800,52 @@ 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 + ) + dosageBlocks <- unname(blocks) + exec(cbind, !!!dosageBlocks)[, + 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 +864,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 +1112,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 +1155,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 +1182,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 +1191,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). @@ -1205,8 +1350,9 @@ readPvar <- function(pvarPath) { } # A plain-text .pvar read as a table, as pgenlibr reads it: the first ALT -# allele of a multi-allelic variant is A1. NULL for a file this cannot read -# (compressed, or with no #CHROM header naming the five columns). +# allele of a multi-allelic variant is A1, and the alleles are upper case +# (.canonAllele()), as .readPvarByVariant() gives them. NULL for a file this +# cannot read (compressed, or with no #CHROM header naming the five columns). # @noRd #' @importFrom vroom vroom #' @importFrom readr cols col_character col_integer @@ -1235,8 +1381,8 @@ readPvar <- function(pvarPath) { chrom = tbl$CHROM, id = tbl$ID, pos = tbl$POS, - A2 = tbl$REF, - A1 = str_remove(tbl$ALT, ",.*$") + A2 = .canonAllele(tbl$REF), + A1 = .canonAllele(str_remove(tbl$ALT, ",.*$")) ) } @@ -1279,8 +1425,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)) ) } @@ -1341,15 +1487,12 @@ refVariantInfo <- function(source, which = NULL) { paths <- resolvePlink2Paths(dataPath) info <- readPvar(paths$pvar) afreq <- readAfreq(dataPath) - mutate( - info, - chrom = withChrPrefix(.data$chrom), - !!!compact(list( - allele_freq = if (!is.null(afreq)) { - afreq$alt_freq[match(info$id, afreq$id)] - } - )) - ) + afCol <- compact(list( + allele_freq = if (!is.null(afreq)) { + afreq$alt_freq[match(info$id, afreq$id)] + } + )) + mutate(info, chrom = withChrPrefix(.data$chrom), !!!afCol) } # plink1 variant info from the .bim (col5 = A1, col6 = A2). @@ -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,15 +2818,14 @@ loadGenotypeRegion <- function( # @noRd .stackDosagePanels <- function(panels, format, metaPath, paths) { .stackCheckSamples(panels, paths) - rowRangesList <- unname(map(panels, SummarizedExperiment::rowRanges)) + dosages <- unname(map(panels, .seDosage)) SummarizedExperiment::SummarizedExperiment( assays = list( - dosage = exec( - BiocGenerics::rbind, - !!!unname(map(panels, .seDosage)) - ) + dosage = exec(BiocGenerics::rbind, !!!dosages) + ), + rowRanges = .bindPanelRanges( + map(panels, SummarizedExperiment::rowRanges) ), - rowRanges = suppressWarnings(exec(c, !!!rowRangesList)), colData = SummarizedExperiment::colData(panels[[1L]]), metadata = list( genotypeSource = list( diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index ff26229e4..555e9f194 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 ), @@ -265,17 +265,14 @@ GwasSumStats <- function( # need no fallback either. # @noRd .gwasPieceMetadata <- function(dfArgs, split, pieces) { + regionCols <- .regionColumns( + split$given, + split$hasGiven, + .rowSpanRanges(pieces) + ) cbind( exec(S4Vectors::DataFrame, !!!dfArgs)[split$fromIdx, , drop = FALSE], - exec( - S4Vectors::DataFrame, - blockId = split$blockId, - !!!.regionColumns( - split$given, - split$hasGiven, - .rowSpanRanges(pieces) - ) - ) + exec(S4Vectors::DataFrame, blockId = split$blockId, !!!regionCols) ) } @@ -294,7 +291,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..848c52b78 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 @@ -48,36 +60,6 @@ snpsPerBlock <- function(snpInfo, ldBlocks) { split(queryHits(hits), subjectHits(hits)) } -# ============================================================================= -# Baseline enrichment computation -# ============================================================================= - -# Enrichment SE: jackknife over per-block enrichment (preferred) or the -# delta-method fallback tauSe * M / |h2| when no blocks are available. -# @noRd -.baselineEnrichmentSe <- function(annotationJackknifeCoefs, tauSe, M_a, M, h2) { - if (is.null(annotationJackknifeCoefs)) { - return(tauSe * M / abs(h2)) - } - nBlocks <- nrow(annotationJackknifeCoefs) - rawH2 <- as.vector(annotationJackknifeCoefs %*% M_a) - # A zero block h2 would divide the enrichment to Inf; NA drops the block - # from the jackknife mean instead. - h2Blocks <- replace(rawH2, rawH2 == 0, NA) - enrichmentBlocks <- sweep( - annotationJackknifeCoefs, - 1, - h2Blocks, - FUN = "/" - ) * - M - enrichmentMean <- colMeans(enrichmentBlocks, na.rm = TRUE) - enrichmentVar <- (nBlocks - 1) / - nBlocks * - colSums(sweep(enrichmentBlocks, 2, enrichmentMean)^2, na.rm = TRUE) - sqrt(enrichmentVar) -} - # ============================================================================= # Genome build utilities # ============================================================================= @@ -258,12 +240,13 @@ RmaOptions <- function(...) { "({conditionMessage(e)}); falling back to DL." ) warn(msg) + user <- as.list(metaArgs) exec( metafor::rma, yi = means, sei = ses, method = "DL", - !!!as.list(metaArgs) + !!!user ) } @@ -299,13 +282,14 @@ RmaOptions <- function(...) { # DL (closed-form DerSimonian-Laird) is the last-resort estimator: run it # directly and let any error propagate. Only the iterative estimators get a # tryCatch fallback to DL. + user <- as.list(metaArgs) fit <- if (identical(method, "DL")) { exec( metafor::rma, yi = means, sei = ses, method = "DL", - !!!as.list(metaArgs) + !!!user ) } else { try_fetch( @@ -314,7 +298,7 @@ RmaOptions <- function(...) { yi = means, sei = ses, method = method, - !!!as.list(metaArgs) + !!!user ), error = function(cnd) { .rmaMetaFallbackToDL(cnd, means, ses, method, metaArgs) @@ -333,8 +317,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 +460,6 @@ NULL A, tau, tauBlocks, - localDf, scoreStats ) { if (is.null(A)) { @@ -485,7 +468,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 +476,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 +501,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 +518,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 +673,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 +706,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 +723,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 +731,6 @@ lderUnivariate <- function( A = baselineMat, tau = fit$tau, tauBlocks = jk$annotationJackknifeCoefs, - localDf = localDf, scoreStats = .lderCandidateScores( blockStats, annotations, @@ -845,15 +783,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 +792,6 @@ lderUnivariate <- function( tau = tau, tauSe = jkRes$tauSe, annotationJackknifeCoefs = jkRes$annotationJackknifeCoefs, - local = localDf, enrichment = enrichmentDf, scoreStats = scoreStats ) @@ -913,8 +842,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( @@ -947,7 +876,7 @@ NULL if (!is.null(ld$R)) { return(rawNtau * crossprod(ld$R * sqrt(d)) + ld$R) } - ldFactor <- ld$F + ldFactor <- ld$ldFactor m1 <- nrow(ldFactor) - 1 gram <- tcrossprod(sweep(ldFactor, 2L, sqrt(d), "*")) crossprod(ldFactor, rawNtau / m1 * (gram %*% ldFactor) + ldFactor) / m1 @@ -966,7 +895,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 +950,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 +1029,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 +1066,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 +1086,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 +1096,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 +1299,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 +1342,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) ) } -# Modeled variance of one block's bstar^2 at local heritability `h2`, the -# intercept fixed at the global fit; floored at `lim`. +# 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 -.hdlLocalVar <- function(h2, bd, M, nSamples, intercept, n, lim) { +.hdlLocusEigen <- function(ld) { + dec <- if (!is.null(ld$ldFactor)) { + .ldFactorEigen(ld$ldFactor) + } 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] + ) +} + +# 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 +.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$ldFactor)) { + .ldFactorEigen(ld$ldFactor) + } 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 +1757,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 +1774,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 +1782,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 +1893,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 +1914,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 +2007,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 +2271,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 +2300,6 @@ sldscUnivariate <- function( n, ldRef, annotations, - local, estimatorArgs = list() ) { # `estimatorArgs` rather than `...`: the estimators take different @@ -2135,7 +2309,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 +2402,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 +2443,6 @@ setMethod( ldRef, method = "lder", annotations = NULL, - local = FALSE, studyName = NULL, estimatorArgs = list() ) { @@ -2277,10 +2463,9 @@ setMethod( n, ldRef, annotations, - local, estimatorArgs = estimatorArgs ) - .h2EstimateFromResult(result, method, M, studyName) + .h2EstimateFromResult(result, method, M, studyName, ldRef) } ) @@ -2303,6 +2488,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 +2779,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 +2834,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 +2847,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 +2871,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 +2883,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 +2901,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 +2941,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 +2948,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 +2962,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..92c82b473 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -410,7 +410,8 @@ setMethod( ), args$methodArgs[["fsusie"]] ) - raw <- exec(fitFsusie, !!!.splitMethodArgs(fitFsusie, fitArgs)) + fitFsusieArgs <- .splitMethodArgs(fitFsusie, fitArgs) + raw <- exec(fitFsusie, !!!fitFsusieArgs) list_assign( raw, coef = try_fetch( @@ -595,7 +596,8 @@ setMethod( compact(list(residual_variance = mvPrior$residualVariance)) ) fitArgs <- .fmMergeUserArgs(mvBaseArgs, args$methodArgs[["mvsusie"]]) - exec(fitMvsusie, !!!.splitMethodArgs(fitMvsusie, fitArgs)) |> + fitMvsusieArgs <- .splitMethodArgs(fitMvsusie, fitArgs) + exec(fitMvsusie, !!!fitMvsusieArgs) |> .setFinemappingFitClass("mvsusie") } @@ -752,10 +754,8 @@ setMethod( ) |> c(compact(list(residual_variance = mvPrior$residualVariance))) fitArgs <- .fmMergeUserArgs(mvBaseArgs, args$methodArgs[["mvsusie"]]) - fit <- exec( - fitMvsusieRss, - !!!.splitMethodArgs(fitMvsusieRss, fitArgs) - ) + fitMvsusieRssArgs <- .splitMethodArgs(fitMvsusieRss, fitArgs) + fit <- exec(fitMvsusieRss, !!!fitMvsusieRssArgs) .setFinemappingFitClass(fit, "mvsusie") } @@ -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( @@ -967,12 +978,17 @@ setMethod( ) { return(ma) } - list_assign(ma, !!!set_names(list(fittedModels[[token]]), adapter$fitArg)) + fittedArg <- set_names(list(fittedModels[[token]]), adapter$fitArg) + list_assign(ma, !!!fittedArg) } # 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 +1002,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 +1049,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 +1163,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 +1176,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 +1202,7 @@ setMethod( } .jointTwasLeakageWarn(args, ma) .jointTwasCvResult( - .jointTwasRunCv(Xc, Yc, wm, args, cfg, cvFolds), + .jointTwasRunCv(Xc, Yc, wm, args, cfg, cvFolds, token), token ) } @@ -1301,15 +1313,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 +1494,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 +1815,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 @@ -1923,7 +1938,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { } cfg <- .jpConfig(pipeline) cond <- .jgConditions(g) - out <- list_assign(args, !!!.twasGroupFmArgs(args, cond)) + groupFmArgs <- .twasGroupFmArgs(args, cond) + out <- list_assign(args, !!!groupFmArgs) cv <- cfg$crossValidationParam %||% list() cvF <- cv$folds %||% 0L if (cvF <= 1L || !is(g, "IndividualJointGroup")) { @@ -1940,7 +1956,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 +1977,72 @@ 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) { + keyValues <- map(pieces, key) + exec(bind, !!!keyValues) +} + # 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 +2112,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 +2165,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 +2216,32 @@ 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 { + unitArgs <- unit$args + exec(unit$builder, !!!unitArgs) + } + if (is(built, "JointGroup")) { + return(list(built)) + } + compact(as.list(built)) } # The group less any (context, trait) condition a per-context `traitId` @@ -2139,7 +2302,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 +2562,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 +2932,34 @@ 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. + constructorArgs <- list_assign( + kept, + studyName = rec$study, + entry = list(rec$entry) + ) + part <- exec(constructor, !!!constructorArgs) + .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 +2982,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 +3012,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..784371485 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,100 @@ 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) + } + windowSpans <- map(groups, .twasWindowSpan, region = region) + suppressWarnings(exec(c, !!!windowSpans)) +} + +# @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 +2299,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..223ff912c 100644 --- a/R/ld.R +++ b/R/ld.R @@ -119,42 +119,18 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { ) } -# Split the comma-joined path column into LD (+ optional bim) path columns. +# The genotype files the rows `intersectionRows` spans name, each found as +# written or beside the TSV (.findValidFilePaths()). # @noRd -.regionalLdParsePaths <- function(genomicData) { - parts <- str_split(genomicData$path, ",", simplify = TRUE) - pathNames <- if (ncol(parts) == 2) { - c("LD_file_path", "bim_file_path") - } else { - "LD_file_path" - } - filePath <- `names<-`( - as_tibble(parts, .name_repair = "minimal"), - pathNames - ) - bind_cols(genomicData, filePath) |> - select(-any_of("path")) -} - -# Resolve the LD (and optional bim) file paths for the intersected rows. .regionalLdExtractPaths <- function( ldReferenceMetaFile, genomicData, intersectionRows ) { - ldPaths <- .findValidFilePaths( + .findValidFilePaths( ldReferenceMetaFile, - extractFilePaths(genomicData, intersectionRows, "LD_file_path") + extractFilePaths(genomicData, intersectionRows, "path") ) - bimPaths <- if (is_in("bim_file_path", names(genomicData))) { - .findValidFilePaths( - ldReferenceMetaFile, - extractFilePaths(genomicData, intersectionRows, "bim_file_path") - ) - } else { - NULL - } - list(ldPaths = ldPaths, bimPaths = bimPaths) } # A metadata row recorded as start=0, end=0 covers the whole chromosome @@ -171,17 +147,15 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { ) } -#' Find LD blocks overlapping a query region from a metadata TSV file. +#' Find the rows of an LD-meta TSV that overlap a query region. #' -#' @param ldReferenceMetaFile TSV with columns chrom, start, end, path. The path -#' column may be comma-separated: "ld_file,bim_file". +#' @param ldReferenceMetaFile TSV with columns chrom, start, end, path, each +#' path a genotype file, as written or relative to the TSV. #' @param region A \code{GRanges} window. #' @param completeCoverageRequired If TRUE, error when the region extends beyond #' available LD blocks. -#' @return A list with: intersections (LD_file_paths, bimFilePaths), ldMetaData, -#' and parsed region. -#' @importFrom stringr str_split -#' @importFrom dplyr select +#' @return A list with: intersections (startIndex, endIndex and the rows' +#' paths), ldMetaData, and the parsed region. #' @importFrom vroom vroom #' @noRd regionalLdMeta <- function( @@ -195,37 +169,34 @@ regionalLdMeta <- function( ) |> mutate(chrom = withChrPrefix(.data$chrom)) |> .ldMetaWidenWholeChrom() |> - orderDedupRegions() |> - .regionalLdParsePaths() - region <- orderDedupRegions(.regionTable(region)) + orderDedupRegions() + query <- orderDedupRegions(.regionTable(region)) intersectionRows <- findIntersectionRows( genomicData, - region$chrom, - region$start, - region$end + query$chrom, + query$start, + query$end ) if (completeCoverageRequired) { validateSelectedRegion( intersectionRows$startRow, intersectionRows$endRow, - region$start, - region$end + query$start, + query$end ) } - paths <- .regionalLdExtractPaths( - ldReferenceMetaFile, - genomicData, - intersectionRows - ) list( intersections = list( startIndex = intersectionRows$startRow, endIndex = intersectionRows$endRow, - LD_file_paths = paths$ldPaths, - bimFilePaths = paths$bimPaths + paths = .regionalLdExtractPaths( + ldReferenceMetaFile, + genomicData, + intersectionRows + ) ), ldMetaData = genomicData, - region = region + region = query ) } @@ -306,9 +277,8 @@ resolveLdSource <- function(path) { return(direct) } meta <- .resolveLdReadMeta(path) - # Strip the comma-separated bim path, then resolve relative to the meta dir. - rawPath <- str_remove(meta$path[1], ",.*$") - resolved <- file.path(dirname(path), rawPath) + # A row's path is relative to the metadata file's directory. + resolved <- file.path(dirname(path), meta$path[1]) genoType <- .resolveLdGenotypeType(resolved, path) if (!is.null(genoType)) { return(genoType) @@ -372,17 +342,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 +425,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 +466,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 +480,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 +499,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 +521,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 +550,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 +558,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 +713,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 +743,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, keepIdx)) + 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) + } + 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 +813,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 +934,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 +969,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 +1187,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 +1277,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 +1340,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 +1347,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) + } + 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) } - named <- `dimnames<-`(signed, list(matched$keptIds, matched$keptIds)) + 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 +1439,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,43 +1530,108 @@ 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 F of it, +# list(ldFactor = ) 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$ldFactor)) { + return(crossprod(ld$ldFactor) / (nrow(ld$ldFactor) - 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$F)) { - return(ncol(ld$F)) + if (!is.null(ld$P)) { + return(nrow(ld$P)) + } + if (!is.null(ld$ldFactor)) { + return(ncol(ld$ldFactor)) } 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$ldFactor)) { + return(.ldFactorEigen(ld$ldFactor)) + } + 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$F)) { + if (!is.null(ld$P)) { + return(.ldPackedRows(ld, rows)) + } + if (!is.null(ld$ldFactor)) { return( - crossprod(ld$F[, rows, drop = FALSE], ld$F) / (nrow(ld$F) - 1) + crossprod(ld$ldFactor[, rows, drop = FALSE], ld$ldFactor) / + (nrow(ld$ldFactor) - 1) ) } scaled <- sweep(ld$vectors[rows, , drop = FALSE], 2L, ld$values, "*") 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(ldFactor = ld$ldFactor[, 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 +1687,88 @@ 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")) + } + if (!is.null(ld$ldFactor)) { + return( + crossprod(ld$ldFactor, ld$ldFactor %*% B) / (nrow(ld$ldFactor) - 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$ldFactor)) { + return(colSums((ld$ldFactor %*% B)^2) / (nrow(ld$ldFactor) - 1)) } - 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$ldFactor)) { + e <- matrix( + rnorm(nrow(ld$ldFactor) * nDraws), + nrow(ld$ldFactor), + nDraws + ) + return(crossprod(ld$ldFactor, e) / sqrt(nrow(ld$ldFactor) - 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 +2341,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 +2447,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 @@ -2366,17 +2538,10 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # genome-wide collection. # @noRd .rowSpans <- function(x) { - if (methods::is(x, "RangedTupleList")) { - spans <- .rtlFirstSpans(x) - return(list( - spans = .locusRanges(spans$first), - rows = unname(which(spans$has)) - )) - } - rr <- range(x) + spans <- .rtlFirstSpans(x) list( - spans = .locusRanges(unlist(rr, use.names = FALSE)), - rows = rep(seq_along(rr), lengths(rr)) + spans = .locusRanges(spans$first), + rows = unname(which(spans$has)) ) } @@ -2803,13 +2968,14 @@ ldPruneByCorrelation <- function( .ldPruneSnprelateCreateGds(tmpGds, X, snpNames, p) gds <- SNPRelate::snpgdsOpen(tmpGds, allow.duplicate = TRUE) on.exit(SNPRelate::snpgdsClose(gds), add = TRUE) + user <- as.list(methodArgs) keepList <- exec( SNPRelate::snpgdsLDpruning, gds, method = "corr", ld.threshold = corThres, verbose = verbose, - !!!as.list(methodArgs) + !!!user ) keepIds <- sort(unname(list_c(keepList))) X.new <- X[, keepIds, drop = FALSE] diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index 568930887..9892e624c 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -69,6 +69,7 @@ NULL )) } fields <- str_split(lines, "\t", simplify = TRUE) + blockIdCol <- compact(list(blockId = if (ncol(fields) > 3L) fields[, 4L])) exec( GenomicRanges::GRanges, seqnames = fields[, 1L], @@ -76,7 +77,7 @@ NULL start = as.integer(fields[, 2L]) + 1L, end = as.integer(fields[, 3L]) ), - !!!compact(list(blockId = if (ncol(fields) > 3L) fields[, 4L])) + !!!blockIdCol ) } @@ -855,8 +856,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]]) ) } @@ -901,6 +902,8 @@ NULL .buildSumstatOut <- function(df, resolved, z, n, mapping, label) { claimed <- .sumstatClaimedCols(mapping) present <- .sumstatOptionalSources(df, mapping, label, claimed) + sampleSizeCols <- .sumstatSampleSizeCols(df, n) + numericCols <- map(present, .sumstatNumericColumn, df = df) result <- mutate( .sumstatIdentityCols(df, resolved), Z = if (z$hasZ) { @@ -913,8 +916,8 @@ NULL # it, a supplied z and a Wald z computed from beta/se are both just # `Z`. z_supplied = z$hasZ, - !!!.sumstatSampleSizeCols(df, n), - !!!map(present, .sumstatNumericColumn, df = df) + !!!sampleSizeCols, + !!!numericCols ) .warnAfProvenance( result, @@ -1042,12 +1045,10 @@ NULL # per-study FORMAT fields ES/SE/LP/SS/EAF, with Z = ES / SE. # @noRd .vcfToSumstatDf <- function(vcf, sampleSelect, formatMapping, label) { - fmap <- list_modify( - .gwasVcfFormatDefaults, - !!!compact( - if (is.null(formatMapping)) list() else as.list(formatMapping) - ) + formatOverrides <- compact( + if (is.null(formatMapping)) list() else as.list(formatMapping) ) + fmap <- list_modify(.gwasVcfFormatDefaults, !!!formatOverrides) rr <- SummarizedExperiment::rowRanges(vcf) altList <- VariantAnnotation::alt(vcf) sample <- .pickVcfSample(colnames(vcf), sampleSelect, label) @@ -1063,13 +1064,14 @@ 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 ) - mutate(out, !!!.vcfOptionalSumstatCols(fld)) + optionalCols <- .vcfOptionalSumstatCols(fld) + mutate(out, !!!optionalCols) } # A GWAS-VCF must yield a z (supplied, or derivable from ES and SE) and a @@ -2239,18 +2241,15 @@ loadQtlSumStatsFromManifest <- function( minLdOverlapWarn, check = .qtlSumStatsCheckContainment ) - exec( - QtlSumStats, - !!!.qtlSumStatsArgs( - df, - entries, - genome, - ldReference, - nSample$nSampleCol - ), - region = windows$perRow %||% windows$shared, - traitPos = .manifestTraitPos(df, "QtlSumStats") + qtlSumStatsArgs <- .qtlSumStatsArgs( + df, + entries, + genome, + ldReference, + nSample$nSampleCol, + windows ) + exec(QtlSumStats, !!!qtlSumStatsArgs) } # A QTL load's windows (.manifestWindows()). A tuple has one window, so the @@ -2331,14 +2330,23 @@ loadQtlSumStatsFromManifest <- function( # Assemble the QtlSumStats() argument list from a canonicalised manifest. # @noRd -.qtlSumStatsArgs <- function(df, entries, genome, ldReference, nSampleCol) { +.qtlSumStatsArgs <- function( + df, + entries, + genome, + ldReference, + nSampleCol, + windows +) { args <- list( study = as.character(df$study), context = as.character(df$context), trait = as.character(df$trait), entry = entries, genome = genome, - ldReference = ldReference + ldReference = ldReference, + region = windows$perRow %||% windows$shared, + traitPos = .manifestTraitPos(df, "QtlSumStats") ) c( args, diff --git a/R/mashPipeline.R b/R/mashPipeline.R index 89c27f13a..7907391ae 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -42,10 +42,8 @@ setClass( )) } .mashValidateComponents(v, "MashPriorParam") - exec( - MashComponentParam, - !!!set_names(rep(list(list()), length(v)), v) - ) + emptyComponents <- set_names(rep(list(list()), length(v)), v) + exec(MashComponentParam, !!!emptyComponents) } # "none" has no constructor, so it is the absent engine: NULL. The default @@ -1124,7 +1122,8 @@ MashComponentParam <- function( if (!iid) { defaults$unconstrained.update <- "ed" } - list_modify(defaults, !!!compact(as.list(fitOpts))) + fitSettings <- compact(as.list(fitOpts)) + list_modify(defaults, !!!fitSettings) } # One half of a covUdr selection, defaulting to that half's empty bundle: @@ -2156,16 +2155,14 @@ filterInvalidSummaryStat <- function( if (is.null(datList[[bhat]]) || is.null(datList[[sbhat]])) { return(datList) } - reset <- list_assign( - datList, - !!!set_names( - list( - .mashReplaceValues(datList[[bhat]], 0), - .mashReplaceValues(datList[[sbhat]], 1000) - ), - c(bhat, sbhat) - ) + resetValues <- set_names( + list( + .mashReplaceValues(datList[[bhat]], 0), + .mashReplaceValues(datList[[sbhat]], 1000) + ), + c(bhat, sbhat) ) + reset <- list_assign(datList, !!!resetValues) hasNullOrRandom <- is_in("null.b", names(reset)) || is_in("random.b", names(reset)) if (!hasNullOrRandom || is.null(filterByMissingRate)) { @@ -2173,19 +2170,17 @@ filterInvalidSummaryStat <- function( } proportionNonzero <- apply(reset[[bhat]], 1, .mashRowNonzeroRate) keep <- proportionNonzero >= filterByMissingRate - list_assign( - reset, - !!!set_names( - # `drop = FALSE`: one surviving variant would collapse these - # to vectors, and they go back into the mash data list where - # mashr expects an N x R matrix. - list( - reset[[bhat]][keep, , drop = FALSE], - reset[[sbhat]][keep, , drop = FALSE] - ), - c(bhat, sbhat) - ) + keptRows <- set_names( + # `drop = FALSE`: one surviving variant would collapse these + # to vectors, and they go back into the mash data list where + # mashr expects an N x R matrix. + list( + reset[[bhat]][keep, , drop = FALSE], + reset[[sbhat]][keep, , drop = FALSE] + ), + c(bhat, sbhat) ) + list_assign(reset, !!!keptRows) } # Derive z = bhat / sbhat (into a `.z` or `z` slot) and apply the @@ -2206,7 +2201,8 @@ filterInvalidSummaryStat <- function( } else { list(NULL) } - withZ <- list_assign(datList, !!!set_names(zValue, zName)) + zEntry <- set_names(zValue, zName) + withZ <- list_assign(datList, !!!zEntry) if (!is_in("strong.z", names(withZ)) || is.null(sigPCutoff)) { return(withZ) } @@ -2235,18 +2231,16 @@ filterInvalidSummaryStat <- function( processed <- if (length(components) == 0L) { datList } else { - list_assign( - datList, - !!!set_names( - map( - components, - .mashProcessPartition, - datList = datList, - filterByMissingRate = filterByMissingRate - ), - components - ) + processedParts <- set_names( + map( + components, + .mashProcessPartition, + datList = datList, + filterByMissingRate = filterByMissingRate + ), + components ) + list_assign(datList, !!!processedParts) } if ( is.null(processed$strong) || @@ -2443,13 +2437,11 @@ mashRandNullSample <- function( abort(msg) } keys <- intersect(names(dat), c("z", "bhat", "sbhat")) - dat <- list_assign( - dat, - !!!set_names( - map(dat[keys], .mashDropConditions, drop = excludeCondition), - keys - ) + keptConditions <- set_names( + map(dat[keys], .mashDropConditions, drop = excludeCondition), + keys ) + dat <- list_assign(dat, !!!keptConditions) } .mashExtractOneData(dat, nRandom, nNull) } @@ -2931,10 +2923,8 @@ mashInput <- function( if (length(needs) == 0L) { return(combined) } - list_assign( - combined, - !!!set_names(map(combined[needs], .mashAsOneRow), needs) - ) + oneRowEntries <- set_names(map(combined[needs], .mashAsOneRow), needs) + list_assign(combined, !!!oneRowEntries) } # @noRd @@ -3269,8 +3259,10 @@ qtlSumStatsFromBetaMatrix <- function( setup <- .mashBlockSetup(x) resolvedScale <- .mashResolveScale(x, role, inputScale) blocks <- .mashBuildBlockMatrices(x, setup, resolvedScale) - bhat <- exec(rbind, !!!blocks$bhat) - shat <- exec(rbind, !!!blocks$shat) + bhatBlocks <- blocks$bhat + bhat <- exec(rbind, !!!bhatBlocks) + shatBlocks <- blocks$shat + shat <- exec(rbind, !!!shatBlocks) # bhat NA -> 0, shat NA / <= 0 -> 1000 (the mash_set_data # zero_Bhat_Shat_reset convention; missing-cell variants do not drive the # fit). diff --git a/R/mashWrapper.R b/R/mashWrapper.R index a36871167..7a78f21dc 100644 --- a/R/mashWrapper.R +++ b/R/mashWrapper.R @@ -34,10 +34,11 @@ "null", inputScale = inputScale ) + user <- as.list(corArgs) exec( mashr::estimate_null_correlation_simple, .mashSetData(nullMats$b, nullMats$s, alpha, NULL, mashDataArgs), - !!!as.list(corArgs) + !!!user ) } @@ -65,21 +66,7 @@ mashDataArgs, corArgs ) { - if (is.null(sumStatsList$random)) { - msg <- glue( - "mashResidualCorrelation: method 'mle' requires a 'random' entry ", - "in `sumStatsList`." - ) - abort(msg) - } - if (is.null(priorCovariances)) { - msg <- glue( - "mashResidualCorrelation: method 'mle' requires ", - "`priorCovariances` ", - "(the prior U the EM refines V against)." - ) - abort(msg) - } + .mashCheckMleInputs(sumStatsList, priorCovariances) priorCovariances <- .mashAsUlist(priorCovariances) randomMats <- .mashSumStatsToMatrices( sumStatsList$random, @@ -95,17 +82,40 @@ NULL, mashDataArgs ) + user <- as.list(corArgs) fit <- exec( mashr::mash_estimate_corr_em, dsub, priorCovariances, max_iter = maxIter, details = TRUE, - !!!as.list(corArgs) + !!!user ) fit$V } +# What method 'mle' needs: a 'random' set of z-scores to refine V on, and the +# prior U the EM refines it against. +# @noRd +.mashCheckMleInputs <- function(sumStatsList, priorCovariances) { + if (is.null(sumStatsList$random)) { + msg <- glue( + "mashResidualCorrelation: method 'mle' requires a 'random' entry ", + "in `sumStatsList`." + ) + abort(msg) + } + if (is.null(priorCovariances)) { + msg <- glue( + "mashResidualCorrelation: method 'mle' requires ", + "`priorCovariances` ", + "(the prior U the EM refines V against)." + ) + abort(msg) + } + invisible(NULL) +} + # methods 'corshrink' / 'simpleSpecific': estimate V on the null z-matrix. The # `null` partition is already the null variants (max|z| < 2), so no # re-thresholding is needed. @@ -146,8 +156,9 @@ ) abort(msg) } + user <- as.list(corArgs) as.matrix( - exec(CorShrink::CorShrinkData, nullZ, !!!as.list(corArgs))$cor + exec(CorShrink::CorShrinkData, nullZ, !!!user)$cor ) } @@ -170,34 +181,23 @@ ) { npc <- nPcs %||% (ncol(mashData$Bhat) - 1) canonical <- if (is_in("canonical", components)) { - exec( - mashr::cov_canonical, - mashData, - !!!compact(.mashComponentArgs("canonical", componentArgs)) - ) + canonicalArgs <- compact(.mashComponentArgs("canonical", componentArgs)) + exec(mashr::cov_canonical, mashData, !!!canonicalArgs) } pca <- if (is_in("pca", components)) { - exec( - mashr::cov_pca, - mashData, - npc = npc, - !!!compact(.mashComponentArgs("pca", componentArgs)) - ) + pcaArgs <- compact(.mashComponentArgs("pca", componentArgs)) + exec(mashr::cov_pca, mashData, npc = npc, !!!pcaArgs) } flash <- if (is_in("flash", components)) { - exec( - mashr::cov_flash, - mashData, - !!!compact(.mashComponentArgs("flash", componentArgs)) - ) + flashArgs <- compact(.mashComponentArgs("flash", componentArgs)) + exec(mashr::cov_flash, mashData, !!!flashArgs) } flashNonneg <- if (is_in("flashNonneg", components)) { - exec( - mashr::cov_flash, - mashData, - factors = "nonneg", - !!!compact(.mashComponentArgs("flashNonneg", componentArgs)) - ) + flashNonnegArgs <- compact(.mashComponentArgs( + "flashNonneg", + componentArgs + )) + exec(mashr::cov_flash, mashData, factors = "nonneg", !!!flashNonnegArgs) } list( canonical = canonical, @@ -240,13 +240,14 @@ componentArgs = componentArgs ) } + user <- as.list(mashArgs) w <- result$w %||% mashr::get_estimated_pi(exec( mashr::mash, mashData, Ulist = result$U, outputlevel = 1, - !!!as.list(mashArgs) + !!!user )) list(U = result$U, w = w, loglik = result$loglik) } @@ -712,12 +713,8 @@ CorShrinkOptions <- function(...) { # mixture weights. Returns list(U, w = NULL, loglik = NULL). # @noRd .mashEngineCovEd <- function(mashData, dataDriven, engineArgs = NULL) { - U.ed <- exec( - mashr::cov_ed, - mashData, - Ulist_init = dataDriven, - !!!compact(as.list(engineArgs %||% list())) - ) + edArgs <- compact(as.list(engineArgs %||% list())) + U.ed <- exec(mashr::cov_ed, mashData, Ulist_init = dataDriven, !!!edArgs) list(U = U.ed, w = NULL, loglik = NULL) } @@ -884,12 +881,13 @@ mashModelFit <- function( inputScale, mashDataArgs ) + user <- as.list(mashArgs) exec( mashr::mash, mashData, Ulist = priorCovariances, outputlevel = outputLevel, - !!!as.list(mashArgs) + !!!user ) } @@ -975,11 +973,12 @@ mashPosterior <- function( ) vhat <- if (is.null(ex$vhat)) diag(rep(1, ncol(ex$b))) else ex$vhat mashData <- .mashSetData(ex$b, ex$s, alpha, vhat, mashDataArgs) + user <- as.list(posteriorArgs) exec( mashr::mash_compute_posterior_matrices, ex$model, mashData, output_posterior_cov = outputPosteriorCov, - !!!as.list(posteriorArgs) + !!!user ) } diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R index 9c1027d3a..17060eddf 100644 --- a/R/overlapTopLoci.R +++ b/R/overlapTopLoci.R @@ -187,19 +187,16 @@ setMethod( joined, across(any_of(signedCols), partial(.overlapApplySign, sign = rowSign)) ) - relabelled <- mutate( - signed, - !!!compact(list( - af = if (is_in("af", names(signed))) { - if_else( - signed$.sign < 0 & !is.na(signed$af), - 1 - signed$af, - signed$af - ) - } - )), - variant_id = .data$canon_vid - ) + afCol <- compact(list( + af = if (is_in("af", names(signed))) { + if_else( + signed$.sign < 0 & !is.na(signed$af), + 1 - signed$af, + signed$af + ) + } + )) + relabelled <- mutate(signed, !!!afCol, variant_id = .data$canon_vid) select( relabelled, all_of(setdiff(names(relabelled), c(coordCols, "canon_vid", ".sign"))) diff --git a/R/pvalCombineWrappers.R b/R/pvalCombineWrappers.R index 234d021c7..bc5402f5b 100644 --- a/R/pvalCombineWrappers.R +++ b/R/pvalCombineWrappers.R @@ -184,11 +184,12 @@ pvalGbj <- function(zScores, R, method, methodArgs = GbjOptions()) { gbj_omni = GBJ::OMNI_ss, .abortUnknownMethod("GBJ", method) ) + user <- as.list(methodArgs) result <- exec( fn, test_stats = zScores, cor_mat = R, - !!!as.list(methodArgs) + !!!user ) pvalName <- switch( method, @@ -214,13 +215,14 @@ pvalAspu <- function( "Package 'aSPU' is required for this method." ) } + user <- as.list(methodArgs) switch( method, aspu = exec( aSPU::aSPUs, Zs = zScores, corSNP = R, - !!!as.list(methodArgs) + !!!user )$pvs["aSPUs"], # GATES2's only formals are the two pecotmr supplies, so there is # nothing for a caller to configure here. diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index b41f89e49..c250e6de6 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -79,23 +79,17 @@ QvalueOptions <- function(...) { exec(qvalue::qvalue, p, !!!extra)$qvalues, error = function(cnd) { if (str_detect(conditionMessage(cnd), "missing or infinite")) { - exec( - qvalue::qvalue, - p, - !!!list_assign(extra, lambda = 0) - )$qvalues + fixedLambdaArgs <- list_assign(extra, lambda = 0) + exec(qvalue::qvalue, p, !!!fixedLambdaArgs)$qvalues } else if (str_detect(conditionMessage(cnd), "pi0 <= 0")) { maxP <- max(p, na.rm = TRUE) lambdaSeq <- seq(0, min(0.9, maxP * 0.95), length.out = 10) - exec( - qvalue::qvalue, - p, - !!!list_assign( - extra, - lambda = lambdaSeq, - pi0.method = "bootstrap" - ) - )$qvalues + bootstrapArgs <- list_assign( + extra, + lambda = lambdaSeq, + pi0.method = "bootstrap" + ) + exec(qvalue::qvalue, p, !!!bootstrapArgs)$qvalues } else { # The cause is chained via `parent`, so it is no longer # interpolated into the message. @@ -143,23 +137,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 +391,7 @@ setMethod( grl <- S4Vectors::`mcols<-`(built, value = md) methods::new( "QtlSumStats", - grl, + .rtlStored("QtlSumStats", grl), ldReference = ldReference(x), qcOptions = qcOptions ) @@ -388,7 +400,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 +413,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 +429,7 @@ setMethod( cisWindow = 0, methods = c("permutation", "bonferroni"), pvalueCol = "P", - afCol = "af", + afCol = "AF", qvalueArgs = QvalueOptions() ) { .assertMethodOptions(qvalueArgs, "QvalueOptions", "qvalueArgs") diff --git a/R/qtlEnrichmentPipeline.R b/R/qtlEnrichmentPipeline.R index e100baa7a..da7848c6a 100644 --- a/R/qtlEnrichmentPipeline.R +++ b/R/qtlEnrichmentPipeline.R @@ -690,16 +690,6 @@ qtlEnrichmentPipeline <- function( is.list(fit) && !is.null(fit$pip) } -# One row's PIP vector keyed by variant id (see .enrPipTablesAt()). -# @noRd -.enrRowPipVector <- function(i, gwasFmr) { - piece <- .enrPipTablesAt(gwasFmr, i) - if (length(piece$pip) == 0L) { - return(NULL) - } - set_names(piece$pip, .variantTableIds(piece$table)) -} - # One outcome fit's PIPs and variants: every row of the collection carrying # that identity -- the fit's LD blocks -- joined. A variant several rows carry # is resolved by `duplicatePips` -- which is why the identity is the full fit @@ -917,12 +907,6 @@ qtlEnrichmentPipeline <- function( list_assign(region, pip = set_names(region$pip, ids)) } -# One row's region payload for qtlEnrichment (see .enrRegionsAt()). -# @noRd -.enrRowRegion <- function(i, qtlFmr) { - .enrRegionsAt(qtlFmr, i)[[1L]] -} - # The per-(study, context) list of region fits with named PIPs, as # qtlEnrichment() takes them (see .enrQtlTuple()). # @noRd diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index 88c6cecfd..d76360050 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: @@ -239,16 +253,14 @@ QtlSumStats <- function( } else { windows[split$fromIdx] } + regionCols <- .regionColumns( + given, + rep(!is.null(windows), n), + .rowSpanRanges(pieces) + ) cbind( exec(S4Vectors::DataFrame, !!!dfArgs)[split$fromIdx, , drop = FALSE], - exec( - S4Vectors::DataFrame, - !!!.regionColumns( - given, - rep(!is.null(windows), n), - .rowSpanRanges(pieces) - ) - ) + exec(S4Vectors::DataFrame, !!!regionCols) ) } diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 1e8817f9f..ca70e5d7a 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -63,6 +63,7 @@ mrashRssWeights <- function( shat <- as.numeric(stat$seb %||% numeric(0)) z <- .mrashRssZ(stat) s0 <- s0 %||% .mrashRssDefaultGrid(n, z, shat, varY) + user <- as.list(methodArgs) callArgs <- list_modify( list( bhat = as.numeric(stat$b %||% numeric(0)), @@ -77,13 +78,17 @@ mrashRssWeights <- function( # it is given, which would otherwise be the caller's. w0 = (w0 %||% rep(1 / length(s0), length(s0))) + 0 ), - !!!methodArgs + !!!user ) 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 +147,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 +180,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 +198,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 +221,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 +242,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$ldFactor)) { + 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$ldFactor, + seed = seed, + track = track ) } @@ -286,6 +333,7 @@ prsCsWeights <- function( n <- median(stat$n) bhat <- .rssMarginalCor(stat, n = n, p = .ldSourceSize(ld)) .rssValidateSource(bhat, ld, n) + user <- as.list(methodArgs) settings <- list_modify( .formalDefaults( prsCs, @@ -298,16 +346,23 @@ prsCsWeights <- function( "nBurnin", "thin", "verbose", - "seed" + "seed", + "shrinkCorr", + "raoBlackwell", + "nChains" ) ), - !!!as.list(methodArgs) + !!!user ) model <- exec(.prsCsRun, bhat = bhat, ld = ld, n = n, !!!settings) 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 +402,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 +440,9 @@ sdpr <- function( thin = 5, optLlk = 1, verbose = TRUE, - seed = NULL + seed = NULL, + raoBlackwell = FALSE, + nChains = 1 ) { .rssValidateInputs(bhat, R, n) .sdprRun( @@ -391,13 +461,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 +488,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 +508,39 @@ 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 ) - 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))) + .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$ldFactor)) { + return(exec( + sdprCpp, + !!!settings, + LD = list(blk1 = ld$R), + seed = seed, + track = track + )) } - exec(sdprFactorCpp, !!!settings, factorR = ld$F) + exec( + sdprFactorCpp, + !!!settings, + factorR = ld$ldFactor, + seed = seed, + track = track + ) } # Validate the SDPR settings: M >= 4 (SDPR uses M-2 indexing in sample_V; @@ -520,6 +617,7 @@ sdprWeights <- function( n <- median(stat$n) bhat <- .rssMarginalCor(stat, n = n, p = .ldSourceSize(ld)) .rssValidateSource(bhat, ld, n) + user <- as.list(methodArgs) settings <- list_modify( .formalDefaults( sdpr, @@ -536,16 +634,22 @@ sdprWeights <- function( "thin", "optLlk", "verbose", - "seed" + "seed", + "raoBlackwell", + "nChains" ) ), - !!!as.list(methodArgs) + !!!user ) model <- exec(.sdprRun, bhat = bhat, ld = ld, n = n, !!!settings) if (identical(fitRetention, "none")) { return(model$betaEst) } - `attr<-`(model$betaEst, "fit", model) + `attr<-`( + model$betaEst, + "fit", + .withFitVariantIds(model, stat[["variantNames"]]) + ) } @@ -602,16 +706,18 @@ 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)) + priorArgs <- split$prior + optionArgs <- split$rest mrmashFit <- exec( mrmashWrapper, X, Y, dataDrivenPriorMatrices = dataDrivenPriorMatrices, - prior = exec(MrmashPriorParam, !!!split$prior), - !!!split$rest + prior = exec(MrmashPriorParam, !!!priorArgs), + methodArgs = exec(MrmashOptions, !!!optionArgs) ) } out <- mr.mashr::coef.mr.mash(mrmashFit)[-1, , drop = FALSE] @@ -622,7 +728,8 @@ mrmashWeights <- function( out, mrmashFit, dataDrivenPriorMatrices, - fitRetention + fitRetention, + colnames(X) ) } @@ -637,7 +744,8 @@ mrmashWeights <- function( weights, fit, dataDrivenPriorMatrices, - fitRetention + fitRetention, + variantIds = NULL ) { if (identical(fitRetention, "none")) { return(weights) @@ -650,7 +758,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 +883,8 @@ mrmashRssWeights <- function( weights, mrmashRssFit, dataDrivenPriorMatrices, - fitRetention + fitRetention, + stat[["variantNames"]] ) } @@ -823,6 +932,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 +994,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 +1036,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 +1047,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 +1079,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 +1152,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 +1195,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 +1209,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", + ldFactor = "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 +1483,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 +1585,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 +1625,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 +1649,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 @@ -1411,6 +1727,7 @@ fitGlmnetCv <- function( # explicit NULL would reach cv.glmnet and override its default with # nothing. methodArgs is spliced last, so a user value wins over the # caller's -- these are literal defaults, not pecotmr-owned arguments. + user <- as.list(methodArgs) callArgs <- list_modify( c( list(x = x, y = y, alpha = alpha), @@ -1421,7 +1738,7 @@ fitGlmnetCv <- function( nfolds = nfolds )) ), - !!!methodArgs + !!!user ) exec(glmnet::cv.glmnet, !!!callArgs) } @@ -1434,10 +1751,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 +1772,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 +1795,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 +1829,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 +1841,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 +1936,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 @@ -1562,10 +1961,8 @@ mrashWeights <- function( XKeep <- X[, keep, drop = FALSE] # as.list(): list_assign() rejects a MethodOptions outright as `.x`, the # same S4-SimpleList seam that makes c() append it instead of splicing. - argsList <- list_assign( - as.list(methodArgs), - !!!.mrashBetaInit(methodArgs, XKeep, y, X, keep) - ) + betaInit <- .mrashBetaInit(methodArgs, XKeep, y, X, keep) + argsList <- list_assign(as.list(methodArgs), !!!betaInit) fit.mr.ash <- exec(mr.ash, X = XKeep, y = y, !!!argsList) # Zero-variance columns were never fitted and keep a zero weight. eff.wgt <- replace( @@ -1576,743 +1973,2311 @@ 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)) - keep <- .dropZeroVariance(X, "bayesAlphabetWeights") - + 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") + 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) + } + user <- as.list(methodArgs) 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 + ), + !!!user + ) + 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))) + user <- as.list(methodArgs) + 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 + !!!user + ) + 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) + user <- as.list(methodArgs) + callArgs <- list_modify( + list( + stat = qin$stat, + Glist = qin$Glist, + LD = qin$LD, + method = .alphabetEngineMethods$qgg[[method]], + nit = nIter - nBurnin, + nburn = nBurnin, + nthin = thin + ), + !!!user + ) + 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) + user <- as.list(methodArgs) + 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 + ), + !!!user + ) + 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) + user <- as.list(methodArgs) + callArgs <- list_modify( + list( + bhat = bhat, + ldFactor = ld$ldFactor, + n = n, + method = method, + nIter = nIter, + nBurnin = nBurnin, + thin = thin, + pi = pi, + nPerVariant = stat$n, + shrinkCorr = shrinkCorr + ), + !!!user + ) + 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 ldFactor The factor F 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, + ldFactor, + 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, + ldFactor, + 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, + ldFactor, + n, + nPerVariant, + perVariantWeights, + ldProjection +) { + projected <- .alphabetProjected(bhat, ldFactor, ldProjection) + list( + bhat = projected$bhat, + factorR = projected$ldFactor, + 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 `ldFactor` (.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 `ldFactor` as they are. +# @noRd +.alphabetProjected <- function(bhat, ldFactor, a) { + if (is.null(a)) { + return(list(bhat = bhat, ldFactor = ldFactor)) + } + ev <- .ldFactorEigen(ldFactor) + 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))), + ldFactor = 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$ldFactor) / (nrow(inp$ld$ldFactor) - 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$ldFactor, + 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$ldFactor, + 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) + keptBetas <- map(chains[kept], "betaEst") + beta <- rowMeans(exec(cbind, !!!keptBetas)) + if (identical(fitRetention, "none")) { + return(beta) + } + keptPostps <- map(chains[kept], "postp") + 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, !!!keptPostps)), + p = mean(map_dbl(chains[kept], "p")), + h2 = mean(map_dbl(chains[kept], "h2")) ) + if (identical(fitRetention, "full")) { + chainBetas <- map(chains, "betaEst") + fit$beta <- exec(cbind, !!!chainBetas) + } + `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 +4384,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 +4412,178 @@ 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 + ) + corScores <- map(scores, "cor") + explainedScores <- map(scores, "explained") + idx <- .rssHeldOutPick( + rowMeans(exec(cbind, !!!corScores)), + rowMeans(exec(cbind, !!!explainedScores)) + ) + 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) + refitArgs <- refit$args + beta <- exec(refit$fn, trainCor = trainCor, share = share, !!!refitArgs) + 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 + ) + fitBetas <- map(fits, "beta") + exec(cbind, !!!fitBetas) +} + +# 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 / @@ -2478,7 +4615,7 @@ lassosumRss <- function( if (missing(n) || n <= 0) { abort("Please provide a valid sample size using 'n'.") } - assertVector(bhat, len = ncol(ld$F)) + assertVector(bhat, len = ncol(ld$ldFactor)) invisible(NULL) } @@ -2611,15 +4748,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(ldFactor = .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 +4818,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)) @@ -2704,13 +4850,19 @@ lassosumRss <- function( n = n, config = config ) - candidateBeta <- exec(cbind, !!!map(fits, "beta")) + fitBetas <- map(fits, "beta") + candidateBeta <- exec(cbind, !!!fitBetas) 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 +4870,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 +4928,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 +4936,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 +4980,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 +5017,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 +5039,195 @@ 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) { + lassosumOptions <- config$options + fits <- exec( + bigsnpr::snp_lassosum2, + engine$corr, + .bigsnprDfBeta(inp), + delta = config$delta, + ncores = 1, + !!!lassosumOptions + ) + 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 +5235,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 +5271,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 +5424,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 +5443,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 +5458,8 @@ penalizedRss <- function( list( method = "penalized", spec = spec, - options = as.list(methodArgs) + options = as.list(methodArgs), + label = label ), selection, fitRetention @@ -3071,8 +5469,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 +5488,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 +5509,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 +5518,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 +5542,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 +5561,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 +5582,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 +5591,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 +5616,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 +5651,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 +5661,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 +5689,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 +5717,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 +5748,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 +5774,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 +5788,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 +5804,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 +5814,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 +5832,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 +5841,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 +5876,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,15 +5899,18 @@ 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.") } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "ncvregWeights") + user <- as.list(methodArgs) callArgs <- list_modify( list( X = X[, keep, drop = FALSE], @@ -3496,10 +5918,40 @@ ncvregWeights <- function( penalty = penalty, nfolds = nfolds ), - !!!methodArgs + !!!user ) 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 +5966,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 +6006,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 +6047,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,14 +6073,17 @@ 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.") } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "l0learnWeights") + user <- as.list(methodArgs) callArgs <- list_modify( list( x = X[, keep, drop = FALSE], @@ -3606,19 +6091,42 @@ l0learnWeights <- function( penalty = penalty, nFolds = nFolds ), - !!!methodArgs + !!!user ) 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 +6145,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 +6166,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.") } @@ -3666,6 +6183,7 @@ bglrWeights <- function( saveAt <- str_c(tmpdir, .Platform$file.sep) eta <- list(c(list(X = X[, keep, drop = FALSE], model = model), etaArgs)) + user <- as.list(methodArgs) callArgs <- list_modify( list( y = y, @@ -3676,118 +6194,14 @@ bglrWeights <- function( saveAt = saveAt, verbose = FALSE ), - !!!methodArgs + !!!user ) 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 +6227,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 @@ -3842,6 +6256,7 @@ dprWeights <- function( zeros <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "dprWeights") w <- matrix(1, nrow = nrow(X), ncol = 1) + user <- as.list(methodArgs) callArgs <- list_modify( list( y = y, @@ -3850,14 +6265,19 @@ dprWeights <- function( rotate_variables = FALSE, fitting_method = fittingMethod ), - !!!methodArgs + !!!user ) 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 +6449,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 +6542,6 @@ mrmashWrapper <- function( X = X, Y = Y, standardize = standardize, - threads = threads, updateVMethod = updateVMethod, methodArgs = methodArgs ) @@ -4276,7 +6695,6 @@ mrmashWrapper <- function( X, Y, standardize, - threads, updateVMethod, methodArgs ) { @@ -4290,7 +6708,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)) @@ -4312,7 +6731,8 @@ mrmashWrapper <- function( verbose = FALSE, w0_threshold = 1e-8 ) - exec(mr.mashr::mr.mash, !!!c(derived, list_modify(defaults, !!!user))) + mrMashArgs <- c(derived, list_modify(defaults, !!!user)) + exec(mr.mashr::mr.mash, !!!mrMashArgs) } # @noRd @@ -4763,11 +7183,12 @@ buildMrmashPriorMatrices <- function( canonicalPriorMatrices, canonicalCovs ) + user <- as.list(expandCovs) S0 <- exec( mr.mashr::expand_covs, S0_raw, priorGrid, - !!!as.list(expandCovs) + !!!user ) list(S0 = S0, priorGrid = priorGrid) } @@ -4784,10 +7205,11 @@ buildMrmashPriorMatrices <- function( if (!isTRUE(canonicalPriorMatrices)) { return(dataDrivenPriorMatrices$U) } + user <- as.list(canonicalCovs) canonical <- exec( mr.mashr::compute_canonical_covs, K, - !!!as.list(canonicalCovs) + !!!user ) if (is.null(dataDrivenPriorMatrices)) { return(canonical) @@ -4798,8 +7220,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 +7237,9 @@ buildMrmashPriorMatrices <- function( maxiter, maxSwaps ) { + if (.rssIsRidge(penalty, alpha)) { + return(.rssRidgeSolve(z, lam, ld)) + } settings <- list( lambdaR = lam, penaltyStr = penalty, @@ -4825,11 +7251,11 @@ buildMrmashPriorMatrices <- function( maxiter = as.integer(maxiter), maxSwaps = as.integer(maxSwaps) ) - if (!is.null(ld$F)) { + if (!is.null(ld$ldFactor)) { return(exec( penalizedRssFactorCpp, zR = z, - factorR = ld$F, + factorR = ld$ldFactor, shrink = ld$shrink %||% 0, !!!settings )) @@ -4843,6 +7269,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..df622a589 100644 --- a/R/resultWriters.R +++ b/R/resultWriters.R @@ -85,7 +85,8 @@ NULL if (length(present) == 0L) { return(rep("", nrow(df))) } - exec(str_c, !!!map(as.list(df[present]), .pubKeyPart), sep = "\r") + keyParts <- map(as.list(df[present]), .pubKeyPart) + exec(str_c, !!!keyParts, sep = "\r") } # The same key read off a COLLECTION's tuple columns, so a long-format view's @@ -95,11 +96,8 @@ NULL # @noRd .pubCollectionKey <- function(x, cols) { present <- intersect(cols, .tupleColumnNames(x)) - exec( - str_c, - !!!map(map(present, .pubTupleColumn, x = x), .pubKeyPart), - sep = "\r" - ) + keyParts <- map(map(present, .pubTupleColumn, x = x), .pubKeyPart) + exec(str_c, !!!keyParts, sep = "\r") } # @noRd @@ -269,15 +267,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 +286,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 +320,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 +1551,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 +1598,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 +1652,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 +1687,50 @@ 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")) + cellAlleles <- map(view$entries[cells], .twvCellAlleles) + all <- exec(c, !!!cellAlleles) 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 +1740,19 @@ setMethod( # The nVariant x nSample weight matrix: one column per model, placed onto the # union by variant id. # @noRd -.twvWeightMatrix <- function(x, samples, unionIds) { - exec( - cbind, - !!!map(samples, .twvSampleColumn, x = x, unionIds = unionIds) +.twvWeightMatrix <- function(view, samples, unionIds) { + sampleCols <- map( + samples, + .twvSampleColumn, + view = view, + unionIds = unionIds ) + exec(cbind, !!!sampleCols) } # @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 +1772,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 +2712,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 +2751,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 +2769,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 +2830,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 +2915,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 +2929,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 +2958,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 +3005,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/sldscPostprocessingPipeline.R b/R/sldscPostprocessingPipeline.R index 2d03dff82..0f41e38d3 100644 --- a/R/sldscPostprocessingPipeline.R +++ b/R/sldscPostprocessingPipeline.R @@ -632,7 +632,8 @@ sldscPostprocessingPipeline <- function( )) nmOld <- c("mean", "se", "p") nmNew <- str_c(label, str_to_upper(str_sub(nmOld, 1, 1)), str_sub(nmOld, 2)) - rename(df, !!!set_names(nmOld, nmNew)) + renameMap <- set_names(nmOld, nmNew) + rename(df, !!!renameMap) } # One category's meta row. diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index d9b12bd61..c29089e04 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -1064,11 +1064,12 @@ sldscSubsetMeta <- function( return(NULL) } present <- colsHave[avail] + presentCols <- set_names( + map(srcCols[avail], .sldscColumnOf, df = df), + present + ) list( - summary = tibble( - target = df$target, - !!!set_names(map(srcCols[avail], .sldscColumnOf, df = df), present) - ) + summary = tibble(target = df$target, !!!presentCols) ) } diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 9798ae604..7d17cf629 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. @@ -203,8 +209,8 @@ resolveLdInput <- function( } # Run DENTIST on a single window, unpacking the shared tuning parameters. -# `ld` is .dentistLdInput()'s list(R) or list(F); a factor goes in as X, which -# dentistSingleWindow() reads without forming the LD. +# `ld` is .dentistLdInput()'s list(R) or list(ldFactor); a factor goes in as +# X, which dentistSingleWindow() reads without forming the LD. .dentistCallSingle <- function(zScore, ld, nSample, dentistParam) { # dentistSingleWindow is what DentistParam() is built for -- ldMismatchQc # splices the same bundle into it -- so the tunables travel as one value @@ -213,7 +219,7 @@ resolveLdInput <- function( dentistSingleWindow, zScore, R = ld$R, - X = ld$F, + X = ld$ldFactor, nSample = nSample, !!!dentistParam ) @@ -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 @@ -262,7 +265,10 @@ resolveLdInput <- function( .ldRequireOneSource(R, X) if (is.null(R) && identical(ldMethod, "sample")) { X <- as.matrix(X) - return(list(F = .ldFactorFromDosage(X), nSample = nSample %||% nrow(X))) + return(list( + ldFactor = .ldFactorFromDosage(X), + nSample = nSample %||% nrow(X) + )) } ld <- resolveLdInput( R = R, @@ -454,11 +460,11 @@ dentist <- function( ) warn(msg) } - if (!is.null(ld$F)) { - if (ncol(ld$F) != length(zScore)) { + if (!is.null(ld$ldFactor)) { + if (ncol(ld$ldFactor) != length(zScore)) { abort(glue( "The genotypes must have one column per z-score ", - "({ncol(ld$F)} columns, {length(zScore)} z-scores)." + "({ncol(ld$ldFactor)} columns, {length(zScore)} z-scores)." )) } return(invisible(NULL)) @@ -483,11 +489,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 +501,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 ) } @@ -514,14 +512,14 @@ dentist <- function( .dentistRunImpute <- function(ld, nSample, zScore, p) { verboseIter <- getOption("pecotmr.dentist.verbose", FALSE) # The factor kernel imputes from the LD's factor without forming it. - kernel <- if (is.null(ld$F)) { + kernel <- if (is.null(ld$ldFactor)) { dentistIterativeImpute } else { dentistIterativeImputeFactor } raw <- kernel( # cpp11 requires exact integer types for int parameters - ld$R %||% ld$F, + ld$R %||% ld$ldFactor, as.integer(nSample), zScore, p$pValueThreshold, @@ -636,27 +634,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 +1351,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(ldFactor = 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$ldFactor)) { + 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 +1499,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 +1538,7 @@ slalom <- function( } else { which.max(prob) } - rLead <- .slalomLeadR(zScore, R, X, leadIdx, ldMethod) + rLead <- .slalomLeadColumn(ld, leadIdx) ds <- .slalomDentistS( zScore, rLead, @@ -2037,14 +2109,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 +2225,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,22 +2519,21 @@ 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 - mutate( - resolved, - !!!compact(list( - beta = if (is_in("beta", colnames(resolved))) { - replace(resolved$beta, observed, NA) - }, - se = if (is_in("se", colnames(resolved))) { - replace(resolved$se, observed, NA) - } - )) - ) + # 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 + maskedCols <- compact(list( + beta = if (is_in("beta", colnames(resolved))) { + replace(resolved$beta, imputed, NA) + }, + se = if (is_in("se", colnames(resolved))) { + replace(resolved$se, imputed, NA) + } + )) + mutate(resolved, !!!maskedCols) } # Format one aligned "label: value" report line (label left-padded to @@ -2785,14 +2862,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 +2881,65 @@ 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) + chosenArgs <- chosen$args + if (chosen$engine == "dentist") { + settings <- list_modify( + .formalDefaults(dentistSingleWindow, .dentistSettingNames()), + !!!chosenArgs + ) + whole <- if (is.null(ld$ldFactor)) 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" + ) + ) + ), + !!!chosenArgs + ) + .slalomOutliers(exec(.slalomOnSource, zScore, ld, !!!settings)) } #' Effective sample size for a case/control study @@ -2908,17 +3024,15 @@ effectiveN <- function(nCase, nControl) { seqnames = chr, ranges = IRanges::IRanges(start = as.integer(df$pos), width = 1L) ) - df <- mutate( - df, - !!!compact(list( - SNP = if ( - is_in("variant_id", colnames(df)) && - !is_in("SNP", colnames(df)) - ) { - df$variant_id - } - )) - ) + snpCol <- compact(list( + SNP = if ( + is_in("variant_id", colnames(df)) && + !is_in("SNP", colnames(df)) + ) { + df$variant_id + } + )) + df <- mutate(df, !!!snpCol) baseCols <- c("SNP", "A1", "A2", "Z", "N") # AF = directional effect-allele frequency (exported as af); MAF = # directionless QC frequency. Both carried when the loader resolved them. @@ -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))) - ) + )) } # ----------------------------------------------------------------------------- @@ -2993,13 +3107,11 @@ effectiveN <- function(nCase, nControl) { present <- statMap[is_in(statMap, colnames(mc))] # mutate() overwrites an existing column in place and appends a new one, # which is what the `df[[out]] <-` loop did. - out <- mutate( - df, - !!!set_names( - map(unname(present), .entryStatColumn, mc = mc), - names(present) - ) + statCols <- set_names( + map(unname(present), .entryStatColumn, mc = mc), + names(present) ) + out <- mutate(df, !!!statCols) .entryDfDeriveMaf(out) } @@ -3140,35 +3252,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 ) @@ -3236,13 +3334,11 @@ effectiveN <- function(nCase, nControl) { bs <- .zToBetaSe(z, maf, n) se <- bs$se beta <- bs$beta - derived <- mutate( - df, - !!!compact(list( - BETA = if (!hasBeta) beta, - SE = if (!hasSe) se - )) - ) + betaSeCols <- compact(list( + BETA = if (!hasBeta) beta, + SE = if (!hasSe) se + )) + derived <- mutate(df, !!!betaSeCols) list(df = derived, audit = list(nDerived = sum(!is.na(se)))) } @@ -3426,7 +3522,8 @@ effectiveN <- function(nCase, nControl) { # The same, for counters that are reported only when something happened. # @noRd .qcAuditPositive <- function(...) { - exec(.qcAudit, !!!discard(list(...), .qcCountIsZero)) + nonZeroCounts <- discard(list(...), .qcCountIsZero) + exec(.qcAudit, !!!nonZeroCounts) } # @noRd @@ -3515,8 +3612,9 @@ effectiveN <- function(nCase, nControl) { ] coercions <- map(toCoerce, .scCoerceColumn, df = df) naIntroduced <- sum(map_int(coercions, "na")) + coercedCols <- set_names(map(coercions, "values"), toCoerce) list( - df = mutate(df, !!!set_names(map(coercions, "values"), toCoerce)), + df = mutate(df, !!!coercedCols), audit = .qcAuditPositive(nonNumericCoerced = naIntroduced) ) } @@ -3682,8 +3780,10 @@ effectiveN <- function(nCase, nControl) { # to run returns the frame unchanged and an empty audit. # @noRd .scApplyStep <- function(state, step) { - r <- exec(step$fn, state$df, !!!step$args) - list(df = r$df, audit = list_modify(state$audit, !!!r$audit)) + stepArgs <- step$args + r <- exec(step$fn, state$df, !!!stepArgs) + stepAudit <- r$audit + list(df = r$df, audit = list_modify(state$audit, !!!stepAudit)) } # Apply ldMismatchQc (SLALOM/DENTIST) against the LD sketch. Returns the @@ -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(ldFactor = 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 @@ -4233,6 +4333,11 @@ effectiveN <- function(nCase, nControl) { return(list(df = df, total = NA_integer_, imputed = 0L)) } impDf <- imputed$resultFilter + imputedCols <- compact(list( + N = if (is_in("n", colnames(impDf))) impDf$n, + BETA = if (is_in("beta", colnames(impDf))) impDf$beta, + SE = if (is_in("se", colnames(impDf))) impDf$se + )) rebuilt <- mutate( tibble( chrom = impDf$chrom, @@ -4242,11 +4347,7 @@ effectiveN <- function(nCase, nControl) { A2 = impDf$A2, Z = impDf$z ), - !!!compact(list( - N = if (is_in("n", colnames(impDf))) impDf$n, - BETA = if (is_in("beta", colnames(impDf))) impDf$beta, - SE = if (is_in("se", colnames(impDf))) impDf$se - )) + !!!imputedCols ) # RAISS reconstructs the z-score only, so it has no frequency for an # imputed variant. But the OBSERVED variants came in with a (harmonized, @@ -4445,20 +4546,19 @@ effectiveN <- function(nCase, nControl) { # Re-key SNP to the harmonized id: .matchAgainstLdRef rewrites variant_id # to the panel orientation + sign-flips swapped variants but leaves SNP; a # stale SNP makes flipped variants miss the panel in later lookups. - reKeyed <- mutate( - `attr<-`(matched, "qcCounts", NULL), - !!!compact(list(SNP = matched$variant_id)) - ) + snpCol <- compact(list(SNP = matched$variant_id)) + reKeyed <- mutate(`attr<-`(matched, "qcCounts", NULL), !!!snpCol) + correctionCounts <- compact(list( + harmCorrSign = harmCounts$signFlip, + harmCorrStrand = harmCounts$strandFlip + )) counts <- list_assign( list( harmCorrSign = 0L, harmCorrStrand = 0L, harmDropped = nHarmIn - nrow(reKeyed) ), - !!!compact(list( - harmCorrSign = harmCounts$signFlip, - harmCorrStrand = harmCounts$strandFlip - )) + !!!correctionCounts ) .qcHarmonizeReport( nrow(reKeyed), @@ -4510,15 +4610,12 @@ effectiveN <- function(nCase, nControl) { if (!any(flip)) { return(df) } - mutate( - df, - Z = replace(.data$Z, flip, -df$Z[flip]), - !!!compact(list( - BETA = if (is_in("BETA", colnames(df))) { - replace(df$BETA, flip, -df$BETA[flip]) - } - )) - ) + flippedCols <- compact(list( + BETA = if (is_in("BETA", colnames(df))) { + replace(df$BETA, flip, -df$BETA[flip]) + } + )) + mutate(df, Z = replace(.data$Z, flip, -df$Z[flip]), !!!flippedCols) } # @noRd @@ -4533,7 +4630,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, @@ -4692,17 +4789,15 @@ effectiveN <- function(nCase, nControl) { df <- nRes$df applied <- isTRUE(is_in(nRes$nSource, c("effective", "total"))) && is_in("N", colnames(df)) + nForPipUpdate <- compact(list( + nForPip = if (applied) { + stats::median(as.numeric(df$N), na.rm = TRUE) + } + )) list( df = df, nSource = nRes$nSource, - opts = list_assign( - opts, - !!!compact(list( - nForPip = if (applied) { - stats::median(as.numeric(df$N), na.rm = TRUE) - } - )) - ) + opts = list_assign(opts, !!!nForPipUpdate) ) } @@ -4739,26 +4834,25 @@ effectiveN <- function(nCase, nControl) { # Derive BETA/SE from signed Z, then P from Z (re-clamping tiny P). .qcStepDerive <- function(df, opts, entryAudit) { derived <- .deriveBetaSeFromZ(df) - withBetaSe <- list_assign( - entryAudit, - !!!compact(list(betaSeFromZ = derived$audit)) - ) + deriveAudit <- compact(list(betaSeFromZ = derived$audit)) + withBetaSe <- list_assign(entryAudit, !!!deriveAudit) if (!is_in("Z", colnames(derived$df)) || is_in("P", colnames(derived$df))) { return(list(df = derived$df, entryAudit = withBetaSe)) } withP <- mutate(derived$df, P = .zToPvalue(.data$Z)) clamped <- .qcClampDerivedP(withP, opts) + clampAudit <- compact(list( + sanityChecks = .qcAddClampCount( + entryAudit$sanityChecks, + clamped$nClamped + ) + )) list( df = clamped$df, entryAudit = list_assign( withBetaSe, pValueFromZ = sum(!is.na(withP$P)), - !!!compact(list( - sanityChecks = .qcAddClampCount( - entryAudit$sanityChecks, - clamped$nClamped - ) - )) + !!!clampAudit ) ) } @@ -4878,10 +4972,11 @@ effectiveN <- function(nCase, nControl) { # @noRd .qcPhaseSanity <- function(state) { san <- .qcStepSanity(state$df, state$opts, state$lbl) + sanityAudit <- san$audit list_assign( state, df = san$df, - entryAudit = list_modify(state$entryAudit, !!!san$audit) + entryAudit = list_modify(state$entryAudit, !!!sanityAudit) ) } @@ -4901,10 +4996,11 @@ effectiveN <- function(nCase, nControl) { # @noRd .qcPhaseContentFilters <- function(state) { cf <- .qcStepContentFilters(state$df, state$opts, state$lbl) + filterAudit <- cf$audit list_assign( state, df = cf$df, - entryAudit = list_modify(state$entryAudit, !!!cf$audit) + entryAudit = list_modify(state$entryAudit, !!!filterAudit) ) } @@ -4920,10 +5016,11 @@ effectiveN <- function(nCase, nControl) { # @noRd .qcPhaseKeepSkip <- function(state) { ks <- .qcStepKeepSkip(state$df, state$opts) + keepSkipAudit <- ks$audit list_assign( state, df = ks$df, - entryAudit = list_modify(state$entryAudit, !!!ks$audit) + entryAudit = list_modify(state$entryAudit, !!!keepSkipAudit) ) } @@ -4936,11 +5033,13 @@ effectiveN <- function(nCase, nControl) { state$opts, state$lbl ) + harmAudit <- harm$audit + harmCounts <- harm$counts list_assign( state, df = harm$df, - entryAudit = list_modify(state$entryAudit, !!!harm$audit), - qcCount = list_modify(state$qcCount, !!!harm$counts) + entryAudit = list_modify(state$entryAudit, !!!harmAudit), + qcCount = list_modify(state$qcCount, !!!harmCounts) ) } @@ -4948,10 +5047,11 @@ effectiveN <- function(nCase, nControl) { # @noRd .qcPhaseScreen <- function(state) { scr <- .qcStepScreen(state$df, state$opts) + screenAudit <- scr$audit list_assign( state, df = scr$df, - entryAudit = list_modify(state$entryAudit, !!!scr$audit) + entryAudit = list_modify(state$entryAudit, !!!screenAudit) ) } @@ -4985,12 +5085,14 @@ effectiveN <- function(nCase, nControl) { list_assign(shared, df = kr$df, dropped = 0L) } ) + krigingAudit <- kr$audit + mismatchAudit <- mm$audit list_assign( state, df = mm$df, entryAudit = list_modify( - list_modify(state$entryAudit, !!!kr$audit), - !!!mm$audit + list_modify(state$entryAudit, !!!krigingAudit), + !!!mismatchAudit ), qcCount = list_assign( state$qcCount, @@ -5010,10 +5112,11 @@ effectiveN <- function(nCase, nControl) { state$lbl, state$qcCount ) + imputeAudit <- imp$audit list_assign( state, df = imp$df, - entryAudit = list_modify(state$entryAudit, !!!imp$audit), + entryAudit = list_modify(state$entryAudit, !!!imputeAudit), qcCount = imp$qcCount ) } @@ -5161,13 +5264,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), @@ -5263,23 +5365,21 @@ effectiveN <- function(nCase, nControl) { .ssqcEntryOpts <- function(opts, sumstats, i) { mc <- S4Vectors::mcols(.collectionEntry(sumstats, i)) cols <- .tupleColumnNames(sumstats) - list_assign( - opts, - !!!compact(list( - nForPip = if (is_in("N", colnames(mc))) { - stats::median(mc$N, na.rm = TRUE) - }, - nCase = if (is_in("nCase", cols)) { - as.numeric(sumstats$nCase)[[i]] - }, - nControl = if (is_in("nControl", cols)) { - as.numeric(sumstats$nControl)[[i]] - }, - nSample = if (is_in("nSample", cols)) { - as.numeric(sumstats$nSample)[[i]] - } - )) - ) + nUpdates <- compact(list( + nForPip = if (is_in("N", colnames(mc))) { + stats::median(mc$N, na.rm = TRUE) + }, + nCase = if (is_in("nCase", cols)) { + as.numeric(sumstats$nCase)[[i]] + }, + nControl = if (is_in("nControl", cols)) { + as.numeric(sumstats$nControl)[[i]] + }, + nSample = if (is_in("nSample", cols)) { + as.numeric(sumstats$nSample)[[i]] + } + )) + list_assign(opts, !!!nUpdates) } # Per-entry log label: study/context/trait (QTL) or study (GWAS). @@ -5335,7 +5435,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]] @@ -5389,7 +5489,8 @@ effectiveN <- function(nCase, nControl) { c("study", "context", "trait"), .tupleColumnNames(sumstats) ) - exec(str_c, !!!map(cols, .ssqcKeyPart, sumstats = sumstats), sep = "\r") + keyParts <- map(cols, .ssqcKeyPart, sumstats = sumstats) + exec(str_c, !!!keyParts, sep = "\r") } # @noRd @@ -5875,7 +5976,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..fbc8a1b17 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,29 +1169,46 @@ # @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 <- list_assign( - set_names(map(allCols, .rbindColumn, parts = parts), allCols), - ldReference = dict$keys - ) - md <- exec( - S4Vectors::DataFrame, - !!!c(combined, list(check.names = FALSE)) + 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) + dictKeys <- set_names(map(dicts, "keys"), keyCols) + combined <- list_assign(combined, !!!dictKeys) + dataFrameArgs <- c( + map(combined, .rbindAsDataFrameColumn), + list(check.names = FALSE) ) + md <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) # 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 # build and NA. The agreed build is written back explicitly to keep # 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)) + slotArgs <- c(map(dicts, "entries"), slots) + exec(methods::new, cls, .rtlStored(cls, grl), !!!slotArgs) +} + +# @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 +1250,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 +1333,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 +1360,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 +1524,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 +1548,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 +1558,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 +1572,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 +1770,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 +1892,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 +1982,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 +2099,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 +2138,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 +2279,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 +2521,7 @@ # first row's reference. # @noRd .ldRefMergeViews <- function(dict, fn) { - refs <- dict$refs + refs <- dict$entries if (length(refs) <= 1L) { return(dict) } @@ -2264,7 +2543,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 +2598,79 @@ } # 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)) + ) { + dosages <- unname(map(panels, .seDosage)) + bound <- exec(BiocGenerics::rbind, !!!dosages) + 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 +2755,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..912575fc3 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 @@ -285,91 +334,1028 @@ TwasWeights <- function( assertCharacter(jointTraits, null.ok = TRUE) } -# The outer-mcols columns for a TwasWeights: the four identity columns, the -# per-row payload columns, then the optional joint axes and trait position. +# 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)) + identCols <- set_names( + map(ident, .twasRowValues, md = md, rows = rows), + ident + ) + tibble( + row = rows, + method = list_c(methods, ptype = character()), + !!!identCols + ) +} + +# 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) + paddedRanges <- unname(padded) + suppressWarnings(exec(c, !!!paddedRanges)) +} + +# @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)))) + } + blockRanges <- unname(blocks) + suppressWarnings(exec(c, !!!blockRanges)) +} + +# @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 + ) +} + +# @noRd +.twasRowValue <- function(nm, md, row) { + md[[nm]][[row]] +} + +# One weight column of one entry as flat ranges. # @noRd -.twasMetadataCols <- function( - studyName, - context, - trait, - method, - entry, - jointStudies, - jointContexts, - jointTraits, - traitPos, - region, - n -) { - baseCols <- c( +.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 +1370,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 +1415,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 +1535,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 +1550,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 +1675,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 +1779,7 @@ setMethod("show", "TwasWeights", function(object) { ), bayesL = list( fn = "bayes_l_weights", - impl = "bLassoWeights", + impl = "bayesLWeights", args = list() ), bayesA = list( @@ -798,11 +1802,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 +1932,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 +1964,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 +2005,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 +2147,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 +2193,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 +2222,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 +2280,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 +2344,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 +2602,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 +2648,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,95 +2705,50 @@ 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 .twasSetMethodArg <- function(weightMethods, method, arg, value) { - updated <- list_assign( - weightMethods[[method]], - !!!set_names(list(value), arg) - ) - list_assign(weightMethods, !!!set_names(list(updated), method)) + argValue <- set_names(list(value), arg) + updated <- list_assign(weightMethods[[method]], !!!argValue) + methodEntry <- set_names(list(updated), method) + list_assign(weightMethods, !!!methodEntry) } -# 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,62 +2799,66 @@ 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 -) { - list_assign( - args, - !!!compact(list( - dataDrivenPriorMatrices = if ( - !is.null(dataDrivenPriorMatricesCv) && - is_in(method, c("mrmash_weights", "mrmashWeights")) - ) { - dataDrivenPriorMatricesCv[[j]] - }, - prior_variance = if ( - !is.null(reweightedMixturePriorCv) && - is_in(method, c("mvsusie_weights", "mvsusieWeights")) - ) { - reweightedMixturePriorCv[[j]] - } - )) - ) +.twasFoldPriors <- function(args, method, j, dataDrivenPriorMatricesCv) { + priorUpdates <- compact(list( + dataDrivenPriorMatrices = if ( + !is.null(dataDrivenPriorMatricesCv) && + is_in(method, c("mrmash_weights", "mrmashWeights")) + ) { + dataDrivenPriorMatricesCv[[j]] + } + )) + list_assign(args, !!!priorUpdates) } -# 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,17 +2868,13 @@ setMethod("show", "TwasWeights", function(object) { args, method, j, - ctx$dataDrivenPriorMatricesCv, - ctx$reweightedMixturePriorCv - ) - retaining <- !identical(ctx$fitRetention, "none") && - is_in("fitRetention", names(formals(fnName))) - fitArgs <- list_assign( - withPriors, - !!!compact(list( - fitRetention = if (retaining) ctx$fitRetention - )) + ctx$dataDrivenPriorMatricesCv ) + retaining <- !identical(ctx$fitRetention, "none") + retentionArg <- compact(list( + fitRetention = if (retaining) ctx$fitRetention + )) + fitArgs <- list_assign(withPriors, !!!retentionArg) callArgs <- .twasWeightCallArgs(fnName, list(X = Xtr, Y = Ytr), fitArgs) W <- if (ctx$verbose < 2) { .quietEval(exec(fnName, !!!callArgs)) @@ -1782,9 +2906,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 +2958,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 +3013,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 +3034,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 +3061,7 @@ twasWeightsCv <- function( fitRetention = fitRetention, seed = seed, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, - reweightedMixturePriorCv = reweightedMixturePriorCv, - fittedModelsCv = fittedModelsCv + foldWeights = foldWeights ) } @@ -1952,26 +3084,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 +3112,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 +3128,7 @@ twasWeightsCv <- function( .twasCvFoldCtx <- function( weightMethods, dataDrivenPriorMatricesCv, - reweightedMixturePriorCv, - fittedModelsCv, + foldWeights, fitRetention, verbose ) { @@ -2008,8 +3139,7 @@ twasWeightsCv <- function( weightMethods = weightMethods, multivariateWeightMethods = .twasCvMultivariateMethods, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, - reweightedMixturePriorCv = reweightedMixturePriorCv, - fittedModelsCv = fittedModelsCv, + foldWeights = foldWeights, fitRetention = fitRetention, verbose = verbose ) @@ -2031,12 +3161,11 @@ twasWeightsCv <- function( fitRetention, seed, dataDrivenPriorMatricesCv, - reweightedMixturePriorCv, - fittedModelsCv + foldWeights ) { weightMethods <- .twasCvResolveMethods( weightMethods, - fittedModelsCv, + foldWeights, samplePartitions, seed, verbose @@ -2053,8 +3182,7 @@ twasWeightsCv <- function( fitFoldCtx = .twasCvFoldCtx( weightMethods, dataDrivenPriorMatricesCv, - reweightedMixturePriorCv, - fittedModelsCv, + foldWeights, fitRetention, verbose ), @@ -2074,22 +3202,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 +3229,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 +3248,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 +3284,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 +3487,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 +3512,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 +3776,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 +3800,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 +3818,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 +3829,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 +3974,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..6bada1568 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 ) ) @@ -368,7 +377,8 @@ combineTwasWeights <- function(..., ldReference = NULL) { return(list(key = tk, args = methods[[tk]])) } snake <- names(base)[[1L]] - merged <- list_modify(base[[snake]], !!!compact(methods[[tk]])) + givenSettings <- compact(methods[[tk]]) + merged <- list_modify(base[[snake]], !!!givenSettings) # `impl` tells .resolveMethodFunction which function backs the token; # without it the bare token is used, which is not a function. list( @@ -413,7 +423,6 @@ combineTwasWeights <- function(..., ldReference = NULL) { "bayesB", "bayesC", "bayesN", - "bLasso", "dprVb", "dprGibbs", "dprAdaptiveGibbs", @@ -446,7 +455,6 @@ combineTwasWeights <- function(..., ldReference = NULL) { bayesB = "bayesB", bayesC = "bayesC", bayesN = "bayesN", - bLasso = "bLasso", dprVb = "dprVb", dprGibbs = "dprGibbs", dprAdaptiveGibbs = "dprAdaptiveGibbs", @@ -456,13 +464,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 +927,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 +1107,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 +1157,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 +1249,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 +1279,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 +1374,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 +1561,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { .twasPipelineQtlDataset <- function( data, methods = "default", + backend = NULL, contexts = NULL, traitId = NULL, region = NULL, @@ -1582,6 +1628,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { resolvedTokens <- .twasQdsResolveTokens( jointSpecification, methods, + backend, fineMappingResult, .cvResolve(crossValidationParam), data @@ -1762,6 +1809,7 @@ setMethod( .twasQdsResolveTokens <- function( jointSpecification, methods, + backend, fineMappingResult, cvCfg, data @@ -1773,6 +1821,7 @@ setMethod( .twasMethodListArgs(norm$methodList), "QtlDataset" ) + .twasCheckBackend(backend, norm$tokens, "individual") .twasCheckFineMappingMethods( norm$tokens, fineMappingResult, @@ -1780,9 +1829,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 +2231,7 @@ setMethod( function( data, methods = NULL, + backend = NULL, contexts = NULL, traitId = NULL, cisWindow = NULL, @@ -2141,6 +2259,7 @@ setMethod( res <- .twasPipelineQtlSumStats( data = data, methods = methods, + backend = backend, contexts = contexts, traitId = traitId, cisWindow = cisWindow, @@ -2212,6 +2331,7 @@ setMethod( .twasPipelineQtlSumStats <- function( data, methods, + backend, contexts, traitId, cisWindow, @@ -2228,6 +2348,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 +2503,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 +2704,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 @@ -2807,7 +2988,19 @@ setMethod( .twasWarnNoFitUniv(tk, st, ctx, tr) return(NULL) } - list_assign(baseArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) + fitArg <- set_names(list(fit), spec$adapter$rssFitArg) + list_assign(baseArgs, !!!fitArg) +} + +# 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. @@ -2838,11 +3031,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 +3333,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) @@ -3270,7 +3464,8 @@ setMethod( .twasWarnNoFitMv(tk, st, tr) return(NULL) } - list_assign(userArgs, !!!set_names(list(fit), spec$adapter$rssFitArg)) + fitArg <- set_names(list(fit), spec$adapter$rssFitArg) + list_assign(userArgs, !!!fitArg) } # Warning for a missing multivariate fine-mapping fit. @@ -3293,9 +3488,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 +3567,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 +3611,7 @@ setMethod( jointSpecification = NULL, fitRetention = cfg$fitRetention, methods = cfg$methods, + backend = cfg$backend, contexts = NULL, traitId = NULL, cisWindow = cfg$cisWindow, @@ -3462,15 +3658,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 +3752,7 @@ setMethod( .twasPipelineMultiStudy <- function( data, methods = "default", + backend = NULL, contexts = NULL, traitId = NULL, region = NULL, @@ -3577,8 +3795,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 +3842,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 +3956,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 +3974,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 +4698,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 +4730,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 +4762,8 @@ ensembleWeights <- function( wtList = wtList, wtKeys = wtKeys, zeta = zeta, - shape = shape + shape = shape, + ids = rownames(firstWt) )), `+`, .init = matrix( @@ -4758,9 +4953,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 +4975,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 d4c11e062..0eaf6bf7e 100644 Binary files a/data/ctwasEstExample.rda and b/data/ctwasEstExample.rda differ diff --git a/data/ctwasFinemapExample.rda b/data/ctwasFinemapExample.rda index 70c1e4314..b4fce8eac 100644 Binary files a/data/ctwasFinemapExample.rda and b/data/ctwasFinemapExample.rda differ diff --git a/data/ctwasInputsExample.rda b/data/ctwasInputsExample.rda index c39b82f8d..7553d0c65 100644 Binary files a/data/ctwasInputsExample.rda and b/data/ctwasInputsExample.rda differ diff --git a/data/ctwasWeightsExample.rda b/data/ctwasWeightsExample.rda index e10a266ae..cd3912457 100644 Binary files a/data/ctwasWeightsExample.rda and b/data/ctwasWeightsExample.rda differ diff --git a/data/fsusieFineMappingExample.rda b/data/fsusieFineMappingExample.rda index e68a64406..e24e3f470 100644 Binary files a/data/fsusieFineMappingExample.rda and b/data/fsusieFineMappingExample.rda differ diff --git a/data/gwasFineMappingExample.rda b/data/gwasFineMappingExample.rda index cc1de8a1f..b978897aa 100644 Binary files a/data/gwasFineMappingExample.rda and b/data/gwasFineMappingExample.rda differ diff --git a/data/gwasFineMappingLbfExample.rda b/data/gwasFineMappingLbfExample.rda index 8a4c9d614..b358efc5c 100644 Binary files a/data/gwasFineMappingLbfExample.rda and b/data/gwasFineMappingLbfExample.rda differ diff --git a/data/gwasSumStatsS4Example.rda b/data/gwasSumStatsS4Example.rda index 3539a1cfb..68bb3fca5 100644 Binary files a/data/gwasSumStatsS4Example.rda and b/data/gwasSumStatsS4Example.rda differ diff --git a/data/h2EstimateExample.rda b/data/h2EstimateExample.rda index c96d5c5fa..061977f40 100644 Binary files a/data/h2EstimateExample.rda and b/data/h2EstimateExample.rda differ diff --git a/data/ldScoreExample.rda b/data/ldScoreExample.rda index 48e7c2a15..d53892e18 100644 Binary files a/data/ldScoreExample.rda and b/data/ldScoreExample.rda differ diff --git a/data/multiStudyQtlDatasetExample.rda b/data/multiStudyQtlDatasetExample.rda index 0ae036dd8..fd8f3593c 100644 Binary files a/data/multiStudyQtlDatasetExample.rda and b/data/multiStudyQtlDatasetExample.rda differ diff --git a/data/mvsusieFineMappingExample.rda b/data/mvsusieFineMappingExample.rda index 690f5788e..e1130b18c 100644 Binary files a/data/mvsusieFineMappingExample.rda and b/data/mvsusieFineMappingExample.rda differ diff --git a/data/qtlDatasetExample.rda b/data/qtlDatasetExample.rda index 581c1886f..cda8f701d 100644 Binary files a/data/qtlDatasetExample.rda and b/data/qtlDatasetExample.rda differ diff --git a/data/qtlFineMappingExample.rda b/data/qtlFineMappingExample.rda index a1ef15a38..cf33bd1a9 100644 Binary files a/data/qtlFineMappingExample.rda and b/data/qtlFineMappingExample.rda differ diff --git a/data/qtlFineMappingLbfExample.rda b/data/qtlFineMappingLbfExample.rda index 691329a6b..152891dac 100644 Binary files a/data/qtlFineMappingLbfExample.rda and b/data/qtlFineMappingLbfExample.rda differ diff --git a/data/qtlFineMappingPairedExample.rda b/data/qtlFineMappingPairedExample.rda index d7863f37a..f003d52d4 100644 Binary files a/data/qtlFineMappingPairedExample.rda and b/data/qtlFineMappingPairedExample.rda differ diff --git a/data/qtlSumStatsExample.rda b/data/qtlSumStatsExample.rda index 203f2dde3..436c55edc 100644 Binary files a/data/qtlSumStatsExample.rda and b/data/qtlSumStatsExample.rda differ diff --git a/data/qtlSumStatsMulticontextExample.rda b/data/qtlSumStatsMulticontextExample.rda index b5c756f55..25b77fe53 100644 Binary files a/data/qtlSumStatsMulticontextExample.rda and b/data/qtlSumStatsMulticontextExample.rda differ diff --git a/data/twasWeightsExample.rda b/data/twasWeightsExample.rda index 957426ce2..80e9463a2 100644 Binary files a/data/twasWeightsExample.rda and b/data/twasWeightsExample.rda differ diff --git a/inst/COPYRIGHTS b/inst/COPYRIGHTS new file mode 100644 index 000000000..885eeb5ad --- /dev/null +++ b/inst/COPYRIGHTS @@ -0,0 +1,239 @@ +pecotmr is distributed under the GNU General Public License, version 3 +(GPL-3); the license text is in the file LICENSE of the source repository and +in R's share/licenses/GPL-3. pecotmr includes code from the projects below, +each under a license compatible with GPL-3. + + +1. SDPR + https://github.com/eldronzhou/SDPR + Copyright (C) the SDPR authors (Geyu Zhou and Hongyu Zhao, Zhao Lab, Yale + University). License: GPL-3. + - src/rss_mcmc.h, src/rss_mcmc.cpp: the SDPR sections, derived from + SDPR's sampler and LD preparation (mcmc.cpp) and rebuilt on pecotmr's + shared sampler code, with GSL and SSE replaced by Armadillo and the + entry points by cpp11; the shared gaussian_draw() follows the joint + draw of SDPR's sample_beta(). + +2. fastenloc + https://github.com/xqwen/fastenloc + Copyright (C) Xiaoquan Wen. License: GPL-3 or (at your option) any later + version. + - src/qtl_enrichment.cpp, src/qtl_enrichment.h: adapted from fastenloc's + imputation and EM steps. + - R/enloc.R: the colocalization priors and scoring (enrichment + parameters, the GWAS log10 Bayes factors and the per-pair cases), + ported from fastenloc's controller.cc. + +3. PRS-CS + https://github.com/getian107/PRScs + Copyright (c) 2018 Tian Ge. License: MIT (text below). + - src/rss_mcmc.h, src/rss_mcmc.cpp: the PRS-CS sections, derived from + PRS-CS's Python sampler (mcmc_gtb.py) and rebuilt on pecotmr's shared + sampler code; gigrnd() is ported from PRS-CS's gigrnd.py, and + DenseLdBlock::draw() follows PRS-CS's draw of a block's effects. + +4. qgg + https://github.com/psoerensen/qgg + Copyright (C) the qgg authors (Peter Soerensen, Palle Duun Rohde, Izel + Fourie Soerensen). License: GPL-3. + - src/rss_mcmc.h, src/rss_mcmc.cpp: in the Bayesian alphabet sections, + the priors and updates of bayesA, bayesC, bayesN and bayesR follow CRAN + qgg 1.1.6's summary-statistics sampler (sbayes()), and Legarra et al.'s + bayesL its individual-level one (bayes()); rinvgauss() follows its + inverse-Gaussian sampler. + +5. hibayes + https://github.com/YinLiLin/hibayes + Copyright (C) the hibayes authors (Lilin Yin, Haohao Zhang, Xiaolei Liu). + License: GPL-3. + - src/rss_mcmc.h, src/rss_mcmc.cpp: in the Bayesian alphabet sections, + the priors and updates of bayesB (BayesBpi) and Park and Casella's + bayesL follow hibayes' summary-statistics sampler (SBayesD()). + +6. L0Learn + https://github.com/hazimehh/L0Learn + Copyright (c) 2021 Hussein Hazimeh. License: MIT (text below). + - src/penalized_rss.cpp: the L0 swap step, ported from CDL012Swaps.cpp. + +7. lassosum + https://github.com/tshmak/lassosum + Copyright (c) 2016 tshmak. License: MIT according to its LICENSE file + (text below); its DESCRIPTION declares GPL-3. + - src/penalized_rss.cpp: the LASSO coordinate updates follow lassosum's + elnet(). + - R/regularizedRegressionWrappers.R: the pseudovalidation of the + penalized summary-statistics path (the local-fdr shrinkage of the + correlations and the score, after pseudovalidate.lassosum.pipeline.R + and pseudovalidation.R) and the path's ordering and records (after + lassosum.R). + +8. bigsnpr + https://github.com/privefl/bigsnpr + Copyright (c) Florian Prive. License: GPL-3. + - src/rss_mcmc.h, src/rss_mcmc.cpp: the LDpred2 sections, derived from + LDpred2's samplers (ldpred2.cpp, ldpred2-auto.cpp) and rebuilt on + pecotmr's shared sampler code, reading the LD as a factor. + - R/regularizedRegressionWrappers.R: LDpred2-auto's chain filter and + LDpred2-grid's grid, after the LDpred2 vignette. + - R/variantId.R: harmonizeAlleles()'s matched-proportion check and + parameter descriptions, after snp_match(). + +9. DENTIST + https://github.com/Yves-CHEN/DENTIST + (C) 2018 Wenhan Chen, Zhihong Zhu and Jian Yang. License: GNU Lesser + General Public License, version 3 (its LICENSE file; its README states + GPL-3). + - src/dentist_iterative_impute.cpp: DENTIST's iterative imputation and + random partitioning. + - R/sumstatsQc.R: DENTIST's segmentation of a region into windows, its + duplicate detection and its restoring of duplicates (after DENTIST.h, + storage.cpp and invoker.h). + - R/ld.R: the GCTA-style LD estimate (after bfileOperations.cpp). + +10. LD score regression (ldsc) + https://github.com/bulik/ldsc + Copyright (C) 2014-2015 Brendan Bulik-Sullivan and Hilary Finucane. + License: GPL-3. + - R/h2EstimationWrappers.R: stratified LD score regression, its weights + and iteratively reweighted least squares (after + ldscore/regressions.py and ldscore/irwls.py). + - R/LdScore.R: the unbiased r^2 (after ldscore/ldscore.py). + +11. HDL and HDL-L + https://github.com/zhenin/HDL + Copyright (C) the HDL authors (Zheng Ning, Xia Shen; HDL-L: Yuying Li, + Xia Shen). License: GPL-3 or (at your option) any later version. + - R/h2EstimationWrappers.R: the HDL likelihood and fit (after llfun.R + and HDL.h2.R) and HDL-L's per-locus fit (after HDL.L.R). + +12. LDER + https://github.com/shuangsong0110/LDER + Copyright (c) 2021 Shuang Song. License: MIT according to its LICENSE + file (text below); its DESCRIPTION declares GPL-3. + - R/h2EstimationWrappers.R: the LDER estimator (after get.res.R, + ldscore.R and lder.R). + +13. gLDSC + https://github.com/xzw20046/gldsc + Copyright (c) 2023 Zewei Xiong. License: MIT (text below). + - R/h2EstimationWrappers.R: the generalized LD score regression + estimator (after middle_fun.R and gldsc.R). + +14. FastHer + https://github.com/gulsvi/FastHer + Copyright (c) 2025 Gulnara R. Svishcheva. License: MIT (text below), as + its DESCRIPTION declares; the repository has no license file or + copyright line, so the line above gives its author and year. + - R/h2EstimationWrappers.R: the local heritability's inputs, eigen cut + and standard error (after fasther.R). + +15. RAiSS + https://gitlab.pasteur.fr/statistical-genetics/raiss + Copyright (c) 2019 Institut Pasteur. License: MIT (text below). + - R/sumstatsQc.R: the summary-statistics imputation and its output + filtering (after raiss/stat_models.py and + raiss/filter_format_output.py). + +16. SLALOM + https://github.com/mkanai/slalom + Copyright (c) 2022 Masahiro Kanai. License: MIT (text below). + - R/sumstatsQc.R: slalom() and its approximate Bayes factors, credible + set and DENTIST-S statistics (after slalom.py). + +17. FUSION + https://github.com/gusevlab/fusion_twas + Copyright (C) the FUSION authors (Alexander Gusev et al.). License: + GPL-3. + - R/regularizedRegressionWrappers.R: the elastic-net weights and the + zero-variance filter (after FUSION.compute_weights.R). + - R/variantId.R: the strand and allele checks of harmonizeAlleles() + (after FUSION.assoc_test.R's allele.qc()). + +18. ACAT and STAAR + https://github.com/yaowuliu/ACAT, https://github.com/xihaoli/STAAR + Copyright (C) Yaowu Liu (ACAT); Xihao Li, Zilin Li, Wenbo Wang, Han + Chen and Yuxin Yuan (STAAR). License: GPL-3. + - R/pvalCombineWrappers.R: pvalAcat(), the Cauchy combination (after + ACAT.R and STAAR's CCT.R). + +19. cTWAS + https://github.com/xinhe-lab/multigroup_ctwas + Copyright (c) 2020 Siming Zhao, Wesley Crouse, Sheng Qian, Kaixuan Luo, + Matthew Stephens and Xin He. License: MIT (text below). + - R/ctwasPipeline.R: the gene z-scores (after compute_gene_z()) and the + region filtering and thinning of the parameter estimation (after + est_param()). + +20. xqtl-protocol + https://github.com/StatFunGen/xqtl-protocol + Copyright (c) 2021 Gao Wang. License: MIT (text below). + - R/relatednessQc.R: the relatedness filter (after GWAS_QC.R). + - R/mashPipeline.R, R/mashWrapper.R: the mash data preparation, + contrasts, posterior summaries and prior fitting (after the MASH + notebooks). + +21. fsusieR + https://github.com/stephenslab/fsusieR + Copyright (c) 2023-2025, William R.P. Denault, Peter Carbonetto, Gao + Wang and Matthew Stephens. License: BSD 3-Clause (text below). + - R/fineMappingWrappers.R: the credible sets' purity (after + cal_purity()) and the wavelet back-transform of the weights (after + operation_on_susiF_obj.R). + +22. mr.mashr + https://github.com/stephenslab/mr.mashr + Copyright (c) 2020-2025 Fabio Morgante, Jason Willwerscheid, Gao Wang, + Deborah Kunkel, Peter Carbonetto and Matthew Stephens. License: MIT + (text below). + - R/regularizedRegressionWrappers.R: the description of mr.mash's fit in + mrmashWrapper()'s documentation (after mr_mash.R). + + +MIT License (items 3, 6, 7, 12, 13, 14, 15, 16, 19, 20 and 22, with the +copyright lines given above) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + + +BSD 3-Clause License (item 21, with the copyright line given above) + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/inst/prototype/generate_test_for_prs_cs.R b/inst/prototype/generate_test_for_prs_cs.R index d8d5f8327..191d73add 100644 --- a/inst/prototype/generate_test_for_prs_cs.R +++ b/inst/prototype/generate_test_for_prs_cs.R @@ -33,7 +33,7 @@ var_y <- var(y) sigmasq_init <- 1.5 # Run PRS CS -maf = rep(0.5, length(b.hat)) # fake MAF +maf <- rep(0.5, length(b.hat)) # fake MAF LD <- list(blk1 = R.hat) sumstats <- list(BETA = b.hat, MAF = maf) write.table( diff --git a/inst/scripts/build_ctwas_examples.R b/inst/scripts/build_ctwas_examples.R index c06677375..906fb4949 100644 --- a/inst/scripts/build_ctwas_examples.R +++ b/inst/scripts/build_ctwas_examples.R @@ -15,15 +15,20 @@ # the cached per-region LD panels. Those two duties are why the token cannot # simply be the backing genotype file: every block on a chromosome shares that # file, so each block was handed the FIRST block's LD panel. The tokens are -# per-region sentinels under the session tempdir instead, and are therefore -# gone when a saved object is read back -- `.ctwasResolveLdPaths()` re-mints -# one per region on the way in and re-keys the loader cache onto them, so no -# path from the building machine is ever baked into the .rda. +# per-region sentinels under the session tempdir instead. The .rda does carry +# them -- the building machine's tempdir paths -- but they are gone when a +# saved object is read back, and `.ctwasResolveLdPaths()` re-mints one per +# region on the way in and re-keys the loader cache onto them, so the stored +# paths are never read. # # Run from the package root: # Rscript inst/scripts/build_ctwas_examples.R # ============================================================================= +# Without source references: a payload's functions would otherwise carry +# their whole source file into the .rda (the loader factories also strip +# them, so this is what keeps any other function in a payload clean). +options(keep.source = FALSE) devtools::load_all(".", quiet = TRUE) # A bundled stem as the portable reference the serialized objects carry, so diff --git a/inst/scripts/build_h2_estimate_example.R b/inst/scripts/build_h2_estimate_example.R new file mode 100644 index 000000000..fa4ef0a7d --- /dev/null +++ b/inst/scripts/build_h2_estimate_example.R @@ -0,0 +1,77 @@ +# ============================================================================= +# Rebuild h2EstimateExample: a stratified estimateH2() result. +# ----------------------------------------------------------------------------- +# g-LDSC on the shipped ldScoreExample (inst/scripts/build_h2_examples.R), +# for a GWAS simulated on that reference's LD in which one baseline +# annotation, over the first half of the variants, carries three times the +# per-variant heritability of the rest. A second +# annotation, over every third variant, is a candidate scored against the +# fit. It needs only the package's own data: +# Rscript inst/scripts/build_h2_estimate_example.R +# ============================================================================= + +devtools::load_all(".", quiet = TRUE) +data(ldScoreExample, package = "pecotmr") + +M <- length(ldScoreExample) +nGwas <- 10000 +inA <- seq_len(M) <= M / 2 +perSnpVar <- ifelse(inA, 0.225 / sum(inA), 0.075 / sum(!inA)) + +# z ~ N(0, N R diag(v) R + R), block by block. +set.seed(1) +z <- numeric(M) +for (block in ldMatrixList(ldScoreExample)) { + idx <- block$snpIdx + p <- length(idx) + sigma <- nGwas * (block$R %*% diag(perSnpVar[idx], p) %*% block$R) + block$R + e <- eigen((sigma + t(sigma)) / 2, symmetric = TRUE) + z[idx] <- as.vector(e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p))) +} + +genome <- unique(unname(GenomeInfoDb::genome(ldScoreExample))) +gr <- as(ldScoreExample, "GRanges") +S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = names(ldScoreExample), + A1 = S4Vectors::mcols(ldScoreExample)$A1, + A2 = S4Vectors::mcols(ldScoreExample)$A2, + Z = z, + N = as.integer(nGwas) +) +gwas <- GwasSumStats( + studyName = "trait1", + entry = list(gr), + genome = genome, + ldReference = readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + ) +) +annot <- AnnotationMatrix( + cbind( + annotA = as.integer(inA), + annotB = as.integer(seq_len(M) %% 3L == 0L) + ), + as(ldScoreExample, "GRanges"), + data.frame( + name = c("annotA", "annotB"), + tier = c("baseline", "candidate"), + type = "binary" + ), + genome = genome +) + +h2EstimateExample <- estimateH2( + gwas, + ldScoreExample, + method = "gldsc", + annotations = annot +) +print(h2EstimateExample) +stopifnot( + length(h2EstimateExample) == 1L, + nrow(stratifiedHeritabilityEnrichment(h2EstimateExample)) == 1L, + is.matrix(annotationJackknifeCoefs(h2EstimateExample)[[1L]]), + !is.null(scoreStats(h2EstimateExample)[[1L]]) +) + +usethis::use_data(h2EstimateExample, overwrite = TRUE, compress = "xz") diff --git a/inst/scripts/prepare_example_data.R b/inst/scripts/prepare_example_data.R index 926850d2a..c12146d9f 100644 --- a/inst/scripts/prepare_example_data.R +++ b/inst/scripts/prepare_example_data.R @@ -21,9 +21,9 @@ # entry point fineMappingPipeline() uses, rather than being assembled by hand. # Earlier versions of this script hand-built a `cs` column of bare integer # labels; that predates the cs_95 / cs_70 / cs_50 (+ _purity) schema, and a -# fixture carrying it makes credibleSets() and credibleSetSummary() silently return -# nothing. Going through the real post-processor keeps the fixtures on whatever -# schema the package currently emits. +# fixture carrying it makes credibleSets() and credibleSetSummary() silently +# return nothing. Going through the real post-processor keeps the fixtures on +# whatever schema the package currently emits. # # Prerequisites # 1. Recover the original files from git history: @@ -47,12 +47,12 @@ dataDir <- "data" newChrom <- "chr22" posOffset <- 5000000L -# The one credible set at this eQTL locus spans 42 variants with -# min.abs.corr = 0.626, so the pipeline default (minAbsCorr = 0.8) would reject -# it and label every variant "susie_0" -- leaving credibleSets() on the package's -# headline QTL example with nothing to show. Building at 0.5 keeps the set -# labelled while cs_95_purity still records the true 0.626, so a caller who -# asks for credibleSets(x, minPurity = 0.8) correctly gets nothing back. The GWAS fit +# The one credible set at this eQTL locus spans 42 variants with min.abs.corr = +# 0.626, so the pipeline default (minAbsCorr = 0.8) would reject it and label +# every variant "susie_0" -- leaving credibleSets() on the package's headline +# QTL example with nothing to show. Building at 0.5 keeps the set labelled while +# cs_95_purity still records the true 0.626, so a caller who asks for +# credibleSets(x, minPurity = 0.8) correctly gets nothing back. The GWAS fit # below needs no such allowance: its credible sets are all above 0.95. qtlMinAbsCorr <- 0.5 diff --git a/man/AnnotationMatrix-class.Rd b/man/AnnotationMatrix-class.Rd index 4ee9cc258..44e208cf3 100644 --- a/man/AnnotationMatrix-class.Rd +++ b/man/AnnotationMatrix-class.Rd @@ -17,4 +17,9 @@ Container for SNP-level annotations used in stratified 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. } diff --git a/man/ColocResult-class.Rd b/man/ColocResult-class.Rd index cc6b82eac..1f64ac579 100644 --- a/man/ColocResult-class.Rd +++ b/man/ColocResult-class.Rd @@ -5,14 +5,21 @@ \alias{ColocResult-class} \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}}. +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{ -The \code{ldReference} is what \code{colocCredibleSets()} uses to - compute credible-set purity, each pair's from its own reference. +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. } \section{Slots}{ @@ -20,7 +27,7 @@ The \code{ldReference} is what \code{colocCredibleSets()} uses to \item{\code{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{ diff --git a/man/ColocResult.Rd b/man/ColocResult.Rd index 13681a46d..b8abcec7c 100644 --- a/man/ColocResult.Rd +++ b/man/ColocResult.Rd @@ -16,7 +16,8 @@ the identity columns of both sides (\code{study}, \code{context}, columns are \code{NA} for it.} \item{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.} \item{ldReference}{Optional LD reference -- a genotype panel (see \code{\link{readGenotypes}}), a \code{GenotypeMixture} or an @@ -36,6 +37,11 @@ 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. +} \examples{ pairs <- data.frame( study = "s1", context = "c1", trait = "g1", method = "susie", diff --git a/man/CtwasResult-class.Rd b/man/CtwasResult-class.Rd index 8dc50ab26..466db53db 100644 --- a/man/CtwasResult-class.Rd +++ b/man/CtwasResult-class.Rd @@ -23,7 +23,11 @@ Unlike the QTL family, \code{trait} is not part of the key: a cTWAS 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 diff --git a/man/FineMappingResultBase-class.Rd b/man/FineMappingResultBase-class.Rd index 650e495af..35d95c48f 100644 --- a/man/FineMappingResultBase-class.Rd +++ b/man/FineMappingResultBase-class.Rd @@ -22,6 +22,19 @@ computed against, each a genotype panel, a \code{GenotypeMixture} or an \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.} + +\item{\code{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.} + +\item{\code{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}{ diff --git a/man/GenotypeDosageSeed-class.Rd b/man/GenotypeDosageSeed-class.Rd index 96c89ebff..bf339a4a7 100644 --- a/man/GenotypeDosageSeed-class.Rd +++ b/man/GenotypeDosageSeed-class.Rd @@ -45,7 +45,8 @@ record's rank among those starting at its position; for a GDS, an holding it; for a PLINK1 fileset, an \code{IRanges} of each variant's position in the \code{.bed}.} -\item{\code{dn}}{List of dimnames (variant ids, sample ids).} +\item{\code{dn}}{List of dimnames: no variant names (a panel's rowRanges name +its rows) and the sample ids.} }} \keyword{internal} diff --git a/man/GenotypeHandle-class.Rd b/man/GenotypeHandle-class.Rd index d5852c34a..2525d149f 100644 --- a/man/GenotypeHandle-class.Rd +++ b/man/GenotypeHandle-class.Rd @@ -28,14 +28,13 @@ GenotypeHandle( \code{NULL}.} \item{ldMeta}{Path to an LD-meta TSV file (columns \code{chrom}, -\code{start}, \code{end}, \code{path}; the \code{path} column may be -comma-separated as \code{ld_file,bim_file}). Requires \code{block}. The -constructor resolves the row covering \code{block}, then delegates to the -appropriate file-based handler. When the resolved row points at PLINK2 -or BGEN files, the corresponding reader is used; a row pointing -at a pre-computed LD matrix (\code{.cor.xz}) is refused, as pecotmr reads -no pre-computed LD from disk -- wrap such a matrix in an -\code{\link{LdMatrix}} instead.} +\code{start}, \code{end}, \code{path}, each path a genotype file). +Requires \code{block}. The constructor resolves the row covering +\code{block}, then delegates to the appropriate file-based handler. When +the resolved row points at PLINK2 or BGEN files, the corresponding reader +is used; a row pointing at a pre-computed LD matrix (\code{.cor.xz}) is +refused, as pecotmr reads no pre-computed LD from disk -- wrap such a +matrix in an \code{\link{LdMatrix}} instead.} \item{block}{The \code{GRanges} window to look up in \code{ldMeta}; the whole file of the row covering it is opened.} diff --git a/man/GhSeed-class.Rd b/man/GhSeed-class.Rd index 91a7a4476..69bbc3af0 100644 --- a/man/GhSeed-class.Rd +++ b/man/GhSeed-class.Rd @@ -21,11 +21,15 @@ handle on demand, so an assay can describe a panel far larger than memory. \section{Slots}{ \describe{ -\item{\code{handle}}{The \code{\link{GenotypeHandle}} to read through.} +\item{\code{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.} \item{\code{dm}}{Integer length-2 dimensions (variants, samples).} -\item{\code{dn}}{List of dimnames (variant ids, sample ids).} +\item{\code{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.} }} \keyword{internal} diff --git a/man/H2Estimate-class.Rd b/man/H2Estimate-class.Rd index d9d91f973..51ddebaa0 100644 --- a/man/H2Estimate-class.Rd +++ b/man/H2Estimate-class.Rd @@ -3,60 +3,41 @@ \docType{class} \name{H2Estimate-class} \alias{H2Estimate-class} -\title{Heritability Estimate} +\title{Heritability Estimates} \description{ -Container for univariate heritability estimation results. Holds - global, local, and annotation-stratified estimates. +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. } -\section{Slots}{ - -\describe{ -\item{\code{estimate}}{Numeric, global SNP heritability estimate.} - -\item{\code{estimateSe}}{Numeric, standard error of global h2.} - -\item{\code{intercept}}{Numeric, confounding intercept estimate (NA if method does -not estimate one).} - -\item{\code{interceptSe}}{Numeric, SE of intercept.} - -\item{\code{localBlocks}}{A \code{data.frame} with per-block local -heritability estimates -(columns: \code{blockId}, \code{h2Local}, \code{h2LocalSe}). NULL if -\code{local = FALSE}.} - -\item{\code{enrichment}}{A \code{data.frame} of per-annotation enrichment results, -NULL if unstratified. Two shapes are possible, depending on which route -produced the estimate: -\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{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).} - -\item{\code{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} +\details{ +Besides the identity, \code{mcols()} hold each estimate's values: + \describe{ + \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}}).} + } + 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. } -NULL if no candidate annotations provided.} - -\item{\code{method}}{Character string identifying the estimation method.} - -\item{\code{nSnps}}{Integer, number of SNPs used in estimation.} - -\item{\code{traitName}}{Character string for trait identifier.} -}} - diff --git a/man/LdMatrix-class.Rd b/man/LdMatrix-class.Rd index 2793b2168..e86b5d8bf 100644 --- a/man/LdMatrix-class.Rd +++ b/man/LdMatrix-class.Rd @@ -34,15 +34,23 @@ An \code{LdMatrix} carries one LD correlation matrix together 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. } \section{Slots}{ \describe{ -\item{\code{correlation}}{The correlation matrix, its dimnames the variant ids.} +\item{\code{correlation}}{The correlation matrix, packed symmetric (a +\code{dspMatrix}), its rows the variants in order.} \item{\code{nSamples}}{Integer, the number of independent samples the LD is worth, or \code{NA} when unknown. For one panel this is its sample size. diff --git a/man/LdScore-class.Rd b/man/LdScore-class.Rd index 54a587ef3..52686314a 100644 --- a/man/LdScore-class.Rd +++ b/man/LdScore-class.Rd @@ -24,8 +24,10 @@ Pre-computed LD scores for each SNP. Used by S-LDSC and \describe{ \item{\code{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}}).} }} diff --git a/man/SumStatsBase-class.Rd b/man/SumStatsBase-class.Rd index 7865724bf..8912d0940 100644 --- a/man/SumStatsBase-class.Rd +++ b/man/SumStatsBase-class.Rd @@ -3,7 +3,32 @@ \docType{class} \name{SumStatsBase-class} \alias{SumStatsBase-class} +\alias{getListElement,SumStatsBase-method} +\alias{as.list,SumStatsBase-method} +\alias{lapply,SumStatsBase-method} \title{Summary Statistics Base Class} +\usage{ +\S4method{getListElement}{SumStatsBase}(x, i, exact = TRUE) + +\S4method{as.list}{SumStatsBase}(x, use.names = TRUE) + +\S4method{lapply}{SumStatsBase}(X, FUN, ...) +} +\arguments{ +\item{x}{A summary-statistics collection.} + +\item{i}{The row: a position or an element name.} + +\item{exact}{Passed on to the element lookup.} + +\item{use.names}{Whether the list keeps the element names.} + +\item{X}{A summary-statistics collection.} + +\item{FUN}{The function applied to each row's variants.} + +\item{...}{Passed on to \code{FUN}.} +} \description{ Virtual base class for QTL and GWAS summary statistics collections. Concrete subclasses (\code{QtlSumStats}, \code{GwasSumStats}) @@ -16,6 +41,18 @@ Virtual base class for QTL and GWAS summary statistics 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. +} \section{Slots}{ \describe{ diff --git a/man/TwasWeights-class.Rd b/man/TwasWeights-class.Rd index 790118665..c8426e931 100644 --- a/man/TwasWeights-class.Rd +++ b/man/TwasWeights-class.Rd @@ -6,23 +6,28 @@ \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. } \section{Slots}{ @@ -33,18 +38,32 @@ derived against, each a genotype panel, a \code{GenotypeMixture} or an \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.} + +\item{\code{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.} + +\item{\code{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}{ - 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: + 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. } diff --git a/man/TwasWeights.Rd b/man/TwasWeights.Rd index 0098b51a3..a9929256a 100644 --- a/man/TwasWeights.Rd +++ b/man/TwasWeights.Rd @@ -20,23 +20,24 @@ TwasWeights( ) } \arguments{ -\item{studyName}{Character vector of study identifiers. Use the sentinel -\code{"joint"} for rows produced by a cross-study joint fit.} +\item{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}.} -\item{context}{Character vector of context labels. Use \code{"joint"} for -rows produced by a cross-context joint fit.} +\item{context}{Character vector of context labels.} -\item{trait}{Character vector of trait identifiers. Use \code{"joint"} for -rows produced by a cross-trait joint fit.} +\item{trait}{Character vector of trait identifiers.} -\item{method}{Character vector of TWAS weight method names.} +\item{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.} \item{entry}{List / \code{SimpleList} of \code{TwasWeightsRow} objects.} -\item{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.} +\item{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.} \item{jointContexts}{Optional character vector for cross-context joints. Same shape as \code{jointStudies}.} @@ -44,21 +45,21 @@ shape as \code{jointStudies}.} \item{jointTraits}{Optional character vector for cross-trait joints. Same shape as \code{jointStudies}.} -\item{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.} +\item{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.} -\item{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.} +\item{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.} \item{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.} +\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.} \item{metadata}{A list of free-form metadata about the collection, as \code{metadata()} holds on any Bioconductor vector. Default @@ -68,8 +69,10 @@ as \code{metadata()} holds on any Bioconductor vector. Default A \code{TwasWeights} object. } \description{ -Construct a \code{TwasWeights} collection from per-tuple - vectors and a list of \code{TwasWeightsRow} payloads (one per tuple). +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. } \examples{ twe <- TwasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), diff --git a/man/TwasWeightsRow-class.Rd b/man/TwasWeightsRow-class.Rd index 424ff1b4a..55c8a67cf 100644 --- a/man/TwasWeightsRow-class.Rd +++ b/man/TwasWeightsRow-class.Rd @@ -24,12 +24,6 @@ One row's worth of TWAS weights. Build one with \item{\code{weightStandardized}}{Whether the weights are on the standardized scale.} \item{\code{weightsDataType}}{Optional data-type label.} - -\item{\code{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}{ diff --git a/man/annotationJackknifeCoefs.Rd b/man/annotationJackknifeCoefs.Rd index a86303d1c..27eedf69a 100644 --- a/man/annotationJackknifeCoefs.Rd +++ b/man/annotationJackknifeCoefs.Rd @@ -13,11 +13,12 @@ annotationJackknifeCoefs(x) \item{x}{An \code{H2Estimate}.} } \value{ -A numeric matrix or NULL. +A list with one entry per estimate: a numeric matrix (blocks x + annotations) for a stratified estimate, otherwise \code{NULL}. } \description{ -Return the per-block jackknife tau matrix carried by an - \code{H2Estimate}. +Return the per-block jackknife tau matrix of each of an + \code{H2Estimate}'s estimates. } \examples{ data(h2EstimateExample) diff --git a/man/assembleCtwasInputs.Rd b/man/assembleCtwasInputs.Rd index a1714c583..b61cbd07a 100644 --- a/man/assembleCtwasInputs.Rd +++ b/man/assembleCtwasInputs.Rd @@ -39,9 +39,12 @@ was narrowed since that fit warns (condition class variants, so its weights are not renormalized over the variants kept.} \item{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.} \item{fineMappingResult}{Optional \code{QtlFineMappingResult}: the genes' own fine-mapping, whose per-variant PIP and credible-set membership the diff --git a/man/bLassoWeights.Rd b/man/bLassoWeights.Rd deleted file mode 100644 index aae8611ce..000000000 --- a/man/bLassoWeights.Rd +++ /dev/null @@ -1,52 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/regularizedRegressionWrappers.R -\name{bLassoWeights} -\alias{bLassoWeights} -\title{Compute Weights Using the Bayesian LASSO (BGLR)} -\usage{ -bLassoWeights( - X, - y, - nIter = 10000, - burnIn = 2000, - thin = 5, - methodArgs = BglrOptions() -) -} -\arguments{ -\item{X}{A numeric matrix of predictors.} - -\item{y}{A numeric response vector.} - -\item{nIter}{Number of MCMC iterations. Default is 10000.} - -\item{burnIn}{Number of burn-in iterations. Default is 2000.} - -\item{thin}{Thinning interval. Default is 5.} - -\item{methodArgs}{Options forwarded to \code{BGLR::BGLR}, built -with \code{\link{BglrOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} -} -\value{ -A numeric vector of length `ncol(X)` of variant weights. -} -\description{ -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`. -} -\details{ -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. -} -\examples{ -data(eqtlRegionExample) -X <- eqtlRegionExample$X[, 1:30] -y <- eqtlRegionExample$yRes -bLassoWeights(X, y) -} diff --git a/man/bayesARssWeights.Rd b/man/bayesARssWeights.Rd new file mode 100644 index 000000000..f975939e3 --- /dev/null +++ b/man/bayesARssWeights.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesARssWeights} +\alias{bayesARssWeights} +\title{BayesA TWAS weights from summary statistics} +\usage{ +bayesARssWeights( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) +} +\arguments{ +\item{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}.} + +\item{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}}.} + +\item{backend}{\code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +\code{NULL} picks the default for the LD reference.} + +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} + +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} + +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the 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.} + +\item{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.} +} +\value{ +A numeric vector of the posterior mean effects, one per variant. +} +\description{ +\code{\link{bayesAlphabetRssWeights}} with the BayesA prior. +} +\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) +} diff --git a/man/bayesAWeights.Rd b/man/bayesAWeights.Rd index 86b6ec5b4..7a7437982 100644 --- a/man/bayesAWeights.Rd +++ b/man/bayesAWeights.Rd @@ -2,47 +2,57 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{bayesAWeights} \alias{bayesAWeights} -\title{BayesA TWAS weights (t-distribution prior)} +\title{BayesA TWAS weights (scaled-t prior)} \usage{ bayesAWeights( X, y, - Z = NULL, - h2 = NULL, - nit = 5000, - nburn = 1000, - nthin = 5, - methodArgs = QggOptions() + backend = c("qgg", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL ) } \arguments{ -\item{X}{Numeric genotype / design matrix (samples x variants).} +\item{X}{A numeric matrix of genotypes (samples x variants).} -\item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{y}{A numeric vector of phenotypes, one per row of \code{X}.} -\item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{backend}{\code{"qgg"} (default) or \code{"hibayes"}.} -\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} -leaves the engine's own default.} +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} -\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} -\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} -\item{nthin}{Integer. Thinning interval for retained MCMC samples. -Default \code{5}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} -\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built -with \code{\link{QggOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{methodArgs}{Options for the backend's engine: +\code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +hibayes. \code{NULL} keeps the engine's defaults.} } \value{ -A numeric vector of effect-size weights, one per variant (column of +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"}. } \description{ -Use t-distribution as prior. +Fits the BayesA prior, a normal on each effect whose + variance is drawn per variant (a scaled-t), through + \code{\link{bayesAlphabetWeights}}. } \examples{ data(eqtlRegionExample) diff --git a/man/bayesAlphabetRss.Rd b/man/bayesAlphabetRss.Rd new file mode 100644 index 000000000..5d207ba8c --- /dev/null +++ b/man/bayesAlphabetRss.Rd @@ -0,0 +1,106 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesAlphabetRss} +\alias{bayesAlphabetRss} +\title{pecotmr's Bayesian Alphabet Sampler on a Factor of the LD} +\usage{ +bayesAlphabetRss( + bhat, + ldFactor, + 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 +) +} +\arguments{ +\item{bhat}{The standardized marginal effects.} + +\item{ldFactor}{The factor F of the LD (k x p).} + +\item{n}{The sample size.} + +\item{method}{The prior, as in \code{\link{bayesAlphabetRssWeights}}.} + +\item{nIter, nBurnin, thin}{The chain's iterations (burn-in included), +burn-in and thinning.} + +\item{pi}{For \code{bayesB} and \code{bayesC}, where the estimate of the +non-null proportion starts.} + +\item{nPerVariant}{The per-variant sample sizes, read when +\code{perVariantWeights = TRUE}.} + +\item{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).} + +\item{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.} + +\item{h2}{The prior guess of the heritability that sets the starting +variances. Default \code{0.5}, qgg's and hibayes'.} + +\item{shrinkCorr}{The LD shrinkage \eqn{c}: the sampler reads +\eqn{cR + (1 - c)I}. Default 1, none.} + +\item{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.} + +\item{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}.} + +\item{raoBlackwell}{Report each effect's conditional posterior mean, +averaged over the kept iterations, rather than the draws' average. +Default \code{FALSE}.} + +\item{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.} + +\item{verbose}{Whether to report the chain's progress.} +} +\value{ +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}. +} +\description{ +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. +} +\details{ +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. +} +\keyword{internal} diff --git a/man/bayesAlphabetRssWeights.Rd b/man/bayesAlphabetRssWeights.Rd new file mode 100644 index 000000000..54fbffe64 --- /dev/null +++ b/man/bayesAlphabetRssWeights.Rd @@ -0,0 +1,134 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesAlphabetRssWeights} +\alias{bayesAlphabetRssWeights} +\title{Bayesian Alphabet TWAS Weights From Summary Statistics} +\usage{ +bayesAlphabetRssWeights( + stat, + ldReference, + method, + backend = NULL, + pi = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) +} +\arguments{ +\item{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}.} + +\item{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}}.} + +\item{method}{The prior: \code{"bayesA"}, \code{"bayesB"}, +\code{"bayesC"}, \code{"bayesL"}, \code{"bayesN"} or \code{"bayesR"}.} + +\item{backend}{The engine, one the method has (see Description); +\code{NULL} picks the default for the LD reference.} + +\item{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.} + +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} + +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} + +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the 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.} + +\item{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.} +} +\value{ +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"}. +} +\description{ +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. +} +\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 +) +} diff --git a/man/bayesAlphabetWeights.Rd b/man/bayesAlphabetWeights.Rd index 24d71fb26..95276a32b 100644 --- a/man/bayesAlphabetWeights.Rd +++ b/man/bayesAlphabetWeights.Rd @@ -2,67 +2,89 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{bayesAlphabetWeights} \alias{bayesAlphabetWeights} -\title{Extract Coefficients From Bayesian Linear Regression} +\title{Bayesian Alphabet TWAS Weights} \usage{ bayesAlphabetWeights( 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 ) } \arguments{ -\item{X}{A numeric matrix of genotypes.} +\item{X}{A numeric matrix of genotypes (samples x variants).} -\item{y}{A numeric vector of phenotypes.} +\item{y}{A numeric vector of phenotypes, one per row of \code{X}.} -\item{method}{A character string declaring the method/prior to be used. -Options are bayesN, bayesL, bayesA, bayesC, or bayesR.} +\item{method}{The prior: \code{"bayesA"}, \code{"bayesB"}, +\code{"bayesC"}, \code{"bayesL"}, \code{"bayesN"} or \code{"bayesR"}.} -\item{Z}{An optional numeric matrix of covariates.} +\item{backend}{The engine, one the method has (see Description); +\code{NULL} picks the method's default.} -\item{h2}{Numeric or \code{NULL}. Prior heritability for the sampler; -\code{NULL} lets \code{qgg} estimate it.} +\item{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.} -\item{nit}{Integer. Total number of MCMC iterations. Default \code{5000}.} +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} -\item{nburn}{Integer. Number of burn-in iterations discarded. Default -\code{1000}.} +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} -\item{nthin}{Integer. Thinning interval for retained MCMC samples. Default +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default \code{5}.} -\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built -with \code{\link{QggOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + +\item{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.} } \value{ -A vector containing the weights to be applied to each genotype in - predicting the phenotype. +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"}. } \description{ -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. } -\details{ -This function fits a Bayesian linear regression model with a range - of priors. +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. } \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) } diff --git a/man/bayesBRssWeights.Rd b/man/bayesBRssWeights.Rd new file mode 100644 index 000000000..8ec2fbf32 --- /dev/null +++ b/man/bayesBRssWeights.Rd @@ -0,0 +1,89 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesBRssWeights} +\alias{bayesBRssWeights} +\title{BayesB TWAS weights from summary statistics} +\usage{ +bayesBRssWeights( + stat, + ldReference, + backend = NULL, + pi = 0.2, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) +} +\arguments{ +\item{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}.} + +\item{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}}.} + +\item{backend}{\code{"hibayes"} or \code{"pecotmr"}; \code{NULL} picks +the default for the LD reference.} + +\item{pi}{The prior proportion of non-null effects, where each engine's +estimate of it starts. Default \code{0.2}.} + +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} + +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} + +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the 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.} + +\item{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.} +} +\value{ +A numeric vector of the posterior mean effects, one per variant. +} +\description{ +\code{\link{bayesAlphabetRssWeights}} with the BayesB prior. +} +\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) +} diff --git a/man/bayesBWeights.Rd b/man/bayesBWeights.Rd index e5f0c1b3a..697609f2a 100644 --- a/man/bayesBWeights.Rd +++ b/man/bayesBWeights.Rd @@ -2,50 +2,60 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{bayesBWeights} \alias{bayesBWeights} -\title{Compute Weights Using BayesB} +\title{BayesB TWAS weights (spike and slab, a variance per variant)} \usage{ bayesBWeights( X, y, - nIter = 10000, - burnIn = 2000, + backend = c("bglr", "hibayes"), + pi = 0.2, + nIter = 5000, + nBurnin = 1000, thin = 5, - probIn = 0.2, - methodArgs = BglrOptions() + fitRetention = c("none", "slim", "full"), + methodArgs = NULL ) } \arguments{ -\item{X}{A numeric matrix of predictors.} +\item{X}{A numeric matrix of genotypes (samples x variants).} -\item{y}{A numeric response vector.} +\item{y}{A numeric vector of phenotypes, one per row of \code{X}.} -\item{nIter}{Number of MCMC iterations. Default is 10000.} +\item{backend}{\code{"bglr"} (default) or \code{"hibayes"}.} -\item{burnIn}{Number of burn-in iterations. Default is 2000.} +\item{pi}{The prior proportion of non-null effects, where each engine's +estimate of it starts. Default \code{0.2}.} -\item{thin}{Thinning interval. Default is 5.} +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} -\item{probIn}{Prior inclusion probability for each marker. Default is 0.2.} +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} -\item{methodArgs}{Options forwarded to \code{BGLR::BGLR}, built -with \code{\link{BglrOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + +\item{methodArgs}{Options for the backend's engine: +\code{\link{BglrOptions}} for BGLR, \code{\link{HibayesOptions}} for +hibayes. \code{NULL} keeps the engine's defaults.} } \value{ -A numeric vector of length `ncol(X)` of variant weights. +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"}. } \description{ -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. -} -\details{ -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. +Fits the BayesB prior, a point mass at zero mixed with a + scaled-t slab, through \code{\link{bayesAlphabetWeights}}. } \examples{ data(eqtlRegionExample) diff --git a/man/bayesCRssWeights.Rd b/man/bayesCRssWeights.Rd new file mode 100644 index 000000000..bfe2ef452 --- /dev/null +++ b/man/bayesCRssWeights.Rd @@ -0,0 +1,90 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesCRssWeights} +\alias{bayesCRssWeights} +\title{BayesC TWAS weights from summary statistics} +\usage{ +bayesCRssWeights( + stat, + ldReference, + backend = NULL, + pi = 0.1, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) +} +\arguments{ +\item{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}.} + +\item{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}}.} + +\item{backend}{\code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +\code{NULL} picks the default for the LD reference.} + +\item{pi}{The prior proportion of non-null effects, where each engine's +estimate of it starts. Default \code{0.1}.} + +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} + +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} + +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the 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.} + +\item{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.} +} +\value{ +A numeric vector of the posterior mean effects, one per variant. +} +\description{ +\code{\link{bayesAlphabetRssWeights}} with the BayesC prior. +} +\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) +} diff --git a/man/bayesCWeights.Rd b/man/bayesCWeights.Rd index 17b9dfad9..881b6d716 100644 --- a/man/bayesCWeights.Rd +++ b/man/bayesCWeights.Rd @@ -2,51 +2,61 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{bayesCWeights} \alias{bayesCWeights} -\title{BayesC TWAS weights (rounded-spike prior)} +\title{BayesC TWAS weights (spike and slab, one slab variance)} \usage{ bayesCWeights( X, y, - Z = NULL, + backend = c("qgg", "hibayes"), pi = 0.1, - h2 = NULL, - nit = 5000, - nburn = 1000, - nthin = 5, - methodArgs = QggOptions() + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL ) } \arguments{ -\item{X}{Numeric genotype / design matrix (samples x variants).} +\item{X}{A numeric matrix of genotypes (samples x variants).} -\item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{y}{A numeric vector of phenotypes, one per row of \code{X}.} -\item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{backend}{\code{"qgg"} (default) or \code{"hibayes"}.} -\item{pi}{Numeric in (0, 1). Prior proportion of non-null effects for the -BayesC mixture. Default \code{0.1}.} +\item{pi}{The prior proportion of non-null effects, where each engine's +estimate of it starts. Default \code{0.1}.} -\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} -leaves the engine's own default.} +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} -\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} -\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} -\item{nthin}{Integer. Thinning interval for retained MCMC samples. -Default \code{5}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} -\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built -with \code{\link{QggOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{methodArgs}{Options for the backend's engine: +\code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +hibayes. \code{NULL} keeps the engine's defaults.} } \value{ -A numeric vector of effect-size weights, one per variant (column of +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"}. } \description{ -Use a rounded spike prior (low-variance Gaussian). +Fits the BayesC prior, a point mass at zero mixed with a + normal whose variance every variant shares, through + \code{\link{bayesAlphabetWeights}}. } \examples{ data(eqtlRegionExample) diff --git a/man/bayesLRssWeights.Rd b/man/bayesLRssWeights.Rd new file mode 100644 index 000000000..062e061e8 --- /dev/null +++ b/man/bayesLRssWeights.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesLRssWeights} +\alias{bayesLRssWeights} +\title{BayesL TWAS weights from summary statistics} +\usage{ +bayesLRssWeights( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) +} +\arguments{ +\item{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}.} + +\item{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}}.} + +\item{backend}{\code{"hibayes"}, \code{"qgg"} or \code{"pecotmr"}; +\code{NULL} picks the default for the LD reference.} + +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} + +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} + +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the 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.} + +\item{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.} +} +\value{ +A numeric vector of the posterior mean effects, one per variant. +} +\description{ +\code{\link{bayesAlphabetRssWeights}} with the Bayesian + LASSO. +} +\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) +} diff --git a/man/bayesLWeights.Rd b/man/bayesLWeights.Rd index c6e9340d6..37993934c 100644 --- a/man/bayesLWeights.Rd +++ b/man/bayesLWeights.Rd @@ -2,48 +2,59 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{bayesLWeights} \alias{bayesLWeights} -\title{BayesL TWAS weights (Laplace prior, LASSO-equivalent)} +\title{BayesL TWAS weights (the Bayesian LASSO)} \usage{ bayesLWeights( X, y, - Z = NULL, - h2 = NULL, - nit = 5000, - nburn = 1000, - nthin = 5, - methodArgs = QggOptions() + backend = c("qgg", "bglr", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL ) } \arguments{ -\item{X}{Numeric genotype / design matrix (samples x variants).} +\item{X}{A numeric matrix of genotypes (samples x variants).} -\item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{y}{A numeric vector of phenotypes, one per row of \code{X}.} -\item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{backend}{\code{"qgg"} (default), \code{"bglr"} or +\code{"hibayes"}.} -\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} -leaves the engine's own default.} +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} -\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} -\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} -\item{nthin}{Integer. Thinning interval for retained MCMC samples. -Default \code{5}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} -\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built -with \code{\link{QggOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{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.} } \value{ -A numeric vector of effect-size weights, one per variant (column of +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"}. } \description{ -Use laplace/double exponential distribution as prior. This is - equivalent to Bayesian LASSO. +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). } \examples{ data(eqtlRegionExample) diff --git a/man/bayesNRssWeights.Rd b/man/bayesNRssWeights.Rd new file mode 100644 index 000000000..3df40e1a5 --- /dev/null +++ b/man/bayesNRssWeights.Rd @@ -0,0 +1,87 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesNRssWeights} +\alias{bayesNRssWeights} +\title{BayesN TWAS weights from summary statistics} +\usage{ +bayesNRssWeights( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) +} +\arguments{ +\item{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}.} + +\item{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}}.} + +\item{backend}{\code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +\code{NULL} picks the default for the LD reference.} + +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} + +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} + +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the 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.} + +\item{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.} +} +\value{ +A numeric vector of the posterior mean effects, one per variant. +} +\description{ +\code{\link{bayesAlphabetRssWeights}} with a normal prior + shared by every effect. +} +\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) +} diff --git a/man/bayesNWeights.Rd b/man/bayesNWeights.Rd index 0afa6c031..cdbe8b862 100644 --- a/man/bayesNWeights.Rd +++ b/man/bayesNWeights.Rd @@ -2,48 +2,57 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{bayesNWeights} \alias{bayesNWeights} -\title{BayesN TWAS weights (Gaussian prior, ridge-equivalent)} +\title{BayesN TWAS weights (Gaussian prior, ridge-like)} \usage{ bayesNWeights( X, y, - Z = NULL, - h2 = NULL, - nit = 5000, - nburn = 1000, - nthin = 5, - methodArgs = QggOptions() + backend = c("qgg", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL ) } \arguments{ -\item{X}{Numeric genotype / design matrix (samples x variants).} +\item{X}{A numeric matrix of genotypes (samples x variants).} -\item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{y}{A numeric vector of phenotypes, one per row of \code{X}.} -\item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{backend}{\code{"qgg"} (default) or \code{"hibayes"}.} -\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} -leaves the engine's own default.} +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} -\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} -\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} -\item{nthin}{Integer. Thinning interval for retained MCMC samples. -Default \code{5}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} -\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built -with \code{\link{QggOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{methodArgs}{Options for the backend's engine: +\code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +hibayes. \code{NULL} keeps the engine's defaults.} } \value{ -A numeric vector of effect-size weights, one per variant (column of +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"}. } \description{ -Use Gaussian distribution as prior. Posterior means will be - BLUP, equivalent to Ridge Regression. +Fits a normal prior shared by every effect, whose posterior + mean is the BLUP, a ridge regression, through + \code{\link{bayesAlphabetWeights}}. } \examples{ data(eqtlRegionExample) diff --git a/man/bayesRRssWeights.Rd b/man/bayesRRssWeights.Rd new file mode 100644 index 000000000..bf413f5d6 --- /dev/null +++ b/man/bayesRRssWeights.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{bayesRRssWeights} +\alias{bayesRRssWeights} +\title{BayesR TWAS weights from summary statistics} +\usage{ +bayesRRssWeights( + stat, + ldReference, + backend = NULL, + nIter = 5000, + nBurnin = 1000, + thin = 5, + shrinkCorr = 0.95, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL +) +} +\arguments{ +\item{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}.} + +\item{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}}.} + +\item{backend}{\code{"qgg"}, \code{"hibayes"} or \code{"pecotmr"}; +\code{NULL} picks the default for the LD reference.} + +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} + +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} + +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} attach the 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.} + +\item{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.} +} +\value{ +A numeric vector of the posterior mean effects, one per variant. +} +\description{ +\code{\link{bayesAlphabetRssWeights}} with the BayesR prior. +} +\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) +} diff --git a/man/bayesRWeights.Rd b/man/bayesRWeights.Rd index e1d31bbee..7fc9946bb 100644 --- a/man/bayesRWeights.Rd +++ b/man/bayesRWeights.Rd @@ -2,48 +2,57 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{bayesRWeights} \alias{bayesRWeights} -\title{BayesR TWAS weights (hierarchical mixture prior)} +\title{BayesR TWAS weights (a mixture of normals)} \usage{ bayesRWeights( X, y, - Z = NULL, - h2 = NULL, - nit = 5000, - nburn = 1000, - nthin = 5, - methodArgs = QggOptions() + backend = c("qgg", "hibayes"), + nIter = 5000, + nBurnin = 1000, + thin = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NULL ) } \arguments{ -\item{X}{Numeric genotype / design matrix (samples x variants).} +\item{X}{A numeric matrix of genotypes (samples x variants).} -\item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{y}{A numeric vector of phenotypes, one per row of \code{X}.} -\item{Z}{Optional numeric matrix of fixed-effect covariates, or \code{NULL}.} +\item{backend}{\code{"qgg"} (default) or \code{"hibayes"}.} -\item{h2}{Numeric or \code{NULL}. Prior heritability; \code{NULL} -leaves the engine's own default.} +\item{nIter}{Integer. Total number of MCMC iterations, burn-in included, +on every engine. Default \code{5000}.} -\item{nit}{Integer. Total MCMC iterations. Default \code{5000}.} +\item{nBurnin}{Integer. Number of burn-in iterations discarded; less than +\code{nIter}. Default \code{1000}.} -\item{nburn}{Integer. Burn-in iterations. Default \code{1000}.} +\item{thin}{Integer. Thinning interval for retained MCMC samples. Default +\code{5}.} -\item{nthin}{Integer. Thinning interval for retained MCMC samples. -Default \code{5}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} -\item{methodArgs}{Options forwarded to \code{qgg::gbayes}, built -with \code{\link{QggOptions}}. A bare list is refused: it cannot be -checked against the engine, so a misspelled option would be -silently ignored.} +\item{methodArgs}{Options for the backend's engine: +\code{\link{QggOptions}} for qgg, \code{\link{HibayesOptions}} for +hibayes. \code{NULL} keeps the engine's defaults.} } \value{ -A numeric vector of effect-size weights, one per variant (column of +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"}. } \description{ -Use a hierarchical Bayesian mixture model with four Gaussian - components. Variances are scaled by 0, 0.0001, 0.001, and 0.01. +Fits the BayesR prior, a mixture of a point mass at zero and + normals of increasing variance, through + \code{\link{bayesAlphabetWeights}}. } \examples{ data(eqtlRegionExample) diff --git a/man/bglrWeights.Rd b/man/bglrWeights.Rd index 7e6233a1f..407f9ba10 100644 --- a/man/bglrWeights.Rd +++ b/man/bglrWeights.Rd @@ -12,6 +12,7 @@ bglrWeights( burnIn, thin, etaArgs = list(), + fitRetention = c("none", "slim", "full"), methodArgs = BglrOptions() ) } @@ -31,13 +32,21 @@ bglrWeights( \item{etaArgs}{Optional named list of additional arguments included in the `ETA` linear-term specification (e.g. `list(probIn = 0.05)` for BayesB).} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} the fitted \code{BGLR} object, +which keeps no copy of the data, so the two retaining levels behave +alike here.} + \item{methodArgs}{Options forwarded to \code{BGLR::BGLR}, built with \code{\link{BglrOptions}}. A bare list is refused: it cannot be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of length `ncol(X)` of variant weights. +A numeric vector of length `ncol(X)` of variant weights, with the + fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Internal helper that fits a `BGLR::BGLR` linear regression with a single diff --git a/man/causalInferencePipeline.Rd b/man/causalInferencePipeline.Rd index 276e94713..c0d9afdf1 100644 --- a/man/causalInferencePipeline.Rd +++ b/man/causalInferencePipeline.Rd @@ -32,7 +32,11 @@ computation.} \item{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}.} \item{weightSelectionParam}{How one TWAS method's weights are picked per \code{(study, context, trait, gwasStudy)} tuple, built with diff --git a/man/colocPipeline.Rd b/man/colocPipeline.Rd index 1e024b6d5..a8b120e6b 100644 --- a/man/colocPipeline.Rd +++ b/man/colocPipeline.Rd @@ -104,10 +104,12 @@ prior probabilities are set through \code{priors} instead, since the enrichment adjustment reads them too.} } \value{ -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}, +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 diff --git a/man/colocViews.Rd b/man/colocViews.Rd index 2a56d54dd..ee9c046a4 100644 --- a/man/colocViews.Rd +++ b/man/colocViews.Rd @@ -77,9 +77,11 @@ hypothesis rather than merely a probable one.} } \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/man/ctwasGroupPriors.Rd b/man/ctwasGroupPriors.Rd index 54b26c14d..0b5b0654f 100644 --- a/man/ctwasGroupPriors.Rd +++ b/man/ctwasGroupPriors.Rd @@ -1,29 +1,48 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/CtwasResultEntry.R +% Please edit documentation in R/AllGenerics.R, R/CtwasResultEntry.R, +% R/CtwasResult.R \name{ctwasGroupPriors} \alias{ctwasGroupPriors} \alias{ctwasGroupPriors,CtwasResultEntry-method} +\alias{ctwasGroupPriors,CtwasResult-method} \title{Get cTWAS Group Prior Parameters} \usage{ ctwasGroupPriors(x, ...) \S4method{ctwasGroupPriors}{CtwasResultEntry}(x) + +\S4method{ctwasGroupPriors}{CtwasResult}(x) } \arguments{ -\item{x}{A \code{CtwasResultEntry}.} +\item{x}{A \code{CtwasResultEntry} or \code{CtwasResult}.} \item{...}{Reserved for future use.} } \value{ -The stored parameter object (typically a list), or \code{NULL}. +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. } \description{ -Return the estimated \code{group_prior} / \code{group_prior_var} - of a \code{\link{CtwasResultEntry}}. +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}). } \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) } diff --git a/man/ctwasPipeline.Rd b/man/ctwasPipeline.Rd index 500c4dd67..da8f01d61 100644 --- a/man/ctwasPipeline.Rd +++ b/man/ctwasPipeline.Rd @@ -45,9 +45,12 @@ was narrowed since that fit warns (condition class variants, so its weights are not renormalized over the variants kept.} \item{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.} \item{fineMappingResult}{Optional \code{QtlFineMappingResult}: the genes' own fine-mapping, whose per-variant PIP and credible-set membership the diff --git a/man/dot-penalizedRssWeights.Rd b/man/dot-penalizedRssWeights.Rd index b9ba0ba1e..19934d99d 100644 --- a/man/dot-penalizedRssWeights.Rd +++ b/man/dot-penalizedRssWeights.Rd @@ -9,7 +9,7 @@ ldReference, spec, s = c(0.2, 0.5, 0.9, 1), - 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") @@ -39,7 +39,7 @@ Shared implementation for \code{scadRssWeights()}, \code{mcpRssWeights()}, (\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. } \keyword{internal} diff --git a/man/dprWeights.Rd b/man/dprWeights.Rd index fea7ed866..bc0ea60af 100644 --- a/man/dprWeights.Rd +++ b/man/dprWeights.Rd @@ -48,9 +48,9 @@ dprAdaptiveGibbsWeights( \item{fitRetention}{How much of the fit is kept as the \code{"fit"} attribute of the returned weights: \code{"none"} (default) attaches -nothing, \code{"slim"} and \code{"full"} attach the fitted model. This -engine keeps no trimmable intermediates, so the two retaining levels -behave alike here.} +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.} \item{methodArgs}{Options forwarded to \code{RcppDPR::fit_model}, built with \code{\link{DprOptions}}. A bare list is refused: it cannot be diff --git a/man/enetRssWeights.Rd b/man/enetRssWeights.Rd index f48f5ed99..7f1c30340 100644 --- a/man/enetRssWeights.Rd +++ b/man/enetRssWeights.Rd @@ -9,7 +9,7 @@ enetRssWeights( ldReference, alpha = 0.5, s = c(0.2, 0.5, 0.9, 1), - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) @@ -33,8 +33,13 @@ penalty. Default 0.5.} \item{s}{Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, 0.5, 0.9, 1.0)}.} -\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or -\code{"minFbeta"}.} +\item{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.} \item{fitRetention}{How much of the search is kept as the \code{"fit"} attribute of the returned weights. \code{"none"} (default) attaches @@ -59,8 +64,8 @@ A numeric vector of SNP coefficient weights. Unless \description{ 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}}). } \details{ \code{alpha} is the L1 share of the penalty: with \eqn{l_1 = \lambda @@ -88,7 +93,7 @@ stat <- list( 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) } diff --git a/man/enetWeights.Rd b/man/enetWeights.Rd index 97832af9e..2f6c54f3c 100644 --- a/man/enetWeights.Rd +++ b/man/enetWeights.Rd @@ -4,7 +4,13 @@ \alias{enetWeights} \title{Compute TWAS weights via elastic net (glmnet)} \usage{ -enetWeights(X, y, alpha = 0.5, methodArgs = GlmnetOptions()) +enetWeights( + X, + y, + alpha = 0.5, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -14,12 +20,23 @@ enetWeights(X, y, alpha = 0.5, methodArgs = GlmnetOptions()) \item{alpha}{Elastic-net mixing in \code{[0, 1]}: the L1 share of the penalty. Default 0.5.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + \item{methodArgs}{Additional arguments forwarded to \code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare list is refused, since it cannot be checked against the engine's formals.} } \value{ -Numeric vector of length \code{ncol(X)} of per-variant weights. +Numeric vector of length \code{ncol(X)} of per-variant weights, + with the fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Convenience wrapper for \code{\link{glmnetWeights}} at a mixing between the diff --git a/man/estimateH2.Rd b/man/estimateH2.Rd index 1a164b51e..f5210608a 100644 --- a/man/estimateH2.Rd +++ b/man/estimateH2.Rd @@ -3,37 +3,46 @@ \name{estimateH2} \alias{estimateH2} \alias{estimateH2,GwasSumStats,LdStatistic-method} +\alias{estimateH2,QtlSumStats,missing-method} \title{Estimate SNP Heritability} \usage{ -estimateH2( +estimateH2(sumstats, ldRef, method = "lder", annotations = NULL, ...) + +\S4method{estimateH2}{GwasSumStats,LdStatistic}( sumstats, ldRef, method = "lder", annotations = NULL, - local = FALSE, - ... + studyName = NULL, + estimatorArgs = list() ) -\S4method{estimateH2}{GwasSumStats,LdStatistic}( +\S4method{estimateH2}{QtlSumStats,missing}( sumstats, ldRef, - method = "lder", + method = "lava", annotations = NULL, - local = FALSE, - studyName = NULL, - estimatorArgs = list() + contexts = NULL, + traitId = NULL, + cisWindow = NULL, + BPPARAM = SerialParam() ) } \arguments{ -\item{sumstats}{A \code{GwasSumStats} object.} +\item{sumstats}{A \code{GwasSumStats}, or a \code{QtlSumStats} that has +been through \code{\link{summaryStatsQc}}, each row with an LD +reference.} -\item{ldRef}{An \code{LdStatistic} object (method-appropriate subclass): -an \code{\link{LdScore}} for \code{"sldsc"} / \code{"gldsc"}, an -\code{\link{LdEigen}} for \code{"lder"} / \code{"hdl"}. Build either -from loaded LD with \code{\link{buildLdScore}} / -\code{\link{buildLdEigen}}.} +\item{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.} -\item{method}{Character, one of \code{"lder"} (the default), +\item{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. @@ -49,26 +58,88 @@ from loaded LD with \code{\link{buildLdScore}} / shrinks hard when \code{nRef} is small.} }} -\item{annotations}{An \code{AnnotationMatrix} object, or NULL for -unstratified estimation.} - -\item{local}{Logical, whether to compute per-block local estimates.} +\item{annotations}{For a \code{GwasSumStats}, an \code{AnnotationMatrix} +object, or NULL for unstratified estimation.} \item{...}{Additional method-specific arguments.} -\item{studyName}{Character (length 1) or \code{NULL}. Restrict the selection -to this study; \code{NULL} matches all studies.} +\item{studyName}{For a \code{GwasSumStats}, the study to estimate (length +1), or \code{NULL} when it holds one.} + +\item{estimatorArgs}{For a \code{GwasSumStats}, an optional named list of +estimator-specific options (\code{nIter} for sldsc).} -\item{estimatorArgs}{Optional named list of estimator-specific options -(\code{lambda} for lder / gldsc / hdl, \code{nIter} for sldsc).} +\item{contexts}{For a \code{QtlSumStats}: optional context selection, as +\code{\link{twasWeightsPipeline}} takes it; \code{NULL} (the default) +uses every context.} + +\item{traitId}{For a \code{QtlSumStats}: optional trait selection, as +\code{\link{twasWeightsPipeline}} takes it; \code{NULL} (the default) +uses every trait.} + +\item{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}.} + +\item{BPPARAM}{For a \code{QtlSumStats}: a \code{BiocParallelParam} over +the selected rows, each row's estimate on one worker. Default +\code{SerialParam()}.} } \value{ -An \code{H2Estimate} object. +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. } \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. +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. } \examples{ data(ldScoreExample) @@ -89,4 +160,24 @@ ss <- GwasSumStats(studyName = "trait1", entry = list(gr), 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) +} +\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. } diff --git a/man/estimateSparsity.Rd b/man/estimateSparsity.Rd index 1b114d280..49e07d77a 100644 --- a/man/estimateSparsity.Rd +++ b/man/estimateSparsity.Rd @@ -22,8 +22,8 @@ Computes an empirical estimate of the proportion of non-zero effects 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). } \examples{ estimateSparsity(list(mrash_weights = structure(c(0.1, 0, 0.3), diff --git a/man/fitMvsusie.Rd b/man/fitMvsusie.Rd index 621a8fd8a..707e323b2 100644 --- a/man/fitMvsusie.Rd +++ b/man/fitMvsusie.Rd @@ -9,6 +9,8 @@ fitMvsusie( Y, prior_variance, coverage = 0.95, + L = 10L, + L_greedy = NULL, methodArgs = MvsusieOptions() ) } @@ -25,6 +27,15 @@ canonical mixture over the conditions it is given.} \item{coverage}{Credible set coverage (default 0.95).} +\item{L}{Maximum number of single effects (default 10). +\code{fineMappingPipeline()} sets it from \code{maxNumSingleEffects} on +its \code{\link{CredibleSetParam}}.} + +\item{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}.} + \item{methodArgs}{Options forwarded to \code{mvsusieR::mvsusie}, built with \code{\link{MvsusieOptions}}. A bare list is refused: it cannot be checked against the engine, so a misspelled option would be silently diff --git a/man/fitMvsusieRss.Rd b/man/fitMvsusieRss.Rd index 8f9d891dc..b07aaefce 100644 --- a/man/fitMvsusieRss.Rd +++ b/man/fitMvsusieRss.Rd @@ -10,6 +10,8 @@ fitMvsusieRss( N, prior_variance, coverage = 0.95, + L = 10L, + L_greedy = NULL, methodArgs = MvsusieRssOptions() ) } @@ -24,6 +26,15 @@ fitMvsusieRss( \item{coverage}{Credible set coverage (default 0.95).} +\item{L}{Maximum number of single effects (default 10). +\code{fineMappingPipeline()} sets it from \code{maxNumSingleEffects} on +its \code{\link{CredibleSetParam}}.} + +\item{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}.} + \item{methodArgs}{Options forwarded to \code{mvsusieR::mvsusie_rss}, built with \code{\link{MvsusieRssOptions}} --- the RSS entry point has its own constructor, since it is a different function from diff --git a/man/flattenTupleRanges.Rd b/man/flattenTupleRanges.Rd index 23895c597..c725f56cc 100644 --- a/man/flattenTupleRanges.Rd +++ b/man/flattenTupleRanges.Rd @@ -36,6 +36,12 @@ Non-atomic \code{mcols} columns -- the per-element \code{susieFit} / 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. } \examples{ diff --git a/man/fsusieWeights.Rd b/man/fsusieWeights.Rd index 786b123ff..08cf32ee4 100644 --- a/man/fsusieWeights.Rd +++ b/man/fsusieWeights.Rd @@ -48,12 +48,17 @@ per-SNP posterior-mean wavelet effects \code{fitted_wc[[l]]} (\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. } \details{ The reconstruction uses the raw posterior wavelet coefficients diff --git a/man/glmnetWeights.Rd b/man/glmnetWeights.Rd index 6e6d4c962..3189a1490 100644 --- a/man/glmnetWeights.Rd +++ b/man/glmnetWeights.Rd @@ -4,7 +4,13 @@ \alias{glmnetWeights} \title{Compute TWAS weights via penalized regression (glmnet)} \usage{ -glmnetWeights(X, y, alpha, methodArgs = GlmnetOptions()) +glmnetWeights( + X, + y, + alpha, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} @@ -14,12 +20,23 @@ glmnetWeights(X, y, alpha, methodArgs = GlmnetOptions()) \item{alpha}{Elastic-net mixing parameter in \code{[0, 1]}: \code{1} = lasso, \code{0} = ridge, \code{0.5} = elastic net.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + \item{methodArgs}{Additional arguments forwarded to \code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare list is refused, since it cannot be checked against the engine's formals.} } \value{ -Numeric vector of length \code{ncol(X)} of per-variant weights. +Numeric vector of length \code{ncol(X)} of per-variant weights, + with the fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Fit a cross-validated elastic-net / lasso model with \code{glmnet::cv.glmnet} diff --git a/man/h2EstimateExample.Rd b/man/h2EstimateExample.Rd index db75d77e5..be81409bd 100644 --- a/man/h2EstimateExample.Rd +++ b/man/h2EstimateExample.Rd @@ -5,16 +5,18 @@ \alias{h2EstimateExample} \title{Example Heritability Estimate} \format{ -An \code{H2Estimate} object with \code{h2}, \code{h2Se}, - \code{intercept}, an \code{enrichment} data frame, and - \code{annotationJackknifeCoefs}. +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. } \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. +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}. } \examples{ data(h2EstimateExample) diff --git a/man/h2EstimateToSldscTrait.Rd b/man/h2EstimateToSldscTrait.Rd index ec0037ad2..ad7170dac 100644 --- a/man/h2EstimateToSldscTrait.Rd +++ b/man/h2EstimateToSldscTrait.Rd @@ -7,8 +7,10 @@ h2EstimateToSldscTrait(h2Est) } \arguments{ -\item{h2Est}{An \code{H2Estimate} object with enrichment and -\code{annotationJackknifeCoefs}.} +\item{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"]}.} } \value{ A named list matching the format of \code{\link{readSldscTrait}}: diff --git a/man/heritabilityEstimate.Rd b/man/heritabilityEstimate.Rd index 4a76d645c..ca850ef54 100644 --- a/man/heritabilityEstimate.Rd +++ b/man/heritabilityEstimate.Rd @@ -3,7 +3,7 @@ \name{heritabilityEstimate} \alias{heritabilityEstimate} \alias{heritabilityEstimate,H2Estimate-method} -\title{Get Global SNP Heritability} +\title{Get SNP Heritability} \usage{ heritabilityEstimate(x) @@ -13,11 +13,11 @@ heritabilityEstimate(x) \item{x}{An \code{H2Estimate}.} } \value{ -Numeric (length 1). +Numeric, one per estimate. } \description{ -Return the global SNP heritability estimate carried by an - \code{H2Estimate}. +Return the SNP heritability of each of an + \code{H2Estimate}'s estimates. } \examples{ data(h2EstimateExample) diff --git a/man/heritabilityEstimateSe.Rd b/man/heritabilityEstimateSe.Rd index 08e742b37..f21dfab6a 100644 --- a/man/heritabilityEstimateSe.Rd +++ b/man/heritabilityEstimateSe.Rd @@ -13,11 +13,11 @@ heritabilityEstimateSe(x) \item{x}{An \code{H2Estimate}.} } \value{ -Numeric (length 1). +Numeric, one per estimate. } \description{ -Return the standard error of the global SNP heritability - estimate carried by an \code{H2Estimate}. +Return the standard error of each of an \code{H2Estimate}'s + heritability estimates. } \examples{ data(h2EstimateExample) diff --git a/man/heritabilityIntercept.Rd b/man/heritabilityIntercept.Rd index 7151b88ff..bd5992340 100644 --- a/man/heritabilityIntercept.Rd +++ b/man/heritabilityIntercept.Rd @@ -13,12 +13,13 @@ heritabilityIntercept(x) \item{x}{An \code{H2Estimate}.} } \value{ -Numeric (length 1). +Numeric, one per estimate. } \description{ -Return the regression intercept carried by an - \code{H2Estimate}. Values above 1 indicate confounding or sample overlap - rather than polygenic signal. +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. } \examples{ data(h2EstimateExample) diff --git a/man/heritabilityInterceptSe.Rd b/man/heritabilityInterceptSe.Rd index 026a44971..6b5c94717 100644 --- a/man/heritabilityInterceptSe.Rd +++ b/man/heritabilityInterceptSe.Rd @@ -13,11 +13,11 @@ heritabilityInterceptSe(x) \item{x}{An \code{H2Estimate}.} } \value{ -Numeric (length 1). +Numeric, one per estimate. } \description{ -Return the standard error of the regression intercept carried - by an \code{H2Estimate}. +Return the standard error of each of an \code{H2Estimate}'s + fitted intercepts. } \examples{ data(h2EstimateExample) diff --git a/man/l0learnRssWeights.Rd b/man/l0learnRssWeights.Rd index 1cdab8811..86bed3a54 100644 --- a/man/l0learnRssWeights.Rd +++ b/man/l0learnRssWeights.Rd @@ -12,7 +12,7 @@ l0learnRssWeights( lambda0 = exp(seq(log(0.001), log(1), length.out = 10)), lambda = NULL, lambda2 = 0, - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), maxSwaps = 100, fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() @@ -45,8 +45,13 @@ Default \code{"L0"}.} \item{lambda2}{L2 penalty weight (for L0L2). Default 0.} -\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or -\code{"minFbeta"}.} +\item{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.} \item{maxSwaps}{Maximum swap rounds per lambda. Default 100.} @@ -73,7 +78,8 @@ A numeric vector of SNP coefficient weights. Unless \description{ 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}}). } \details{ The swap optimization from L0Learn is included: after coordinate descent @@ -92,5 +98,5 @@ stat <- list( n = rep(nrow(X), ncol(X)), variantNames = colnames(X) ) -l0learnRssWeights(stat, LdMatrix(cor(X))) +l0learnRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) } diff --git a/man/l0learnWeights.Rd b/man/l0learnWeights.Rd index 05b697a9c..aa5538dca 100644 --- a/man/l0learnWeights.Rd +++ b/man/l0learnWeights.Rd @@ -4,7 +4,14 @@ \alias{l0learnWeights} \title{Compute Weights Using L0Learn} \usage{ -l0learnWeights(X, y, penalty = "L0", nFolds = 5, methodArgs = L0learnOptions()) +l0learnWeights( + X, + y, + penalty = "L0", + nFolds = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = L0learnOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -16,13 +23,24 @@ l0learnWeights(X, y, penalty = "L0", nFolds = 5, methodArgs = L0learnOptions()) \item{nFolds}{Number of cross-validation folds. Default is 5.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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}.} + \item{methodArgs}{Options forwarded to \code{L0Learn::L0Learn.cvfit}, built with \code{\link{L0learnOptions}}. A bare list is refused: it cannot be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of length `ncol(X)` of variant weights. +A numeric vector of length `ncol(X)` of variant weights, with the + fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Fits an L0-regularized linear regression model via `L0Learn::L0Learn.cvfit` diff --git a/man/lassoWeights.Rd b/man/lassoWeights.Rd index 55a2a0295..bfb38d721 100644 --- a/man/lassoWeights.Rd +++ b/man/lassoWeights.Rd @@ -4,19 +4,35 @@ \alias{lassoWeights} \title{Compute TWAS weights via lasso (glmnet, alpha = 1)} \usage{ -lassoWeights(X, y, methodArgs = GlmnetOptions()) +lassoWeights( + X, + y, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} \item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + \item{methodArgs}{Additional arguments forwarded to \code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare list is refused, since it cannot be checked against the engine's formals.} } \value{ -Numeric vector of length \code{ncol(X)} of per-variant weights. +Numeric vector of length \code{ncol(X)} of per-variant weights, + with the fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 1}. diff --git a/man/lassosumRssWeights.Rd b/man/lassosumRssWeights.Rd index ec313259b..52ec126fa 100644 --- a/man/lassosumRssWeights.Rd +++ b/man/lassosumRssWeights.Rd @@ -7,10 +7,11 @@ lassosumRssWeights( stat, ldReference, - s = c(0.2, 0.5, 0.9, 1), - selection = c("ldQuadratic", "minFbeta"), + backend = NULL, + s = NULL, + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), - methodArgs = LassosumOptions() + methodArgs = NULL ) } \arguments{ @@ -26,12 +27,37 @@ to by \code{stat$variantNames}: a genotype panel (see \code{\link{LdMatrix}}. A genotype reference's LD is used through its standardized genotypes, never formed as a matrix.} -\item{s}{Numeric vector of shrinkage parameters to search over. Default: -\code{c(0.2, 0.5, 0.9, 1.0)} following Mak et al (2017) and OTTERS.} +\item{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.} -\item{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.} +\item{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.} + +\item{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.} \item{fitRetention}{How much of the search is kept as the \code{"fit"} attribute of the returned weights. \code{"none"} (default) attaches @@ -42,10 +68,13 @@ 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).} -\item{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.} +\item{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.} } \value{ A numeric vector of the posterior SNP coefficients at the best (s, @@ -56,20 +85,39 @@ A numeric vector of the posterior SNP coefficients at the best (s, 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. } \examples{ data(eqtlRegionExample) @@ -83,6 +131,8 @@ stat <- list( 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) } diff --git a/man/ldpred2AutoWeights.Rd b/man/ldpred2AutoWeights.Rd new file mode 100644 index 000000000..6c752950f --- /dev/null +++ b/man/ldpred2AutoWeights.Rd @@ -0,0 +1,112 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{ldpred2AutoWeights} +\alias{ldpred2AutoWeights} +\title{LDpred2-auto Weights from Summary Statistics} +\usage{ +ldpred2AutoWeights( + stat, + ldReference, + backend = NULL, + h2Init = NULL, + pInit = exp(seq(log(1e-04), log(0.2), length.out = 30)), + nIter = 700, + nBurnin = 500, + shrinkCorr = 0.95, + allowJumpSign = FALSE, + pBounds = c(1e-05, 1), + fitRetention = c("none", "slim", "full") +) +} +\arguments{ +\item{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.} + +\item{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}}.} + +\item{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.} + +\item{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.} + +\item{pInit}{The starting proportions of causal variants, one chain each.} + +\item{nIter, nBurnin}{Each chain's iterations, burn-in included, and its +burn-in.} + +\item{shrinkCorr}{The LD shrinkage \eqn{c}: the sampler reads +\eqn{cR + (1 - c)I}.} + +\item{allowJumpSign}{Keep a drawn effect whose sign differs from the +current one; \code{FALSE} sets it to zero instead.} + +\item{pBounds}{The bounds on \eqn{p}.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights. \code{"none"} (default) attaches +nothing. \code{"slim"} 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).} +} +\value{ +A numeric vector of weights, the kept chains' mean effects. Unless + \code{fitRetention = "none"}, the fit is attached as attribute + \code{"fit"}. +} +\description{ +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. +} +\details{ +The defaults are the LDpred2 vignette's, without the MAF-dependent prior +variance. + + +\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. +} +\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 +} +} diff --git a/man/ldpred2GridWeights.Rd b/man/ldpred2GridWeights.Rd new file mode 100644 index 000000000..37d754b46 --- /dev/null +++ b/man/ldpred2GridWeights.Rd @@ -0,0 +1,114 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{ldpred2GridWeights} +\alias{ldpred2GridWeights} +\title{LDpred2-grid Weights from Summary Statistics} +\usage{ +ldpred2GridWeights( + stat, + ldReference, + backend = NULL, + p = exp(seq(log(1e-05), 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") +) +} +\arguments{ +\item{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.} + +\item{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}}.} + +\item{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.} + +\item{p}{The proportions of causal variants in the grid.} + +\item{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.} + +\item{sparse}{Whether each fit sets an effect whose inclusion probability +falls below \code{p} to zero; both by default.} + +\item{nIter, nBurnin}{Each chain's iterations, burn-in included, and its +burn-in.} + +\item{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.} + +\item{allowJumpSign}{As for \code{\link{ldpred2AutoWeights}}; bigsnpr's +grid sampler takes only \code{TRUE}, the default.} + +\item{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.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights. \code{"none"} (default) attaches +nothing. \code{"slim"} 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).} +} +\value{ +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"}. +} +\description{ +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. +} +\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") +} +} diff --git a/man/learnTwasWeights.Rd b/man/learnTwasWeights.Rd index 3841c7c4d..cae69ec18 100644 --- a/man/learnTwasWeights.Rd +++ b/man/learnTwasWeights.Rd @@ -60,8 +60,11 @@ produce the fits.} \item{fitRetention}{How much of each per-method fit is kept on the result: \code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed payload downstream needs, \code{"full"} keeps the whole fitted object. -Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; -for every other method the two behave alike.} +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.} \item{weightStandardized}{Logical. Whether the supplied \code{X} / \code{Y} are already standardized. Default \code{FALSE}.} @@ -83,8 +86,10 @@ main-process seed is scoped to the call, so the session RNG is left as it was found. \code{NULL} (default) seeds neither.} } \value{ -A list where each element is named after a method and contains the - weight matrix produced by that method. +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"}. } \description{ Applies specified weight methods to the datasets X and Y, returning weight diff --git a/man/localH2Blocks.Rd b/man/localH2Blocks.Rd deleted file mode 100644 index 76a5c3828..000000000 --- a/man/localH2Blocks.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/H2Estimate.R -\name{localH2Blocks} -\alias{localH2Blocks} -\alias{localH2Blocks,H2Estimate-method} -\title{Get Local Estimates} -\usage{ -localH2Blocks(object) - -\S4method{localH2Blocks}{H2Estimate}(object) -} -\arguments{ -\item{object}{An \code{H2Estimate} object.} -} -\value{ -A \code{data.frame} of local estimates, or NULL. -} -\description{ -Extract per-block local estimates from a result object. -} -\examples{ -data(h2EstimateExample) -localH2Blocks(h2EstimateExample) -} diff --git a/man/mcpRssWeights.Rd b/man/mcpRssWeights.Rd index 6189a0183..eb5ada9f4 100644 --- a/man/mcpRssWeights.Rd +++ b/man/mcpRssWeights.Rd @@ -10,7 +10,7 @@ mcpRssWeights( s = c(0.2, 0.5, 0.9, 1), gamma = 3, alpha = 1, - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) @@ -37,8 +37,13 @@ standardized genotypes, never formed as a matrix.} the penalty, the rest a ridge term, as \code{\link{penalizedRss}} mixes them. Default 1, no ridge term.} -\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or -\code{"minFbeta"}.} +\item{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.} \item{fitRetention}{How much of the search is kept as the \code{"fit"} attribute of the returned weights. \code{"none"} (default) attaches @@ -62,8 +67,8 @@ A numeric vector of SNP coefficient weights. Unless } \description{ 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}}). } \examples{ data(eqtlRegionExample) @@ -77,5 +82,5 @@ stat <- list( n = rep(nrow(X), ncol(X)), variantNames = colnames(X) ) -mcpRssWeights(stat, LdMatrix(cor(X))) +mcpRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) } diff --git a/man/mcpWeights.Rd b/man/mcpWeights.Rd index 66d7cc626..d2a424f30 100644 --- a/man/mcpWeights.Rd +++ b/man/mcpWeights.Rd @@ -4,7 +4,13 @@ \alias{mcpWeights} \title{Compute Weights Using MCP-Penalized Regression} \usage{ -mcpWeights(X, y, nfolds = 5, methodArgs = NcvregOptions()) +mcpWeights( + X, + y, + nfolds = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NcvregOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -13,13 +19,24 @@ mcpWeights(X, y, nfolds = 5, methodArgs = NcvregOptions()) \item{nfolds}{Number of cross-validation folds. Default is 5.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + \item{methodArgs}{Options forwarded to \code{ncvreg::cv.ncvreg}, built with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of length `ncol(X)` of variant weights. +A numeric vector of length `ncol(X)` of variant weights, with the + fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Fits an MCP-penalized linear regression model via `ncvreg::cv.ncvreg` and diff --git a/man/methodNames.Rd b/man/methodNames.Rd index 59a1f2448..de9f7ca88 100644 --- a/man/methodNames.Rd +++ b/man/methodNames.Rd @@ -27,8 +27,8 @@ methodNames(x) Character vector. } \description{ -Extract the method name(s) an object was produced with: one - per entry for a collection, a single name for one estimate. +Extract the unique method name(s) an object was produced + with. } \examples{ data(h2EstimateExample) diff --git a/man/mrashWeights.Rd b/man/mrashWeights.Rd index 5229a2498..4cb7490a4 100644 --- a/man/mrashWeights.Rd +++ b/man/mrashWeights.Rd @@ -18,9 +18,10 @@ mrashWeights( \item{fitRetention}{How much of the fit is kept as the \code{"fit"} attribute of the returned weights: \code{"none"} (default) attaches -nothing, \code{"slim"} and \code{"full"} attach the fitted model. This -engine keeps no trimmable intermediates, so the two retaining levels -behave alike here.} +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.} \item{methodArgs}{Options forwarded to \code{susieR::mr.ash}, built with \code{\link{MrashOptions}}. A bare list is refused: it cannot be diff --git a/man/mrmashWrapper.Rd b/man/mrmashWrapper.Rd index 40f88eb9f..fab5ec220 100644 --- a/man/mrmashWrapper.Rd +++ b/man/mrmashWrapper.Rd @@ -54,11 +54,11 @@ steps as well as the fit, so it is set here rather than in \code{methodArgs}.} \item{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()}.} \item{methodArgs}{Options forwarded to \code{mr.mashr::mr.mash} under its own names, built with \code{\link{MrmashOptions}} diff --git a/man/mvsusieWeights.Rd b/man/mvsusieWeights.Rd index eca38ab80..a2692b990 100644 --- a/man/mvsusieWeights.Rd +++ b/man/mvsusieWeights.Rd @@ -4,13 +4,30 @@ \alias{mvsusieWeights} \title{Compute mvSuSiE TWAS weights} \usage{ -mvsusieWeights(mvsusieFit = NULL) +mvsusieWeights( + X = NULL, + Y = NULL, + mvsusieFit = NULL, + fitRetention = c("none", "slim", "full") +) } \arguments{ -\item{mvsusieFit}{A fitted mvSuSiE object. Required.} +\item{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()}.} + +\item{mvsusieFit}{A fitted mvSuSiE object, or the trimmed one a +fine-mapping result stores, whose precomputed \code{coef} is read. +Required.} + +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing, \code{"slim"} and \code{"full"} the fit the weights were +extracted from, as given. It names the variants it was fitted on.} } \value{ -Matrix of variant weights. +Matrix of variant weights, with the fit attached as attribute + \code{"fit"} unless \code{fitRetention = "none"}. } \description{ Extracts coefficients from an existing mvSuSiE fit. This never fits diff --git a/man/nSnps.Rd b/man/nSnps.Rd index 19f208c38..cd6672d73 100644 --- a/man/nSnps.Rd +++ b/man/nSnps.Rd @@ -28,12 +28,12 @@ this context; \code{NULL} matches all contexts.} this trait; \code{NULL} matches all traits.} } \value{ -Integer. +Integer; for an \code{H2Estimate}, one per estimate. } \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. } \examples{ data(qtlSumStatsExample) diff --git a/man/ncvregWeights.Rd b/man/ncvregWeights.Rd index 0fa18b01a..13de01193 100644 --- a/man/ncvregWeights.Rd +++ b/man/ncvregWeights.Rd @@ -4,7 +4,14 @@ \alias{ncvregWeights} \title{Compute Weights Using ncvreg with SCAD or MCP Penalty} \usage{ -ncvregWeights(X, y, penalty, nfolds = 5, methodArgs = NcvregOptions()) +ncvregWeights( + X, + y, + penalty, + nfolds = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NcvregOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors (no intercept column; `ncvreg` @@ -16,13 +23,24 @@ standardizes internally and adds its own intercept).} \item{nfolds}{Number of cross-validation folds. Default is 5.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + \item{methodArgs}{Options forwarded to \code{ncvreg::cv.ncvreg}, built with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of length `ncol(X)` of variant weights. +A numeric vector of length `ncol(X)` of variant weights, with the + fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Internal helper that fits an `ncvreg` model with the specified non-convex diff --git a/man/nestTupleRanges.Rd b/man/nestTupleRanges.Rd index 97f02e66c..28e0f7e78 100644 --- a/man/nestTupleRanges.Rd +++ b/man/nestTupleRanges.Rd @@ -26,6 +26,9 @@ all survive a plyranges round trip. \details{ 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. } \examples{ data(qtlFineMappingExample) diff --git a/man/pecotmr-h2-lder.Rd b/man/pecotmr-h2-lder.Rd index 955a6a700..e72deb05e 100644 --- a/man/pecotmr-h2-lder.Rd +++ b/man/pecotmr-h2-lder.Rd @@ -5,8 +5,8 @@ \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. Estimate SNP heritability by LD eigenvalue regression (Song et al. 2022). Within each LD block the z-scores are whitened in the diff --git a/man/penalizedRss.Rd b/man/penalizedRss.Rd index cf7af3b7f..9f1656253 100644 --- a/man/penalizedRss.Rd +++ b/man/penalizedRss.Rd @@ -52,10 +52,11 @@ variants; ignored otherwise. Default 0.} \item{lambda2}{L2 penalty weight for L0L2 variant. Default 0.} -\item{thr}{Convergence threshold. Default 1e-4.} +\item{thr}{Convergence threshold. Default 1e-4. The ridge, solved +exactly, does not use it.} \item{maxiter}{Maximum coordinate descent iterations per lambda. Default -10000.} +10000. The ridge, solved exactly, does not use it.} \item{maxSwaps}{Maximum swap rounds for L0 variants. Default 100. Set to 0 to disable swaps.} @@ -78,7 +79,10 @@ mixtures, MCP, SCAD, L0, L0L1 and L0L2. Uses coordinate descent on the 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}. } \details{ Internal: \code{\link{enetRssWeights}}, \code{\link{ridgeRssWeights}}, diff --git a/man/prsCs.Rd b/man/prsCs.Rd index 654eccd9d..5ffbf2b64 100644 --- a/man/prsCs.Rd +++ b/man/prsCs.Rd @@ -17,7 +17,10 @@ prsCs( nBurnin = 500, thin = 5, verbose = FALSE, - seed = NULL + seed = NULL, + shrinkCorr = 1, + raoBlackwell = FALSE, + nChains = 1 ) } \arguments{ @@ -47,12 +50,30 @@ standardize the effect sizes by MAF. Default is NULL.} \item{verbose}{Whether to print verbose output. Default is FALSE.} \item{seed}{Random seed for reproducibility. Default is NULL.} + +\item{shrinkCorr}{The LD shrinkage \eqn{c}: the sampler reads +\eqn{cR + (1 - c)I}. Default 1, none.} + +\item{raoBlackwell}{Report the blocks' conditional posterior means, +averaged over the kept iterations, rather than the draws' average. +Default \code{FALSE}.} + +\item{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.} } \value{ 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. } \description{ This function is a wrapper for the PRS-CS method implemented in C++. It takes diff --git a/man/qtlAssociationPostprocess.Rd b/man/qtlAssociationPostprocess.Rd index 7d38c3ce0..a7d9ca281 100644 --- a/man/qtlAssociationPostprocess.Rd +++ b/man/qtlAssociationPostprocess.Rd @@ -14,7 +14,7 @@ qtlAssociationPostprocess(x, ...) cisWindow = 0, methods = c("permutation", "bonferroni"), pvalueCol = "P", - afCol = "af", + afCol = "AF", qvalueArgs = QvalueOptions() ) } @@ -26,7 +26,7 @@ qtlAssociationPostprocess(x, ...) \item{fdrThreshold}{Event- and variant-level FDR threshold (default 0.05).} \item{mafCutoff}{Minor-allele-frequency cutoff for the FILTERED Bonferroni -flavour (fold of the per-variant \code{af} mcol). \code{0} disables it.} +flavour (fold of the per-variant \code{AF} mcol). \code{0} disables it.} \item{cisWindow}{cis-window (bp) for the FILTERED Bonferroni flavour, applied to the per-variant \code{tss_distance}/\code{tes_distance} mcols. \code{0} @@ -42,7 +42,8 @@ no stored column -- it is a significance query (see \code{significantQtls}).} \item{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).} \item{qvalueArgs}{Extra arguments for \code{qvalue::qvalue()}, built with \code{\link{QvalueOptions}} -- the \code{pi0.method} / \code{lambda} diff --git a/man/readAfreq.Rd b/man/readAfreq.Rd index 80b4c4ba6..00ea623ea 100644 --- a/man/readAfreq.Rd +++ b/man/readAfreq.Rd @@ -10,8 +10,10 @@ readAfreq(path) \item{path}{File prefix (without .afreq extension).} } \value{ -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. +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. } \description{ Read a PLINK2 allele frequency file (.afreq or .afreq.zst) diff --git a/man/readAnnotations.Rd b/man/readAnnotations.Rd index c3425a257..7503c1171 100644 --- a/man/readAnnotations.Rd +++ b/man/readAnnotations.Rd @@ -16,14 +16,19 @@ objects. Names become annotation names.} \item{snpRanges}{A \code{GRanges} object defining SNP positions.} \item{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.} \item{genome}{Character, genome build.} \item{...}{Additional arguments.} } \value{ -An \code{AnnotationMatrix} object. +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. } \description{ Read genomic annotations from files (BED, BigWig, S-LDSC .annot diff --git a/man/resolveWeights.Rd b/man/resolveWeights.Rd index 623ee00f6..8a94f2146 100644 --- a/man/resolveWeights.Rd +++ b/man/resolveWeights.Rd @@ -41,6 +41,8 @@ one LD block; \code{NULL} (default) leaves it unconstrained.} \value{ 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. } \description{ Return an aligned \code{(variantIds, weights)} pair from a diff --git a/man/ridgeRssWeights.Rd b/man/ridgeRssWeights.Rd index daabde912..e264181af 100644 --- a/man/ridgeRssWeights.Rd +++ b/man/ridgeRssWeights.Rd @@ -8,7 +8,7 @@ ridgeRssWeights( stat, ldReference, s = c(0.2, 0.5, 0.9, 1), - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) @@ -29,8 +29,13 @@ standardized genotypes, never formed as a matrix.} \item{s}{Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, 0.5, 0.9, 1.0)}.} -\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or -\code{"minFbeta"}.} +\item{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.} \item{fitRetention}{How much of the search is kept as the \code{"fit"} attribute of the returned weights. \code{"none"} (default) attaches @@ -57,7 +62,17 @@ Fits ridge regression on the RSS objective, \code{\link{enetRssWeights}} 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}}). +} +\details{ +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. } \examples{ data(eqtlRegionExample) @@ -71,5 +86,5 @@ stat <- list( n = rep(nrow(X), ncol(X)), variantNames = colnames(X) ) -ridgeRssWeights(stat, LdMatrix(cor(X))) +ridgeRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) } diff --git a/man/ridgeWeights.Rd b/man/ridgeWeights.Rd index fb2242923..09d85200c 100644 --- a/man/ridgeWeights.Rd +++ b/man/ridgeWeights.Rd @@ -4,19 +4,35 @@ \alias{ridgeWeights} \title{Compute TWAS weights via ridge regression (glmnet, alpha = 0)} \usage{ -ridgeWeights(X, y, methodArgs = GlmnetOptions()) +ridgeWeights( + X, + y, + fitRetention = c("none", "slim", "full"), + methodArgs = GlmnetOptions() +) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} \item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + \item{methodArgs}{Additional arguments forwarded to \code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare list is refused, since it cannot be checked against the engine's formals.} } \value{ -Numeric vector of length \code{ncol(X)} of per-variant weights. +Numeric vector of length \code{ncol(X)} of per-variant weights, + with the fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 0}. diff --git a/man/scadRssWeights.Rd b/man/scadRssWeights.Rd index bbc7966b5..e10b6e010 100644 --- a/man/scadRssWeights.Rd +++ b/man/scadRssWeights.Rd @@ -10,7 +10,7 @@ scadRssWeights( s = c(0.2, 0.5, 0.9, 1), gamma = 3.7, alpha = 1, - selection = c("ldQuadratic", "minFbeta"), + selection = c("heldOut", "ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), methodArgs = PenalizedRssOptions() ) @@ -37,8 +37,13 @@ standardized genotypes, never formed as a matrix.} the penalty, the rest a ridge term, as \code{\link{penalizedRss}} mixes them. Default 1, no ridge term.} -\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or -\code{"minFbeta"}.} +\item{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.} \item{fitRetention}{How much of the search is kept as the \code{"fit"} attribute of the returned weights. \code{"none"} (default) attaches @@ -62,8 +67,8 @@ A numeric vector of SNP coefficient weights. Unless } \description{ 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}}). } \examples{ data(eqtlRegionExample) @@ -77,5 +82,5 @@ stat <- list( n = rep(nrow(X), ncol(X)), variantNames = colnames(X) ) -scadRssWeights(stat, LdMatrix(cor(X))) +scadRssWeights(stat, LdMatrix(cor(X), nSamples = nrow(X))) } diff --git a/man/scadWeights.Rd b/man/scadWeights.Rd index 976dd6c82..fb504ecf1 100644 --- a/man/scadWeights.Rd +++ b/man/scadWeights.Rd @@ -4,7 +4,13 @@ \alias{scadWeights} \title{Compute Weights Using SCAD-Penalized Regression} \usage{ -scadWeights(X, y, nfolds = 5, methodArgs = NcvregOptions()) +scadWeights( + X, + y, + nfolds = 5, + fitRetention = c("none", "slim", "full"), + methodArgs = NcvregOptions() +) } \arguments{ \item{X}{A numeric matrix of predictors.} @@ -13,13 +19,24 @@ scadWeights(X, y, nfolds = 5, methodArgs = NcvregOptions()) \item{nfolds}{Number of cross-validation folds. Default is 5.} +\item{fitRetention}{How much of the fit is kept as the \code{"fit"} +attribute of the returned weights: \code{"none"} (default) attaches +nothing; \code{"slim"} 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.} + \item{methodArgs}{Options forwarded to \code{ncvreg::cv.ncvreg}, built with \code{\link{NcvregOptions}}. A bare list is refused: it cannot be checked against the engine, so a misspelled option would be silently ignored.} } \value{ -A numeric vector of length `ncol(X)` of variant weights. +A numeric vector of length `ncol(X)` of variant weights, with the + fit attached as attribute \code{"fit"} unless + \code{fitRetention = "none"}. } \description{ Fits a SCAD-penalized linear regression model via `ncvreg::cv.ncvreg` and diff --git a/man/scoreStats.Rd b/man/scoreStats.Rd index 01c957e88..18b1ff99e 100644 --- a/man/scoreStats.Rd +++ b/man/scoreStats.Rd @@ -13,10 +13,14 @@ scoreStats(object) \item{object}{An \code{H2Estimate} object.} } \value{ -A list with \code{z} and \code{R}, or NULL. +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}. } \description{ -Extract score statistics for candidate annotations. +Extract score statistics for candidate annotations, suitable + for input to \code{susieRss}. } \examples{ data(h2EstimateExample) diff --git a/man/sdpr.Rd b/man/sdpr.Rd index ba60f01e7..9298b9b7d 100644 --- a/man/sdpr.Rd +++ b/man/sdpr.Rd @@ -21,7 +21,9 @@ sdpr( thin = 5, optLlk = 1, verbose = TRUE, - seed = NULL + seed = NULL, + raoBlackwell = FALSE, + nChains = 1 ) } \arguments{ @@ -64,10 +66,19 @@ arrays in a separate cohort). Default is 1.} \item{seed}{Integer or \code{NULL}. Random seed for the Gibbs sampler; \code{NULL} leaves the RNG state unchanged.} + +\item{raoBlackwell}{Report \eqn{\eta} times the effects' conditional +posterior means, averaged over the kept iterations, rather than the +draws' average. Default \code{FALSE}.} + +\item{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.} } \value{ 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. } \description{ This function is a wrapper for the SDPR C++ implementation, which performs @@ -86,5 +97,11 @@ This function wraps a rewritten and adapted version of the SDPR C++ 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. } \keyword{internal} diff --git a/man/stratifiedHeritabilityEnrichment.Rd b/man/stratifiedHeritabilityEnrichment.Rd index e197a1221..5a387c16a 100644 --- a/man/stratifiedHeritabilityEnrichment.Rd +++ b/man/stratifiedHeritabilityEnrichment.Rd @@ -13,10 +13,23 @@ stratifiedHeritabilityEnrichment(object) \item{object}{An \code{H2Estimate} object.} } \value{ -A \code{data.frame} of enrichment estimates, or NULL. +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. } \description{ -Extract annotation enrichment estimates from a result object. +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}.} + } } \examples{ data(h2EstimateExample) diff --git a/man/studyName.Rd b/man/studyName.Rd index 6d3da4bd9..4fd93d5bb 100644 --- a/man/studyName.Rd +++ b/man/studyName.Rd @@ -1,11 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/AllClasses.R, -% R/CtwasResult.R, R/QtlDataset.R, R/MultiStudyQtlDataset.R, R/twasWeights.R +% R/CtwasResult.R, R/H2Estimate.R, R/QtlDataset.R, R/MultiStudyQtlDataset.R, +% R/twasWeights.R \name{studyName} \alias{studyName} \alias{studyName,SumStatsBase-method} \alias{studyName,FineMappingResultBase-method} \alias{studyName,CtwasResult-method} +\alias{studyName,H2Estimate-method} \alias{studyName,QtlDataset-method} \alias{studyName,MultiStudyQtlDataset-method} \alias{studyName,TwasWeights-method} @@ -19,6 +21,8 @@ studyName(x) \S4method{studyName}{CtwasResult}(x) +\S4method{studyName}{H2Estimate}(x) + \S4method{studyName}{QtlDataset}(x) \S4method{studyName}{MultiStudyQtlDataset}(x) @@ -26,13 +30,15 @@ studyName(x) \S4method{studyName}{TwasWeights}(x) } \arguments{ -\item{x}{A \code{QtlDataset} object.} +\item{x}{A \code{QtlDataset}, \code{CtwasResult} or \code{H2Estimate} +object.} } \value{ -Character (length 1). +Character: length 1 for a \code{QtlDataset}. } \description{ -Return the study identifier carried by a \code{QtlDataset}. +Return the study identifier carried by a \code{QtlDataset}, + or the unique studies of a \code{CtwasResult} or \code{H2Estimate}. } \examples{ data(qtlDatasetExample) diff --git a/man/traitNames.Rd b/man/traitNames.Rd index 6f87383af..ff24d8e12 100644 --- a/man/traitNames.Rd +++ b/man/traitNames.Rd @@ -30,14 +30,12 @@ traitNames(x) \item{x}{The object.} } \value{ -Character vector of unique trait names; length 1 for an - \code{H2Estimate}. +Character vector of 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}}. } \examples{ data(qtlSumStatsExample) diff --git a/man/twasEngineOptions.Rd b/man/twasEngineOptions.Rd index ae8a85d8b..67f4d0d46 100644 --- a/man/twasEngineOptions.Rd +++ b/man/twasEngineOptions.Rd @@ -5,6 +5,9 @@ \alias{GlmnetOptions} \alias{QggOptions} \alias{BglrOptions} +\alias{HibayesOptions} +\alias{HibayesRssOptions} +\alias{BayesAlphabetRssOptions} \alias{DprOptions} \alias{NcvregOptions} \alias{L0learnOptions} @@ -12,6 +15,7 @@ \alias{MrashRssOptions} \alias{PrsCsOptions} \alias{LassosumOptions} +\alias{BigsnprOptions} \alias{PenalizedRssOptions} \alias{SdprOptions} \alias{MrmashOptions} @@ -24,6 +28,12 @@ QggOptions(...) BglrOptions(...) +HibayesOptions(...) + +HibayesRssOptions(...) + +BayesAlphabetRssOptions(...) + DprOptions(...) NcvregOptions(...) @@ -38,6 +48,8 @@ PrsCsOptions(...) LassosumOptions(...) +BigsnprOptions(...) + PenalizedRssOptions(...) SdprOptions(...) @@ -62,7 +74,9 @@ Options forwarded to the engine behind a TWAS weight method, 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} @@ -71,6 +85,18 @@ Options forwarded to the engine behind a TWAS weight method, what lets each be checked exactly, rather than against a union in which an option meant for the other path would pass and then be dropped. + 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 @@ -91,6 +117,10 @@ Options forwarded to the engine behind a TWAS weight method, 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. } \examples{ GlmnetOptions(nfolds = 10) diff --git a/man/twasWeightsCv.Rd b/man/twasWeightsCv.Rd index 7db3ea5cc..9b490b56d 100644 --- a/man/twasWeightsCv.Rd +++ b/man/twasWeightsCv.Rd @@ -18,8 +18,7 @@ twasWeightsCv( fitRetention = c("none", "slim", "full"), seed = NULL, dataDrivenPriorMatricesCv = NULL, - reweightedMixturePriorCv = NULL, - fittedModelsCv = NULL + foldWeights = NULL ) } \arguments{ @@ -62,8 +61,11 @@ messages including those from external packages.} \item{fitRetention}{How much of each per-method fit is kept on the result: \code{"none"} (default) keeps none, \code{"slim"} keeps the trimmed payload downstream needs, \code{"full"} keeps the whole fitted object. -Only the mr.mash methods distinguish \code{"slim"} from \code{"full"}; -for every other method the two behave alike.} +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.} \item{seed}{Integer or \code{NULL}. When supplied, seeds both the main-process RNG (fold partitioning, variant sub-sampling) and the @@ -74,15 +76,17 @@ is scoped to the call, so the session RNG is left as it was found. \item{dataDrivenPriorMatricesCv}{Optional list, one element per fold, of data-driven prior matrices for the mr.mash learner.} -\item{reweightedMixturePriorCv}{Optional list, one element per fold, of -reweighted mixture priors for the mvSuSiE learner.} - -\item{fittedModelsCv}{Optional per-fold fine-mapping fits, as -\code{method -> fold_ -> fit}, from a \code{fineMappingPipeline()} -run with \code{cvFolds > 1}. SuSiE-family weight wrappers extract from a -supplied fit and never fine-map, so this is what makes cross-validating -them possible; it must have been produced on \code{samplePartitions}, -since a fit trained on different folds would leak held-out samples.} +\item{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.} } \value{ A list with the following components: @@ -121,8 +125,9 @@ data(multiTraitData) X <- multiTraitData$X[, 1:80] Y <- multiTraitData$Y # A cross-validated method is refit on each fold's training rows. The -# SuSiE family never fine-maps, so it needs each fold's own fit, passed -# as `fittedModelsCv` from a fineMappingPipeline() run with cvFolds > 1. +# 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())) } diff --git a/man/twasWeightsEntry.Rd b/man/twasWeightsEntry.Rd index aafdbef8c..cc41d431e 100644 --- a/man/twasWeightsEntry.Rd +++ b/man/twasWeightsEntry.Rd @@ -13,15 +13,18 @@ twasWeights(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) \item{x}{A \code{TwasWeights} object.} \item{studyName, context, trait, method}{Single character identifiers. All -required when the collection has more than one row; optional when the -collection has a single row.} +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}).} } \value{ -A \code{TwasWeightsRow} object. +A \code{TwasWeights} holding that one entry; read it with + \code{\link[=weights-methods]{weights}}, \code{\link{methodFits}} or + \code{\link{cvResult}}. } \description{ -Return the \code{TwasWeightsRow} for one \code{(study, - context, trait, method)} row of a \code{TwasWeights} collection. +Return one \code{(study, context, trait, method)} entry of a + \code{TwasWeights} collection: its gene's row, cut to that method. } \examples{ twe <- TwasWeightsRow( diff --git a/man/twasWeightsExample.Rd b/man/twasWeightsExample.Rd index 1b8d413ae..a7be35ecd 100644 --- a/man/twasWeightsExample.Rd +++ b/man/twasWeightsExample.Rd @@ -5,10 +5,10 @@ \alias{twasWeightsExample} \title{Example TWAS Weights (Multiple Methods)} \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}). +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}. } \description{ A \code{\link{TwasWeights}} collection holding per-variant TWAS diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index c0a348be1..bf193abf9 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -12,6 +12,7 @@ twasWeightsPipeline(data, ...) \S4method{twasWeightsPipeline}{QtlDataset}( data, methods = "default", + backend = NULL, contexts = NULL, traitId = NULL, region = NULL, @@ -38,6 +39,7 @@ twasWeightsPipeline(data, ...) \S4method{twasWeightsPipeline}{QtlSumStats}( data, methods = NULL, + backend = NULL, contexts = NULL, traitId = NULL, cisWindow = NULL, @@ -54,6 +56,7 @@ twasWeightsPipeline(data, ...) \S4method{twasWeightsPipeline}{MultiStudyQtlDataset}( data, methods = "default", + backend = NULL, contexts = NULL, traitId = NULL, region = NULL, @@ -93,6 +96,19 @@ 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}.} +\item{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.} + \item{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 @@ -163,14 +179,15 @@ so a row narrowed since its fit warns (condition class \code{pecotmrFitCoverage}).} \item{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.} \item{mashPrior}{Optional \code{\link{MashPrior}} (or coercible) supplying data-driven prior matrices for mr.mash weight methods; \code{NULL} to skip.} @@ -223,12 +240,22 @@ components fitted per context when \code{usePCA = TRUE} (default 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.} \item{residualizationParam}{Covariate residualization settings, built with \code{\link{ResidualizationParam}} and forwarded to @@ -275,9 +302,10 @@ built with above.} } \value{ -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. +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. } @@ -300,11 +328,16 @@ Method-restriction rules (enforced): (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 diff --git a/man/updateObject-methods.Rd b/man/updateObject-methods.Rd index ecda74c6a..e543da11d 100644 --- a/man/updateObject-methods.Rd +++ b/man/updateObject-methods.Rd @@ -1,27 +1,36 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/RangedTupleList.R, R/AllClasses.R, -% R/ColocBoostResult.R, R/CtwasResult.R, R/H2Estimate.R, R/LdStatistic.R, -% R/QtlDataset.R, R/MultiStudyQtlDataset.R, R/twasWeights.R -\name{updateObject-methods} +% Please edit documentation in R/LdMatrix.R, R/RangedTupleList.R, +% R/AllClasses.R, R/ColocResult.R, R/ColocBoostResult.R, R/CtwasResult.R, +% R/H2Estimate.R, R/LdStatistic.R, R/LdScore.R, R/QtlDataset.R, +% R/MultiStudyQtlDataset.R, R/twasWeights.R, R/twasWeightsRow.R +\name{updateObject,LdMatrix-method} +\alias{updateObject,LdMatrix-method} \alias{updateObject-methods} \alias{updateObject,RangedTupleList-method} \alias{updateObject,SumStatsBase-method} \alias{updateObject,FineMappingResultBase-method} +\alias{updateObject,ColocResult-method} \alias{updateObject,ColocBoostResult-method} \alias{updateObject,CtwasResult-method} \alias{updateObject,H2Estimate-method} \alias{updateObject,LdStatistic-method} +\alias{updateObject,LdScore-method} \alias{updateObject,QtlDataset-method} \alias{updateObject,MultiStudyQtlDataset-method} \alias{updateObject,TwasWeights-method} +\alias{updateObject,TwasWeightsRow-method} \title{Update an Object Saved by an Earlier pecotmr} \usage{ +\S4method{updateObject}{LdMatrix}(object, ..., verbose = FALSE) + \S4method{updateObject}{RangedTupleList}(object, ..., verbose = FALSE) \S4method{updateObject}{SumStatsBase}(object, ..., verbose = FALSE) \S4method{updateObject}{FineMappingResultBase}(object, ..., verbose = FALSE) +\S4method{updateObject}{ColocResult}(object, ..., verbose = FALSE) + \S4method{updateObject}{ColocBoostResult}(object, ..., verbose = FALSE) \S4method{updateObject}{CtwasResult}(object, ..., verbose = FALSE) @@ -30,11 +39,15 @@ \S4method{updateObject}{LdStatistic}(object, ..., verbose = FALSE) +\S4method{updateObject}{LdScore}(object, ..., verbose = FALSE) + \S4method{updateObject}{QtlDataset}(object, ..., verbose = FALSE) \S4method{updateObject}{MultiStudyQtlDataset}(object, ..., verbose = FALSE) \S4method{updateObject}{TwasWeights}(object, ..., verbose = FALSE) + +\S4method{updateObject}{TwasWeightsRow}(object, ..., verbose = FALSE) } \arguments{ \item{object}{A collection (summary statistics, fine-mapping results, TWAS @@ -83,11 +96,10 @@ Bring an object saved by an earlier version of pecotmr up to 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 @@ -102,9 +114,11 @@ Bring an object saved by an earlier version of pecotmr up to 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. } } \examples{ diff --git a/pixi.toml b/pixi.toml index b287e369d..37fa27950 100644 --- a/pixi.toml +++ b/pixi.toml @@ -14,7 +14,7 @@ codecov = "cd $GITHUB_WORKSPACE; R -e 'covr::codecov(quiet = FALSE)'" rcmdcheck = "cd $GITHUB_WORKSPACE; R -e 'rcmdcheck::rcmdcheck(error_on = \"error\", args = c(\"--no-manual\", \"--no-build-vignettes\"))'" bioccheck_git_clone = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheckGitClone(\"quit-with-status\" = TRUE)'" bioccheck = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheck(\"quit-with-status\" = FALSE)'" -goodpractice = "cd $GITHUB_WORKSPACE; R -e 'goodpractice::gp(\".\")'" +goodpractice = "cd $GITHUB_WORKSPACE; R -e 'goodpractice::gp(\".\", checks = stringr::str_subset(goodpractice::all_checks(), \"^(covr|rcmdcheck_)\", negate = TRUE))'" use_major_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"major\", push = FALSE)'" use_minor_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"minor\", push = FALSE)'" use_patch_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"patch\", push = FALSE)'" @@ -78,12 +78,14 @@ r45 = {features = ["r45"]} "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" = "*" diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 0a1cccba0..e516273b8 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -54,39 +54,53 @@ extern "C" SEXP _pecotmr_penalizedRssFactorCpp(SEXP zR, SEXP factorR, SEXP shrin return cpp11::as_sexp(penalizedRssFactorCpp(cpp11::as_cpp>(zR), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(shrink), cpp11::as_cpp>(lambdaR), cpp11::as_cpp>(penaltyStr), cpp11::as_cpp>(gamma), cpp11::as_cpp>(alpha), cpp11::as_cpp>(lambda0), cpp11::as_cpp>(lambda2), cpp11::as_cpp>(thr), cpp11::as_cpp>(maxiter), cpp11::as_cpp>(maxSwaps))); END_CPP11 } -// prscs_mcmc.cpp -cpp11::writable::list prsCsCpp(double a, double b, sexp phi, doubles bhat, sexp maf, int n, list ldBlk, int nIter, int nBurnin, int thin, bool verbose, sexp seed); -extern "C" SEXP _pecotmr_prsCsCpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEXP maf, SEXP n, SEXP ldBlk, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed) { +// qtl_enrichment.cpp +cpp11::writable::list qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, double piGwas, double piQtl, double totalVariants, int ImpN, double shrinkageLambda, bool doubleShrinkage, bool besselCorrection, int numThreads, cpp11::sexp seed); +extern "C" SEXP _pecotmr_qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, SEXP piGwas, SEXP piQtl, SEXP totalVariants, SEXP ImpN, SEXP shrinkageLambda, SEXP doubleShrinkage, SEXP besselCorrection, SEXP numThreads, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(prsCsCpp(cpp11::as_cpp>(a), cpp11::as_cpp>(b), cpp11::as_cpp>(phi), cpp11::as_cpp>(bhat), cpp11::as_cpp>(maf), cpp11::as_cpp>(n), cpp11::as_cpp>(ldBlk), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(qtlEnrichmentCpp(cpp11::as_cpp>(rGwasPip), cpp11::as_cpp>(rQtlSusieFit), cpp11::as_cpp>(piGwas), cpp11::as_cpp>(piQtl), cpp11::as_cpp>(totalVariants), cpp11::as_cpp>(ImpN), cpp11::as_cpp>(shrinkageLambda), cpp11::as_cpp>(doubleShrinkage), cpp11::as_cpp>(besselCorrection), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(seed))); END_CPP11 } -// prscs_mcmc.cpp -cpp11::writable::list prsCsFactorCpp(double a, double b, sexp phi, doubles bhat, sexp maf, int n, const doubles_matrix<>& factorR, int nIter, int nBurnin, int thin, bool verbose, sexp seed); -extern "C" SEXP _pecotmr_prsCsFactorCpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEXP maf, SEXP n, SEXP factorR, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed) { +// rss_mcmc.cpp +cpp11::writable::list prsCsCpp(double a, double b, sexp phi, doubles bhat, sexp maf, int n, list ldBlk, int nIter, int nBurnin, int thin, bool verbose, sexp seed, double shrinkCorr, bool raoBlackwell, bool track); +extern "C" SEXP _pecotmr_prsCsCpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEXP maf, SEXP n, SEXP ldBlk, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed, SEXP shrinkCorr, SEXP raoBlackwell, SEXP track) { BEGIN_CPP11 - return cpp11::as_sexp(prsCsFactorCpp(cpp11::as_cpp>(a), cpp11::as_cpp>(b), cpp11::as_cpp>(phi), cpp11::as_cpp>(bhat), cpp11::as_cpp>(maf), cpp11::as_cpp>(n), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(prsCsCpp(cpp11::as_cpp>(a), cpp11::as_cpp>(b), cpp11::as_cpp>(phi), cpp11::as_cpp>(bhat), cpp11::as_cpp>(maf), cpp11::as_cpp>(n), cpp11::as_cpp>(ldBlk), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed), cpp11::as_cpp>(shrinkCorr), cpp11::as_cpp>(raoBlackwell), cpp11::as_cpp>(track))); END_CPP11 } -// qtl_enrichment.cpp -cpp11::writable::list qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, double piGwas, double piQtl, double totalVariants, int ImpN, double shrinkageLambda, bool doubleShrinkage, bool besselCorrection, int numThreads, cpp11::sexp seed); -extern "C" SEXP _pecotmr_qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, SEXP piGwas, SEXP piQtl, SEXP totalVariants, SEXP ImpN, SEXP shrinkageLambda, SEXP doubleShrinkage, SEXP besselCorrection, SEXP numThreads, SEXP seed) { +// rss_mcmc.cpp +cpp11::writable::list prsCsFactorCpp(double a, double b, sexp phi, doubles bhat, sexp maf, int n, const doubles_matrix<>& factorR, int nIter, int nBurnin, int thin, bool verbose, sexp seed, double shrinkCorr, bool raoBlackwell, bool track); +extern "C" SEXP _pecotmr_prsCsFactorCpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEXP maf, SEXP n, SEXP factorR, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed, SEXP shrinkCorr, SEXP raoBlackwell, SEXP track) { BEGIN_CPP11 - return cpp11::as_sexp(qtlEnrichmentCpp(cpp11::as_cpp>(rGwasPip), cpp11::as_cpp>(rQtlSusieFit), cpp11::as_cpp>(piGwas), cpp11::as_cpp>(piQtl), cpp11::as_cpp>(totalVariants), cpp11::as_cpp>(ImpN), cpp11::as_cpp>(shrinkageLambda), cpp11::as_cpp>(doubleShrinkage), cpp11::as_cpp>(besselCorrection), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(prsCsFactorCpp(cpp11::as_cpp>(a), cpp11::as_cpp>(b), cpp11::as_cpp>(phi), cpp11::as_cpp>(bhat), cpp11::as_cpp>(maf), cpp11::as_cpp>(n), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed), cpp11::as_cpp>(shrinkCorr), cpp11::as_cpp>(raoBlackwell), cpp11::as_cpp>(track))); + END_CPP11 +} +// rss_mcmc.cpp +cpp11::writable::list sdprCpp(const doubles& bhatR, const list& LD, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int optLlk, bool verbose, sexp seed, bool raoBlackwell, bool track); +extern "C" SEXP _pecotmr_sdprCpp(SEXP bhatR, SEXP LD, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP optLlk, SEXP verbose, SEXP seed, SEXP raoBlackwell, SEXP track) { + BEGIN_CPP11 + return cpp11::as_sexp(sdprCpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp>(LD), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed), cpp11::as_cpp>(raoBlackwell), cpp11::as_cpp>(track))); + END_CPP11 +} +// rss_mcmc.cpp +cpp11::writable::list sdprFactorCpp(const doubles& bhatR, const doubles_matrix<>& factorR, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int optLlk, bool verbose, sexp seed, bool raoBlackwell, bool track); +extern "C" SEXP _pecotmr_sdprFactorCpp(SEXP bhatR, SEXP factorR, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP optLlk, SEXP verbose, SEXP seed, SEXP raoBlackwell, SEXP track) { + BEGIN_CPP11 + return cpp11::as_sexp(sdprFactorCpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed), cpp11::as_cpp>(raoBlackwell), cpp11::as_cpp>(track))); END_CPP11 } -// sdpr.cpp -cpp11::writable::list sdprCpp(const doubles& bhatR, const list& LD, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int numThreads, int optLlk, bool verbose, sexp seed); -extern "C" SEXP _pecotmr_sdprCpp(SEXP bhatR, SEXP LD, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP numThreads, SEXP optLlk, SEXP verbose, SEXP seed) { +// rss_mcmc.cpp +cpp11::writable::list bayesAlphabetFactorCpp(const doubles& bhat, const doubles_matrix<>& factorR, const doubles& weights, int n, std::string method, bool legarra, double pi, double h2, int nIter, int nBurnin, int thin, bool verbose, int seed, double shrinkCorr, bool allowJumpSign, bool raoBlackwell, bool track); +extern "C" SEXP _pecotmr_bayesAlphabetFactorCpp(SEXP bhat, SEXP factorR, SEXP weights, SEXP n, SEXP method, SEXP legarra, SEXP pi, SEXP h2, SEXP nIter, SEXP nBurnin, SEXP thin, SEXP verbose, SEXP seed, SEXP shrinkCorr, SEXP allowJumpSign, SEXP raoBlackwell, SEXP track) { BEGIN_CPP11 - return cpp11::as_sexp(sdprCpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp>(LD), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(bayesAlphabetFactorCpp(cpp11::as_cpp>(bhat), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(weights), cpp11::as_cpp>(n), cpp11::as_cpp>(method), cpp11::as_cpp>(legarra), cpp11::as_cpp>(pi), cpp11::as_cpp>(h2), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(thin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed), cpp11::as_cpp>(shrinkCorr), cpp11::as_cpp>(allowJumpSign), cpp11::as_cpp>(raoBlackwell), cpp11::as_cpp>(track))); END_CPP11 } -// sdpr.cpp -cpp11::writable::list sdprFactorCpp(const doubles& bhatR, const doubles_matrix<>& factorR, int n, sexp perVariantSampleSize, sexp array, double a, double c, int M, double a0k, double b0k, int iter, int burn, int thin, int numThreads, int optLlk, bool verbose, sexp seed); -extern "C" SEXP _pecotmr_sdprFactorCpp(SEXP bhatR, SEXP factorR, SEXP n, SEXP perVariantSampleSize, SEXP array, SEXP a, SEXP c, SEXP M, SEXP a0k, SEXP b0k, SEXP iter, SEXP burn, SEXP thin, SEXP numThreads, SEXP optLlk, SEXP verbose, SEXP seed) { +// rss_mcmc.cpp +cpp11::writable::list ldpred2FactorCpp(const doubles& bhat, const doubles_matrix<>& factorR, const doubles& n, bool automatic, double p, double h2, bool sparse, double shrinkCorr, bool allowJumpSign, double pLower, double pUpper, double meanLd, int nIter, int nBurnin, bool verbose, int seed); +extern "C" SEXP _pecotmr_ldpred2FactorCpp(SEXP bhat, SEXP factorR, SEXP n, SEXP automatic, SEXP p, SEXP h2, SEXP sparse, SEXP shrinkCorr, SEXP allowJumpSign, SEXP pLower, SEXP pUpper, SEXP meanLd, SEXP nIter, SEXP nBurnin, SEXP verbose, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(sdprFactorCpp(cpp11::as_cpp>(bhatR), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(n), cpp11::as_cpp>(perVariantSampleSize), cpp11::as_cpp>(array), cpp11::as_cpp>(a), cpp11::as_cpp>(c), cpp11::as_cpp>(M), cpp11::as_cpp>(a0k), cpp11::as_cpp>(b0k), cpp11::as_cpp>(iter), cpp11::as_cpp>(burn), cpp11::as_cpp>(thin), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(optLlk), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(ldpred2FactorCpp(cpp11::as_cpp>(bhat), cpp11::as_cpp&>>(factorR), cpp11::as_cpp>(n), cpp11::as_cpp>(automatic), cpp11::as_cpp>(p), cpp11::as_cpp>(h2), cpp11::as_cpp>(sparse), cpp11::as_cpp>(shrinkCorr), cpp11::as_cpp>(allowJumpSign), cpp11::as_cpp>(pLower), cpp11::as_cpp>(pUpper), cpp11::as_cpp>(meanLd), cpp11::as_cpp>(nIter), cpp11::as_cpp>(nBurnin), cpp11::as_cpp>(verbose), cpp11::as_cpp>(seed))); END_CPP11 } // vcf_gt.cpp @@ -99,18 +113,20 @@ extern "C" SEXP _pecotmr_vcfGtDosageCpp(SEXP gt, SEXP alleles) { extern "C" { static const R_CallMethodDef CallEntries[] = { + {"_pecotmr_bayesAlphabetFactorCpp", (DL_FUNC) &_pecotmr_bayesAlphabetFactorCpp, 17}, {"_pecotmr_bgenDosageCpp", (DL_FUNC) &_pecotmr_bgenDosageCpp, 3}, {"_pecotmr_bgenSampleIdsCpp", (DL_FUNC) &_pecotmr_bgenSampleIdsCpp, 2}, {"_pecotmr_dentistIterativeImpute", (DL_FUNC) &_pecotmr_dentistIterativeImpute, 12}, {"_pecotmr_dentistIterativeImputeFactor", (DL_FUNC) &_pecotmr_dentistIterativeImputeFactor, 12}, {"_pecotmr_ldThresholdComponents", (DL_FUNC) &_pecotmr_ldThresholdComponents, 3}, + {"_pecotmr_ldpred2FactorCpp", (DL_FUNC) &_pecotmr_ldpred2FactorCpp, 16}, {"_pecotmr_penalizedRssCpp", (DL_FUNC) &_pecotmr_penalizedRssCpp, 12}, {"_pecotmr_penalizedRssFactorCpp", (DL_FUNC) &_pecotmr_penalizedRssFactorCpp, 12}, - {"_pecotmr_prsCsCpp", (DL_FUNC) &_pecotmr_prsCsCpp, 12}, - {"_pecotmr_prsCsFactorCpp", (DL_FUNC) &_pecotmr_prsCsFactorCpp, 12}, + {"_pecotmr_prsCsCpp", (DL_FUNC) &_pecotmr_prsCsCpp, 15}, + {"_pecotmr_prsCsFactorCpp", (DL_FUNC) &_pecotmr_prsCsFactorCpp, 15}, {"_pecotmr_qtlEnrichmentCpp", (DL_FUNC) &_pecotmr_qtlEnrichmentCpp, 11}, - {"_pecotmr_sdprCpp", (DL_FUNC) &_pecotmr_sdprCpp, 17}, - {"_pecotmr_sdprFactorCpp", (DL_FUNC) &_pecotmr_sdprFactorCpp, 17}, + {"_pecotmr_sdprCpp", (DL_FUNC) &_pecotmr_sdprCpp, 18}, + {"_pecotmr_sdprFactorCpp", (DL_FUNC) &_pecotmr_sdprFactorCpp, 18}, {"_pecotmr_vcfGtDosageCpp", (DL_FUNC) &_pecotmr_vcfGtDosageCpp, 2}, {NULL, NULL, 0} }; diff --git a/src/dentist_iterative_impute.cpp b/src/dentist_iterative_impute.cpp index 71357c33d..87a7d2aa1 100644 --- a/src/dentist_iterative_impute.cpp +++ b/src/dentist_iterative_impute.cpp @@ -3,6 +3,10 @@ // // This code reproduces the original DENTIST binary's algorithm and logic, // using Armadillo (LAPACK) for eigendecomposition and GCTA-style LD computation. +// +// Derived from DENTIST (https://github.com/Yves-CHEN/DENTIST), (C) 2018 +// Wenhan Chen, Zhihong Zhu and Jian Yang, distributed under the GNU Lesser +// General Public License, version 3. See inst/COPYRIGHTS. #include #include #include diff --git a/src/function_pool.cpp b/src/function_pool.cpp deleted file mode 100644 index 86ddf99b7..000000000 --- a/src/function_pool.cpp +++ /dev/null @@ -1,60 +0,0 @@ - -#include "function_pool.h" -#include -/* based on -https://stackoverflow.com/a/51400041 - -https://stackoverflow.com/questions/23896421/efficiently-waiting-for-all-tasks-in-a-threadpool-to-finish -*/ - -Function_pool::Function_pool(unsigned int n) : m_function_queue(), m_lock(), m_data_condition(), busy(0), stop(false) { - for (size_t i=0; i lock(m_lock); - stop = true; - m_data_condition.notify_all(); - lock.unlock(); - for (size_t i=0; i func) { - std::unique_lock lock(m_lock); - m_function_queue.push(func); - lock.unlock(); - m_data_condition.notify_one(); -} - -void Function_pool::infinite_loop_func() { - std::function func; - while (true) { - std::unique_lock lock(m_lock); - m_data_condition.wait(lock, [this]() {return \ - !m_function_queue.empty() || stop; }); - if (!m_function_queue.empty()) { - busy++; - func = m_function_queue.front(); - m_function_queue.pop(); - lock.unlock(); - func(); - lock.lock(); - busy--; - lock.unlock(); - finished.notify_one(); - } - else if (stop) { - return; - } - } -} - -void Function_pool::waitFinished() { - std::unique_lock lock(m_lock); - finished.wait(lock, [this](){return m_function_queue.empty() && busy == 0; }); -} - diff --git a/src/function_pool.h b/src/function_pool.h deleted file mode 100644 index 3c4c84c34..000000000 --- a/src/function_pool.h +++ /dev/null @@ -1,26 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include - -class Function_pool { - private: - std::vector thread_pool; - std::queue> m_function_queue; - std::mutex m_lock; - std::condition_variable m_data_condition; - std::condition_variable finished; - std::atomic m_accept_functions; - int busy; - bool stop; - - public: - Function_pool(unsigned int n); - ~Function_pool(); - void push(std::function func); - void infinite_loop_func(); - void waitFinished(); -}; diff --git a/src/penalized_rss.cpp b/src/penalized_rss.cpp index 5bddb3e01..d6465cec9 100644 --- a/src/penalized_rss.cpp +++ b/src/penalized_rss.cpp @@ -5,6 +5,12 @@ // lassosum (Mak et al 2017) is its LASSO at alpha = 1: the same updates in the // same order, so the same coefficients bit for bit. // +// The LASSO updates follow lassosum's elnet() +// (https://github.com/tshmak/lassosum, Copyright (c) 2016 tshmak, MIT), and +// the L0 swap step is ported from L0Learn's CDL012Swaps.cpp +// (https://github.com/hazimehh/L0Learn, Copyright (c) 2021 Hussein Hazimeh, +// MIT). Their license notice is in inst/COPYRIGHTS. +// // Objective (smooth part): min_beta beta'R beta - 2 beta'z + penalty(beta) // where R is the LD matrix shrunk to R_s = (1 - s) R + s I (s = `shrink`; // 0 for an LD matrix already shrunk) and z = bhat / sqrt(n). diff --git a/src/prscs_mcmc.cpp b/src/prscs_mcmc.cpp deleted file mode 100644 index 7c6e6834f..000000000 --- a/src/prscs_mcmc.cpp +++ /dev/null @@ -1,111 +0,0 @@ -/** - * @file prscs_mcmc.cpp - * @brief cpp11 entry points for the PRS-CS sampler (prscs_mcmc.h). - */ - -#include -#include -#include -#include -#include "prscs_mcmc.h" - -using namespace cpp11; -using namespace arma; - -namespace { - -// Run the sampler on `ld_blk` with the arguments as R passes them: a NULL -// `maf` is a vector of zeros, a NULL `phi` is learned from the data, and a -// NULL `seed` draws one. -template -cpp11::writable::list prs_cs_run(double a, double b, sexp phi, doubles bhat, sexp maf, int n, - const std::vector& ld_blk, int nIter, int nBurnin, - int thin, bool verbose, sexp seed) { - std::vector bhat_vec = cpp11::as_cpp>(bhat); - std::vector maf_vec; - if (maf != R_NilValue) { - maf_vec = cpp11::as_cpp>(maf); - } else { - maf_vec = std::vector(bhat_vec.size(), 0.0); // Populate with zeros if maf is NULL - } - - // Use stack variable to avoid heap allocation and memory leak risk. - double phi_val = 0.0; - double* phi_ptr = nullptr; - if (phi != R_NilValue) { - phi_val = cpp11::as_cpp(phi); - phi_ptr = &phi_val; - } - - unsigned int seed_val = 0; - if (seed != R_NilValue) { - seed_val = cpp11::as_cpp(seed); - } else { - seed_val = std::random_device{}(); - } - - std::map output = prs_cs_mcmc(a, b, phi_ptr, bhat_vec, maf_vec, n, ld_blk, - nIter, nBurnin, thin, verbose, seed_val); - - using namespace cpp11::literals; - writable::list result({ - "betaEst"_nm = as_doubles(output["beta_est"]), - "psiEst"_nm = as_doubles(output["psi_est"]), - "sigmaEst"_nm = cpp11::as_sexp(output["sigma_est"](0)), - "phiEst"_nm = cpp11::as_sexp(output["phi_est"](0)) - }); - return result; -} - -} // namespace - -/** - * @brief PRS-CS from LD matrices. - * - * @param a Shape parameter for the prior distribution of psi. - * @param b Scale parameter for the prior distribution of psi. - * @param phi Global shrinkage parameter. If NULL, it will be estimated automatically. - * @param bhat Vector of effect sizes. - * @param maf Vector of minor allele frequencies. If NULL, it is assumed to be a vector of zeros. - * @param n Sample size. - * @param ldBlk List of LD blocks. - * @param nIter Number of MCMC iterations. - * @param nBurnin Number of burn-in iterations. - * @param thin Thinning interval. - * @param verbose Whether to print verbose output. - * @param seed Random seed. If NULL, no seed is set. - * @return A list containing the posterior estimates. - */ -[[cpp11::register]] -cpp11::writable::list prsCsCpp(double a, double b, sexp phi, - doubles bhat, sexp maf, - int n, list ldBlk, - int nIter, int nBurnin, int thin, - bool verbose, sexp seed) { - std::vector ld_blk_vec; - for (int i = 0; i < ldBlk.size(); ++i) { - ld_blk_vec.emplace_back(as_Mat(doubles_matrix<>(ldBlk[i]))); - } - return prs_cs_run(a, b, phi, bhat, maf, n, ld_blk_vec, nIter, nBurnin, thin, verbose, seed); -} - -/** - * @brief PRS-CS from a factor F of one LD block, R = F'F / (m - 1), never forming R. - * - * The arguments are prsCsCpp()'s with `factorR` in place of the LD blocks. The chain - * targets the same posterior as prsCsCpp() on R but draws differently (FactorLdBlock). - */ -[[cpp11::register]] -cpp11::writable::list prsCsFactorCpp(double a, double b, sexp phi, - doubles bhat, sexp maf, - int n, const doubles_matrix<>& factorR, - int nIter, int nBurnin, int thin, - bool verbose, sexp seed) { - mat F = as_Mat(factorR); - if (F.n_cols != static_cast(bhat.size())) - cpp11::stop("The LD factor has %d columns but there are %d effects.", - (int)F.n_cols, (int)bhat.size()); - std::vector ld_blk_vec; - ld_blk_vec.emplace_back(F / std::sqrt(static_cast(F.n_rows) - 1.0)); - return prs_cs_run(a, b, phi, bhat, maf, n, ld_blk_vec, nIter, nBurnin, thin, verbose, seed); -} diff --git a/src/prscs_mcmc.h b/src/prscs_mcmc.h deleted file mode 100644 index ae44b1e44..000000000 --- a/src/prscs_mcmc.h +++ /dev/null @@ -1,393 +0,0 @@ -/** - * @file mcmc.hpp - * @brief Markov Chain Monte Carlo (MCMC) sampler for polygenic prediction with continuous shrinkage (CS) priors. - */ - -#ifndef MCMC_HPP -#define MCMC_HPP - -#include -#include -#include -#include -#include -#include -#include - -/** - * @brief Evaluate the function psi(x, alpha, lambda). - * - * @param x Input value. - * @param alpha Shape parameter. - * @param lambda Scale parameter. - * @return Value of psi(x, alpha, lambda). - */ -double fpsi(double x, double alpha, double lambda) { - double f = -alpha * (std::cosh(x) - 1.0) - lambda * (std::exp(x) - x - 1.0); - return f; -} - -/** - * @brief Evaluate the derivative of fpsi(x, alpha, lambda). - * - * @param x Input value. - * @param alpha Shape parameter. - * @param lambda Scale parameter. - * @return Value of fdpsi(x, alpha, lambda). - */ -double fdpsi(double x, double alpha, double lambda) { - double f = -alpha * std::sinh(x) - lambda * (std::exp(x) - 1.0); - return f; -} - -/** - * @brief Evaluate the function g(x, sd, td, f1, f2). - * - * @param x Input value. - * @param sd Parameter sd. - * @param td Parameter td. - * @param f1 Parameter f1. - * @param f2 Parameter f2. - * @return Value of g(x, sd, td, f1, f2). - */ -double g(double x, double sd, double td, double f1, double f2) { - if (x >= -sd && x <= td) { - return 1.0; - } else if (x > td) { - return f1; - } else { - return f2; - } -} - -/** - * @brief Generate random variates from the generalized inverse Gaussian distribution. - * - * @param p Shape parameter. - * @param a Scale parameter. - * @param b Scale parameter. - * @return Random variate from the generalized inverse Gaussian distribution. - */ -double gigrnd(double p, double a, double b, std::mt19937& rng) { - double lambda = p; - double omega = std::sqrt(a * b); - bool swap = false; - if (lambda < 0) { - lambda = -lambda; - swap = true; - } - - double alpha = std::sqrt(std::pow(omega, 2) + std::pow(lambda, 2)) - lambda; - -// find t - double x = -fpsi(1.0, alpha, lambda); - double t; - if (x >= 0.5 && x <= 2.0) { - t = 1.0; - } else if (x > 2.0) { - if (alpha == 0 && lambda == 0) { - t = 1.0; - } else { - t = std::sqrt(2.0 / (alpha + lambda)); - } - } else if (x < 0.5) { - if (alpha == 0 && lambda == 0) { - t = 1.0; - } else { - t = std::log(4.0 / (alpha + 2.0 * lambda)); - } - } - -// find s - x = -fpsi(-1.0, alpha, lambda); - double s; - if (x >= 0.5 && x <= 2.0) { - s = 1.0; - } else if (x > 2.0) { - if (alpha == 0 && lambda == 0) { - s = 1.0; - } else { - s = std::sqrt(4.0 / (alpha * std::cosh(1.0) + lambda)); - } - } else if (x < 0.5) { - if (alpha == 0 && lambda == 0) { - s = 1.0; - } else if (alpha == 0) { - s = 1.0 / lambda; - } else if (lambda == 0) { - s = std::log(1.0 + 1.0 / alpha + std::sqrt(1.0 / std::pow(alpha, 2) + 2.0 / alpha)); - } else { - s = std::min(1.0 / lambda, std::log(1.0 + 1.0 / alpha + std::sqrt(1.0 / std::pow(alpha, 2) + 2.0 / alpha))); - } - } - - double eta = -fpsi(t, alpha, lambda); - double zeta = -fdpsi(t, alpha, lambda); - double theta = -fpsi(-s, alpha, lambda); - double xi = fdpsi(-s, alpha, lambda); - - double p_r = 1.0 / xi; - double r = 1.0 / zeta; - - double td = t - r * eta; - double sd = s - p_r * theta; - double q = td + sd; - - std::uniform_real_distribution unif_dist(0.0, 1.0); - double rnd = 0.0; - while (true) { - double U = unif_dist(rng); - double V = unif_dist(rng); - double W = unif_dist(rng); - - if (U < q / (p_r + q + r)) { - rnd = -sd + q * V; - } else if (U < (q + r) / (p_r + q + r)) { - rnd = td - r * std::log(V); - } else { - rnd = -sd + p_r * std::log(V); - } - - double f1 = std::exp(-eta - zeta * (rnd - t)); - double f2 = std::exp(-theta + xi * (rnd + s)); - - if (W * g(rnd, sd, td, f1, f2) <= std::exp(fpsi(rnd, alpha, lambda))) { - break; - } - } - - rnd = std::exp(rnd) * (lambda / omega + std::sqrt(1.0 + std::pow(lambda / omega, 2))); - - if (swap) { - rnd = 1.0 / rnd; - } - - double result = rnd / std::sqrt(a / b); - - // Guard against exact zero (can happen with extreme parameters) - if (result == 0.0) { - result = std::numeric_limits::min(); - } - - return result; -} - -/** - * @brief One LD block's update of beta in the PRS-CS sampler, from the block's LD matrix R. - * - * Draws beta ~ N(A^-1 b, (sigma / n) A^-1) with A = R + diag(1 / psi) and b the block's - * marginal effects, through the Cholesky factor of A, and returns beta'A beta for the - * update of sigma. - */ -class DenseLdBlock { -public: - explicit DenseLdBlock(arma::mat R) : R_(std::move(R)) {} - - arma::uword size() const { return R_.n_rows; } - - double draw(const arma::vec& psi, const arma::vec& b, double scale, - std::normal_distribution& normal_dist, std::mt19937& rng, - arma::vec& beta) const { - arma::mat dinvt = R_ + arma::diagmat(1.0 / psi); - arma::mat dinvt_chol = arma::chol(dinvt); - arma::vec beta_tmp = arma::solve(arma::trimatl(dinvt_chol.t()), b) + - arma::vec(R_.n_rows).transform([&](double) { - return normal_dist(rng); - }) * std::sqrt(scale); - beta = arma::solve(arma::trimatu(dinvt_chol), beta_tmp); - return arma::as_scalar(beta.t() * dinvt * beta); - } - -private: - arma::mat R_; -}; - -/** - * @brief One LD block's update of beta in the PRS-CS sampler, from a factor W of the - * block's LD, R = W'W (W is m x p). - * - * The same draw as DenseLdBlock without forming R or A. With D = diag(psi) and - * M = W D W' + I (m x m), Woodbury gives A^-1 = D - D W' M^-1 W D, so the mean A^-1 b - * costs one solve against M, and the noise comes from the sampler of Bhattacharya, - * Chakraborty and Mallick (2016): u ~ N(0, D), delta ~ N(0, I), v = W u + delta, - * theta = u - D W' M^-1 v is N(0, A^-1). One Cholesky factor of M serves both, at - * O(m^2 p + m^3) per draw instead of the O(p^3) of factoring A. The draws consume the - * random stream differently from DenseLdBlock's, so the two samplers agree in - * distribution, not draw for draw. - */ -class FactorLdBlock { -public: - explicit FactorLdBlock(arma::mat W) : W_(std::move(W)) {} - - arma::uword size() const { return W_.n_cols; } - - double draw(const arma::vec& psi, const arma::vec& b, double scale, - std::normal_distribution& normal_dist, std::mt19937& rng, - arma::vec& beta) const { - arma::uword p = W_.n_cols; - arma::uword m = W_.n_rows; - arma::mat WD = W_.each_row() % psi.t(); - arma::mat M = WD * W_.t(); - M.diag() += 1.0; - arma::mat L = arma::chol(M, "lower"); - arma::vec mean = psi % b - WD.t() * solveChol(L, WD * b); - arma::vec u = arma::sqrt(psi) % arma::vec(p).transform([&](double) { - return normal_dist(rng); - }); - arma::vec delta = arma::vec(m).transform([&](double) { return normal_dist(rng); }); - arma::vec theta = u - WD.t() * solveChol(L, W_ * u + delta); - beta = mean + std::sqrt(scale) * theta; - arma::vec Wbeta = W_ * beta; - return arma::dot(Wbeta, Wbeta) + arma::sum(arma::square(beta) / psi); - } - -private: - arma::mat W_; - - // M^-1 x from the lower Cholesky factor L of M. - static arma::vec solveChol(const arma::mat& L, const arma::vec& x) { - return arma::solve(arma::trimatu(L.t()), arma::solve(arma::trimatl(L), x)); - } -}; - -/** - * @brief Markov Chain Monte Carlo (MCMC) sampler for polygenic prediction with continuous shrinkage (CS) priors. - * - * @param a Shape parameter for the prior distribution of psi. - * @param b Scale parameter for the prior distribution of psi. - * @param phi Global shrinkage parameter. If nullptr, it will be estimated automatically. - * @param bhat Vector of effect sizes. - * @param maf Vector of minor allele frequencies. - * @param n Sample size. - * @param ld_blk The LD blocks, each a DenseLdBlock or each a FactorLdBlock. - * @param n_iter Number of MCMC iterations. - * @param n_burnin Number of burn-in iterations. - * @param thin Thinning interval. - * @param verbose Whether to print verbose output. - * @param seed Random seed. If nullptr, no seed is set. - * @return A map containing the posterior estimates. - */ -template -std::map prs_cs_mcmc(double a, double b, double* phi, - const std::vector& bhat, const std::vector& maf, - int n, const std::vector& ld_blk, - int n_iter, int n_burnin, int thin, - bool verbose, unsigned int seed) { - if (verbose) { - Rprintf("Running Markov Chain Monte Carlo (MCMC) sampler...\n"); - } - - // Derived statistics - arma::vec beta_mrg(bhat); - int n_pst = (n_iter - n_burnin) / thin; - int p = beta_mrg.n_elem; - - // Initialization - std::mt19937 rng(seed); - std::normal_distribution normal_dist(0.0, 1.0); - std::gamma_distribution gamma_dist_sigma((n + p) / 2.0, 1.0); - - arma::vec beta(p, arma::fill::zeros); - arma::vec psi(p, arma::fill::ones); - double sigma = 1.0; - // Use stack variable to avoid heap allocation and potential memory leak. - // If phi is NULL (learn from data), use phi_local on the stack and point - // phi to it. If phi is provided, phi_local is unused. - double phi_local = 1.0; - bool phi_updt = (phi == nullptr); - if (phi_updt) { - phi = &phi_local; - } - - arma::vec beta_est(p, arma::fill::zeros); - arma::vec psi_est(p, arma::fill::zeros); - double sigma_est = 0.0; - double phi_est = 0.0; - - // MCMC - for (int itr = 1; itr <= n_iter; ++itr) { - if (verbose && itr % 100 == 0) { - Rprintf("Iteration %4d of %d\n", itr, n_iter); - } - - int mm = 0; - double quad = 0.0; - for (std::size_t kk = 0; kk < ld_blk.size(); ++kk) { - if (ld_blk[kk].size() == 0) { - continue; - } - - arma::uvec idx_blk = arma::regspace(mm, mm + ld_blk[kk].size() - 1); - mm += ld_blk[kk].size(); - - arma::vec beta_blk; - quad += ld_blk[kk].draw(psi.elem(idx_blk), beta_mrg(idx_blk), sigma / n, - normal_dist, rng, beta_blk); - beta(idx_blk) = beta_blk; - } - double err = std::max(n / 2.0 * (1.0 - 2.0 * arma::dot(beta, beta_mrg) + quad), - n / 2.0 * arma::sum(arma::pow(beta, 2) / psi)); - - // Original PRS-CS (Ge et al.): sigma = 1/Gamma((n+p)/2, scale=1/err) - // = InvGamma((n+p)/2, rate=err), i.e. mean = err/((n+p)/2-1). - // gamma_dist_sigma samples X ~ Gamma((n+p)/2, scale=1), so - // sigma = err/X gives the correct InvGamma(a, rate=err). - sigma = err / gamma_dist_sigma(rng); - - arma::vec delta = arma::vec(p); - for (int jj = 0; jj < p; ++jj) { - std::gamma_distribution gamma_dist_delta(a + b, 1.0 / (psi(jj) + *phi)); - delta(jj) = gamma_dist_delta(rng); - } - - // std::cout << "sigma " << sigma << std::endl; - // std::cout << "delta " << delta << std::endl; - for (int jj = 0; jj < p; ++jj) { - psi(jj) = gigrnd(a - 0.5, 2.0 * delta(jj), n * std::pow(beta(jj), 2) / sigma, rng); - } - // Clamp psi to [0, 1] — matches original PRS-CS (Ge et al.): - // psi[psi>1] = 1.0 (prevents explosive local shrinkage) - psi = arma::clamp(psi, 0.0, 1.0); - - if (phi_updt) { - std::gamma_distribution gamma_dist_phi(1.0, 1.0 / (*phi + 1.0)); - double w = gamma_dist_phi(rng); - std::gamma_distribution gamma_dist_phi_new(p * b + 0.5, 1.0 / (arma::sum(delta) + w)); - *phi = gamma_dist_phi_new(rng); - } - - // Posterior - if (itr > n_burnin && (itr % thin == 0)) { - beta_est += beta / n_pst; - psi_est += psi / n_pst; - sigma_est += sigma / n_pst; - phi_est += *phi / n_pst; - } - } - - // No delete needed — phi_local is on the stack. - - // Convert standardized beta to per-allele beta only if not all maf are zeros - arma::vec maf_vec(maf); - if (arma::max(maf_vec) > 0) { - beta_est /= arma::sqrt(2.0 * maf_vec % (1.0 - maf_vec)); - } - // Prepare the output map - std::map output; - output["beta_est"] = beta_est; - output["psi_est"] = psi_est; - output["sigma_est"] = arma::vec(1).fill(sigma_est); - output["phi_est"] = arma::vec(1).fill(phi_est); - - // Print estimated phi - if (verbose && phi_updt) { - Rprintf("Estimated global shrinkage parameter: %g\n", phi_est); - } - - if (verbose) { - Rprintf("MCMC sampling completed.\n"); - } - - return output; -} -#endif // MCMC_HPP diff --git a/src/qtl_enrichment.cpp b/src/qtl_enrichment.cpp index 303d89ebb..b58a85eb4 100644 --- a/src/qtl_enrichment.cpp +++ b/src/qtl_enrichment.cpp @@ -1,3 +1,10 @@ +// qtl_enrichment.cpp -- cpp11 entry point for the QTL enrichment estimate +// (qtl_enrichment.h). +// +// Adapted from fastenloc (https://github.com/xqwen/fastenloc), Copyright (C) +// Xiaoquan Wen, distributed under the GNU General Public License, version 3 +// or (at your option) any later version. See inst/COPYRIGHTS. + #include "qtl_enrichment.h" // `rGwasPip` holds the GWAS PIP values; `rQtlSusieFit` is a list of fits, each diff --git a/src/qtl_enrichment.h b/src/qtl_enrichment.h index 3abb9920f..9cc1481ad 100644 --- a/src/qtl_enrichment.h +++ b/src/qtl_enrichment.h @@ -1,3 +1,10 @@ +// qtl_enrichment.h -- QTL enrichment in GWAS signals, estimated by EM over +// causal variants imputed from the QTL SuSiE fits. +// +// Adapted from fastenloc (https://github.com/xqwen/fastenloc), Copyright (C) +// Xiaoquan Wen, distributed under the GNU General Public License, version 3 +// or (at your option) any later version. See inst/COPYRIGHTS. + #ifndef QTL_ENRICHMENT_HPP #define QTL_ENRICHMENT_HPP #include diff --git a/src/rss_mcmc.cpp b/src/rss_mcmc.cpp new file mode 100644 index 000000000..5cb333fb7 --- /dev/null +++ b/src/rss_mcmc.cpp @@ -0,0 +1,1138 @@ +// rss_mcmc.cpp -- SDPR's likelihood and chain, and the cpp11 entry points of +// every summary-statistics sampler in rss_mcmc.h. +// +// Derived from PRS-CS, SDPR, qgg, hibayes and bigsnpr, each under its own +// license; rss_mcmc.h lists what each part comes from, and inst/COPYRIGHTS +// has the notices. + +#include +#include +#include +#include +#include +#include +#include +#include +#include "rss_mcmc.h" + +// ==== SDPR: likelihood and chain ================================================ + +// SDPR's likelihood and chain. The "Original:" notes point to SDPR's +// mcmc.cpp. The original used GSL and x86 SSE intrinsics. Here GSL's BLAS +// and Cholesky calls are Armadillo products, solves and chol(), its random +// variates are 's (and beta_distribution, a ratio of gammas), and +// the SSE log/exp of sample_assignment() are Armadillo's vectorized float +// log/exp. The sampler reads each LD block through the shared block types: +// the dense matrices SDPR itself precomputes (sdpr_dense_blocks()) or their +// low-rank form from a factor of the LD (sdpr_factor_block()). The original +// ran each block's assignment step on a thread pool sharing one random +// number generator; the blocks run in turn here, as the original does with +// one thread. + +namespace { + +inline double square(double x) { return x * x; } + +// The precision of eta's prior, N(1, 1 / eta_prior_precision) (sample_eta()). +constexpr double eta_prior_precision = 1.0; + +// The sampler's state over `blocks`. +template +class SdprChain { +public: + SdprChain(const std::vector> &blocks, size_t M, + double a0k, double b0k, unsigned int seed, + const ChainOptions &opts, double gap0); + + // Original: mcmc.cpp lines 434-513, one iteration of the main loop. + void sweep() { + sample_sigma2(); + for (size_t j = 0; j < blocks_.size(); j++) { + calc_b(j); + } + for (size_t j = 0; j < blocks_.size(); j++) { + sample_assignment(j); + } + update_suffstats(); + sample_V(); + update_p(); + sample_alpha(); + eta_beta = eta; + for (size_t j = 0; j < blocks_.size(); j++) { + sample_beta(j); + } + sample_eta(); + } + + // The reported effects are eta beta, and the heritability eta^2 beta'R beta. + // Rao-Blackwellized, an effect is the conditional mean of beta given the + // rest of the state when it was drawn, times eta at that time. + void keep(int n_kept) { + if (check_divergence(est_, opts_, eta * beta, gap0_)) { + return; + } + compute_h2(); + est_.h2 += h2 * square(eta) / n_kept; + keep_effects(est_, opts_, eta * beta, eta_beta * beta_mean, n_kept); + if (opts_.track) { + for (size_t j = 0; j < blocks_.size(); j++) { + arma::span blk = layout_.span(j); + est_.corr(blk) += blocks_[j].R.times(eta * beta(blk)) / n_kept; + } + } + } + + void report(int itr, int /* n_iter */) { + compute_h2(); + Rprintf("%d iter. h2: %g max beta: %g\n", + itr, h2 * square(eta), arma::max(beta) * eta); + } + + bool stopped() const { return est_.diverged; } + + const SdprEstimates &estimates() const { return est_; } + +private: + const std::vector> &blocks_; + BlockLayout layout_; + size_t M, n_snp; + double a0k; + double b0k; + std::mt19937 r; + + double alpha; + double eta; + double h2; + double N; + arma::vec beta; + arma::vec b; + std::vector cls_assgn; + std::vector V; + std::vector p; + std::vector log_p; + std::vector cluster_var; + std::vector suff_stats; + std::vector sumsq; + // Each block's terms of the eta update, from sample_beta(). + std::vector num; + std::vector denom; + ChainOptions opts_; + double gap0_; + arma::vec beta_mean; // the conditional means of beta, for Rao-Blackwell + double eta_beta = 1.0; // eta when beta was drawn + SdprEstimates est_; + + void sample_sigma2(); + void calc_b(size_t j); + void sample_assignment(size_t j); + void update_suffstats(); + void sample_V(); + void update_p(); + void sample_alpha(); + void sample_beta(size_t j); + void compute_h2(); + void sample_eta(); +}; + +template +SdprChain::SdprChain(const std::vector> &blocks, + size_t M, double a0k, double b0k, + unsigned int seed, const ChainOptions &opts, + double gap0) + : blocks_(blocks), layout_(block_sizes(blocks)), M(M), a0k(a0k), + b0k(b0k), r(seed), opts_(opts), gap0_(gap0) { + n_snp = 0; + for (size_t j = 0; j < layout_.n_blocks(); j++) { + n_snp += layout_.size(j); + } + // N (sz) is absorbed into A and B (SDPR, May 20 2021), so it is 1. + N = 1.0; + alpha = 1; + eta = 1; + h2 = 0; + beta = arma::vec(n_snp, arma::fill::zeros); + b = arma::vec(n_snp, arma::fill::zeros); + p.assign(M, 1.0 / M); + log_p.assign(M, 0); + for (size_t i = 0; i < M; i++) { + log_p[i] = std::log(static_cast(p[i] + 1e-40)); + } + + cluster_var.assign(M, 0.0); + suff_stats.assign(M, 0); + sumsq.assign(M, 0.0); + V.assign(M, 0.0); + num.assign(blocks.size(), 0.0); + denom.assign(blocks.size(), 0.0); + // Every variant starts in the null component (k = 0). The original + // started from a uniform draw over 0..M-1, which makes nearly every + // variant causal, so the first sample_beta() factors a matrix the size + // of the block; starting from null lets the sampler find the causal + // assignments. + cls_assgn.assign(n_snp, 0); + est_.beta = arma::vec(n_snp, arma::fill::zeros); + est_.corr = arma::vec(n_snp, arma::fill::zeros); + beta_mean = arma::vec(n_snp, arma::fill::zeros); + update_suffstats(); +} + +// --------------------------------------------------------------------------- +// sample_sigma2: Sample cluster variances from inverse-gamma posterior +// var_k ~ InvGamma(suff_stats[k]/2 + a0k, sumsq[k]/2 + b0k) +// Original: mcmc.cpp lines 25-40 +// --------------------------------------------------------------------------- +template +void SdprChain::sample_sigma2() { + std::gamma_distribution dist; + for (size_t i = 1; i < M; i++) { + double a = suff_stats[i] / 2.0 + a0k; + double b = 1.0 / (sumsq[i] / 2.0 + b0k); + dist = std::gamma_distribution(a, b); + cluster_var[i] = 1.0 / dist(r); + if (std::isinf(cluster_var[i])) { + cluster_var[i] = 1e5; + REprintf("Cluster variance is infinite.\n"); + } + else if (cluster_var[i] == 0) { + cluster_var[i] = 1e-10; + REprintf("Cluster variance is zero.\n"); + } + } +} + +// --------------------------------------------------------------------------- +// calc_b: Compute the b vector for block j +// b_j = eta^2 * (diag(B)*beta - B*beta) + eta * A^T * beta_mrg +// Original: mcmc.cpp lines 42-62 +// --------------------------------------------------------------------------- +template +void SdprChain::calc_b(size_t j) { + const SdprBlock &blk = blocks_[j]; + arma::vec beta_j = beta(layout_.span(j)); + b(layout_.span(j)) = eta * eta * (blk.B.diag() % beta_j - blk.B.times(beta_j)) + + eta * blk.calc_b_tmp; +} + +// --------------------------------------------------------------------------- +// sample_assignment: Sample cluster assignments for each SNP in block j +// For each SNP i, compute log P(z_i = k) for k = 0..M-1, then sample. +// +// Original: mcmc.cpp lines 64-165, which vectorized log/exp over the M +// clusters with SSE intrinsics in single precision; Armadillo's float +// vectors do the same. +// +// Math for cluster k >= 1: +// C_k = eta^2 * N * B[i,i] * var_k + 1 +// log P(z_i=k) = -0.5*log(C_k) + log(p_k) + (N*b_i)^2 * var_k / (2*C_k) +// --------------------------------------------------------------------------- +template +void SdprChain::sample_assignment(size_t j) { + size_t start_i = layout_.start(j); + size_t n_snp_blk = layout_.size(j); + const arma::vec &diag_B = blocks_[j].B.diag(); + + std::uniform_real_distribution unif(0.0f, 1.0f); + + // N = 1.0 after May 21 2021 (absorbed into A, B in solve_ldmat) + float C = static_cast(eta * eta * N); + + arma::fvec cvar(M); + arma::fvec log_p_fvec(M); + for (size_t k = 0; k < M; k++) { + cvar(k) = static_cast(cluster_var[k]); + log_p_fvec(k) = static_cast(log_p[k]); + } + + for (size_t i = 0; i < n_snp_blk; i++) { + float Bjj_i = static_cast(diag_B(i)); + float bj_i = static_cast(b(start_i + i)); + float rnd_i = unif(r); + + arma::fvec prob(M); + prob(0) = log_p_fvec(0); + + arma::fvec Ck = C * Bjj_i * cvar.subvec(1, M - 1) + 1.0f; + + prob.subvec(1, M - 1) = -0.5f * arma::log(Ck) + log_p_fvec.subvec(1, M - 1) + + square(N * bj_i) * cvar.subvec(1, M - 1) / (2.0f * Ck); + + // Log-sum-exp for numerical stability + float max_elem = prob.max(); + float log_exp_sum = max_elem + + std::log(arma::accu(arma::exp(prob - max_elem))); + + // Categorical sampling via inverse CDF + // Original: mcmc.cpp lines 155-163 + cls_assgn[i + start_i] = M - 1; + for (size_t k = 0; k < M - 1; k++) { + rnd_i -= std::exp(prob(k) - log_exp_sum); + if (rnd_i < 0) { + cls_assgn[i + start_i] = k; + break; + } + } + } +} + +// --------------------------------------------------------------------------- +// update_suffstats: Count SNPs per cluster and sum of squared effects +// Original: mcmc.cpp lines 167-175 +// --------------------------------------------------------------------------- +template +void SdprChain::update_suffstats() { + std::fill(suff_stats.begin(), suff_stats.end(), 0); + std::fill(sumsq.begin(), sumsq.end(), 0.0); + for (size_t i = 0; i < n_snp; i++) { + suff_stats[cls_assgn[i]]++; + double tmp = beta(i); + sumsq[cls_assgn[i]] += square(tmp); + } +} + +// --------------------------------------------------------------------------- +// sample_V: Sample stick-breaking fractions from Beta posterior +// V[k] ~ Beta(1 + suff_stats[k], alpha + sum_{k'>k} suff_stats[k']) +// Original: mcmc.cpp lines 177-189 +// --------------------------------------------------------------------------- +template +void SdprChain::sample_V() { + std::vector a(M - 1); + a[M - 2] = suff_stats[M - 1]; + for (int i = static_cast(M) - 3; i >= 0; i--) { + a[i] = suff_stats[i + 1] + a[i + 1]; + } + + for (size_t i = 0; i < M - 1; i++) { + beta_distribution dist(1 + suff_stats[i], alpha + a[i]); + V[i] = dist(r); + } + V[M - 1] = 1; +} + +// --------------------------------------------------------------------------- +// update_p: Convert stick-breaking fractions V to cluster probabilities p +// p[0] = V[0]; p[k] = V[k] * prod_{j +void SdprChain::update_p() { + std::vector cumprod(M - 1); + cumprod[0] = 1 - V[0]; + for (size_t i = 1; i < M - 1; i++) { + cumprod[i] = cumprod[i - 1] * (1 - V[i]); + if (V[i] == 1) { + std::fill(cumprod.begin() + i + 1, cumprod.end(), 0.0); + break; + } + } + + p[0] = V[0]; + for (size_t i = 1; i < M - 1; i++) { + p[i] = cumprod[i - 1] * V[i]; + } + + double sum = std::accumulate(p.begin(), p.end() - 1, 0.0); + p[M - 1] = (1 - sum > 0) ? (1 - sum) : 0; + + for (size_t i = 0; i < M; i++) { + log_p[i] = std::log(static_cast(p[i]) + 1e-40f); + } +} + +// --------------------------------------------------------------------------- +// sample_alpha: Sample Dirichlet process concentration parameter +// alpha ~ Gamma(0.1 + m - 1, 1/(0.1 - sum(log(1-V)))) +// Original: mcmc.cpp lines 224-237 +// --------------------------------------------------------------------------- +template +void SdprChain::sample_alpha() { + double sum = 0, m = 0; + for (size_t i = 0; i < M; i++) { + if (V[i] != 1) { + sum += std::log(1 - V[i]); + m++; + } + } + if (m == 0) m = 1; + + std::gamma_distribution dist(0.1 + m - 1, 1.0 / (0.1 - sum)); + alpha = dist(r); +} + +// --------------------------------------------------------------------------- +// sample_beta: Sample effect sizes for causal SNPs in block j +// Precision = eta^2*N*B_gamma + Sigma_0^{-1}, mean Precision^-1 A_vec, +// with A_vec = N*eta*A^T*beta_mrg over the causal SNPs (gaussian_draw()). +// The block's other effects are zero, so eta's terms are +// num = N beta'A^T beta_mrg and denom = N beta'B beta. +// +// Original: mcmc.cpp lines 239-329. The original drew a lone causal SNP in +// closed form from its b_j instead, which carries the residuals of the +// previous effects of SNPs no longer causal, and took num = b_j beta_j, +// which is eta times the num above; sample_eta() then centres eta near +// eta^2, so on windows with one causal SNP eta, and with it the effects and +// h2, ran away. A lone causal SNP takes the joint draw here, which draws +// from the same random stream. +// --------------------------------------------------------------------------- +template +void SdprChain::sample_beta(size_t j) { + const SdprBlock &blk = blocks_[j]; + size_t start_i = layout_.start(j); + size_t end_i = start_i + layout_.size(j); + + // Build causal list (SNPs not in null cluster) + std::vector causal_list; + for (size_t i = start_i; i < end_i; i++) { + if (cls_assgn[i] != 0) { + causal_list.push_back(i); + } + } + + // Zero out this block's betas + beta(layout_.span(j)).zeros(); + beta_mean(layout_.span(j)).zeros(); + + if (causal_list.empty()) { + num[j] = 0; + denom[j] = 0; + return; + } + + size_t nc = causal_list.size(); + arma::uvec causal_idx(nc); + arma::vec var_c(nc); + for (size_t i = 0; i < nc; i++) { + causal_idx(i) = causal_list[i] - start_i; + var_c(i) = cluster_var[cls_assgn[causal_list[i]]]; + } + + // Original: mcmc.cpp lines 273-289 + double C_coeff = square(eta) * N; + arma::vec A_vec = N * eta * blk.calc_b_tmp(causal_idx); + arma::mat B_gamma = C_coeff * blk.B.sub(causal_idx); + B_gamma.diag() += 1.0 / var_c; + + std::normal_distribution dist(0.0, 1.0); + arma::vec z = standard_normals(nc, dist, r); + arma::vec mean_c; + arma::vec beta_c = opts_.rao_blackwell ? gaussian_draw(B_gamma, A_vec, z, 1.0, mean_c) + : gaussian_draw(B_gamma, A_vec, z); + + // Compute eta-related terms for sample_eta(): B_gamma's diagonal back to + // eta^2 * N * B[i,i], without 1/var_k. + // Original: mcmc.cpp lines 312-321 + B_gamma.diag() = C_coeff * blk.B.diag()(causal_idx); + num[j] = arma::dot(A_vec, beta_c) / eta; + arma::vec tmp = B_gamma * beta_c; + denom[j] = arma::dot(beta_c, tmp) / square(eta); + + for (size_t i = 0; i < nc; i++) { + beta(causal_list[i]) = beta_c(i); + if (opts_.rao_blackwell) { + beta_mean(causal_list[i]) = mean_c(i); + } + } +} + +// --------------------------------------------------------------------------- +// compute_h2: Compute heritability h2 = sum_j beta_j^T * R_j * beta_j +// Original: mcmc.cpp lines 331-343 +// --------------------------------------------------------------------------- +template +void SdprChain::compute_h2() { + h2 = 0; + for (size_t j = 0; j < blocks_.size(); j++) { + arma::vec beta_j = beta(layout_.span(j)); + h2 += blocks_[j].R.quad(beta_j); + } +} + +// --------------------------------------------------------------------------- +// sample_eta: Sample global scaling parameter +// With the prior eta ~ N(1, 1 / eta_prior_precision), +// eta ~ N((num_sum + prec) / (denom_sum + prec), 1 / (denom_sum + prec)). +// Original: mcmc.cpp lines 345-352, which had no prior on eta beyond the +// guard denom_sum += 1e-6, in effect N(0, 1e6). With no causal SNP, num and +// denom vanish and eta was drawn from that prior: an |eta| in the hundreds +// makes every SNP's inclusion unlikely, so a window could stay null for +// good. +// --------------------------------------------------------------------------- +template +void SdprChain::sample_eta() { + double num_sum = std::accumulate(num.begin(), num.end(), 0.0); + double denom_sum = std::accumulate(denom.begin(), denom.end(), 0.0); + double precision = denom_sum + eta_prior_precision; + + std::normal_distribution dist( + (num_sum + eta_prior_precision) / precision, + std::sqrt(1.0 / precision)); + eta = dist(r); +} + +// --------------------------------------------------------------------------- +// sdpr_llk2_matrix: The optLlk = 2 matrix B2 from one block's LD +// Each pair's LD is scaled by min(N_i, N_j) / (1.1 * N_i * N_j) and zeroed +// between arrays 1 and 2; the diagonal is then set to 1 / N_i, raised by +// 1.1 times the scaled matrix's most negative eigenvalue, if any, to keep +// B2 positive definite. +// +// Original: mcmc.cpp lines 368-402 +// --------------------------------------------------------------------------- +arma::mat sdpr_llk2_matrix(arma::mat B, const SdprData &dat, size_t start) { + size_t blk_size = B.n_rows; + for (size_t j = 0; j < blk_size; j++) { + for (size_t k = 0; k < blk_size; k++) { + size_t idx1 = j + start; + size_t idx2 = k + start; + if ((dat.array[idx1] == 1 && dat.array[idx2] == 2) || + (dat.array[idx1] == 2 && dat.array[idx2] == 1)) { + B(j, k) = 0; + } else { + B(j, k) *= std::min(dat.sz[idx1], dat.sz[idx2]) + / (1.1 * dat.sz[idx1] * dat.sz[idx2]); + } + } + } + + // Force positive definite via eigenvalue correction. Only the smallest + // eigenvalue is read, so no eigenvectors are computed. + double eval_min = arma::eig_sym(B).min(); + + // Restore exact symmetry before the diagonal is reset + B = arma::symmatu(B); + + // Add to diagonal to ensure PD + for (size_t j = 0; j < blk_size; j++) { + double diag_val = 1.0 / dat.sz[j + start]; + if (eval_min < 0) diag_val -= 1.1 * eval_min; + B(j, j) = diag_val; + } + return B; +} + +// --------------------------------------------------------------------------- +// sdpr_factor_root: R = Z Z' for the factor F (m x p) of R = F'F / (m - 1) +// Z (p x r) has orthogonal columns with Z'Z = diag(lambda), lambda the +// nonzero eigenvalues of R, from the eigendecomposition of the smaller of +// G G' and G'G (G = F / sqrt(m - 1)). Eigenvalues at the rounding level of +// that decomposition are dropped. +// --------------------------------------------------------------------------- +arma::mat sdpr_factor_root(const arma::mat &F) { + arma::mat G = F / std::sqrt(static_cast(F.n_rows) - 1.0); + bool wide = G.n_rows <= G.n_cols; + arma::mat gram = wide ? arma::mat(G * G.t()) : arma::mat(G.t() * G); + arma::vec lam; + arma::mat Q; + arma::eig_sym(lam, Q, gram); + double tol = lam.is_empty() ? 0.0 + : lam.max() * gram.n_rows * arma::datum::eps; + arma::uvec keep = arma::find(lam > tol); + if (wide) { + return G.t() * Q.cols(keep); + } + return Q.cols(keep) * arma::diagmat(arma::sqrt(lam(keep))); +} + +// --------------------------------------------------------------------------- +// sdpr_llk2_solve: B2^{-1} rhs for the block R = Z Z', with B2 as +// sdpr_llk2_matrix() builds it, without forming B2 while it has a narrow +// low-rank part +// B2 = T - diag(T) + D0 with T = R .* S .* Mask, D0 = diag(1 / N) + fix. +// S_ij = 1 / (1.1 max(N_i, N_j)) is a sum over the K distinct sample sizes +// n_1 < ... < n_K, +// S = sum_l Delta_l 1_l 1_l' / 1.1, 1_l = [N_i <= n_l], +// Delta_l = 1 / n_l - 1 / n_(l+1) (1 / n_K for l = K), +// so R .* S = U_S U_S' with U_S = [sqrt(Delta_l / 1.1) diag(1_l) Z]_l. +// The array mask keeps the pairs within arrays {0, 1} and within {0, 2}, +// which counts the pairs within array 0 twice, so T = U Sigma U' with +// U = [P01 U_S, P02 U_S, P0 U_S] and Sigma = diag(I, I, -I). +// While U is narrower than p, T is singular, its most negative eigenvalue +// is that of the small (U'U)^(1/2) Sigma (U'U)^(1/2), and the Woodbury +// identity solves B2 = U Sigma U' + D through an inner matrix as wide as U. +// Otherwise B2 is formed exactly as the dense route forms it. +// --------------------------------------------------------------------------- +arma::mat sdpr_llk2_solve(const SdprData &dat, const arma::mat &Z, + const arma::mat &rhs) { + size_t p = Z.n_rows; + size_t r = Z.n_cols; + arma::vec sz(dat.sz); + arma::ivec arr = arma::conv_to::from(dat.array); + arma::vec levels = arma::unique(sz); + size_t K = levels.n_elem; + bool masked = arma::any(arr == 1) && arma::any(arr == 2); + size_t width = (masked ? 3 : 1) * K * r; + + if (width >= p) { + arma::mat L_chol = arma::chol(sdpr_llk2_matrix(Z * Z.t(), dat, 0), + "lower"); + arma::mat Y = arma::solve(arma::trimatl(L_chol), rhs); + return arma::solve(arma::trimatu(L_chol.t()), Y); + } + + arma::mat U_S(p, K * r); + for (size_t l = 0; l < K; l++) { + double next = (l + 1 < K) ? 1.0 / levels(l + 1) : 0.0; + double delta = 1.0 / levels(l) - next; + arma::vec in_l = arma::conv_to::from(sz <= levels(l)); + U_S.cols(l * r, (l + 1) * r - 1) = + std::sqrt(delta / 1.1) * (Z.each_col() % in_l); + } + + arma::mat U = U_S; + arma::vec sigma(width, arma::fill::ones); + // Unmasked, T = U_S U_S' is positive semidefinite (and singular), so its + // smallest eigenvalue is 0 and B2 needs no fix. + double eval_min = 0.0; + if (masked) { + arma::vec p01 = arma::conv_to::from(arr != 2); + arma::vec p02 = arma::conv_to::from(arr != 1); + arma::vec p0 = arma::conv_to::from(arr == 0); + U = arma::join_rows(U_S.each_col() % p01, U_S.each_col() % p02, + U_S.each_col() % p0); + sigma.tail(K * r).fill(-1.0); + arma::vec omega; + arma::mat P; + arma::eig_sym(omega, P, U.t() * U); + arma::mat root = P + * arma::diagmat(arma::sqrt(arma::clamp(omega, 0.0, + arma::datum::inf))) + * P.t(); + arma::vec small = arma::eig_sym(root * arma::diagmat(sigma) * root); + eval_min = std::min(0.0, small.min()); + } + + // D: 1 / N_i in place of T's own diagonal R_ii / (1.1 N_i), plus the fix. + arma::vec d = 1.0 / sz - arma::sum(arma::square(Z), 1) / (1.1 * sz); + if (eval_min < 0) d -= 1.1 * eval_min; + + arma::mat UD = U.each_col() / d; + arma::mat D_rhs = rhs.each_col() / d; + arma::mat inner = arma::diagmat(sigma) + U.t() * UD; + return D_rhs - UD * arma::solve(inner, U.t() * D_rhs); +} + +} // namespace + +// --------------------------------------------------------------------------- +// sdpr_dense_blocks: Precompute LD-derived matrices B and A' beta_mrg for +// each block +// opt_llk=1: B0 = R + aI; A = B0^{-1} R * sz; B = R * A +// opt_llk=2: B0 = sdpr_llk2_matrix(R); A = B0^{-1} R; B = R * A +// +// Original: mcmc.cpp lines 354-431 (solve_ldmat). The original also kept A +// and R .* R per block, which nothing reads after this, so neither is kept +// here. +// --------------------------------------------------------------------------- +std::vector> sdpr_dense_blocks(const SdprData &dat, + std::vector ref_ld_mat, + double a, unsigned sz, + int opt_llk) { + std::vector> blocks; + size_t start = 0; + for (size_t i = 0; i < ref_ld_mat.size(); i++) { + const arma::mat &R = ref_ld_mat[i]; + size_t blk_size = R.n_rows; + + arma::mat B0; + if (opt_llk == 1) { + // B0 = R + a*I (diagonal shrinkage) + B0 = R; + B0.diag() += a; + } else { + B0 = sdpr_llk2_matrix(R, dat, start); + } + + // A = B0^{-1} * R via forward then back-solve on B0 = L L' + arma::mat L_chol = arma::chol(B0, "lower"); + arma::mat A = arma::solve(arma::trimatl(L_chol), R); + A = arma::solve(arma::trimatu(L_chol.t()), A); + + // Scale by sample size for opt_llk=1 + if (opt_llk == 1) { + A *= sz; + } + + arma::vec beta_mrg(blk_size); + for (size_t j = 0; j < blk_size; j++) { + beta_mrg(j) = dat.beta_mrg[j + start]; + } + + // B = R * A. The sampler reads it as symmetric (the original through + // dsymv), so it is symmetrized once here rather than on every product. + blocks.push_back(SdprBlock{ + DenseLdBlock(arma::symmatu(R * A)), + DenseLdBlock(arma::symmatu(R)), + A.t() * beta_mrg + }); + start += blk_size; + } + return blocks; +} + +// --------------------------------------------------------------------------- +// sdpr_factor_block: The one block's B and A' beta_mrg from a factor of R +// With R = Z Z' = V diag(lambda) V': +// opt_llk=1: A = n (R + aI)^{-1} R = n V diag(lambda / (lambda + a)) V' and +// B = R A = W W', W = sqrt(n) V diag(lambda / sqrt(lambda + a)). +// opt_llk=2: A = B2^{-1} R and B = R A = Z H Z', H = Z' B2^{-1} Z (r x r), +// so W = Z H^(1/2) and B2^{-1} is needed only on Z and beta_mrg. +// B and R are held through their factors W' and Z'. +// --------------------------------------------------------------------------- +SdprBlock sdpr_factor_block(const SdprData &dat, const arma::mat &F, + double a, unsigned sz, int opt_llk) { + arma::mat Z = sdpr_factor_root(F); + size_t p = Z.n_rows; + size_t r = Z.n_cols; + arma::vec beta_mrg(dat.beta_mrg); + + arma::mat W; + arma::vec calc_b_tmp; + if (r == 0) { + // No LD at all (every variant monomorphic): B and A vanish. + W.zeros(p, 0); + calc_b_tmp.zeros(p); + } else if (opt_llk == 1) { + double n = static_cast(sz); + arma::vec lam = arma::sum(arma::square(Z), 0).t(); + arma::mat V = Z.each_row() / arma::sqrt(lam).t(); + W = std::sqrt(n) * (V.each_row() % (lam / arma::sqrt(lam + a)).t()); + calc_b_tmp = n * (V * ((lam / (lam + a)) % (V.t() * beta_mrg))); + } else { + arma::mat Y = sdpr_llk2_solve(dat, Z, arma::join_rows(Z, beta_mrg)); + arma::mat H = Z.t() * Y.head_cols(r); + H = 0.5 * (H + H.t()); + arma::vec h; + arma::mat Q; + arma::eig_sym(h, Q, H); + W = Z * Q + * arma::diagmat(arma::sqrt(arma::clamp(h, 0.0, arma::datum::inf))); + calc_b_tmp = Z * (Z.t() * Y.col(r)); + } + return SdprBlock{ + FactorLdBlock(W.t()), FactorLdBlock(Z.t()), calc_b_tmp + }; +} + +template +SdprEstimates sdpr_mcmc(const std::vector> &blocks, size_t M, + double a0k, double b0k, const ChainSchedule &schedule, + bool verbose, unsigned int seed, const ChainOptions &opts, + double gap0) { + SdprChain chain(blocks, M, a0k, b0k, seed, opts, gap0); + run_chain(chain, schedule, verbose); + const SdprEstimates &est = chain.estimates(); + if (verbose) { + Rprintf("h2: %g max: %g\n", est.h2, arma::max(est.beta)); + } + return est; +} + +template SdprEstimates sdpr_mcmc( + const std::vector> &, size_t, double, double, + const ChainSchedule &, bool, unsigned int, const ChainOptions &, double); +template SdprEstimates sdpr_mcmc( + const std::vector> &, size_t, double, double, + const ChainSchedule &, bool, unsigned int, const ChainOptions &, double); + +// ==== Entry points ============================================================== + +using namespace cpp11; +using namespace arma; + +namespace { + +// The seed R passes, or one drawn for NULL. +unsigned int seed_from(sexp seed) { + if (seed != R_NilValue) { + return cpp11::as_cpp(seed); + } + return std::random_device{}(); +} + +ChainOptions chain_options(bool raoBlackwell, bool track) { + ChainOptions opts; + opts.rao_blackwell = raoBlackwell; + opts.track = track; + return opts; +} + +// A factor of the LD as R passes it, refused unless it has a column per +// effect. +mat checked_factor(const doubles_matrix<>& factorR, R_xlen_t n_effects) { + mat F = as_Mat(factorR); + if (F.n_cols != static_cast(n_effects)) { + cpp11::stop("The LD factor has %d columns but there are %d effects.", + (int)F.n_cols, (int)n_effects); + } + return F; +} + +// What a chain reports to R: its effects, the sampler's own estimates +// (`own`, each a named field), and the fitted correlations and divergence +// every chain tracks. +template +writable::list chain_report(const ChainEstimates& est, Fields... own) { + using namespace cpp11::literals; + return writable::list({ + "betaEst"_nm = as_doubles(est.beta), + own..., + "corrEst"_nm = as_doubles(est.corr), + "diverged"_nm = cpp11::as_sexp(est.diverged) + }); +} + +} // namespace + +// ==== PRS-CS ==================================================================== + +namespace { + +// Run the sampler on `blocks` with the arguments as R passes them: a NULL +// `maf` is a vector of zeros, a NULL `phi` is learned from the data, and a +// NULL `seed` draws one. +template +cpp11::writable::list prs_cs_run(double a, double b, sexp phi, doubles bhat, sexp maf, int n, + const std::vector& blocks, int nIter, int nBurnin, + int thin, bool verbose, sexp seed, + const ChainOptions& opts) { + vec beta_mrg = as_Col(bhat); + vec maf_vec = maf == R_NilValue ? vec(beta_mrg.n_elem, fill::zeros) + : as_Col(doubles(maf)); + bool learn_phi = phi == R_NilValue; + double phi_val = learn_phi ? 0.0 : cpp11::as_cpp(phi); + ChainSchedule schedule(nIter, nBurnin, thin); + PrsCsEstimates est = prs_cs_mcmc(a, b, learn_phi, phi_val, beta_mrg, maf_vec, n, + blocks, schedule, verbose, seed_from(seed), opts); + using namespace cpp11::literals; + return chain_report(est, "psiEst"_nm = as_doubles(est.psi), + "sigmaEst"_nm = cpp11::as_sexp(est.sigma), + "phiEst"_nm = cpp11::as_sexp(est.phi)); +} + +} // namespace + +/** + * @brief PRS-CS from LD matrices. + * + * @param a Shape parameter for the prior distribution of psi. + * @param b Scale parameter for the prior distribution of psi. + * @param phi Global shrinkage parameter. If NULL, it will be estimated automatically. + * @param bhat Vector of effect sizes. + * @param maf Vector of minor allele frequencies. If NULL, it is assumed to be a vector of zeros. + * @param n Sample size. + * @param ldBlk List of LD blocks. + * @param nIter Number of MCMC iterations. + * @param nBurnin Number of burn-in iterations. + * @param thin Thinning interval. + * @param verbose Whether to print verbose output. + * @param seed Random seed. If NULL, one is drawn. + * @param shrinkCorr The LD shrinkage c: the sampler reads c R + (1 - c) I. + * @param raoBlackwell Report the blocks' conditional means rather than the + * draws' average. + * @param track Stop a diverging chain and report the mean fitted + * correlations, for combining several chains. + * @return A list containing the posterior estimates. + */ +[[cpp11::register]] +cpp11::writable::list prsCsCpp(double a, double b, sexp phi, + doubles bhat, sexp maf, + int n, list ldBlk, + int nIter, int nBurnin, int thin, + bool verbose, sexp seed, double shrinkCorr, + bool raoBlackwell, bool track) { + std::vector blocks; + for (int i = 0; i < ldBlk.size(); ++i) { + mat S = as_Mat(doubles_matrix<>(ldBlk[i])); + if (shrinkCorr != 1.0) { + S *= shrinkCorr; + S.diag() += 1.0 - shrinkCorr; + } + blocks.emplace_back(S); + } + return prs_cs_run(a, b, phi, bhat, maf, n, blocks, nIter, nBurnin, thin, verbose, seed, + chain_options(raoBlackwell, track)); +} + +/** + * @brief PRS-CS from a factor F of one LD block, R = F'F / (m - 1), never forming R. + * + * The arguments are prsCsCpp()'s with `factorR` in place of the LD blocks. The chain + * targets the same posterior as prsCsCpp() on R but draws differently (FactorLdBlock). + */ +[[cpp11::register]] +cpp11::writable::list prsCsFactorCpp(double a, double b, sexp phi, + doubles bhat, sexp maf, + int n, const doubles_matrix<>& factorR, + int nIter, int nBurnin, int thin, + bool verbose, sexp seed, double shrinkCorr, + bool raoBlackwell, bool track) { + mat F = checked_factor(factorR, bhat.size()); + mat W = F / std::sqrt(static_cast(F.n_rows) - 1.0); + // c R + (1 - c) I: the factor of c R, and the ridge 1 - c. + if (shrinkCorr != 1.0) { + W *= std::sqrt(shrinkCorr); + } + std::vector blocks; + blocks.emplace_back(W, 1.0 - shrinkCorr); + return prs_cs_run(a, b, phi, bhat, maf, n, blocks, nIter, nBurnin, thin, verbose, seed, + chain_options(raoBlackwell, track)); +} + +// ==== SDPR ====================================================================== + +namespace { + +// The per-variant data as R passes it: the marginal betas deflated by `c`, a +// NULL perVariantSampleSize is n for every variant, and a NULL array is +// array 1 for every variant. +SdprData sdpr_data(const doubles& bhatR, int n, sexp perVariantSampleSize, sexp array, + double c) { + SdprData dat; + dat.beta_mrg = cpp11::as_cpp>(bhatR); + // Deflation correction + for (size_t i = 0; i < dat.beta_mrg.size(); i++) { + dat.beta_mrg[i] /= c; + } + if (perVariantSampleSize != R_NilValue) { + dat.sz = cpp11::as_cpp>(perVariantSampleSize); + } else { + dat.sz = std::vector(dat.beta_mrg.size(), n); + } + if (array != R_NilValue) { + dat.array = cpp11::as_cpp>(array); + } else { + dat.array = std::vector(dat.beta_mrg.size(), 1); + } + return dat; +} + +cpp11::writable::list sdpr_output(const SdprEstimates& est) { + using namespace cpp11::literals; + return chain_report(est, "h2"_nm = cpp11::as_sexp(est.h2)); +} + +} // namespace + +// cpp11 interface function +[[cpp11::register]] +cpp11::writable::list sdprCpp( + const doubles& bhatR, + const list& LD, + int n, + sexp perVariantSampleSize = R_NilValue, + sexp array = R_NilValue, + double a = 0.1, + double c = 1.0, + int M = 1000, + double a0k = 0.5, + double b0k = 0.5, + int iter = 1000, + int burn = 200, + int thin = 5, + int optLlk = 1, + bool verbose = true, + sexp seed = R_NilValue, + bool raoBlackwell = false, + bool track = false + ) { + ChainSchedule schedule(iter, burn, thin); + std::vector ref_ld_mat; + for (int i = 0; i < LD.size(); i++) { + ref_ld_mat.push_back(as_Mat(doubles_matrix<>(LD[i]))); + } + + SdprData data = sdpr_data(bhatR, n, perVariantSampleSize, array, c); + std::vector> blocks = + sdpr_dense_blocks(data, std::move(ref_ld_mat), a, n, optLlk); + return sdpr_output(sdpr_mcmc(blocks, M, a0k, b0k, schedule, verbose, seed_from(seed), + chain_options(raoBlackwell, track), + divergence_gap(as_Col(bhatR)))); +} + +/** + * @brief SDPR from a factor F of the LD, R = F'F / (m - 1), never forming R. + * + * The arguments are sdprCpp()'s with `factorR` (m x p) in place of the LD + * blocks; the window is one block. The sampler is SDPR's own, run on the + * low-rank form of its matrices (sdpr_factor_block()), so it draws as + * sdprCpp() does on the matrix the factor gives. + */ +[[cpp11::register]] +cpp11::writable::list sdprFactorCpp( + const doubles& bhatR, + const doubles_matrix<>& factorR, + int n, + sexp perVariantSampleSize = R_NilValue, + sexp array = R_NilValue, + double a = 0.1, + double c = 1.0, + int M = 1000, + double a0k = 0.5, + double b0k = 0.5, + int iter = 1000, + int burn = 200, + int thin = 5, + int optLlk = 1, + bool verbose = true, + sexp seed = R_NilValue, + bool raoBlackwell = false, + bool track = false + ) { + ChainSchedule schedule(iter, burn, thin); + mat F = checked_factor(factorR, bhatR.size()); + + SdprData data = sdpr_data(bhatR, n, perVariantSampleSize, array, c); + std::vector> blocks = { + sdpr_factor_block(data, F, a, n, optLlk) + }; + return sdpr_output(sdpr_mcmc(blocks, M, a0k, b0k, schedule, verbose, seed_from(seed), + chain_options(raoBlackwell, track), + divergence_gap(as_Col(bhatR)))); +} + +// ==== The Bayesian alphabet ===================================================== + +namespace { + +template +cpp11::writable::list alphabet_run(Chain& chain, const ChainSchedule& schedule, + bool verbose) { + run_chain(chain, schedule, verbose); + const AlphabetEstimates& est = chain.estimates(); + using namespace cpp11::literals; + return chain_report(est, "pip"_nm = as_doubles(est.pip), + "pi"_nm = cpp11::as_sexp(est.pi), + "residualVariance"_nm = cpp11::as_sexp(est.ve)); +} + +// qgg's family of priors for every method but bayesB and Park and Casella's +// bayesL. +QggFormChain::Method qgg_method(const std::string& method) { + if (method == "bayesN") return QggFormChain::N; + if (method == "bayesA") return QggFormChain::A; + if (method == "bayesL") return QggFormChain::L; + if (method == "bayesC") return QggFormChain::C; + if (method == "bayesR") return QggFormChain::R; + cpp11::stop("Unknown Bayesian alphabet method '%s'.", method.c_str()); +} + +} // namespace + +/** + * @brief The Bayesian alphabet's posterior means from a factor F of the LD, + * R = F'F / (k - 1), never forming R. + * + * @param bhat The standardized marginal effects. + * @param factorR The factor F (k x p). + * @param weights The per-variant weights w: X'X = W^1/2 R W^1/2 and + * X'y = w % bhat. + * @param n The sample size. + * @param method "bayesA", "bayesB", "bayesC", "bayesL", "bayesN" or "bayesR". + * @param legarra For bayesL, Legarra et al.'s form (qgg's) rather than Park + * and Casella's (hibayes'). + * @param pi For bayesB and bayesC, the starting proportion of non-null + * effects. + * @param h2 The prior guess of the heritability that sets the starting + * variances. + * @param nIter The chain's iterations, burn-in included. + * @param nBurnin The burn-in. + * @param thin The thinning interval. + * @param verbose Whether to report progress. + * @param seed Seed of the sampler's random number generator. + * @param shrinkCorr The LD shrinkage c: X'X = W^1/2 (c R + (1 - c) I) W^1/2. + * @param allowJumpSign Keep a drawn effect whose sign differs from the + * current one, rather than setting it to zero. + * @param raoBlackwell Report the effects' conditional means rather than the + * draws' average. + * @param track Stop a diverging chain and report the mean fitted + * correlations, for combining several chains. + */ +[[cpp11::register]] +cpp11::writable::list bayesAlphabetFactorCpp( + const doubles& bhat, const doubles_matrix<>& factorR, const doubles& weights, + int n, std::string method, bool legarra, double pi, double h2, + int nIter, int nBurnin, int thin, bool verbose, int seed, + double shrinkCorr, bool allowJumpSign, bool raoBlackwell, bool track) { + ChainSchedule schedule(nIter, nBurnin, thin); + mat F = checked_factor(factorR, bhat.size()); + AlphabetData data; + data.w = as_Col(weights); + data.bhat = as_Col(bhat); + data.Fw = F.each_row() % arma::sqrt(data.w).t(); + data.wy = data.w % data.bhat; + data.n = n; + data.shrink = shrinkCorr; + data.allow_jump_sign = allowJumpSign; + data.opts.rao_blackwell = raoBlackwell; + data.opts.track = track; + unsigned int s = static_cast(seed); + if (method == "bayesB" || (method == "bayesL" && !legarra)) { + HibayesFormChain chain(data, + method == "bayesB" ? HibayesFormChain::B : HibayesFormChain::L, + pi, h2, s); + return alphabet_run(chain, schedule, verbose); + } + QggFormChain chain(data, qgg_method(method), pi, h2, s); + return alphabet_run(chain, schedule, verbose); +} + +// ==== LDpred2 =================================================================== + +/** + * @brief One LDpred2 chain from a factor F of the LD, R = F'F / (k - 1), + * never forming R. + * + * @param bhat The standardized marginal effects. + * @param factorR The factor F (k x p). + * @param n The per-variant sample sizes. + * @param automatic LDpred2-auto rather than LDpred2-grid. + * @param p The proportion of causal variants: fixed for the grid, the + * starting value for auto. + * @param h2 The heritability: fixed for the grid, the starting value for + * auto. + * @param sparse For the grid, set an effect to zero when its inclusion + * probability falls below p. + * @param shrinkCorr The LD shrinkage c in R_s = c R + (1 - c) I. + * @param allowJumpSign Keep a drawn effect whose sign differs from the + * current one, rather than setting it to zero. + * @param pLower,pUpper For auto, the bounds on p. + * @param meanLd For auto, the mean LD score that divides the counts of p's + * Beta full conditional. + * @param nIter The chain's iterations, burn-in included. + * @param nBurnin The burn-in. + * @param verbose Whether to report progress. + * @param seed Seed of the sampler's random number generator. + */ +[[cpp11::register]] +cpp11::writable::list ldpred2FactorCpp( + const doubles& bhat, const doubles_matrix<>& factorR, const doubles& n, + bool automatic, double p, double h2, bool sparse, double shrinkCorr, + bool allowJumpSign, double pLower, double pUpper, double meanLd, + int nIter, int nBurnin, bool verbose, int seed) { + ChainSchedule schedule(nIter, nBurnin, 1); + mat F = checked_factor(factorR, bhat.size()); + vec b = as_Col(bhat); + vec nv = as_Col(n); + if (nv.n_elem != b.n_elem) { + cpp11::stop("There are %d sample sizes but %d effects.", (int)nv.n_elem, + (int)b.n_elem); + } + Ldpred2Settings settings; + settings.automatic = automatic; + settings.p = p; + settings.h2 = h2; + settings.sparse = sparse; + settings.shrink = shrinkCorr; + settings.allow_jump_sign = allowJumpSign; + settings.p_lower = pLower; + settings.p_upper = pUpper; + settings.mean_ld = meanLd; + Ldpred2Chain chain(F, b, nv, settings, static_cast(seed)); + run_chain(chain, schedule, verbose); + const Ldpred2Estimates& est = chain.estimates(); + using namespace cpp11::literals; + return chain_report( + est, "postp"_nm = as_doubles(est.postp), + "pathP"_nm = writable::doubles(est.path_p.begin(), est.path_p.end()), + "pathH2"_nm = writable::doubles(est.path_h2.begin(), est.path_h2.end())); +} diff --git a/src/rss_mcmc.h b/src/rss_mcmc.h new file mode 100644 index 000000000..a00664e88 --- /dev/null +++ b/src/rss_mcmc.h @@ -0,0 +1,1449 @@ +// rss_mcmc.h -- the summary-statistics samplers: what they share, and each +// prior on it. +// +// The samplers draw the effects beta of a window's variants from their +// posterior under the RSS likelihood of the marginal effects, +// bhat ~ N(R beta, R / n), each with its own prior. What does not depend on +// the prior comes first, so a prior is one Gibbs sweep and what a kept draw +// adds to the posterior means: +// * run_chain() runs the sweeps, keeps the draws past the burn-in at the +// thinning interval, reports progress, lets the user interrupt and ends +// a chain that has stopped; +// * ChainOptions are what every sampler can do beyond its prior: +// Rao-Blackwellized means, and tracking for combining several chains; +// * ChainEstimates are what every chain reports, which keep_effects() +// and check_divergence() update; ChainRandom is the generator of the +// single-site samplers; +// * BlockLayout places the variants in contiguous LD blocks; +// * DenseLdBlock and FactorLdBlock hold a block's matrix S -- the LD R, or +// a matrix a likelihood derives from it -- whole or as a factor W with +// S = W'W, and answer what the samplers ask of it: its diagonal, +// products, quadratic forms, principal submatrices and the joint +// Gaussian draw of the block's effects; +// * gaussian_draw() draws from a Gaussian given its precision, and +// standard_normals(), gigrnd(), rinvgauss(), dirichlet_plus_one() and +// beta_distribution add the variates lacks. +// Then the priors, each a chain on the above: +// * PRS-CS's continuous shrinkage prior (PrsCsChain); +// * SDPR's Dirichlet process prior (SdprData and SdprBlock here; its +// chain is in rss_mcmc.cpp); +// * the Bayesian alphabet in qgg's and hibayes' forms, on a factor of the +// LD (QggFormChain, HibayesFormChain); +// * LDpred2's point-normal prior, on a factor of the LD (Ldpred2Chain). +// rss_mcmc.cpp has every sampler's cpp11 entry points. +// +// Derived from these projects, each under its own license (the notices are +// in inst/COPYRIGHTS): +// * PRS-CS (https://github.com/getian107/PRScs), Copyright (c) 2018 Tian +// Ge, distributed under the MIT License: PrsCsChain, gigrnd(), and +// DenseLdBlock::draw(), which follows PRS-CS's draw of a block's +// effects; +// * SDPR (https://github.com/eldronzhou/SDPR), Copyright (C) the SDPR +// authors (Geyu Zhou and Hongyu Zhao), distributed under the GNU General +// Public License, version 3: the SDPR section, and gaussian_draw(), +// which follows the joint draw of SDPR's sample_beta(); +// * qgg (https://github.com/psoerensen/qgg) and hibayes +// (https://github.com/YinLiLin/hibayes), both distributed under the GNU +// General Public License, version 3: the Bayesian alphabet section; +// * bigsnpr (https://github.com/privefl/bigsnpr), Copyright (c) Florian +// Prive, distributed under the GNU General Public License, version 3: +// the LDpred2 section, from its ldpred2.cpp and ldpred2-auto.cpp. +#pragma once + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "rss_ld.h" + +// ==== Shared ==================================================================== + +// ---- Random variates -------------------------------------------------------- + +// n standard normal draws from `normal`, in order. +inline arma::vec standard_normals(arma::uword n, + std::normal_distribution& normal, + std::mt19937& rng) { + arma::vec z(n); + for (arma::uword i = 0; i < n; ++i) { + z(i) = normal(rng); + } + return z; +} + +// The functions of Devroye's (2014) generator of the generalized inverse +// Gaussian: the log density of the transformed variate, its derivative, and +// the envelope. +namespace gig_detail { + +inline double psi(double x, double alpha, double lambda) { + return -alpha * (std::cosh(x) - 1.0) - lambda * (std::exp(x) - x - 1.0); +} + +inline double dpsi(double x, double alpha, double lambda) { + return -alpha * std::sinh(x) - lambda * (std::exp(x) - 1.0); +} + +inline double envelope(double x, double sd, double td, double f1, double f2) { + if (x >= -sd && x <= td) { + return 1.0; + } else if (x > td) { + return f1; + } + return f2; +} + +} // namespace gig_detail + +// A draw from the generalized inverse Gaussian GIG(p, a, b), with density +// proportional to x^(p - 1) exp(-(a x + b / x) / 2), by Devroye's (2014) +// rejection sampler. +inline double gigrnd(double p, double a, double b, std::mt19937& rng) { + using gig_detail::psi; + using gig_detail::dpsi; + double lambda = p; + double omega = std::sqrt(a * b); + bool swap = false; + if (lambda < 0) { + lambda = -lambda; + swap = true; + } + + double alpha = std::sqrt(std::pow(omega, 2) + std::pow(lambda, 2)) - lambda; + + double x = -psi(1.0, alpha, lambda); + double t; + if (x >= 0.5 && x <= 2.0) { + t = 1.0; + } else if (x > 2.0) { + if (alpha == 0 && lambda == 0) { + t = 1.0; + } else { + t = std::sqrt(2.0 / (alpha + lambda)); + } + } else { + if (alpha == 0 && lambda == 0) { + t = 1.0; + } else { + t = std::log(4.0 / (alpha + 2.0 * lambda)); + } + } + + x = -psi(-1.0, alpha, lambda); + double s; + if (x >= 0.5 && x <= 2.0) { + s = 1.0; + } else if (x > 2.0) { + if (alpha == 0 && lambda == 0) { + s = 1.0; + } else { + s = std::sqrt(4.0 / (alpha * std::cosh(1.0) + lambda)); + } + } else { + if (alpha == 0 && lambda == 0) { + s = 1.0; + } else if (alpha == 0) { + s = 1.0 / lambda; + } else if (lambda == 0) { + s = std::log(1.0 + 1.0 / alpha + std::sqrt(1.0 / std::pow(alpha, 2) + 2.0 / alpha)); + } else { + s = std::min(1.0 / lambda, std::log(1.0 + 1.0 / alpha + + std::sqrt(1.0 / std::pow(alpha, 2) + 2.0 / alpha))); + } + } + + double eta = -psi(t, alpha, lambda); + double zeta = -dpsi(t, alpha, lambda); + double theta = -psi(-s, alpha, lambda); + double xi = dpsi(-s, alpha, lambda); + + double p_r = 1.0 / xi; + double r = 1.0 / zeta; + + double td = t - r * eta; + double sd = s - p_r * theta; + double q = td + sd; + + std::uniform_real_distribution unif_dist(0.0, 1.0); + double rnd = 0.0; + while (true) { + double U = unif_dist(rng); + double V = unif_dist(rng); + double W = unif_dist(rng); + + if (U < q / (p_r + q + r)) { + rnd = -sd + q * V; + } else if (U < (q + r) / (p_r + q + r)) { + rnd = td - r * std::log(V); + } else { + rnd = -sd + p_r * std::log(V); + } + + double f1 = std::exp(-eta - zeta * (rnd - t)); + double f2 = std::exp(-theta + xi * (rnd + s)); + + if (W * gig_detail::envelope(rnd, sd, td, f1, f2) <= + std::exp(psi(rnd, alpha, lambda))) { + break; + } + } + + rnd = std::exp(rnd) * (lambda / omega + std::sqrt(1.0 + std::pow(lambda / omega, 2))); + + if (swap) { + rnd = 1.0 / rnd; + } + + double result = rnd / std::sqrt(a / b); + + // An exact zero (possible at extreme parameters) would be an infinite + // precision downstream. + if (result == 0.0) { + result = std::numeric_limits::min(); + } + + return result; +} + +// A draw from the inverse Gaussian with mean mu and shape lambda, by Michael, +// Schucany and Haas's (1976) transformation, as qgg and hibayes draw it. +inline double rinvgauss(double mu, double lambda, std::mt19937& rng) { + std::normal_distribution normal(0.0, 1.0); + double z = normal(rng); + double z2 = z * z; + double x = mu + 0.5 * mu * mu * z2 / lambda - + 0.5 * (mu / lambda) * std::sqrt(4.0 * mu * lambda * z2 + mu * mu * z2 * z2); + std::uniform_real_distribution unif(0.0, 1.0); + if (unif(rng) <= mu / (mu + x)) { + return x; + } + return mu * mu / x; +} + +// A draw from the Dirichlet with parameters counts + 1, through gamma draws. +inline std::vector dirichlet_plus_one(const std::vector& counts, + std::mt19937& rng) { + std::vector draw(counts.size()); + double total = 0.0; + for (std::size_t j = 0; j < counts.size(); ++j) { + std::gamma_distribution gamma(counts[j] + 1.0, 1.0); + draw[j] = gamma(rng); + total += draw[j]; + } + for (double& d : draw) { + d /= total; + } + return draw; +} + +// Beta(alpha, beta) as the ratio of two gamma draws, x / (x + y). +class beta_distribution { +public: + beta_distribution(double alpha, double beta) + : a_distribution(alpha, 1.0), b_distribution(beta, 1.0) {} + + template + double operator()(RNG& rng) { + double x = a_distribution(rng); + double y = b_distribution(rng); + return x / (x + y); + } + +private: + std::gamma_distribution a_distribution; + std::gamma_distribution b_distribution; +}; + +// A draw from N(P^-1 a, scale P^-1) for a symmetric positive definite P, +// from the standard normals z: with P = L L', L'^-1 (L^-1 a + sqrt(scale) z). +inline arma::vec gaussian_draw(const arma::mat& P, const arma::vec& a, + const arma::vec& z, double scale = 1.0) { + arma::mat L = arma::chol(P, "lower"); + return arma::solve(arma::trimatu(L.t()), + arma::solve(arma::trimatl(L), a) + std::sqrt(scale) * z); +} + +// The same draw, with its mean P^-1 a as well: the draw is computed as +// gaussian_draw() computes it, so the two agree bit for bit. +inline arma::vec gaussian_draw(const arma::mat& P, const arma::vec& a, + const arma::vec& z, double scale, arma::vec& mean) { + arma::mat L = arma::chol(P, "lower"); + arma::vec x = arma::solve(arma::trimatl(L), a); + mean = arma::solve(arma::trimatu(L.t()), x); + return arma::solve(arma::trimatu(L.t()), x + std::sqrt(scale) * z); +} + +// What every sampler can do beyond its prior: report Rao-Blackwellized +// means, the average over the kept iterations of each effect's conditional +// posterior mean, instead of the draws' average; and when several chains run +// (`track`), stop a chain once it diverges and average the fitted +// correlations over the kept iterations, for the filter that combines the +// chains. +struct ChainOptions { + bool rao_blackwell = false; + bool track = false; +}; + +// What every chain reports: its posterior mean effects and, when tracked, +// its mean fitted correlations and whether it diverged. +struct ChainEstimates { + arma::vec beta; + arma::vec corr; + bool diverged = false; +}; + +// The bound of LDpred2's test of divergence: twice the marginal effects' sum +// of squares. +inline double divergence_gap(const arma::vec& bhat) { + return 2.0 * arma::dot(bhat, bhat); +} + +// A tracked chain's kept draw tested for divergence: its effects' squares +// summing past `gap0`, bigsnpr's test for LDpred2. bigsnpr tests every sweep +// from the first; here the test starts past the burn-in, since some priors +// start far from the posterior (SDPR's first sweeps overshoot the bound many +// times over, then settle well below it). Returns whether the chain has +// diverged, which stops it. +inline bool check_divergence(ChainEstimates& est, const ChainOptions& opts, + const arma::vec& beta, double gap0) { + if (opts.track && arma::dot(beta, beta) > gap0) { + est.diverged = true; + } + return est.diverged; +} + +// A kept iteration's effects added to the posterior means: the conditional +// means when Rao-Blackwellized, else the draws. +inline void keep_effects(ChainEstimates& est, const ChainOptions& opts, + const arma::vec& draws, const arma::vec& cond_means, + int n_kept) { + est.beta += (opts.rao_blackwell ? cond_means : draws) / n_kept; +} + +// The sizes of `blocks`, for a BlockLayout. +template +std::vector block_sizes(const std::vector& blocks) { + std::vector sizes; + for (const Block& block : blocks) { + sizes.push_back(block.size()); + } + return sizes; +} + +// The single-site samplers' generator, each variate from a fresh +// distribution. +class ChainRandom { +public: + explicit ChainRandom(unsigned int seed) : rng_(seed) {} + + double normal(double mean, double sd) { + std::normal_distribution dist(mean, sd); + return dist(rng_); + } + + double chisq(double df) { + std::chi_squared_distribution dist(df); + return dist(rng_); + } + + double unif() { + std::uniform_real_distribution dist(0.0, 1.0); + return dist(rng_); + } + + std::mt19937& engine() { return rng_; } + +private: + std::mt19937 rng_; +}; + +// ---- The chain -------------------------------------------------------------- + +// Iterations 1, ..., n_iter, of which the multiples of thin past the burn-in +// are kept for the posterior means. +class ChainSchedule { +public: + ChainSchedule(int n_iter, int n_burnin, int thin) + : n_iter_(n_iter), n_burnin_(n_burnin), thin_(thin) { + if (n_burnin < 0 || thin < 1) { + cpp11::stop("The burn-in must be non-negative and the thinning " + "interval positive."); + } + if (n_kept() < 1) { + cpp11::stop("The chain keeps no draws: it must run at least one " + "thinning interval past the burn-in."); + } + } + + int n_iter() const { return n_iter_; } + + // How many iterations are kept: the multiples of thin in (n_burnin, n_iter]. + int n_kept() const { return n_iter_ / thin_ - n_burnin_ / thin_; } + + bool keeps(int itr) const { return itr > n_burnin_ && itr % thin_ == 0; } + +private: + int n_iter_; + int n_burnin_; + int thin_; +}; + +// Runs `chain` through `schedule`: each iteration is one chain.sweep(), then +// chain.keep(n_kept) when the schedule keeps it and, when verbose, +// chain.report(itr, n_iter) every 100th iteration. A chain that has stopped +// (chain.stopped(), as a tracked chain that diverged has) ends the run. The +// user can interrupt between iterations. +template +void run_chain(Chain& chain, const ChainSchedule& schedule, bool verbose) { + const int n_kept = schedule.n_kept(); + for (int itr = 1; itr <= schedule.n_iter(); ++itr) { + cpp11::check_user_interrupt(); + chain.sweep(); + if (schedule.keeps(itr)) { + chain.keep(n_kept); + } + if (chain.stopped()) { + break; + } + if (verbose && itr % 100 == 0) { + chain.report(itr, schedule.n_iter()); + } + } +} + +// ---- LD blocks -------------------------------------------------------------- + +// The variants laid out in contiguous blocks: block k holds size(k) of them +// from start(k) on. +class BlockLayout { +public: + explicit BlockLayout(const std::vector& sizes) : size_(sizes) { + arma::uword start = 0; + for (arma::uword size : sizes) { + start_.push_back(start); + start += size; + } + } + + arma::uword n_blocks() const { return size_.size(); } + arma::uword start(arma::uword k) const { return start_[k]; } + arma::uword size(arma::uword k) const { return size_[k]; } + + // Block k's variants; the block must not be empty. + arma::span span(arma::uword k) const { + return arma::span(start_[k], start_[k] + size_[k] - 1); + } + +private: + std::vector size_; + std::vector start_; +}; + +// A block's symmetric positive semidefinite p x p matrix S held whole. +class DenseLdBlock { +public: + explicit DenseLdBlock(arma::mat S) : S_(std::move(S)), diag_(S_.diag()) {} + + arma::uword size() const { return S_.n_rows; } + const arma::vec& diag() const { return diag_; } + arma::vec times(const arma::vec& x) const { return S_ * x; } + double quad(const arma::vec& x) const { return arma::dot(S_ * x, x); } + arma::mat sub(const arma::uvec& idx) const { return S_.submat(idx, idx); } + + // Draws the block's effects, beta ~ N(P^-1 a, scale P^-1) with + // P = S + diag(1 / v) for prior variances v (gaussian_draw()), and + // returns beta'P beta. With `mean`, the mean P^-1 a too. + double draw(const arma::vec& v, const arma::vec& a, double scale, + std::normal_distribution& normal, std::mt19937& rng, + arma::vec& beta, arma::vec* mean = nullptr) const { + arma::mat P = S_ + arma::diagmat(1.0 / v); + arma::vec z = standard_normals(S_.n_rows, normal, rng); + beta = mean ? gaussian_draw(P, a, z, scale, *mean) : gaussian_draw(P, a, z, scale); + return arma::as_scalar(beta.t() * P * beta); + } + +private: + arma::mat S_; + arma::vec diag_; +}; + +// A block's symmetric positive semidefinite p x p matrix S = W'W + e I held +// as its factor W (r x p) and the ridge e, so that nothing p x p is formed: a +// product costs O(rp). The ridge is what an LD shrunk toward the identity, +// c R + (1 - c) I, adds to the factor of c R; it is 0 otherwise. +class FactorLdBlock { +public: + explicit FactorLdBlock(arma::mat W, double extra = 0.0) + : W_(std::move(W)), extra_(extra), + diag_(arma::sum(arma::square(W_), 0).t() + extra) {} + + arma::uword size() const { return W_.n_cols; } + const arma::vec& diag() const { return diag_; } + arma::vec times(const arma::vec& x) const { + arma::vec Sx = W_.t() * (W_ * x); + if (extra_ != 0.0) { + Sx += extra_ * x; + } + return Sx; + } + + double quad(const arma::vec& x) const { + arma::vec Wx = W_ * x; + return arma::dot(Wx, Wx) + extra_ * arma::dot(x, x); + } + + arma::mat sub(const arma::uvec& idx) const { + arma::mat W_idx = W_.cols(idx); + arma::mat S = W_idx.t() * W_idx; + if (extra_ != 0.0) { + S.diag() += extra_; + } + return S; + } + + // The same draw as DenseLdBlock's without forming S or P. With D = diag(v) + // and M = W D W' + I (r x r), Woodbury gives P^-1 = D - D W' M^-1 W D, so + // the mean P^-1 a costs one solve against M, and the noise comes from the + // sampler of Bhattacharya, Chakraborty and Mallick (2016): u ~ N(0, D), + // delta ~ N(0, I), theta = u - D W' M^-1 (W u + delta) is N(0, P^-1). One + // Cholesky factor of M serves both, at O(r^2 p + r^3) per draw instead of + // the O(p^3) of factoring P. The draws consume the random stream + // differently from DenseLdBlock's, so the two agree in distribution, not + // draw for draw. + // The ridge joins the prior's diagonal: P = W'W + diag(1 / v'), with + // 1 / v' = 1 / v + e. With `mean`, the mean P^-1 a is returned too. + double draw(const arma::vec& v, const arma::vec& a, double scale, + std::normal_distribution& normal, std::mt19937& rng, + arma::vec& beta, arma::vec* mean = nullptr) const { + const arma::vec vp = extra_ == 0.0 ? v : 1.0 / (1.0 / v + extra_); + arma::uword p = W_.n_cols; + arma::uword r = W_.n_rows; + arma::mat WD = W_.each_row() % vp.t(); + arma::mat M = WD * W_.t(); + M.diag() += 1.0; + arma::mat L = arma::chol(M, "lower"); + arma::vec centre = vp % a - WD.t() * solve_chol(L, WD * a); + arma::vec u = arma::sqrt(vp) % standard_normals(p, normal, rng); + arma::vec delta = standard_normals(r, normal, rng); + arma::vec theta = u - WD.t() * solve_chol(L, W_ * u + delta); + beta = centre + std::sqrt(scale) * theta; + if (mean) { + *mean = centre; + } + arma::vec Wbeta = W_ * beta; + return arma::dot(Wbeta, Wbeta) + arma::sum(arma::square(beta) / vp); + } + +private: + arma::mat W_; + double extra_; + arma::vec diag_; + + // M^-1 x from the lower Cholesky factor L of M. + static arma::vec solve_chol(const arma::mat& L, const arma::vec& x) { + return arma::solve(arma::trimatu(L.t()), arma::solve(arma::trimatl(L), x)); + } +}; + +// ==== PRS-CS ==================================================================== + +// PRS-CS's prior is beta_j ~ N(0, sigma / n psi_j) with the +// Strawderman-Berger local scales psi_j ~ G(a, delta_j), delta_j ~ G(b, phi), +// and the global scale phi either fixed or learned under a half-Cauchy +// prior. A sweep draws each block's beta jointly given psi (the block's +// draw()), then sigma, delta, psi and, when it is learned, phi. + +// The posterior means, besides the effects every chain reports. +struct PrsCsEstimates : ChainEstimates { + arma::vec psi; + double sigma = 0.0; + double phi = 0.0; +}; + +// The sampler's state on the marginal effects `beta_mrg` of the variants in +// `blocks` (each a DenseLdBlock of R or each a FactorLdBlock with R = W'W). +template +class PrsCsChain { +public: + PrsCsChain(double a, double b, bool learn_phi, double phi, + const arma::vec& beta_mrg, int n, + const std::vector& blocks, unsigned int seed, + const ChainOptions& opts = ChainOptions()) + : a_(a), b_(b), learn_phi_(learn_phi), n_(n), + p_(static_cast(beta_mrg.n_elem)), beta_mrg_(beta_mrg), + blocks_(blocks), layout_(block_sizes(blocks)), rng_(seed), + normal_(0.0, 1.0), gamma_sigma_((n + p_) / 2.0, 1.0), + beta_(p_, arma::fill::zeros), psi_(p_, arma::fill::ones), + sigma_(1.0), phi_(learn_phi ? 1.0 : phi), opts_(opts), + beta_mean_(p_, arma::fill::zeros), + gap0_(divergence_gap(beta_mrg)) { + est_.beta.zeros(p_); + est_.psi.zeros(p_); + est_.corr.zeros(p_); + } + + void sweep() { + double quad = 0.0; + for (arma::uword k = 0; k < layout_.n_blocks(); ++k) { + if (layout_.size(k) == 0) { + continue; + } + arma::span blk = layout_.span(k); + arma::vec beta_blk; + arma::vec mean_blk; + quad += blocks_[k].draw(psi_(blk), beta_mrg_(blk), sigma_ / n_, + normal_, rng_, beta_blk, + opts_.rao_blackwell ? &mean_blk : nullptr); + beta_(blk) = beta_blk; + if (opts_.rao_blackwell) { + beta_mean_(blk) = mean_blk; + } + } + double err = std::max(n_ / 2.0 * (1.0 - 2.0 * arma::dot(beta_, beta_mrg_) + quad), + n_ / 2.0 * arma::sum(arma::pow(beta_, 2) / psi_)); + + // sigma ~ InvGamma((n + p) / 2, rate = err), as err / Gamma((n + p) / 2, 1). + sigma_ = err / gamma_sigma_(rng_); + + arma::vec delta(p_); + for (int j = 0; j < p_; ++j) { + std::gamma_distribution gamma_delta(a_ + b_, 1.0 / (psi_(j) + phi_)); + delta(j) = gamma_delta(rng_); + } + + for (int j = 0; j < p_; ++j) { + psi_(j) = gigrnd(a_ - 0.5, 2.0 * delta(j), n_ * std::pow(beta_(j), 2) / sigma_, + rng_); + } + // psi is capped at 1, as in PRS-CS, against explosive local shrinkage. + psi_ = arma::clamp(psi_, 0.0, 1.0); + + if (learn_phi_) { + std::gamma_distribution gamma_w(1.0, 1.0 / (phi_ + 1.0)); + double w = gamma_w(rng_); + std::gamma_distribution gamma_phi(p_ * b_ + 0.5, + 1.0 / (arma::sum(delta) + w)); + phi_ = gamma_phi(rng_); + } + } + + void keep(int n_kept) { + if (check_divergence(est_, opts_, beta_, gap0_)) { + return; + } + keep_effects(est_, opts_, beta_, beta_mean_, n_kept); + est_.psi += psi_ / n_kept; + est_.sigma += sigma_ / n_kept; + est_.phi += phi_ / n_kept; + if (opts_.track) { + for (arma::uword k = 0; k < layout_.n_blocks(); ++k) { + if (layout_.size(k) > 0) { + arma::span blk = layout_.span(k); + est_.corr(blk) += blocks_[k].times(beta_(blk)) / n_kept; + } + } + } + } + + void report(int itr, int n_iter) const { + Rprintf("Iteration %4d of %d\n", itr, n_iter); + } + + bool stopped() const { return est_.diverged; } + + const PrsCsEstimates& estimates() const { return est_; } + +private: + double a_; + double b_; + bool learn_phi_; + int n_; + int p_; + arma::vec beta_mrg_; + const std::vector& blocks_; + BlockLayout layout_; + std::mt19937 rng_; + std::normal_distribution normal_; + std::gamma_distribution gamma_sigma_; + arma::vec beta_; + arma::vec psi_; + double sigma_; + double phi_; + ChainOptions opts_; + arma::vec beta_mean_; // the blocks' conditional means, for Rao-Blackwell + double gap0_; + PrsCsEstimates est_; +}; + +/** + * @brief The PRS-CS posterior means of the effects. + * + * @param a,b The shapes of the local scales' prior. + * @param learn_phi Whether the global scale is learned; if not, it is `phi`. + * @param beta_mrg The marginal effects. + * @param maf The minor allele frequencies, all zero to keep the effects + * standardized; otherwise beta is returned per allele. + * @param n The sample size. + * @param blocks The LD blocks, each a DenseLdBlock or each a FactorLdBlock. + */ +template +PrsCsEstimates prs_cs_mcmc(double a, double b, bool learn_phi, double phi, + const arma::vec& beta_mrg, const arma::vec& maf, int n, + const std::vector& blocks, + const ChainSchedule& schedule, bool verbose, + unsigned int seed, + const ChainOptions& opts = ChainOptions()) { + if (verbose) { + Rprintf("Running Markov Chain Monte Carlo (MCMC) sampler...\n"); + } + PrsCsChain chain(a, b, learn_phi, phi, beta_mrg, n, blocks, seed, opts); + run_chain(chain, schedule, verbose); + PrsCsEstimates est = chain.estimates(); + + if (arma::max(maf) > 0) { + est.beta /= arma::sqrt(2.0 * maf % (1.0 - maf)); + } + if (verbose && learn_phi) { + Rprintf("Estimated global shrinkage parameter: %g\n", est.phi); + } + if (verbose) { + Rprintf("MCMC sampling completed.\n"); + } + return est; +} + +// ==== SDPR ====================================================================== + +// SDPR's prior on each effect is a Dirichlet process mixture of normals, the +// first component a point mass at zero, and its likelihood is SDPR's +// approximation to the RSS likelihood through the matrices B and A of each +// block. A sweep draws the components' variances, each variant's component, +// the stick-breaking weights and the concentration, the causal variants' +// effects jointly per block, and the effects' global scale eta, which has an +// N(1, 1) prior (the original's is flat). + +// The per-variant data SDPR's likelihood reads. +// +// - beta_mrg: the marginal effects, deflated by `c`. +// - sz: the sample size of each variant. +// - array: the genotyping array of each variant (0 = every cohort, 1 or 2 = +// the cohorts genotyped on that array). Pairs of variants on arrays 1 and +// 2 share no samples, so the optLlk = 2 likelihood zeroes their LD. +struct SdprData { + std::vector beta_mrg; + std::vector sz; + std::vector array; +}; + +// What the sampler reads from one LD block, R: B, the matrix of the +// likelihood, n R (R + aI)^-1 R for optLlk = 1 or R B2^-1 R for optLlk = 2 +// (B2 the scaled R of sdpr_llk2_matrix()), calc_b_tmp, the matching +// A' beta_mrg, and R itself for beta'R beta (the heritability). B and R are +// both held whole (DenseLdBlock) or both as factors (FactorLdBlock). +template +struct SdprBlock { + LdBlock B; + LdBlock R; + arma::vec calc_b_tmp; + + arma::uword size() const { return B.size(); } +}; + +// The posterior mean of the heritability, besides the effects every chain +// reports. +struct SdprEstimates : ChainEstimates { + double h2 = 0.0; +}; + +/** + * @brief The dense LD blocks of the SDPR likelihood (solve_ldmat). + * + * @param dat The per-variant data, with beta_mrg already deflated by `c`. + * @param ref_ld_mat The LD matrix of each block, taken over. + * @param a Factor to shrink the reference LD matrix (optLlk = 1). + * @param sz The sample size of the GWAS (optLlk = 1). + * @param opt_llk 1 for equation 6 (slightly shrink the correlation of + * variants) and 2 for equation 5 (variants genotyped on different arrays in + * a separate cohort). + */ +std::vector> sdpr_dense_blocks(const SdprData &dat, + std::vector ref_ld_mat, + double a, unsigned sz, + int opt_llk); + +/** + * @brief The one LD block of the SDPR likelihood from a factor of its LD, + * R = F'F / (m - 1), never forming R or B. + * + * The arguments are sdpr_dense_blocks()'s with the factor F (m x p) in place + * of the LD matrices. B and A' beta_mrg agree with the dense block's to + * rounding: optLlk = 1 has them in closed form from the eigenvalues of R; + * optLlk = 2 applies B2^-1 to r + 1 vectors, through the Woodbury identity + * while B2's low-rank part is narrower than p, and otherwise by forming B2. + */ +SdprBlock sdpr_factor_block(const SdprData &dat, const arma::mat &F, + double a, unsigned sz, int opt_llk); + +/** + * @brief The SDPR posterior means of the effects and the heritability. + * + * @param blocks The LD blocks (sdpr_dense_blocks() or sdpr_factor_block()). + * @param M Max number of variance components. + * @param a0k,b0k The inverse gamma prior of the components' variances. + * @param schedule The chain's iterations, burn-in and thinning. + * @param verbose Whether to report progress. + * @param seed Seed of the sampler's random number generator. + * @param opts Rao-Blackwellized means, and tracking for several chains. + * @param gap0 Twice the squared marginal effects' sum, past which the + * effects' squares mark a tracked chain diverged. + */ +template +SdprEstimates sdpr_mcmc(const std::vector> &blocks, size_t M, + double a0k, double b0k, const ChainSchedule &schedule, + bool verbose, unsigned int seed, const ChainOptions &opts, + double gap0); + +// ==== The Bayesian alphabet ===================================================== + +// qgg's and hibayes' summary-statistics samplers read the LD as a matrix. +// This one reads it as a factor F (k x p) of R = F'F / (k - 1), keeping +// u = F_w b for the current effects b through rss_ld.h's FactorLd, so a +// single-site update costs O(k) and nothing p x p is formed. The likelihood +// is SBayes's: with per-variant weights w (the sample size n, or qgg's +// w = 1 / (se^2 + b^2 / n)), X'X = W^1/2 R W^1/2 and X'y = w % bhat, both +// held through F_w = F diag(sqrt(w)). +// +// Two families of priors, each sampled as its package samples it: +// * qgg's (CRAN 1.1.6): bayesA, bayesC, bayesN and bayesR as its +// summary-statistics sampler sbayes() has them, and bayesL in Legarra et +// al.'s (2011) form, as its individual-level sampler has it. Scaled +// inverse chi-square priors with nu = 4 on the marker and residual +// variances; pi drawn from a Dirichlet. +// * hibayes': bayesB as BayesBpi, and bayesL in Park and Casella's (2008) +// form, as its SBayesD() has them. A scaled inverse chi-square prior on +// the genetic variance and an improper one on the residual variance. + +// What every alphabet sampler reads, and the options every sampler shares: +// the LD shrinkage c, under which X'X is W^1/2 (c R + (1 - c) I) W^1/2, so +// only its off-diagonal part is scaled; whether a drawn effect may change +// sign (without, it is zero instead, and leaves its class); and +// ChainOptions. +struct AlphabetData { + arma::mat Fw; // F diag(sqrt(w)), k x p: X'X = Fw'Fw / (k - 1) + arma::vec w; // the per-variant weights + arma::vec wy; // X'y = w % bhat + arma::vec bhat; + int n; + double shrink = 1.0; + bool allow_jump_sign = true; + ChainOptions opts; +}; + +// The posterior means, and when the chain is tracked its mean fitted +// correlations and whether it diverged. +struct AlphabetEstimates : ChainEstimates { + arma::vec pip; // share of kept draws with a non-null effect + double pi = 0.0; // proportion of non-null effects + double ve = 0.0; // residual variance +}; + +// What the two families share: the effects, the factor that keeps X'X b, the +// generator and the posterior means. +class AlphabetChainBase : protected ChainRandom { +public: + const AlphabetEstimates& estimates() const { return est_; } + + void report(int itr, int n_iter) const { + Rprintf("Iteration %4d of %d: residual variance %g\n", itr, n_iter, ve_); + } + + bool stopped() const { return est_.diverged; } + +protected: + AlphabetChainBase(const AlphabetData& data, unsigned int seed) + : ChainRandom(seed), data_(data), p_(data.wy.n_elem), + b_(p_, arma::fill::zeros), ld_(data.Fw, 0.0, b_), ve_(0.0), + cond_mean_(p_, arma::fill::zeros), gap0_(divergence_gap(data.bhat)) { + est_.beta.zeros(p_); + est_.pip.zeros(p_); + est_.corr.zeros(p_); + } + + // (X'X)_jj under the LD shrinkage. + double xx(arma::uword j) const { + const double c = data_.shrink; + return c * ld_.diag(j) + (1.0 - c) * data_.w(j); + } + + // X'y_j - (X'X b)_j + (X'X)_jj b_j: variant j's statistic net of the + // other effects, whose LD the shrinkage scales. + double rhs(arma::uword j) const { + const double c = data_.shrink; + return data_.wy(j) - c * ld_.row(j, b_) + c * ld_.diag(j) * b_(j); + } + + // Sets b_j, which without sign jumps is zero where the draw's sign + // differs from the current effect's; returns what was set. + double set(arma::uword j, double bn) { + if (!data_.allow_jump_sign && bn * b_(j) < 0.0) { + bn = 0.0; + } + double diff = bn - b_(j); + if (diff != 0.0) { + ld_.update(j, diff); + b_(j) = bn; + } + return bn; + } + + // X'y - X'X b. + arma::vec residuals() const { + arma::vec r = data_.wy - data_.shrink * ld_.product(b_); + if (data_.shrink != 1.0) { + r -= (1.0 - data_.shrink) * (data_.w % b_); + } + return r; + } + + // Kept draws add to the means of the effects (Rao-Blackwellized: their + // conditional means), the inclusions, pi and ve, and when tracked to the + // fitted correlations X'X b / w. + void keep_common(int n_kept, const std::vector& d, double pi) { + if (check_divergence(est_, data_.opts, b_, gap0_)) { + return; + } + keep_effects(est_, data_.opts, b_, cond_mean_, n_kept); + if (data_.opts.track) { + est_.corr += (data_.wy - residuals()) / data_.w / n_kept; + } + for (arma::uword j = 0; j < d.size(); ++j) { + if (d[j] != 0) { + est_.pip(j) += 1.0 / n_kept; + } + } + est_.pi += pi / n_kept; + est_.ve += ve_ / n_kept; + } + + const AlphabetData& data_; + arma::uword p_; + arma::vec b_; + FactorLd ld_; + double ve_; + arma::vec cond_mean_; // each effect's conditional mean, for Rao-Blackwell + double gap0_; + AlphabetEstimates est_; +}; + +// qgg's priors: bayesN, bayesA, bayesC, bayesR and Legarra's bayesL. +class QggFormChain : public AlphabetChainBase { +public: + enum Method { N, A, L, C, R }; + + QggFormChain(const AlphabetData& data, Method method, double pi, double h2, + unsigned int seed) + : AlphabetChainBase(data, seed), method_(method), d_(p_, 1) { + init_priors(pi, h2); + // qgg enters the variants with the largest marginal effects first. + order_.resize(p_); + std::iota(order_.begin(), order_.end(), 0); + const arma::vec& bhat = data_.bhat; + std::stable_sort(order_.begin(), order_.end(), [&](arma::uword i, arma::uword j) { + return bhat(i) * bhat(i) > bhat(j) * bhat(j); + }); + } + + void sweep() { + for (arma::uword j : order_) { + sweep_one(j); + } + if (method_ == L) { + update_lasso_precisions(); + } else { + update_marker_variance(); + } + if (method_ == C || method_ == R) { + pi_ = dirichlet_plus_one(class_counts(), engine()); + } + update_residual_variance(); + } + + void keep(int n_kept) { + keep_common(n_kept, d_, 1.0 - pi_[0]); + } + +private: + Method method_; + std::vector order_; + std::vector d_; // each effect's variance class; 0 is null + std::vector pi_; + std::vector gamma_; + double vb_ = 0.0; + double ssb_prior_ = 0.0; + double sse_prior_ = 0.0; + const double nub_ = 4.0; + const double nue_ = 4.0; + arma::vec vbi_; // bayesA: each effect's variance + arma::vec lambda_; // bayesL: each effect's prior precision + double lambda2_ = 0.0; + + // qgg's sbayes_sparse() defaults; bayesR's classes ignore `pi`, which + // then sets the slab variance at qgg's default of 0.001. qgg's y'y, + // median((b^2 + (n - 2) se^2) w), is median(w) for standardized + // statistics. + void init_priors(double pi, double h2) { + double vy = arma::median(data_.w) / (data_.n - 1.0); + ve_ = vy * (1.0 - h2); + double vg = vy * h2; + double m = static_cast(p_); + pi_ = {1.0 - pi, pi}; + gamma_ = {0.0, 1.0}; + if (method_ == R) { + pi = 0.001; + pi_ = {0.95, 0.02, 0.02, 0.01}; + gamma_ = {0.0, 0.01, 0.1, 1.0}; + } + vb_ = (method_ == C || method_ == R) ? vg / (m * pi) : vg / m; + ssb_prior_ = ((nub_ - 2.0) / nub_) * vb_; + sse_prior_ = ((nue_ - 2.0) / nue_) * ve_; + vbi_ = arma::vec(p_, arma::fill::value(vb_)); + lambda_ = arma::vec(p_, arma::fill::value(ve_ / vb_)); + lambda2_ = m; + if (method_ == N || method_ == A || method_ == L) { + std::fill(d_.begin(), d_.end(), 1); + } else { + std::fill(d_.begin(), d_.end(), 0); + } + } + + void sweep_one(arma::uword j) { + double dj = xx(j); + double rhs_j = rhs(j); + switch (method_) { + case N: + cond_mean_(j) = slab_mean(rhs_j, dj, vb_); + set(j, slab_draw(rhs_j, dj, vb_)); + break; + case A: + vbi_(j) = (b_(j) * b_(j) + ssb_prior_ * nub_) / chisq(1.0 + nub_); + cond_mean_(j) = slab_mean(rhs_j, dj, vbi_(j)); + set(j, slab_draw(rhs_j, dj, vbi_(j))); + break; + case L: { + double lhs = dj / ve_ + lambda_(j); + cond_mean_(j) = (rhs_j / ve_) / lhs; + set(j, normal((rhs_j / ve_) / lhs, std::sqrt(1.0 / lhs))); + break; + } + case C: + case R: + sweep_mixture(j, rhs_j, dj); + break; + } + } + + // b_j's conditional under a normal prior of variance v, and its mean. + double slab_draw(double rhs_j, double dj, double v) { + double lhs = dj + ve_ / v; + return normal(rhs_j / lhs, std::sqrt(ve_ / lhs)); + } + + double slab_mean(double rhs_j, double dj, double v) const { + return rhs_j / (dj + ve_ / v); + } + + // b_j's conditional mean over the variance classes, weighted by their + // posterior probabilities. + double mixture_mean(const std::vector& loglik, double rhs_j, double dj) const { + double top = *std::max_element(loglik.begin(), loglik.end()); + double total = 0.0; + double mean = 0.0; + for (std::size_t c = 0; c < loglik.size(); ++c) { + double weight = std::exp(loglik[c] - top); + total += weight; + if (c > 0) { + mean += weight * slab_mean(rhs_j, dj, vb_ * gamma_[c]); + } + } + return mean / total; + } + + // bayesC and bayesR: the variance class from its marginal likelihood, + // then the effect within it. + void sweep_mixture(arma::uword j, double rhs_j, double dj) { + std::size_t nc = pi_.size(); + std::vector loglik(nc); + double v0 = dj * ve_; + loglik[0] = -0.5 * std::log(v0) - 0.5 * rhs_j * rhs_j / v0 + std::log(pi_[0]); + for (std::size_t c = 1; c < nc; ++c) { + double v1 = dj * ve_ + dj * dj * vb_ * gamma_[c]; + loglik[c] = -0.5 * std::log(v1) - 0.5 * rhs_j * rhs_j / v1 + std::log(pi_[c]); + } + double u = unif(); + double cum = 0.0; + int cls = 0; + for (std::size_t c = 0; c < nc; ++c) { + double denom = 0.0; + for (std::size_t k = 0; k < nc; ++k) { + denom += std::exp(loglik[k] - loglik[c]); + } + cum += 1.0 / denom; + if (u < cum) { + cls = static_cast(c); + break; + } + } + d_[j] = cls; + if (data_.opts.rao_blackwell) { + cond_mean_(j) = mixture_mean(loglik, rhs_j, dj); + } + if (set(j, cls == 0 ? 0.0 : slab_draw(rhs_j, dj, vb_ * gamma_[cls])) == 0.0) { + d_[j] = 0; + } + } + + std::vector class_counts() const { + std::vector counts(pi_.size(), 0.0); + for (int cls : d_) { + counts[cls] += 1.0; + } + return counts; + } + + // The slab variance from the effects in the slab, each scaled by its + // class (bayesN and bayesA have every effect in class 1, of scale 1). + void update_marker_variance() { + double ssb = 0.0; + double dfb = 0.0; + for (arma::uword j = 0; j < p_; ++j) { + if (d_[j] != 0) { + ssb += b_(j) * b_(j) / gamma_[d_[j]]; + dfb += 1.0; + } + } + vb_ = (ssb + ssb_prior_ * nub_) / chisq(dfb + nub_); + } + + // Legarra et al.: each effect's prior precision from its inverse-Gaussian + // conditional, then lambda^2 from its gamma conditional, kept in [1, 1e6]. + void update_lasso_precisions() { + const double eps = 1e-8; + double rate = std::max(lambda2_, eps); + double sum_tau = 0.0; + for (arma::uword j = 0; j < p_; ++j) { + double abs_b = std::max(std::abs(b_(j)), eps); + double mu = std::max(std::sqrt(rate) / abs_b, eps); + lambda_(j) = rinvgauss(mu, rate, engine()); + sum_tau += 1.0 / lambda_(j); + } + std::gamma_distribution gamma(static_cast(p_) + 1.0, 2.0 / sum_tau); + lambda2_ = std::max(1.0, std::min(gamma(engine()), 1e6)); + } + + // y'y - 2 b'X'y + b'X'X b is the residual sum of squares only while the + // statistics agree with the LD; where they disagree (an LD reference + // unlike the study's) it can turn negative, which qgg does not guard + // and which makes its chain NaN. The residual variance then keeps its + // last value, as hibayes falls back on one too. + void update_residual_variance() { + arma::vec r = residuals(); + double sse = arma::median(data_.w) - arma::dot(b_, r + data_.wy); + double scale = sse + sse_prior_ * nue_; + if (scale > 0.0) { + ve_ = scale / chisq(data_.n + nue_); + } + } +}; + +// hibayes' priors: bayesB as BayesBpi and Park and Casella's bayesL. +class HibayesFormChain : public AlphabetChainBase { +public: + enum Method { B, L }; + + HibayesFormChain(const AlphabetData& data, Method method, double pi, double h2, + unsigned int seed) + : AlphabetChainBase(data, seed), method_(method), d_(p_, method == L ? 1 : 0) { + init_priors(pi, h2); + } + + void sweep() { + if (method_ == B) { + for (arma::uword j = 0; j < p_; ++j) { + sweep_spike_slab(j); + } + std::vector counts = {0.0, 0.0}; + for (int flag : d_) { + counts[flag] += 1.0; + } + pi_ = dirichlet_plus_one(counts, engine()); + } else { + for (arma::uword j = 0; j < p_; ++j) { + sweep_lasso(j); + } + std::gamma_distribution gamma(shape0_ + p_, 1.0 / (rate0_ + arma::sum(vargL_) / 2.0)); + lambda2_ = gamma(engine()); + } + update_variances(); + } + + void keep(int n_kept) { + keep_common(n_kept, d_, pi_[1]); + } + +private: + Method method_; + std::vector d_; + std::vector pi_; + double dfvara_ = 4.0; + double dfvare_ = -2.0; + double vara_ = 0.0; + double s2vara_ = 0.0; + double s2varg_ = 0.0; + double yy_ = 0.0; + double lambda2_ = 0.0; + double shape0_ = 1.1; + double rate0_ = 0.0; + arma::vec vargL_; + + // SBayesD()'s defaults. Its genotype variances vx are R's diagonal, + // (X'X)_jj / w_j, and its y'y, the mean of (X'X)_jj (b^2 + (n - 2) se^2), + // is the mean of (X'X)_jj for standardized statistics. + void init_priors(double pi, double h2) { + double sumvx = 0.0; + yy_ = 0.0; + for (arma::uword j = 0; j < p_; ++j) { + yy_ += ld_.diag(j); + sumvx += ld_.diag(j) / data_.w(j); + } + yy_ /= static_cast(p_); + double vary = yy_ / (data_.n - 1.0); + vara_ = ((dfvara_ - 2.0) / dfvara_) * vary * h2; + ve_ = vary * (1.0 - h2); + s2vara_ = vara_ * (dfvara_ - 2.0) / dfvara_; + pi_ = (method_ == L) ? std::vector{0.0, 1.0} : std::vector{1.0 - pi, pi}; + double scale = (1.0 - pi_[0]) * sumvx; + s2varg_ = s2vara_ / scale; + double R2 = (dfvara_ - 2.0) / dfvara_; + lambda2_ = 2.0 * (1.0 - R2) / R2 * sumvx; + rate0_ = (shape0_ - 1.0) / lambda2_; + vargL_ = arma::vec(p_, arma::fill::value(vara_ / scale)); + } + + void sweep_spike_slab(arma::uword j) { + double xx = this->xx(j); + double rhs_j = rhs(j); + double gi = b_(j); + double varg = (gi * gi + s2varg_ * dfvara_) / chisq(dfvara_ + 1.0); + double logdetV = std::log(varg * xx / ve_ + 1.0); + double uhat = rhs_j / (xx + ve_ / varg); + double s1 = -0.5 * (logdetV - rhs_j * uhat / ve_) + std::log(pi_[1]); + double accept = 1.0 / (1.0 + std::exp(s1 - std::log(pi_[0]))); + double v = xx + ve_ / varg; + cond_mean_(j) = (1.0 - accept) * rhs_j / v; + d_[j] = unif() < accept ? 0 : 1; + if (d_[j] == 0) { + set(j, 0.0); + return; + } + if (set(j, normal(rhs_j / v, std::sqrt(ve_ / v))) == 0.0) { + d_[j] = 0; + } + } + + // Park and Casella: b_j's prior variance is ve * tau_j^2, and 1 / tau_j^2 + // has an inverse-Gaussian conditional. + void sweep_lasso(arma::uword j) { + double xx = this->xx(j); + double rhs_j = rhs(j); + double v = xx + 1.0 / vargL_(j); + cond_mean_(j) = rhs_j / v; + double gi = normal(rhs_j / v, std::sqrt(ve_ / v)); + if (std::abs(gi) < 1e-6) { + gi = 1e-6; + } + double lambda = std::sqrt(lambda2_); + double vargi = 1.0 / rinvgauss(std::sqrt(ve_) * lambda / std::abs(gi), lambda2_, engine()); + if (vargi > 0.0) { + vargL_(j) = vargi; + } + set(j, gi); + } + + void update_variances() { + arma::vec r = residuals(); + vara_ = (arma::dot(b_, data_.wy - r) + s2vara_ * dfvara_) / chisq(data_.n + dfvara_); + ve_ = (yy_ - arma::dot(b_, data_.wy + r)) / chisq(data_.n + dfvare_); + if (ve_ < 0.0) { + ve_ = vara_ * 0.5; + } + } +}; + +// ==== LDpred2 =================================================================== + +// The point-normal prior of LDpred2's Gibbs samplers in bigsnpr, read from a +// factor F (k x p) of R = F'F / (k - 1) through rss_ld.h's FactorLd, so a +// single-site update costs O(k) and nothing p x p is formed: +// * LDpred2-grid holds the proportion p of causal variants and the +// heritability h2 fixed; with `sparse`, an effect whose posterior +// inclusion probability falls below p is set to zero; +// * LDpred2-auto draws p from its Beta full conditional, with the counts +// divided by the mean LD score, and takes h2 = b'R_s b after each sweep, +// for R_s = c R + (1 - c) I at the LD shrinkage c. +// Either reads R_s, and with no sign jumps sets a drawn effect whose sign +// differs from the current one to zero; bigsnpr's grid has neither, which +// is c = 1 with sign jumps allowed. Both report what bigsnpr does: +// Rao-Blackwellized effects, the average over the kept sweeps of each +// variant's conditional posterior mean, with the inclusion probabilities and +// the fitted correlations R_s b. A chain whose squared effects sum past +// twice the squared marginal effects has diverged and stops. + +// How a chain runs: LDpred2-auto's starting p and h2, or LDpred2-grid's fixed +// ones. +struct Ldpred2Settings { + bool automatic = false; + double p = 0.1; + double h2 = 0.1; + bool sparse = false; // grid only + double shrink = 1.0; // the LD shrinkage c + bool allow_jump_sign = true; + double p_lower = 1e-5; // auto only: the bounds on p + double p_upper = 1.0; + double mean_ld = 1.0; // auto only: the mean LD score +}; + +// The chain's report besides the effects every chain reports: those are +// Rao-Blackwellized and the fitted correlations are R_s b, as bigsnpr has +// them. +struct Ldpred2Estimates : ChainEstimates { + arma::vec postp; // inclusion probabilities + std::vector path_p; // auto: p after each sweep + std::vector path_h2; // auto: h2 after each sweep +}; + +// The LD is FactorLd's R_s, its shrinkage s = 1 - c, so (R_s b)_j is its +// row(); the chain always Rao-Blackwellizes and tracks, as bigsnpr does. +class Ldpred2Chain : private ChainRandom { +public: + Ldpred2Chain(const arma::mat& F, const arma::vec& bhat, const arma::vec& n, + const Ldpred2Settings& settings, unsigned int seed) + : ChainRandom(seed), bhat_(bhat), n_(n), s_(settings), m_(bhat.n_elem), + b_(m_, arma::fill::zeros), ld_(F, 1.0 - settings.shrink, b_), + cond_mean_(m_, arma::fill::zeros), cond_postp_(m_, arma::fill::zeros), + cond_corr_(m_, arma::fill::zeros), gap0_(divergence_gap(bhat)) { + opts_.rao_blackwell = true; + opts_.track = true; + est_.beta.zeros(m_); + est_.postp.zeros(m_); + est_.corr.zeros(m_); + if (s_.automatic) { + s_.h2 = std::max(s_.h2, kMinH2); + s_.p = std::min(std::max(s_.p, s_.p_lower), s_.p_upper); + } + } + + // One pass over the variants; LDpred2-auto then draws p and sets h2. + void sweep() { + const double inv_odd_p = (1.0 - s_.p) / s_.p; + const double sigma2 = s_.h2 / (static_cast(m_) * s_.p); + arma::uword causal = 0; + for (arma::uword j = 0; j < m_; ++j) { + if (update(j, inv_odd_p, sigma2)) { + ++causal; + } + } + if (s_.automatic) { + draw_parameters(causal); + } + } + + // A kept sweep adds its conditional means to the posterior means. Every + // effect was just redrawn, so b'b is bigsnpr's gap. + void keep(int n_kept) { + if (check_divergence(est_, opts_, b_, gap0_)) { + return; + } + keep_effects(est_, opts_, b_, cond_mean_, n_kept); + est_.postp += cond_postp_ / n_kept; + est_.corr += cond_corr_ / n_kept; + } + + void report(int itr, int n_iter) const { + Rprintf("Iteration %4d of %d: p %g, h2 %g\n", itr, n_iter, s_.p, s_.h2); + } + + bool stopped() const { return est_.diverged; } + + const Ldpred2Estimates& estimates() const { return est_; } + +private: + static constexpr double kMinH2 = 1e-3; + + // Variant j's update; true when it draws a non-zero effect. The fitted + // correlation (R_s b)_j net of b_j's own term is the other effects' share + // of the statistic. + bool update(arma::uword j, double inv_odd_p, double sigma2) { + const double fitted = ld_.row(j, b_); + const double prev = b_(j); + const double res = bhat_(j) - (fitted - ld_.diag(j) * prev); + const double C1 = sigma2 * n_(j); + const double C2 = 1.0 / (1.0 + 1.0 / C1); + const double C3 = C2 * res; + const double C4 = C2 / n_(j); + const double postp = + 1.0 / (1.0 + inv_odd_p * std::sqrt(1.0 + C1) * std::exp(-C3 * C3 / C4 / 2.0)); + cond_mean_(j) = C3 * postp; + cond_postp_(j) = postp; + cond_corr_(j) = fitted; + double next = 0.0; + bool drawn = false; + if (s_.sparse && postp < s_.p) { + cond_mean_(j) = 0.0; + } else if (postp > unif()) { + const double draw = normal(C3, std::sqrt(C4)); + if (s_.allow_jump_sign || draw * prev >= 0.0) { + next = draw; + drawn = true; + } + } + const double diff = next - prev; + if (diff != 0.0) { + cur_h2_ += diff * (2.0 * fitted + diff * ld_.diag(j)); + ld_.update(j, diff); + b_(j) = next; + } + return drawn; + } + + // LDpred2-auto's p from its Beta full conditional, within its bounds, and + // h2 = b'R_s b, floored as bigsnpr floors it. + void draw_parameters(arma::uword causal) { + const double k = static_cast(causal); + const double m = static_cast(m_); + beta_distribution beta(1.0 + k / s_.mean_ld, 1.0 + (m - k) / s_.mean_ld); + s_.p = std::min(std::max(beta(engine()), s_.p_lower), s_.p_upper); + s_.h2 = std::max(cur_h2_, kMinH2); + est_.path_p.push_back(s_.p); + est_.path_h2.push_back(s_.h2); + } + + const arma::vec& bhat_; + const arma::vec& n_; + Ldpred2Settings s_; + arma::uword m_; + arma::vec b_; + FactorLd ld_; + ChainOptions opts_; + arma::vec cond_mean_; + arma::vec cond_postp_; + arma::vec cond_corr_; + double gap0_; + double cur_h2_ = 0.0; + Ldpred2Estimates est_; +}; diff --git a/src/sdpr.cpp b/src/sdpr.cpp deleted file mode 100644 index 6ba35b40b..000000000 --- a/src/sdpr.cpp +++ /dev/null @@ -1,139 +0,0 @@ -#include -#include -#include -#include -#include "sdpr_mcmc.h" - -using namespace cpp11; -using namespace arma; - -namespace { - -// The per-SNP data as R passes it: the marginal betas deflated by `c`, a NULL -// perVariantSampleSize is n for every SNP, and a NULL array is array 1 for -// every SNP. -mcmc_data sdpr_data(const doubles& bhatR, const std::vector& block_sizes, - int n, sexp perVariantSampleSize, sexp array, double c) { - std::vector bhat = cpp11::as_cpp>(bhatR); - // Deflation correction - for (size_t i = 0; i < bhat.size(); i++) { - bhat[i] /= c; - } - std::vector sz; - std::vector arr; - if (perVariantSampleSize != R_NilValue) { - sz = cpp11::as_cpp>(perVariantSampleSize); - } else { - sz = std::vector(bhat.size(), n); - } - if (array != R_NilValue) { - arr = cpp11::as_cpp>(array); - } else { - arr = std::vector(bhat.size(), 1); - } - return mcmc_data(bhat, block_sizes, sz, arr); -} - -// The seed R passes, or a drawn one for NULL. -unsigned int sdpr_seed(sexp seed) { - if (seed != R_NilValue) { - return cpp11::as_cpp(seed); - } - return std::random_device{}(); -} - -cpp11::writable::list sdpr_output(std::unordered_map& results) { - using namespace cpp11::literals; - writable::list output({ - "betaEst"_nm = as_doubles(results["beta"]), - "h2"_nm = as_doubles(results["h2"]) - }); - return output; -} - -} // namespace - -// cpp11 interface function -[[cpp11::register]] -cpp11::writable::list sdprCpp( - const doubles& bhatR, - const list& LD, - int n, - sexp perVariantSampleSize = R_NilValue, - sexp array = R_NilValue, - double a = 0.1, - double c = 1.0, - int M = 1000, - double a0k = 0.5, - double b0k = 0.5, - int iter = 1000, - int burn = 200, - int thin = 5, - int numThreads = 1, - int optLlk = 1, - bool verbose = true, - sexp seed = R_NilValue - ) { - // Convert list to std::vector - std::vector ref_ld_mat; - std::vector block_sizes; - for (int i = 0; i < LD.size(); i++) { - ref_ld_mat.push_back(as_Mat(doubles_matrix<>(LD[i]))); - block_sizes.push_back(ref_ld_mat.back().n_rows); - } - - mcmc_data data = sdpr_data(bhatR, block_sizes, n, perVariantSampleSize, array, c); - std::vector blocks = - sdpr_dense_blocks(data, std::move(ref_ld_mat), a, n, optLlk); - - std::unordered_map results = mcmc( - data, blocks, M, a0k, b0k, iter, burn, thin, numThreads, verbose, - sdpr_seed(seed) - ); - return sdpr_output(results); -} - -/** - * @brief SDPR from a factor F of the LD, R = F'F / (m - 1), never forming R. - * - * The arguments are sdprCpp()'s with `factorR` (m x p) in place of the LD - * blocks; the window is one block. The sampler is SDPR's own, run on the - * low-rank form of its matrices (sdpr_factor_block()), so it draws as - * sdprCpp() does on the matrix the factor gives. - */ -[[cpp11::register]] -cpp11::writable::list sdprFactorCpp( - const doubles& bhatR, - const doubles_matrix<>& factorR, - int n, - sexp perVariantSampleSize = R_NilValue, - sexp array = R_NilValue, - double a = 0.1, - double c = 1.0, - int M = 1000, - double a0k = 0.5, - double b0k = 0.5, - int iter = 1000, - int burn = 200, - int thin = 5, - int numThreads = 1, - int optLlk = 1, - bool verbose = true, - sexp seed = R_NilValue - ) { - mat F = as_Mat(factorR); - if (F.n_cols != static_cast(bhatR.size())) - cpp11::stop("The LD factor has %d columns but there are %d effects.", - (int)F.n_cols, (int)bhatR.size()); - - mcmc_data data = sdpr_data(bhatR, {F.n_cols}, n, perVariantSampleSize, array, c); - std::vector blocks = { - sdpr_factor_block(data, F, a, n, optLlk) - }; - - std::unordered_map results = mcmc( - data, blocks, M, a0k, b0k, iter, burn, thin, numThreads, verbose, - sdpr_seed(seed) - ); - return sdpr_output(results); -} diff --git a/src/sdpr_mcmc.cpp b/src/sdpr_mcmc.cpp deleted file mode 100644 index e09c5b1e8..000000000 --- a/src/sdpr_mcmc.cpp +++ /dev/null @@ -1,739 +0,0 @@ -// sdpr_mcmc.cpp -- SDPR MCMC sampler using Armadillo -// -// Clean Armadillo port of the original SDPR by Zhou et al. -// (https://github.com/eldronzhou/SDPR), which used GSL + x86 SSE intrinsics. -// -// Translation strategy: -// GSL gsl_blas_dsymv -> M * v, with M symmetrized once when it is built -// GSL gsl_blas_dgemv -> A.t() * v -// GSL gsl_blas_dgemm -> A * B -// GSL gsl_blas_dtrsv -> arma::solve(trimatl(L), v) -// GSL gsl_blas_dtrsm -> arma::solve(trimatl(L), A) -// GSL gsl_blas_ddot -> arma::dot(x, y) -// GSL gsl_blas_daxpy -> y += alpha * x -// GSL gsl_linalg_cholesky_decomp1 -> arma::chol(A, "lower") -// GSL gsl_ran_gamma -> std::gamma_distribution -// GSL gsl_ran_beta -> beta_distribution (ratio of gammas) -// GSL gsl_ran_ugaussian -> std::normal_distribution(0,1) -// GSL gsl_rng_uniform -> std::uniform_real_distribution(0,1) -// -// The original SSE intrinsics (log_ps, exp_ps, _mm_max_ps, _mm_hadd_ps) -// in sample_assignment() are replaced with Armadillo vectorized operations -// (arma::log, arma::exp, arma::max, arma::accu) which delegate to -// platform-optimal SIMD (NEON on ARM, SSE/AVX on x86) through the -// underlying BLAS/compiler auto-vectorization. -// -// The sampler reads each LD block through a block type (sdpr_mcmc.h): the -// dense matrices SDPR itself precomputes (sdpr_dense_blocks()), or their -// low-rank form from a factor of the LD (sdpr_factor_block()). - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include "function_pool.h" -#include "sdpr_mcmc.h" - -using std::cout; using std::endl; -using std::thread; using std::ref; -using std::vector; using std::ofstream; -using std::string; using std::min; - -// A function rather than the original macro, which would also expand inside -// arma::square(). -static inline double square(double x) { return x * x; } - -// --------------------------------------------------------------------------- -// sample_sigma2: Sample cluster variances from inverse-gamma posterior -// var_k ~ InvGamma(suff_stats[k]/2 + a0k, sumsq[k]/2 + b0k) -// Original: mcmc.cpp lines 25-40 -// --------------------------------------------------------------------------- -void MCMC_state::sample_sigma2() { - std::gamma_distribution dist; - for (size_t i = 1; i < M; i++) { - double a = suff_stats[i] / 2.0 + a0k; - double b = 1.0 / (sumsq[i] / 2.0 + b0k); - dist = std::gamma_distribution(a, b); - cluster_var[i] = 1.0 / dist(r); - if (std::isinf(cluster_var[i])) { - cluster_var[i] = 1e5; - REprintf("Cluster variance is infinite.\n"); - } - else if (cluster_var[i] == 0) { - cluster_var[i] = 1e-10; - REprintf("Cluster variance is zero.\n"); - } - } -} - -// --------------------------------------------------------------------------- -// calc_b: Compute the b vector for block j -// b_j = eta^2 * (diag(B)*beta - B*beta) + eta * A^T * beta_mrg -// Original: mcmc.cpp lines 42-62 -// gsl_blas_dsymv(CblasUpper, -eta*eta, B, beta, eta*eta, b) -// gsl_blas_daxpy(eta, calc_b_tmp, b) -// --------------------------------------------------------------------------- -template -void MCMC_state::calc_b(size_t j, const mcmc_data &dat, - const std::vector &blocks) { - size_t start_i = dat.boundary[j].first; - size_t end_i = dat.boundary[j].second; - - arma::vec beta_j = beta.subvec(start_i, end_i - 1); - - // Original GSL: b = eta^2 * diag(B)*beta; - // b = eta^2*b - eta^2 * B*beta (via dsymv with alpha=-eta^2, beta=eta^2) - // b += eta * calc_b_tmp - arma::vec b_j = eta * eta * (blocks[j].diag_B % beta_j - - blocks[j].B_times(beta_j)) - + eta * blocks[j].calc_b_tmp; - - b.subvec(start_i, end_i - 1) = b_j; -} - -// --------------------------------------------------------------------------- -// sample_assignment: Sample cluster assignments for each SNP in block j -// For each SNP i, compute log P(z_i = k) for k = 0..M-1, then sample. -// -// Original: mcmc.cpp lines 64-165 -// Used x86 SSE intrinsics (log_ps, exp_ps, _mm_max_ps, _mm_hadd_ps) -// to vectorize log/exp over M clusters. We use Armadillo vectorized -// ops instead, which auto-vectorize via NEON (ARM) or SSE/AVX (x86). -// -// Math for cluster k >= 1: -// C_k = eta^2 * N * B[i,i] * var_k + 1 -// log P(z_i=k) = -0.5*log(C_k) + log(p_k) + (N*b_i)^2 * var_k / (2*C_k) -// --------------------------------------------------------------------------- -template -void MCMC_state::sample_assignment(size_t j, const mcmc_data &dat, - const std::vector &blocks) { - size_t start_i = dat.boundary[j].first; - size_t end_i = dat.boundary[j].second; - size_t n_snp_blk = end_i - start_i; - - std::uniform_real_distribution unif(0.0f, 1.0f); - - // N = 1.0 after May 21 2021 (absorbed into A, B in solve_ldmat) - float C = static_cast(eta * eta * N); - - // Pre-convert cluster variances and log-probabilities to float vectors - // for Armadillo vectorized ops (matching original's float precision) - arma::fvec cvar(M); - arma::fvec log_p_fvec(M); - for (size_t k = 0; k < M; k++) { - cvar(k) = static_cast(cluster_var[k]); - log_p_fvec(k) = static_cast(log_p[k]); - } - - for (size_t i = 0; i < n_snp_blk; i++) { - float Bjj_i = static_cast(blocks[j].diag_B(i)); - float bj_i = static_cast(b(start_i + i)); - float rnd_i = unif(r); - - // prob[0] = log_p[0] (null cluster) - // prob[k] for k>=1: see math above - arma::fvec prob(M); - prob(0) = log_p_fvec(0); - - // Vectorized: Ck = C * Bjj * cvar[1..M-1] + 1 - arma::fvec Ck = C * Bjj_i * cvar.subvec(1, M - 1) + 1.0f; - - // prob[k] = -0.5*log(Ck) + log_p[k] + (N*bj)^2 * var_k / (2*Ck) - // Original: tmp[k] = log(prob[k]); prob[k] = -0.5*tmp[k] + log_p[k] + ... - prob.subvec(1, M - 1) = -0.5f * arma::log(Ck) + log_p_fvec.subvec(1, M - 1) - + square(N * bj_i) * cvar.subvec(1, M - 1) / (2.0f * Ck); - - // Log-sum-exp for numerical stability (replaces SSE _mm_max_ps + exp_ps + _mm_hadd_ps) - float max_elem = prob.max(); - float log_exp_sum = max_elem - + std::logf(arma::accu(arma::exp(prob - max_elem))); - - // Categorical sampling via inverse CDF - // Original: mcmc.cpp lines 155-163 - cls_assgn[i + start_i] = M - 1; - for (size_t k = 0; k < M - 1; k++) { - rnd_i -= std::expf(prob(k) - log_exp_sum); - if (rnd_i < 0) { - cls_assgn[i + start_i] = k; - break; - } - } - } -} - -// --------------------------------------------------------------------------- -// update_suffstats: Count SNPs per cluster and sum of squared effects -// Original: mcmc.cpp lines 167-175 -// --------------------------------------------------------------------------- -void MCMC_state::update_suffstats() { - std::fill(suff_stats.begin(), suff_stats.end(), 0); - std::fill(sumsq.begin(), sumsq.end(), 0.0); - for (size_t i = 0; i < n_snp; i++) { - suff_stats[cls_assgn[i]]++; - double tmp = beta(i); - sumsq[cls_assgn[i]] += square(tmp); - } -} - -// --------------------------------------------------------------------------- -// sample_V: Sample stick-breaking fractions from Beta posterior -// V[k] ~ Beta(1 + suff_stats[k], alpha + sum_{k'>k} suff_stats[k']) -// Original: mcmc.cpp lines 177-189 -// --------------------------------------------------------------------------- -void MCMC_state::sample_V() { - vector a(M - 1); - a[M - 2] = suff_stats[M - 1]; - for (int i = M - 3; i >= 0; i--) { - a[i] = suff_stats[i + 1] + a[i + 1]; - } - - for (size_t i = 0; i < M - 1; i++) { - beta_distribution dist(1 + suff_stats[i], alpha + a[i]); - V[i] = dist(r); - } - V[M - 1] = 1; -} - -// --------------------------------------------------------------------------- -// update_p: Convert stick-breaking fractions V to cluster probabilities p -// p[0] = V[0]; p[k] = V[k] * prod_{j cumprod(M - 1); - cumprod[0] = 1 - V[0]; - for (size_t i = 1; i < M - 1; i++) { - cumprod[i] = cumprod[i - 1] * (1 - V[i]); - if (V[i] == 1) { - std::fill(cumprod.begin() + i + 1, cumprod.end(), 0.0); - break; - } - } - - p[0] = V[0]; - for (size_t i = 1; i < M - 1; i++) { - p[i] = cumprod[i - 1] * V[i]; - } - - double sum = std::accumulate(p.begin(), p.end() - 1, 0.0); - p[M - 1] = (1 - sum > 0) ? (1 - sum) : 0; - - for (size_t i = 0; i < M; i++) { - log_p[i] = std::logf(static_cast(p[i]) + 1e-40f); - } -} - -// --------------------------------------------------------------------------- -// sample_alpha: Sample Dirichlet process concentration parameter -// alpha ~ Gamma(0.1 + m - 1, 1/(0.1 - sum(log(1-V)))) -// Original: mcmc.cpp lines 224-237 -// --------------------------------------------------------------------------- -void MCMC_state::sample_alpha() { - double sum = 0, m = 0; - for (size_t i = 0; i < M; i++) { - if (V[i] != 1) { - sum += std::log(1 - V[i]); - m++; - } - } - if (m == 0) m = 1; - - std::gamma_distribution dist(0.1 + m - 1, 1.0 / (0.1 - sum)); - alpha = dist(r); -} - -// --------------------------------------------------------------------------- -// sample_beta: Sample effect sizes for causal SNPs in block j -// Precision = eta^2*N*B_gamma + Sigma_0^{-1} -// Mean via Cholesky: L*L^T = Precision; mu = L^{-T}*L^{-1}*A_vec -// Sample: z ~ N(0,I); beta = L^{-T}*(L^{-1}*A_vec + z) -// -// Original: mcmc.cpp lines 239-329 -// Uses gsl_linalg_cholesky_decomp1, gsl_blas_dtrsv for forward/back-solve -// --------------------------------------------------------------------------- -template -void MCMC_state::sample_beta(size_t j, const mcmc_data &dat, - const std::vector &blocks) { - size_t start_i = dat.boundary[j].first; - size_t end_i = dat.boundary[j].second; - - // Build causal list (SNPs not in null cluster) - vector causal_list; - for (size_t i = start_i; i < end_i; i++) { - if (cls_assgn[i] != 0) { - causal_list.push_back(i); - } - } - - // Zero out this block's betas - beta.subvec(start_i, end_i - 1).zeros(); - - if (causal_list.empty()) { - num[j] = 0; - denom[j] = 0; - return; - } - - // Single causal SNP: closed-form sampling - // Original: mcmc.cpp lines 259-270 - if (causal_list.size() == 1) { - double var_k = cluster_var[cls_assgn[causal_list[0]]]; - double bj = b(causal_list[0]); - double Bjj = blocks[j].diag_B(causal_list[0] - start_i); - // C = var_k / (N * var_k * eta^2 * Bjj + 1) - double C_val = var_k / (N * var_k * square(eta) * Bjj + 1.0); - std::normal_distribution dist(0.0, std::sqrt(C_val)); - double rv = dist(r) + C_val * N * bj; - beta(causal_list[0]) = rv; - num[j] = bj * rv; - denom[j] = square(rv) * Bjj; - return; - } - - // Multiple causal SNPs: multivariate normal sampling via Cholesky - size_t nc = causal_list.size(); - - // A_vec = N * eta * A^T * beta_mrg (restricted to causal indices) - // Original: mcmc.cpp line 279: N*eta*gsl_vector_get(calc_b_tmp, idx) - arma::vec A_vec(nc); - double C_coeff = square(eta) * N; // Original: C = square(eta)*N (line 273) - - // Build precision matrix B_gamma and A_vec - // Original: mcmc.cpp lines 278-289 - arma::uvec causal_idx(nc); - for (size_t i = 0; i < nc; i++) { - causal_idx(i) = causal_list[i] - start_i; - A_vec(i) = N * eta * blocks[j].calc_b_tmp(causal_idx(i)); - } - // Off-diagonal: eta^2 * N * B[i,k]; diagonal: eta^2 * N * B[i,i] + 1/var_k - arma::mat B_gamma = C_coeff * blocks[j].B_sub(causal_idx); - for (size_t i = 0; i < nc; i++) { - B_gamma(i, i) += 1.0 / cluster_var[cls_assgn[causal_list[i]]]; - } - - arma::vec A_vec2 = A_vec; // Save for eta computation - - // Sample z ~ N(0, I) - arma::vec beta_c(nc); - std::normal_distribution dist(0.0, 1.0); - for (size_t i = 0; i < nc; i++) { - beta_c(i) = dist(r); - } - - // Cholesky: B_gamma = L * L^T - // Original: gsl_linalg_cholesky_decomp1(&B.matrix) - arma::mat L = arma::chol(B_gamma, "lower"); - - // mu = L^{-1} * A_vec (forward-solve) - // Original: gsl_blas_dtrsv(CblasLower, CblasNoTrans, CblasNonUnit, &B, A_vec) - A_vec = arma::solve(arma::trimatl(L), A_vec); - - // beta_c = mu + z ~ N(mu, I) - beta_c += A_vec; - - // beta_c = L^{-T} * beta_c ~ N(L^{-T}*mu, (L*L^T)^{-1}) - // Original: gsl_blas_dtrsv(CblasLower, CblasTrans, CblasNonUnit, &B, beta_c) - beta_c = arma::solve(arma::trimatu(L.t()), beta_c); - - // Compute eta-related terms for sample_eta() - // Original: mcmc.cpp lines 312-321 - // Restore diagonal of B_gamma to eta^2 * N * B[i,i] (without 1/var_k) - for (size_t i = 0; i < nc; i++) { - B_gamma(i, i) = C_coeff * blocks[j].diag_B(causal_idx(i)); - } - - // num = A_vec2^T * beta_c / eta - num[j] = arma::dot(A_vec2, beta_c) / eta; - - // denom = beta_c^T * B_gamma * beta_c / eta^2 - // Original: gsl_blas_dsymv(CblasUpper, 1.0, &B, beta_c, 0, A_vec) - arma::vec tmp = B_gamma * beta_c; - denom[j] = arma::dot(beta_c, tmp) / square(eta); - - // Write sampled betas back - for (size_t i = 0; i < nc; i++) { - beta(causal_list[i]) = beta_c(i); - } -} - -// --------------------------------------------------------------------------- -// compute_h2: Compute heritability h2 = sum_j beta_j^T * R_j * beta_j -// Original: mcmc.cpp lines 331-343 -// --------------------------------------------------------------------------- -template -void MCMC_state::compute_h2(const mcmc_data &dat, - const std::vector &blocks) { - h2 = 0; - for (size_t j = 0; j < blocks.size(); j++) { - size_t start_i = dat.boundary[j].first; - size_t end_i = dat.boundary[j].second; - arma::vec beta_j = beta.subvec(start_i, end_i - 1); - // Original: gsl_blas_dsymv(CblasUpper, 1.0, ref_ld_mat, beta, 0, tmp) - h2 += blocks[j].R_quad(beta_j); - } -} - -// --------------------------------------------------------------------------- -// sample_eta: Sample global scaling parameter -// eta ~ N(num_sum/denom_sum, 1/denom_sum) -// Original: mcmc.cpp lines 345-352 -// --------------------------------------------------------------------------- -void MCMC_state::sample_eta() { - double num_sum = std::accumulate(num.begin(), num.end(), 0.0); - double denom_sum = std::accumulate(denom.begin(), denom.end(), 0.0); - denom_sum += 1e-6; - - std::normal_distribution dist(num_sum / denom_sum, - std::sqrt(1.0 / denom_sum)); - eta = dist(r); -} - -// --------------------------------------------------------------------------- -// sdpr_llk2_matrix: The optLlk = 2 matrix B2 from one block's LD -// Each pair's LD is scaled by min(N_i, N_j) / (1.1 * N_i * N_j) and zeroed -// between arrays 1 and 2; the diagonal is then set to 1 / N_i, raised by -// 1.1 times the scaled matrix's most negative eigenvalue, if any, to keep -// B2 positive definite. -// -// Original: mcmc.cpp lines 368-402 -// --------------------------------------------------------------------------- -static arma::mat sdpr_llk2_matrix(arma::mat B, const mcmc_data &dat, - size_t start) { - size_t blk_size = B.n_rows; - for (size_t j = 0; j < blk_size; j++) { - for (size_t k = 0; k < blk_size; k++) { - size_t idx1 = j + start; - size_t idx2 = k + start; - if ((dat.array[idx1] == 1 && dat.array[idx2] == 2) || - (dat.array[idx1] == 2 && dat.array[idx2] == 1)) { - B(j, k) = 0; - } else { - B(j, k) *= min(dat.sz[idx1], dat.sz[idx2]) - / (1.1 * dat.sz[idx1] * dat.sz[idx2]); - } - } - } - - // Force positive definite via eigenvalue correction. Only the smallest - // eigenvalue is read, so no eigenvectors are computed. - double eval_min = arma::eig_sym(B).min(); - - // Restore exact symmetry before the diagonal is reset - B = arma::symmatu(B); - - // Add to diagonal to ensure PD - for (size_t j = 0; j < blk_size; j++) { - double diag_val = 1.0 / dat.sz[j + start]; - if (eval_min < 0) diag_val -= 1.1 * eval_min; - B(j, j) = diag_val; - } - return B; -} - -// --------------------------------------------------------------------------- -// sdpr_dense_blocks: Precompute LD-derived matrices B and A' beta_mrg for -// each block -// opt_llk=1: B0 = R + aI; A = B0^{-1} R * sz; B = R * A -// opt_llk=2: B0 = sdpr_llk2_matrix(R); A = B0^{-1} R; B = R * A -// -// Original: mcmc.cpp lines 354-431 (solve_ldmat) -// Uses gsl_linalg_cholesky_decomp1, gsl_blas_dtrsm for matrix solves. The -// original also kept A and R .* R per block, which nothing reads after -// this, so neither is kept here. -// --------------------------------------------------------------------------- -std::vector sdpr_dense_blocks(const mcmc_data &dat, - std::vector ref_ld_mat, - double a, unsigned sz, - int opt_llk) { - std::vector blocks; - for (size_t i = 0; i < ref_ld_mat.size(); i++) { - size_t start = dat.boundary[i].first; - size_t blk_size = dat.boundary[i].second - start; - const arma::mat &R = ref_ld_mat[i]; - - arma::mat B0; - if (opt_llk == 1) { - // B0 = R + a*I (diagonal shrinkage) - // Original: gsl_vector_add_constant(&diag.vector, a) - B0 = R; - B0.diag() += a; - } else { - B0 = sdpr_llk2_matrix(R, dat, start); - } - - // Cholesky: B0 = L_chol * L_chol^T - // Original: gsl_linalg_cholesky_decomp1(B) - arma::mat L_chol = arma::chol(B0, "lower"); - - // A = B0^{-1} * R via forward then back-solve - // Original: gsl_blas_dtrsm(Left, Lower, NoTrans, NonUnit, 1.0, B, A) - // gsl_blas_dtrsm(Left, Lower, Trans, NonUnit, 1.0, B, A) - arma::mat A = arma::solve(arma::trimatl(L_chol), R); - A = arma::solve(arma::trimatu(L_chol.t()), A); - - // Scale by sample size for opt_llk=1 - if (opt_llk == 1) { - A *= sz; - } - - // Precompute A^T * beta_mrg for calc_b() - // Original: gsl_blas_dgemv(CblasTrans, 1.0, A, beta_mrg, 0, b_tmp) - arma::vec beta_mrg(blk_size); - for (size_t j = 0; j < blk_size; j++) { - beta_mrg(j) = dat.beta_mrg[j + start]; - } - - SdprDenseBlock blk; - // B = R * A. The sampler reads it as symmetric (the original through - // dsymv), so it is symmetrized once here rather than on every product. - // Original: gsl_blas_dgemm(NoTrans, NoTrans, 1.0, L, A, 0, B) - blk.B = arma::symmatu(R * A); - blk.diag_B = blk.B.diag(); - blk.calc_b_tmp = A.t() * beta_mrg; - blk.R = arma::symmatu(R); - blocks.push_back(std::move(blk)); - } - return blocks; -} - -// --------------------------------------------------------------------------- -// sdpr_factor_root: R = Z Z' for the factor F (m x p) of R = F'F / (m - 1) -// Z (p x r) has orthogonal columns with Z'Z = diag(lambda), lambda the -// nonzero eigenvalues of R, from the eigendecomposition of the smaller of -// G G' and G'G (G = F / sqrt(m - 1)). Eigenvalues at the rounding level of -// that decomposition are dropped. -// --------------------------------------------------------------------------- -static arma::mat sdpr_factor_root(const arma::mat &F) { - arma::mat G = F / std::sqrt(static_cast(F.n_rows) - 1.0); - bool wide = G.n_rows <= G.n_cols; - arma::mat gram = wide ? arma::mat(G * G.t()) : arma::mat(G.t() * G); - arma::vec lam; - arma::mat Q; - arma::eig_sym(lam, Q, gram); - double tol = lam.is_empty() ? 0.0 - : lam.max() * gram.n_rows * arma::datum::eps; - arma::uvec keep = arma::find(lam > tol); - if (wide) { - return G.t() * Q.cols(keep); - } - return Q.cols(keep) * arma::diagmat(arma::sqrt(lam(keep))); -} - -// --------------------------------------------------------------------------- -// sdpr_llk2_solve: B2^{-1} rhs for the block R = Z Z', with B2 as -// sdpr_llk2_matrix() builds it, without forming B2 while it has a narrow -// low-rank part -// B2 = T - diag(T) + D0 with T = R .* S .* Mask, D0 = diag(1 / N) + fix. -// S_ij = 1 / (1.1 max(N_i, N_j)) is a sum over the K distinct sample sizes -// n_1 < ... < n_K, -// S = sum_l Delta_l 1_l 1_l' / 1.1, 1_l = [N_i <= n_l], -// Delta_l = 1 / n_l - 1 / n_(l+1) (1 / n_K for l = K), -// so R .* S = U_S U_S' with U_S = [sqrt(Delta_l / 1.1) diag(1_l) Z]_l. -// The array mask keeps the pairs within arrays {0, 1} and within {0, 2}, -// which counts the pairs within array 0 twice, so T = U Sigma U' with -// U = [P01 U_S, P02 U_S, P0 U_S] and Sigma = diag(I, I, -I). -// While U is narrower than p, T is singular, its most negative eigenvalue -// is that of the small (U'U)^(1/2) Sigma (U'U)^(1/2), and the Woodbury -// identity solves B2 = U Sigma U' + D through an inner matrix as wide as U. -// Otherwise B2 is formed exactly as the dense route forms it. -// --------------------------------------------------------------------------- -static arma::mat sdpr_llk2_solve(const mcmc_data &dat, const arma::mat &Z, - const arma::mat &rhs) { - size_t p = Z.n_rows; - size_t r = Z.n_cols; - arma::vec sz(dat.sz); - arma::ivec arr = arma::conv_to::from(dat.array); - arma::vec levels = arma::unique(sz); - size_t K = levels.n_elem; - bool masked = arma::any(arr == 1) && arma::any(arr == 2); - size_t width = (masked ? 3 : 1) * K * r; - - if (width >= p) { - arma::mat L_chol = arma::chol(sdpr_llk2_matrix(Z * Z.t(), dat, 0), - "lower"); - arma::mat Y = arma::solve(arma::trimatl(L_chol), rhs); - return arma::solve(arma::trimatu(L_chol.t()), Y); - } - - arma::mat U_S(p, K * r); - for (size_t l = 0; l < K; l++) { - double next = (l + 1 < K) ? 1.0 / levels(l + 1) : 0.0; - double delta = 1.0 / levels(l) - next; - arma::vec in_l = arma::conv_to::from(sz <= levels(l)); - U_S.cols(l * r, (l + 1) * r - 1) = - std::sqrt(delta / 1.1) * (Z.each_col() % in_l); - } - - arma::mat U = U_S; - arma::vec sigma(width, arma::fill::ones); - // Unmasked, T = U_S U_S' is positive semidefinite (and singular), so its - // smallest eigenvalue is 0 and B2 needs no fix. - double eval_min = 0.0; - if (masked) { - arma::vec p01 = arma::conv_to::from(arr != 2); - arma::vec p02 = arma::conv_to::from(arr != 1); - arma::vec p0 = arma::conv_to::from(arr == 0); - U = arma::join_rows(U_S.each_col() % p01, U_S.each_col() % p02, - U_S.each_col() % p0); - sigma.tail(K * r).fill(-1.0); - arma::vec omega; - arma::mat P; - arma::eig_sym(omega, P, U.t() * U); - arma::mat root = P - * arma::diagmat(arma::sqrt(arma::clamp(omega, 0.0, - arma::datum::inf))) - * P.t(); - arma::vec small = arma::eig_sym(root * arma::diagmat(sigma) * root); - eval_min = std::min(0.0, small.min()); - } - - // D: 1 / N_i in place of T's own diagonal R_ii / (1.1 N_i), plus the fix. - arma::vec d = 1.0 / sz - arma::sum(arma::square(Z), 1) / (1.1 * sz); - if (eval_min < 0) d -= 1.1 * eval_min; - - arma::mat UD = U.each_col() / d; - arma::mat D_rhs = rhs.each_col() / d; - arma::mat inner = arma::diagmat(sigma) + U.t() * UD; - return D_rhs - UD * arma::solve(inner, U.t() * D_rhs); -} - -// --------------------------------------------------------------------------- -// sdpr_factor_block: The one block's B and A' beta_mrg from a factor of R -// With R = Z Z' = V diag(lambda) V': -// opt_llk=1: A = n (R + aI)^{-1} R = n V diag(lambda / (lambda + a)) V' and -// B = R A = W W', W = sqrt(n) V diag(lambda / sqrt(lambda + a)). -// opt_llk=2: A = B2^{-1} R and B = R A = Z H Z', H = Z' B2^{-1} Z (r x r), -// so W = Z H^(1/2) and B2^{-1} is needed only on Z and beta_mrg. -// --------------------------------------------------------------------------- -SdprFactorBlock sdpr_factor_block(const mcmc_data &dat, const arma::mat &F, - double a, unsigned sz, int opt_llk) { - SdprFactorBlock blk; - blk.Z = sdpr_factor_root(F); - const arma::mat &Z = blk.Z; - size_t p = Z.n_rows; - size_t r = Z.n_cols; - arma::vec beta_mrg(dat.beta_mrg); - - if (r == 0) { - // No LD at all (every variant monomorphic): B and A vanish. - blk.W.zeros(p, 0); - blk.calc_b_tmp.zeros(p); - } else if (opt_llk == 1) { - double n = static_cast(sz); - arma::vec lam = arma::sum(arma::square(Z), 0).t(); - arma::mat V = Z.each_row() / arma::sqrt(lam).t(); - blk.W = std::sqrt(n) - * (V.each_row() % (lam / arma::sqrt(lam + a)).t()); - blk.calc_b_tmp = n * (V * ((lam / (lam + a)) % (V.t() * beta_mrg))); - } else { - arma::mat Y = sdpr_llk2_solve(dat, Z, arma::join_rows(Z, beta_mrg)); - arma::mat H = Z.t() * Y.head_cols(r); - H = 0.5 * (H + H.t()); - arma::vec h; - arma::mat Q; - arma::eig_sym(h, Q, H); - blk.W = Z * Q - * arma::diagmat(arma::sqrt(arma::clamp(h, 0.0, arma::datum::inf))); - blk.calc_b_tmp = Z * (Z.t() * Y.col(r)); - } - blk.diag_B = arma::sum(arma::square(blk.W), 1); - return blk; -} - -// --------------------------------------------------------------------------- -// mcmc: Main MCMC loop -// Original: mcmc.cpp lines 434-513 -// --------------------------------------------------------------------------- -template -std::unordered_map mcmc( - const mcmc_data& data, - const std::vector& blocks, - size_t M, - double a0k, - double b0k, - int iter, - int burn, - int thin, - unsigned n_threads, - bool verbose, - unsigned int seed - ) { - - int n_pst = (iter - burn) / thin; - - MCMC_state state(data.beta_mrg.size(), M, blocks.size(), a0k, b0k, seed); - - MCMC_samples samples(data.beta_mrg.size()); - - state.update_suffstats(); - - Function_pool func_pool(n_threads); - - for (int j = 1; j < iter + 1; j++) { - state.sample_sigma2(); - - for (size_t i = 0; i < blocks.size(); i++) { - state.calc_b(i, data, blocks); - } - - // sample_assignment dispatched to thread pool across LD blocks. - // NOTE: std::mt19937 is not thread-safe. With n_threads > 1 there - // is a data race on MCMC_state::r. This matches the original SDPR - // (eldronzhou/SDPR) which has the same issue with gsl_rng. The - // default n_threads=1 avoids the race. For safe parallelism, each - // block would need its own RNG seeded from the shared one. - for (size_t i = 0; i < blocks.size(); i++) { - func_pool.push(std::bind(&MCMC_state::sample_assignment, - &state, i, std::cref(data), - std::cref(blocks))); - } - func_pool.waitFinished(); - - state.update_suffstats(); - state.sample_V(); - state.update_p(); - state.sample_alpha(); - - for (size_t i = 0; i < blocks.size(); i++) { - state.sample_beta(i, data, blocks); - } - - state.sample_eta(); - - // Collect posterior samples - if ((j > burn) && (j % thin == 0)) { - state.compute_h2(data, blocks); - samples.h2 += state.h2 * square(state.eta) / n_pst; - samples.beta += state.eta / n_pst * state.beta; - } - - if (verbose && j % 100 == 0) { - state.compute_h2(data, blocks); - Rprintf("%d iter. h2: %g max beta: %g\n", - j, state.h2 * square(state.eta), - arma::max(state.beta) * state.eta); - } - } - - if (verbose) { - Rprintf("h2: %g max: %g\n", samples.h2, arma::max(samples.beta)); - } - - std::unordered_map results; - results["beta"] = samples.beta; - results["h2"] = arma::vec(1, arma::fill::value(samples.h2)); - - return results; -} - -template std::unordered_map mcmc( - const mcmc_data&, const std::vector&, size_t, double, - double, int, int, int, unsigned, bool, unsigned int); -template std::unordered_map mcmc( - const mcmc_data&, const std::vector&, size_t, double, - double, int, int, int, unsigned, bool, unsigned int); diff --git a/src/sdpr_mcmc.h b/src/sdpr_mcmc.h deleted file mode 100644 index 0797bd801..000000000 --- a/src/sdpr_mcmc.h +++ /dev/null @@ -1,262 +0,0 @@ -#include -#include -#include -#include -#include -#include - -class beta_distribution { -public: -// Constructor that takes alpha and beta parameters -beta_distribution(double alpha, double beta) - : a_distribution(alpha, 1.0), b_distribution(beta, 1.0) { -} - -// Generates a beta-distributed random number -template -double operator()(RNG& rng) { - double x = a_distribution(rng); - double y = b_distribution(rng); - return x / (x + y); -} - -private: -std::gamma_distribution a_distribution; -std::gamma_distribution b_distribution; -}; - -/** - * @class mcmc_data - * @brief The per-SNP data the MCMC algorithm reads, and where each LD block's - * SNPs sit in it. - * - * - beta_mrg: the marginal beta values for each SNP, deflated by `c`. - * - boundary: the [start, end) positions of each LD block's SNPs. - * - sz: the sample size of each SNP. - * - array: the genotyping array of each SNP (0 = every cohort, 1 or 2 = the - * cohorts genotyped on that array). Pairs of SNPs on arrays 1 and 2 share - * no samples, so the optLlk = 2 likelihood zeroes their LD. - * - * Example usage: - * @code - * std::vector beta_mrg = {0.1, 0.2, 0.3, 0.4, 0.5}; - * std::vector block_sizes = {2, 3}; - * std::vector sz = {1000, 1000, 1500, 1500, 1500}; - * std::vector array = {1, 1, 2, 2, 2}; - * - * mcmc_data data(beta_mrg, block_sizes, sz, array); - * @endcode - */ -class mcmc_data { -public: -std::vector beta_mrg; -std::vector > boundary; -std::vector sz; -std::vector array; - -mcmc_data(const std::vector& beta_mrg, - const std::vector& block_sizes, - const std::vector& sz, - const std::vector& array) - : beta_mrg(beta_mrg), sz(sz), array(array) { - size_t start = 0; - for (size_t size : block_sizes) { - boundary.emplace_back(start, start + size); - start += size; - } -} -}; - -// What the sampler reads from one LD block, R. B is the matrix of the -// likelihood: n R (R + aI)^{-1} R for optLlk = 1, R B2^{-1} R for optLlk = 2 -// (B2 the scaled R of solve_ldmat), and calc_b_tmp the matching -// A' beta_mrg. The sampler asks B for its diagonal, a product B beta, and the -// submatrix over the causal SNPs, and R for beta'R beta (the heritability). -// Each block type below answers those from one way of holding the matrices, -// so the sampler runs unchanged on either. - -// B and R held whole, each symmetrized once. -struct SdprDenseBlock { - arma::mat B; - arma::mat R; - arma::vec diag_B; - arma::vec calc_b_tmp; - - arma::vec B_times(const arma::vec& beta) const { return B * beta; } - arma::mat B_sub(const arma::uvec& idx) const { return B.submat(idx, idx); } - double R_quad(const arma::vec& beta) const { - return arma::dot(R * beta, beta); - } -}; - -// R = Z Z' with Z (p x r) from a factor of R, and B = W W'. B has rank at -// most r under either likelihood, since it is R times a matrix times R, so a -// product costs O(pr) and neither p x p matrix is formed. -struct SdprFactorBlock { - arma::mat W; - arma::mat Z; - arma::vec diag_B; - arma::vec calc_b_tmp; - - arma::vec B_times(const arma::vec& beta) const { - return W * (W.t() * beta); - } - arma::mat B_sub(const arma::uvec& idx) const { - arma::mat W_c = W.rows(idx); - return W_c * W_c.t(); - } - double R_quad(const arma::vec& beta) const { - arma::vec t = Z.t() * beta; - return arma::dot(t, t); - } -}; - -class MCMC_state { -public: -double alpha; -double eta; -double h2; -double N; -arma::vec beta; -arma::vec b; -std::vector cls_assgn; -std::vector V; -std::vector p; -std::vector log_p; -std::vector cluster_var; -std::vector suff_stats; -std::vector sumsq; -// Each block's terms of the eta update, from sample_beta(). -std::vector num; -std::vector denom; -MCMC_state(size_t num_snp, size_t max_cluster, size_t num_blocks, \ - double a0, double b0, unsigned int seed) { - a0k = a0; b0k = b0; - // Changed May 20 2021 - // N (sz) is absorbed into A, B; so set to 1. - N = 1.0; - - n_snp = num_snp; - M = max_cluster; - alpha = 1; - eta = 1; - beta = arma::vec(num_snp, arma::fill::zeros); - b = arma::vec(num_snp, arma::fill::zeros); - p.assign(max_cluster, 1.0/max_cluster); - log_p.assign(max_cluster, 0); - for (size_t i=0; i -void calc_b(size_t j, const mcmc_data &dat, const std::vector &blocks); -template -void sample_assignment(size_t j, const mcmc_data &dat, \ - const std::vector &blocks); -void update_suffstats(); -void sample_V(); -void update_p(); -void sample_alpha(); -template -void sample_beta(size_t j, const mcmc_data &dat, \ - const std::vector &blocks); -template -void compute_h2(const mcmc_data &dat, const std::vector &blocks); -void sample_eta(); - -private: -double a0k; -double b0k; -size_t M, n_snp; -std::mt19937 r; -}; - -class MCMC_samples { -public: -arma::vec beta; -double h2; -MCMC_samples(size_t num_snps) { - beta = arma::vec(num_snps, arma::fill::zeros); - h2 = 0; -} -}; - -/** - * @brief The dense LD blocks of the SDPR likelihood (solve_ldmat). - * - * @param dat The per-SNP data, with beta_mrg already deflated by `c`. - * @param ref_ld_mat The LD matrix of each block, taken over. - * @param a Factor to shrink the reference LD matrix (optLlk = 1). - * @param sz The sample size of the GWAS (optLlk = 1). - * @param opt_llk 1 for equation 6 (slightly shrink the correlation of SNPs) - * and 2 for equation 5 (SNPs genotyped on different arrays in a separate - * cohort). - */ -std::vector sdpr_dense_blocks(const mcmc_data &dat, - std::vector ref_ld_mat, - double a, unsigned sz, - int opt_llk); - -/** - * @brief The one LD block of the SDPR likelihood from a factor of its LD, - * R = F'F / (m - 1), never forming R or B. - * - * The arguments are sdpr_dense_blocks()'s with the factor F (m x p) in place - * of the LD matrices. B and A' beta_mrg agree with the dense block's to - * rounding: optLlk = 1 has them in closed form from the eigenvalues of R; - * optLlk = 2 applies B2^{-1} to r + 1 vectors, through the Woodbury identity - * while B2's low-rank part is narrower than p, and otherwise by forming B2. - */ -SdprFactorBlock sdpr_factor_block(const mcmc_data &dat, const arma::mat &F, - double a, unsigned sz, int opt_llk); - -/** - * @brief Perform Markov Chain Monte Carlo (MCMC) for estimating effect sizes. - * - * @param data The `mcmc_data` object, with beta_mrg deflated by `c`. - * @param blocks The LD blocks, one per `data.boundary` entry - * (sdpr_dense_blocks() or sdpr_factor_block()). - * @param M Max number of variance components. Default is 1000. - * @param a0k Hyperparameter for inverse gamma distribution. Default is 0.5. - * @param b0k Hyperparameter for inverse gamma distribution. Default is 0.5. - * @param iter Number of iterations for MCMC. Default is 1000. - * @param burn Number of burn-in iterations for MCMC. Default is 200. - * @param thin Thinning interval for MCMC. Default is 5. - * @param n_threads Number of threads to use. Default is 1. - * @param verbose Whether to print verbose output. Default is true. - * @param seed Seed of the sampler's random number generator. - * - * @return An `std::unordered_map` with "beta", the estimated effect sizes, - * and "h2", the estimated heritability. - */ -template -std::unordered_map mcmc( - const mcmc_data& data, - const std::vector& blocks, - size_t M, - double a0k, - double b0k, - int iter, - int burn, - int thin, - unsigned n_threads, - bool verbose, - unsigned int seed - ); diff --git a/tests/testthat/helper-fineMapping.R b/tests/testthat/helper-fineMapping.R index 0a0ac22c2..30741981f 100644 --- a/tests/testthat/helper-fineMapping.R +++ b/tests/testthat/helper-fineMapping.R @@ -120,7 +120,9 @@ delayedAssign( verbose = 0, seed = 1 ) - list(X = X, Y = Y, cv = cv, slice = pecotmr:::.fmSliceCv(cv, "susie")) + slice <- pecotmr:::.fmSliceCv(cv, "susie") + # The fold weights as cvResult() hands them out: named by variant. + list(X = X, Y = Y, cv = cv, slice = slice, foldWeights = slice$foldWeights) } # Built once: each build runs a susie fit per fold, and the tests only read @@ -169,10 +171,11 @@ delayedAssign(".twcvFixture", suppressMessages(.twcv_foldFits())) get(name, envir = env) } -# Row i of `x` as FineMappingRow() takes it: its element's columns as the -# topLoci table, plus its stored fit. +# Row i of `x` as FineMappingRow() takes it: its element's columns, as the +# row hands them out, as the topLoci table, plus its fit and CV. .fmExampleRowInputs <- function(x, i) { - el <- x[[i]] + parts <- pecotmr:::.fmrRowParts(x, i) + el <- as(parts, "GRanges") md <- as.data.frame(S4Vectors::mcols(el), optional = TRUE) ids <- sprintf( "%s:%d:%s:%s", @@ -183,9 +186,9 @@ delayedAssign(".twcvFixture", suppressMessages(.twcv_foldFits())) ) list( variantIds = ids, - susieFit = S4Vectors::mcols(x)$susieFit[[i]], + susieFit = susieFit(parts), topLoci = cbind(variant_id = ids, md), - cvResult = S4Vectors::mcols(x)$cvResult[[i]] + cvResult = cvResult(parts) ) } diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index 470f5a6c7..25557a5b6 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -106,6 +106,8 @@ makeTestLdMatrixBlocks <- function( list(panel = panel, blocks = blocks, ld = ld) } +# One genome-wide LDER estimate, stratified (with an enrichment table and a +# jackknife matrix) unless `with_enrichment = FALSE`. makeTestH2Estimate <- function(with_enrichment = TRUE) { enrich <- if (with_enrichment) { data.frame( @@ -135,19 +137,28 @@ makeTestH2Estimate <- function(with_enrichment = TRUE) { NULL } - new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.01, - interceptSe = 0.02, - localBlocks = NULL, - enrichment = enrich, - annotationJackknifeCoefs = annotationJackknifeCoefs, - scoreStats = NULL, - method = "lder", - nSnps = 100L, - traitName = "test" + .h2EstimateNew( + list(GenomicRanges::GRanges()), + list( + study = "test", + context = NA_character_, + trait = NA_character_, + method = "lder", + h2 = 0.3, + h2_se = 0.05, + intercept = 1.01, + intercept_se = 0.02, + p_value = NA_real_, + n_snps = 100L, + n_components = NA_integer_, + scale = NA_real_ + ), + list( + enrichment = list(enrich), + jackknife = list(annotationJackknifeCoefs), + score_stats = list(NULL) + ), + GenomicRanges::GRanges() ) } diff --git a/tests/testthat/helper-rrwFixtures.R b/tests/testthat/helper-rrwFixtures.R index fb657019c..93c33bd9f 100644 --- a/tests/testthat/helper-rrwFixtures.R +++ b/tests/testthat/helper-rrwFixtures.R @@ -42,7 +42,13 @@ var_y = 1, variantNames = colnames(LD) ) - list(stat = stat, LD = LD, ldReference = LdMatrix(LD), p = p, n = n) + list( + stat = stat, + LD = LD, + ldReference = LdMatrix(LD, nSamples = n), + p = p, + n = n + ) } # Multi-context (variants x conditions) fixture for mr.mash / mvSuSiE wrappers. @@ -59,14 +65,12 @@ B[2, ] <- rnorm(K, sd = 2) Y <- X %*% B + matrix(rnorm(n * K), n, K) colnames(Y) <- paste0("ctx", seq_len(K)) - Z <- exec( - cbind, - !!!map(seq_len(K), function(k) { - map_dbl(seq_len(p), function(j) { - summary(lm(Y[, k] ~ X[, j]))$coefficients[2, 3] - }) + marginalZ <- map(seq_len(K), function(k) { + map_dbl(seq_len(p), function(j) { + summary(lm(Y[, k] ~ X[, j]))$coefficients[2, 3] }) - ) + }) + Z <- exec(cbind, !!!marginalZ) colnames(Z) <- colnames(Y) list( X = X, @@ -81,11 +85,46 @@ # Variant ids chr1:100:A:G, chr1:200:A:G, ... for p variants, and an LdMatrix # over `R` named by them, for tests that build their own statistics and LD. +# `nSamples` is the reference size held-out selection reads. .rrwIds <- function(p) { sprintf("chr1:%d:A:G", 100L * seq_len(p)) } -.rrwLdMatrix <- function(R) { +.rrwLdMatrix <- function(R, nSamples = NA_integer_) { ids <- .rrwIds(nrow(R)) - LdMatrix(`dimnames<-`(R, list(ids, ids))) + LdMatrix(`dimnames<-`(R, list(ids, ids)), nSamples = nSamples) +} + +# A genotype panel's first `p` variants, the LD matrix it gives, and +# statistics with two strong effects, for the RSS weights that read either. +.rrwPanelStat <- function(p = 40) { + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + ids <- names(SummarizedExperiment::rowRanges(panel))[seq_len(p)] + R <- pecotmr:::.ldFromRef(panel, ids, "test") + set.seed(3) + effects <- replace(numeric(p), c(3, 20), c(4, -3)) + z <- as.vector(R %*% effects) + rnorm(p) + list( + panel = panel, + ldMatrix = LdMatrix(R, nSamples = ncol(panel)), + stat = list(z = z, n = rep(500, p), variantNames = ids) + ) +} + +# .rrwPanelStat()'s panel and LD, with statistics whose noise has the LD's +# covariance, as real marginal statistics do: the samplers that estimate a +# residual variance or diverge from them need statistics consistent with the +# LD. +.rrwPanelStatLd <- function() { + d <- .rrwPanelStat() + # Noise drawn through the factor, F'e / sqrt(k - 1), has covariance R + # even where R is singular, as it is here. + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + k <- nrow(ldFactor) + set.seed(3) + effects <- replace(numeric(ncol(ldFactor)), c(3, 20), c(4, -3)) + signal <- crossprod(ldFactor, ldFactor %*% effects) / (k - 1) + noise <- crossprod(ldFactor, rnorm(k)) / sqrt(k - 1) + d$stat$z <- as.vector(signal + noise) + d } diff --git a/tests/testthat/helper-s4Constructors.R b/tests/testthat/helper-s4Constructors.R index ce94f7143..6854cdab4 100644 --- a/tests/testthat/helper-s4Constructors.R +++ b/tests/testthat/helper-s4Constructors.R @@ -225,7 +225,7 @@ A1 = "A", A2 = "G", P = pv, - af = c(0.30, 0.20, 0.005, 0.40), # v3 fails MAF 0.01 + AF = c(0.30, 0.20, 0.005, 0.40), # v3 fails MAF 0.01 tss_distance = c(0L, 500L, 900000L, 2000000L), # v4 outside 1Mb cis tes_distance = c(0L, 500L, 900000L, 2000000L), qvalue = c(pBeta[i] / 5, 0.30, 0.60, 0.90) diff --git a/tests/testthat/helper-savedObjects.R b/tests/testthat/helper-savedObjects.R index 3b4fbfc08..4bfc88a49 100644 --- a/tests/testthat/helper-savedObjects.R +++ b/tests/testthat/helper-savedObjects.R @@ -1,8 +1,8 @@ # Objects as an earlier pecotmr saved them, for the updateObject() tests of # the collections (test_RangedTupleList.R, test_AllClasses.R, -# test_twasWeights.R, test_ColocBoostResult.R), test_LdStatistic.R, -# test_H2Estimate.R, test_QtlDataset.R and the panel tests in -# test_genotypeIo.R. +# test_twasWeights.R, test_crossValidation.R, test_ColocBoostResult.R), +# test_LdStatistic.R, test_H2Estimate.R, test_QtlDataset.R and the panel +# tests in test_genotypeIo.R. # `x` with each slot in `renames` (old name = current name) stored under its # old name, as an object saved before the rename holds it: R stores a slot as @@ -14,13 +14,15 @@ .savedUnderName <- function(x, old, new) { value <- methods::slot(x, new) attr(x, new) <- NULL - `slot<-`(x, old, check = FALSE, value = value) + methods::slot(x, old, check = FALSE) <- value + x } # A collection as saved before its references became per-row: one reference # (or NULL) in the slot and no row key. .savedWithOneLdRef <- function(x, ref) { - old <- `slot<-`(x, "ldReference", check = FALSE, value = ref) + old <- x + methods::slot(old, "ldReference", check = FALSE) <- ref md <- attr(old, "elementMetadata") md[["ldReference"]] <- NULL attr(old, "elementMetadata") <- md @@ -35,12 +37,13 @@ # A genotype panel as saved before panels recorded where their genotypes come # from: its dosages read through a GenotypeHandle's GhSeed at `path` -- one -# claiming `format`, which may be a format a handle no longer reads -- with -# no metadata and only the SNP / A1 / A2 variant columns, and reading the -# per-chromosome files `chromPaths` when given. Its variants, samples and -# sample data are copied from `panel`, today's panel over the same files. +# claiming `format`, which may be a format a handle no longer reads, its +# variant table whole and the seed naming its rows -- with no metadata and +# only the SNP / A1 / A2 variant columns, and reading the per-chromosome +# files `chromPaths` when given. Its variants, samples and sample data are +# copied from `panel`, today's panel over the same files. .savedHandlePanel <- function(panel, path, format, chromPaths = character(0)) { - rr <- SummarizedExperiment::rowRanges(panel) + rr <- .withPanelLabels(SummarizedExperiment::rowRanges(panel)) handle <- methods::new( "GenotypeHandle", path = path, @@ -57,9 +60,14 @@ pgenPtr = NULL, chromPaths = chromPaths ) - old <- `slot<-`(handle, "format", check = FALSE, value = format) + seed <- methods::new( + "GhSeed", + handle = `slot<-`(handle, "format", check = FALSE, value = format), + dm = dim(panel), + dn = list(rownames(panel), NULL) + ) SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = genotypeDelayedArray(old)), + assays = list(dosage = DelayedArray::DelayedArray(seed)), rowRanges = S4Vectors::`mcols<-`( rr, value = S4Vectors::mcols(rr)[c("SNP", "A1", "A2")] @@ -67,3 +75,80 @@ colData = SummarizedExperiment::colData(panel) ) } + +# `panel` as saved before panels shed their copies of their variants' +# labels: an SNP column repeating its row names, and a dosage seed naming +# its rows -- over `handle`, its variant table whole, for a panel read +# through a GenotypeHandle. The panel holds every row of its seed, in order; +# it may hold some of its columns (a mixture's cohort). +.savedLabelledPanel <- function(panel, handle = NULL) { + seed <- .panelSeed(panel) + labelled <- if (methods::is(seed, "GhSeed")) { + methods::new( + "GhSeed", + handle = handle, + dm = dim(seed), + dn = list(rownames(panel), NULL) + ) + } else { + methods::initialize( + seed, + dn = list(rownames(panel), dimnames(seed)[[2L]]) + ) + } + index <- .panelSeedIndex(panel) + SummarizedExperiment::SummarizedExperiment( + assays = list( + dosage = DelayedArray::DelayedArray(labelled)[, + index[[2L]], + drop = FALSE + ] + ), + rowRanges = .withPanelLabels(SummarizedExperiment::rowRanges(panel)), + colData = SummarizedExperiment::colData(panel), + metadata = S4Vectors::metadata(panel) + ) +} + +# `x` as saved with one row per (study, context, trait, method): each +# method's variants an element carrying its `weight` column (named by +# variant id when `named`, as rows once stored them), its payload the row's +# columns, plus any `extra` columns. Attributes are written directly, as a +# saved object holds them: that layout no longer validates. +.savedTwasPerMethod <- function(x, named = FALSE, extra = list()) { + cells <- .twasCells(x) + entries <- .collectionEntries(x) + grs <- map(entries, .savedTwasElement, named = named) + flat <- suppressWarnings(exec(c, !!!grs)) + dataFrameArgs <- c( + list( + study = cells$study, + context = cells$context, + trait = cells$trait, + method = cells$method, + fits = S4Vectors::SimpleList(map(entries, methodFits)), + cvResult = S4Vectors::SimpleList(map(entries, cvResult)), + standardized = map_lgl(entries, weightStandardized), + dataType = S4Vectors::SimpleList(map(entries, weightsDataType)), + ldReference = rep(NA_character_, nrow(cells)) + ), + extra, + list(check.names = FALSE) + ) + md <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) + saved <- x + attr(saved, "unlistData") <- flat + attr(saved, "partitioning") <- IRanges::PartitioningByEnd( + cumsum(lengths(grs)) + ) + attr(saved, "elementMetadata") <- md + saved +} + +.savedTwasElement <- function(e, named) { + gr <- variants(e) + if (named) { + S4Vectors::mcols(gr)$weight <- weights(e) + } + gr +} diff --git a/tests/testthat/test_AllClasses.R b/tests/testthat/test_AllClasses.R index b4761604b..1ed9696ab 100644 --- a/tests/testthat/test_AllClasses.R +++ b/tests/testthat/test_AllClasses.R @@ -57,7 +57,7 @@ context("AllClasses (virtual base classes)") ) } -.alc_makeFmEntry <- function(n = 3) { +.alc_makeFmEntry <- function(n = 3, fit = list()) { tl <- data.frame( variant_id = paste0("chr1:", 100 * seq_len(n), ":A:G"), chrom = rep("1", n), @@ -77,7 +77,7 @@ context("AllClasses (virtual base classes)") ) FineMappingRow( variantIds = tl$variant_id, - susieFit = list(), + susieFit = fit, topLoci = tl ) } @@ -331,11 +331,152 @@ test_that("updateObject() leaves a current summary-statistics object as is", { expect_message(updateObject(ss, verbose = TRUE), "updateObject") }) +# =========================================================================== +# Summary statistics stored compactly +# =========================================================================== + +# Variants as QC leaves them: each labelled with the id rendered from its +# position and alleles, P, BETA and SE derived from Z (and MAF and N), one +# sample size, and MAF named by the ids, as the example builders name it. +.alc_derivedGr <- function() { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(seq(100L, by = 100L, length.out = 4L), width = 1L), + A1 = rep("A", 4L), + A2 = rep("G", 4L) + ) + ids <- pecotmr:::.grVariantIds(gr) + z <- c(1.5, -0.4, 2.2, 0.1) + maf <- c(0.1, 0.25, 0.4, 0.3) + derived <- pecotmr:::.zToBetaSe(z, maf, rep(5000L, 4L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = ids, + A1 = rep("A", 4L), + A2 = rep("G", 4L), + Z = z, + N = rep(5000L, 4L), + MAF = set_names(maf, ids), + BETA = derived$beta, + SE = derived$se, + P = pecotmr:::.zToPvalue(z) + ) + gr +} + +.alc_gwasOf <- function(gr, studyName = "g1") { + GwasSumStats(studyName = studyName, entry = list(gr), genome = "hg19") +} + +test_that("summary statistics leave out what recomputes and hand it back", { + gr <- .alc_derivedGr() + x <- .alc_gwasOf(gr) + stored <- unlist(x, use.names = FALSE) + expect_identical( + colnames(S4Vectors::mcols(stored)), + c("A1", "A2", "Z", "N", "MAF") + ) + expect_identical( + S4Vectors::metadata(stored)$derivedColumns, + c("SNP", "BETA", "SE", "P") + ) + expect_s4_class(S4Vectors::mcols(stored)$N, "Rle") + want <- S4Vectors::mcols(gr) + want$MAF <- unname(want$MAF) + expect_identical(S4Vectors::mcols(x[[1L]]), want) + expect_null(S4Vectors::metadata(x[[1L]])$derivedColumns) + expect_identical(as.list(x)[[1L]], x[[1L]]) + expect_identical(unname(lapply(x, length)), list(4L)) + expect_identical(sumStats(x), x[[1L]]) +}) + +test_that("a derived column out of its usual place is kept", { + # P recomputes exactly, but it sits before N here, and putting it back + # where a row holds it would reorder the columns, so nothing is left out. + gr <- .alc_derivedGr() + md <- S4Vectors::mcols(gr) + S4Vectors::mcols(gr) <- md[c("SNP", "A1", "A2", "Z", "P", "N", "MAF")] + stored <- unlist(.alc_gwasOf(gr), use.names = FALSE) + expect_true(is_in("P", colnames(S4Vectors::mcols(stored)))) + expect_null(S4Vectors::metadata(stored)$derivedColumns) +}) + +test_that("a column the source never had is not handed back", { + gr <- .alc_derivedGr() + S4Vectors::mcols(gr)$P <- NULL + x <- .alc_gwasOf(gr) + expect_false(is_in("P", colnames(S4Vectors::mcols(x[[1L]])))) + expect_null(pval(x)) +}) + +test_that("labels and values that do not recompute exactly are kept", { + gr <- .alc_derivedGr() + S4Vectors::mcols(gr)$SNP <- str_c("rs", 1:4) + S4Vectors::mcols(gr)$P <- pmax(S4Vectors::mcols(gr)$P, 0.05) + stored <- unlist(.alc_gwasOf(gr), use.names = FALSE) + expect_true(all(is_in(c("SNP", "P"), colnames(S4Vectors::mcols(stored))))) + expect_identical( + S4Vectors::metadata(stored)$derivedColumns, + c("BETA", "SE") + ) + expect_identical(S4Vectors::mcols(stored)$SNP, str_c("rs", 1:4)) +}) + +test_that("a collection built from unlist() gets the columns left out back", { + x <- .alc_gwasOf(.alc_derivedGr()) + again <- .alc_gwasOf(unlist(x, use.names = FALSE)) + expect_identical(again[[1L]], x[[1L]]) +}) + +test_that("a rebuild keeps a column the caller dropped", { + x <- .alc_gwasOf(.alc_derivedGr()) + el <- x[[1L]] + S4Vectors::mcols(el)$P <- NULL + x[[1L]] <- el + expect_false(is_in("P", colnames(S4Vectors::mcols(x[[1L]])))) + expect_identical( + colnames(S4Vectors::mcols(x[[1L]])), + setdiff(colnames(S4Vectors::mcols(el)), "P") + ) +}) + +test_that("stored and plain collections combine with every column", { + a <- .alc_gwasOf(.alc_derivedGr(), "a") + gr <- .alc_derivedGr() + S4Vectors::mcols(gr)$SNP <- str_c("rs", 1:4) + b <- .alc_gwasOf(gr, "b") + both <- combineGwasSumStats(a, b) + expect_identical(both[[1L]], a[[1L]]) + expect_identical(both[[2L]], b[[1L]]) +}) + +test_that("updateObject() stores a collection saved in full compactly", { + x <- .alc_gwasOf(.alc_derivedGr()) + saved <- x + methods::slot(saved, "unlistData") <- pecotmr:::.ssPlainElement( + unlist(x, use.names = FALSE) + ) + up <- updateObject(saved) + expect_identical( + unlist(up, use.names = FALSE), + unlist(x, use.names = FALSE) + ) + expect_identical(up[[1L]], x[[1L]]) +}) + +test_that("a record of left-out columns the variants hold is refused", { + x <- .alc_gwasOf(.alc_derivedGr()) + flat <- unlist(x, use.names = FALSE) + S4Vectors::metadata(flat)$derivedColumns <- c("SNP", "A1") + bad <- x + methods::slot(bad, "unlistData", check = FALSE) <- flat + expect_error(methods::validObject(bad), "cannot leave out: A1") +}) + # =========================================================================== # FineMappingResultBase: adjustPips zero-row short-circuit # =========================================================================== -test_that("FineMappingResultBase: adjustPips on a zero-row collection returns the input unchanged", { +test_that("adjustPips returns a zero-row fine-mapping collection unchanged", { e <- .alc_makeFmEntry(3) res <- GwasFineMappingResult( studyName = "g1", @@ -370,7 +511,7 @@ test_that("topLoci() has no type switch: the stored table stays internal", { expect_error(topLoci(.alc_makeFmr2(), raw = TRUE), "unused argument") }) -test_that("QtlFineMappingResult: topLoci aggregates entries when selectors do not pin one", { +test_that("QtlFineMappingResult topLoci aggregates unless selectors pin one", { # Two entries, no selectors: the old behaviour errored ("2 entries; pass # study/context/trait/method"). Now it stacks the per-variant tables, # prefixed with the row identity so variants stay attributable. @@ -398,7 +539,7 @@ test_that("QtlFineMappingResult: topLoci aggregates entries when selectors do no expect_equal(sum(names(S4Vectors::mcols(agg)) == "method"), 1L) }) -test_that("QtlFineMappingResult: topLoci with a full tuple keeps the bare (id-free) table", { +test_that("topLoci for a full tuple gives the bare, id-free table", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( @@ -437,10 +578,10 @@ test_that("QtlFineMappingResult: topLoci aggregates only the matching subset", { expect_equal(unique(sub$context), "c2") }) -test_that("QtlFineMappingResult: topLoci on a single-row collection still carries identity columns", { +test_that("topLoci on a one-row collection still carries identity columns", { # A no-selector call takes the aggregate path even for one row, so the PIP - # table has a uniform shape (identity columns present) whatever the row count - # -- callers don't special-case single-entry results. + # table has a uniform shape (identity columns present) whatever the row + # count -- callers don't special-case single-entry results. row <- .sc_makeFineMappingRow(4) res <- QtlFineMappingResult( studyName = "s1", @@ -464,11 +605,12 @@ test_that("QtlFineMappingResult: topLoci on a single-row collection still carrie }) test_that("aggregate view: empty per-entry views give empty ranges", { - # .alc_makeFmEntry has no credible sets, so credibleSets aggregates to nothing. + # .alc_makeFmEntry has no credible sets, so credibleSets aggregates to + # nothing. expect_length(credibleSets(.alc_makeFmr2()), 0L) }) -test_that("FineMappingResultBase aggregate view: a no-match selector re-raises the selection error", { +test_that("an aggregate view re-raises a no-match selector's error", { expect_error(credibleSets(.alc_makeFmr2(), studyName = "nope"), "entries") }) @@ -767,15 +909,52 @@ test_that("intersectVariants restricts a narrowed row's fit by id", { expect_length(fit$pip, 20L) }) +# A row's fit, as the collection hands it out. +.alc_rowFit <- function(i, x) { + susieFit(.fmrRowParts(x, i)) +} + +# `x` as saved before rows shared their fits: each row's fit in its own +# `susieFit` cell, and no fits dictionary. +.alc_savedInlineFits <- function(x) { + saved <- x + md <- attr(saved, "elementMetadata") + md$susieFit <- S4Vectors::SimpleList(map(seq_along(x), .alc_rowFit, x = x)) + attr(saved, "elementMetadata") <- md + attr(saved, "fits") <- NULL + saved +} + +# ...and while rows recorded the variants their fits were made with, in a +# `fitVariants` column. +.alc_savedWithFitVariants <- function(x, fitVariants) { + saved <- .alc_savedInlineFits(x) + md <- attr(saved, "elementMetadata") + md$fitVariants <- IRanges::CharacterList(fitVariants) + attr(saved, "elementMetadata") <- md + saved +} + +test_that("updateObject() leaves the object it is given as it was", { + saved <- .alc_savedInlineFits(.rc_makeFmr(.rc_vids(1:10))) + md <- attr(saved, "elementMetadata") + updated <- updateObject(saved) + expect_length(updated@fits, 1L) + expect_null(attr(saved, "fits")) + expect_identical(attr(saved, "elementMetadata"), md) +}) + test_that("updateObject() drops the fitVariants column older rows saved", { x <- .rc_makeFmr(.rc_vids(1:10)) - saved <- x - saved$fitVariants <- IRanges::CharacterList(list(.rc_vids(1:10))) + saved <- .alc_savedWithFitVariants(x, list(.rc_vids(1:10))) up <- updateObject(saved) expect_false("fitVariants" %in% colnames(S4Vectors::mcols(up))) expect_identical(up, x) # A row narrowed before it was saved still reads its whole fit. - savedNarrowed <- .alc_narrowed(saved, 4L) + savedNarrowed <- .alc_savedWithFitVariants( + .alc_narrowed(x, 4L), + list(.rc_vids(1:10)) + ) expect_warning(fit <- susieFit(updateObject(savedNarrowed)), "no longer") expect_length(fit$pip, 10L) # A current collection is left as it is. @@ -785,8 +964,7 @@ test_that("updateObject() drops the fitVariants column older rows saved", { test_that("updateObject() drops fitVariants and keys LD rows in one call", { x <- .rc_makeFmr(.rc_vids(1:10)) - saved <- x - saved$fitVariants <- IRanges::CharacterList(list(.rc_vids(1:10))) + saved <- .alc_savedWithFitVariants(x, list(.rc_vids(1:10))) up <- updateObject(.savedWithLdSketch(saved, NULL)) expect_true(validObject(up)) expect_false("fitVariants" %in% colnames(S4Vectors::mcols(up))) @@ -795,6 +973,135 @@ test_that("updateObject() drops fitVariants and keys LD rows in one call", { expect_identical(updateObject(up), up) }) +# A saved row's per-fold SuSiE fit over `ids`: one effect, weights alpha * mu. +.alc_foldFit <- function(ids, alpha, mu) { + list( + pip = alpha, + alpha = matrix(alpha, 1L, dimnames = list(NULL, ids)), + mu = matrix(mu, 1L, dimnames = list(NULL, ids)) + ) +} + +.alc_savedCv <- function(foldFits) { + list( + samplePartition = data.frame(Sample = c("a", "b"), Fold = 1:2), + prediction = list(), + performance = list(), + foldFits = `attr<-`(foldFits, "partitionKey", "key") + ) +} + +# `x` as saved while rows kept per-fold fits: each row's CV in full in the +# column, before rows shared their partitions, so with no partition key or +# dictionary. +.alc_savedWithFoldFits <- function(x) { + full <- map(seq_along(x), .alc_rowCv, x = x) + saved <- x + saved$cvPartition <- NULL + saved$cvResult <- S4Vectors::SimpleList(full) + attr(saved, "cvPartition") <- NULL + saved +} + +# Row `i`'s CV as the collection hands it out. +.alc_rowCv <- function(i, x) { + cvResult(pecotmr:::.collectionEntry(x, i)) +} + +test_that("updateObject() turns saved per-fold fits into per-fold weights", { + vids <- .rc_vids(1:3) + tl <- data.frame(variant_id = vids, pip = c(0.5, 0.3, 0.2)) + # Fold 2's fit saw two of the three variants, as a capped CV's does. + cv <- .alc_savedCv(list( + fold_1 = .alc_foldFit(vids, c(0.5, 0.3, 0.2), c(1, 2, 3)), + fold_2 = .alc_foldFit(vids[c(1L, 3L)], c(0.6, 0.4), c(1, 1)) + )) + saved <- .alc_savedWithFoldFits(QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "g1", + method = "susie", + entry = list(FineMappingRow(vids, list(pip = tl$pip), tl, cv)) + )) + up <- updateObject(saved) + stored <- up$cvResult[[1L]] + expect_null(stored$foldFits) + expect_null(rownames(stored$foldWeights)) + want <- matrix( + c(0.5, 0.6, 0.6, 0.6, 0, 0.4), + 3L, + 2L, + dimnames = list(vids, c("fold_1", "fold_2")) + ) + expect_equal( + cvResult(pecotmr:::.collectionEntry(up, 1L))$foldWeights, + `attr<-`(want, "partitionKey", "key") + ) + expect_identical(updateObject(up), up) +}) + +test_that("updateObject() keeps fold weights' ids where the row has none", { + vids <- .rc_vids(1:3) + a <- vids[1:2] + cvA <- .alc_savedCv(list(fold_1 = .alc_foldFit(a, c(0.5, 0.5), c(1, 2)))) + cvB <- .alc_savedCv(list(fold_1 = .alc_foldFit(vids[3L], 0.4, 1))) + merged <- pecotmr:::.fmMergeEntries(list( + FineMappingRow(a, NULL, data.frame(variant_id = a, pip = 0.1), cvA), + FineMappingRow( + vids[3L], + NULL, + data.frame(variant_id = vids[3L], pip = 0.1), + cvB + ) + )) + saved <- .alc_savedWithFoldFits(QtlFineMappingResult( + studyName = c("s1", "s1"), + context = c("c1", "c1"), + trait = c("g1", "g2"), + method = c("susie", "susie"), + entry = list(pecotmr:::.fmCvOnlyRow(cvA), merged) + )) + up <- updateObject(saved) + # A cross-validation-only row holds no variants: its weights keep their + # fits' ids. + expect_equal( + up$cvResult[[1L]]$foldWeights, + `attr<-`( + matrix(c(0.5, 1), 2L, 1L, dimnames = list(a, "fold_1")), + "partitionKey", + "key" + ) + ) + # A merged row's regions together name its variants, so they drop theirs. + regions <- up$cvResult[[2L]] + expect_null(regions$region1$foldFits) + expect_equal(dim(regions$region1$foldWeights), c(2L, 1L)) + expect_null(rownames(regions$region1$foldWeights)) + expect_equal( + rownames( + cvResult(pecotmr:::.collectionEntry(up, 2L))$region2$foldWeights + ), + vids[3L] + ) +}) + +test_that(".fitNamedVariants reads a fit's names, never susieR's null column", { + f <- pecotmr:::.fitNamedVariants + expect_equal(f(NULL), character(0)) + expect_equal(f(list()), character(0)) + # A null_weight fit: one more effect-matrix column, named "null". + alpha <- matrix(0.5, 1L, 3L, dimnames = list(NULL, c("v1", "v2", "null"))) + expect_equal(f(list(alpha = alpha)), c("v1", "v2")) + expect_equal( + f(list(pip = c(v1 = 0.1, v2 = 0.2), alpha = alpha)), + c("v1", "v2") + ) + lbfMat <- matrix(0, 1L, 2L, dimnames = list(NULL, c("a", "b"))) + expect_equal(f(list(lbf_variable = lbfMat)), c("a", "b")) + # fSuSiE names its variables on csd_X. + expect_equal(f(list(csd_X = c(x1 = 1, x2 = 2))), c("x1", "x2")) +}) + # =========================================================================== # adjustPips: entries that share no variant with `keepVariants` # @@ -837,7 +1144,22 @@ test_that("adjustPips drops non-overlapping entries and says so", { expect_equal(as.character(mcols(out)$study), "s1") }) -test_that("adjustPips on a FineMappingResultBase collection renormalizes each entry", { +test_that("adjustPips keeps the names its rows had", { + # As every rebuild does: the result used to come back unnamed. Names a + # caller set stay too. + x <- .ac_twoEntry() + expect_false(is.null(names(x))) + expect_message( + out <- adjustPips(x, .rc_vids(1:5)), + "dropping 1 of 2 entries" + ) + expect_equal(names(out), names(x)[1L]) + names(x) <- c("first", "second") + keep <- c(.rc_vids(1:5), sprintf("chr9:%d:A:G", 100L * 1:5)) + expect_equal(names(adjustPips(x, keep)), c("first", "second")) +}) + +test_that("adjustPips renormalizes each entry of a fine-mapping collection", { vidsA <- paste0("chr1:", 1:6, ":A:G") vidsB <- paste0("chr1:", 3:8, ":A:G") entryA <- .makeAdjustEntry(vidsA) @@ -930,7 +1252,7 @@ test_that("an empty collection has no variants", { expect_equal(pecotmr:::.rcAllVariants(empty), character(0)) }) -test_that("retained mass is NULL for a fit that never went through reconciliation", { +test_that("retained mass is NULL for a fit never reconciled", { # NULL rather than a vector of 1s: nothing was dropped, so there is no # mass to report. expect_null(pecotmr:::.rcFitRetainedMass(NULL)) @@ -1321,7 +1643,7 @@ test_that("a result's ranged views carry its genome build", { # Collection aggregates: lbf, credibleSetSummary and the fSuSiE accessors # =========================================================================== -test_that("lbf aggregates over a collection, carrying identity + NA-filling ragged effects", { +test_that("lbf over a collection: identity kept, ragged effects NA-filled", { vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") mkEntry <- function(maxNumSingleEffects) { lbf <- matrix( @@ -1343,8 +1665,9 @@ test_that("lbf aggregates over a collection, carrying identity + NA-filling ragg ) ) } - # Two entries with different effect counts (L = 2 vs 3) exercise the NA-fill of - # the ragged lbf_L columns described in the collection method's contract. + # Two entries with different effect counts (L = 2 vs 3) exercise the NA-fill + # of the ragged lbf_L columns described in the collection method's + # contract. res <- QtlFineMappingResult( studyName = c("s1", "s1"), context = c("brain", "blood"), @@ -1361,11 +1684,13 @@ test_that("lbf aggregates over a collection, carrying identity + NA-filling ragg expect_equal(length(w), 6L) # 2 entries x 3 variants expect_setequal(unique(w$context), c("brain", "blood")) expect_true("lbf_L3" %in% names(S4Vectors::mcols(w))) - expect_true(all(is.na(w$lbf_L3[w$context == "brain"]))) # L = 2 entry: no effect 3 - expect_true(all(!is.na(w$lbf_L3[w$context == "blood"]))) # L = 3 entry: present + # L = 2 entry: no effect 3 + expect_true(all(is.na(w$lbf_L3[w$context == "brain"]))) + # L = 3 entry: present + expect_true(all(!is.na(w$lbf_L3[w$context == "blood"]))) }) -test_that("credibleSetSummary aggregates across a collection with entry identity", { +test_that("credibleSetSummary aggregates a collection with entry identity", { mkEntry <- function() { vn <- c("chr1:100:A:G", "chr1:200:C:T") tl <- data.frame( @@ -1400,7 +1725,7 @@ test_that("fsusieCredibleBand on a result with no fSuSiE fit is empty ranges", { expect_length(cb, 0L) }) -test_that("fsusieCredibleBand + fsusieAffectedRegions aggregate across a collection", { +test_that("fsusieCredibleBand, fsusieAffectedRegions aggregate a collection", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") fit <- .fsa_fits$none # one fit, read by both rows @@ -1440,7 +1765,7 @@ test_that("fsusieCredibleBand + fsusieAffectedRegions aggregate across a collect expect_setequal(unique(S4Vectors::mcols(gr)$context), c("brain", "blood")) }) -test_that("fsusieAffectedRegions on a collection of non-fSuSiE entries is an empty GRanges", { +test_that("fsusieAffectedRegions of non-fSuSiE entries is an empty GRanges", { e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), @@ -1644,3 +1969,58 @@ test_that("enrichment estimates are the same from trimmed collections", { run(gwas, qtl) ) }) + +# ---- fits dictionary -------------------------------------------------------- + +# The two rows of a joint fit, one per context, holding the same fit. +.alc_jointFmr <- function() { + e <- .alc_makeFmEntry(fit = list(pip = c(0.9, 0.8, 0.7), V = c(1, 0.5))) + QtlFineMappingResult( + studyName = c("Q1", "Q1"), + context = c("c1", "c2"), + trait = c("t1", "t1"), + method = c("mvsusie", "mvsusie"), + entry = list(e, e), + jointContexts = c("c1;c2", "c1;c2") + ) +} + +test_that("a fit the rows of a joint fit share is stored once", { + x <- .alc_jointFmr() + expect_length(.fitDict(x), 1L) + expect_identical(.alc_rowFit(1L, x), .alc_rowFit(2L, x)) + expect_identical( + .alc_rowFit(1L, x), + list(pip = c(0.9, 0.8, 0.7), V = c(1, 0.5)) + ) +}) + +test_that("updateObject() moves saved inline fits into the dictionary", { + x <- .alc_jointFmr() + up <- updateObject(.alc_savedInlineFits(x)) + expect_identical(up, x) + expect_identical(updateObject(up), up) +}) + +test_that("combining keeps one copy of a fit the parts share", { + x <- .alc_jointFmr() + both <- combineFineMappingResults(x[1L], x[2L]) + expect_length(.fitDict(both), 1L) + expect_identical(both, x) +}) + +test_that("a subset keeps only the fits its rows name", { + one <- list(pip = c(0.9, 0.8, 0.7)) + two <- list(pip = c(0.1, 0.2, 0.3)) + x <- QtlFineMappingResult( + studyName = c("Q1", "Q1"), + context = c("c1", "c1"), + trait = c("t1", "t2"), + method = c("susie", "susie"), + entry = list(.alc_makeFmEntry(fit = one), .alc_makeFmEntry(fit = two)) + ) + expect_length(.fitDict(x), 2L) + second <- x[2L] + expect_length(.fitDict(second), 1L) + expect_identical(.alc_rowFit(1L, second), two) +}) diff --git a/tests/testthat/test_ColocBoostResult.R b/tests/testthat/test_ColocBoostResult.R index 4368fc04d..cdb4afc2a 100644 --- a/tests/testthat/test_ColocBoostResult.R +++ b/tests/testthat/test_ColocBoostResult.R @@ -541,12 +541,9 @@ test_that("updateObject keys an old result's sumstat outcomes to its ref", { info <- mutate(.cbr_info(), dataForm = c("sumstats", "individual")) x <- ColocBoostResult(list(.cbr_fake()), "joint_gwas", outcomeInfo = info) # As an earlier version saved it: one reference, no outcome keys. - old <- `slot<-`(x, "ldReference", check = FALSE, value = ref) - old <- `slot<-`( - old, - "outcomeInfo", - value = select(info, -any_of("ldReference")) - ) + old <- x + methods::slot(old, "ldReference", check = FALSE) <- ref + methods::slot(old, "outcomeInfo") <- select(info, -any_of("ldReference")) new <- updateObject(old) expect_true(methods::validObject(new)) expect_identical(ldReference(new), list(ld1 = ref)) diff --git a/tests/testthat/test_ColocResult.R b/tests/testthat/test_ColocResult.R index 91ff38850..a153968df 100644 --- a/tests/testthat/test_ColocResult.R +++ b/tests/testthat/test_ColocResult.R @@ -51,12 +51,80 @@ rep(list(one), n) } -test_that("ColocResult: stores one element per pair with its variants", { +# A group's variants as they are. +.cr_same <- function(g) { + g +} + +# A group's variants in reverse order, as an element operation may leave +# them. +.cr_reversed <- function(g) { + rev(g) +} + +# `x` as saved before a ColocResult held one element per scored group: one +# element per pair, carrying its variants and SNP.PP.H4, and the pair's +# columns in mcols. Attributes are written directly, as a saved object +# holds them: that layout no longer validates. +.cr_savedPerPair <- function(x) { + pairs <- colocPairs(x) + group <- pecotmr:::.crPairGroups(x) + pp <- as.list(pecotmr:::.crPairPp(x)) + elements <- map2(as.list(x)[group], pp, .cr_withPp) + saved <- x + attr(saved, "unlistData") <- unlist( + GenomicRanges::GRangesList(unname(elements)), + use.names = FALSE + ) + attr(saved, "partitioning") <- IRanges::PartitioningByEnd( + cumsum(lengths(elements)), + names = NULL + ) + attr(saved, "elementMetadata") <- S4Vectors::DataFrame( + as.data.frame(pairs), + check.names = FALSE + ) + saved +} + +.cr_withPp <- function(g, pp) { + S4Vectors::mcols(g)$SNP.PP.H4 <- as.numeric(pp) + g +} + +test_that("ColocResult: stores one element per scored group", { x <- ColocResult(.cr_pairs(), .cr_variants()) expect_s4_class(x, "ColocResult") expect_equal(nrow(x), 1L) expect_equal(unname(lengths(x)), 3L) - expect_equal(x$PP.H4.abf, 0.6) + expect_equal(colocPairs(x)$PP.H4.abf, 0.6) +}) + +test_that("ColocResult: a group's pairs share its variants, stored once", { + pairs <- rbind(.cr_pairs(), .cr_pairs(gwasCs = 2L, pp4 = 0.3)) + x <- ColocResult(pairs, .cr_variants(2L, pp = c(0.2, 0.5, 0.3))) + expect_equal(length(x), 1L) + expect_equal(unname(lengths(x)), 3L) + expect_equal(nrow(colocPairs(x)), 2L) + expect_equal(colocPairs(x)$gwasCs, c(1L, 2L)) + # Pairs over other variants, or in another block, are their own group. + other <- rbind(pairs, .cr_pairs(blockId = "chr1_1001_2000")) + y <- ColocResult(other, .cr_variants(3L)) + expect_equal(length(y), 2L) + expect_equal(nrow(colocPairs(y)), 3L) +}) + +test_that("an element operation keeps pairs' posteriors with the variants", { + pairs <- rbind(.cr_pairs(), .cr_pairs(gwasCs = 2L, pp4 = 0.3)) + variants <- list( + .cr_variants(pp = c(0.6, 0.3, 0.1))[[1L]], + .cr_variants(pp = c(0.2, 0.5, 0.3))[[1L]] + ) + x <- ColocResult(pairs, variants) + reordered <- endoapply(x, .cr_reversed) + long <- S4Vectors::mcols(colocVariants(reordered)) + expect_equal(long$variant_id[1:3], rev(.cr_variants()[[1L]]$variant_id)) + expect_equal(long$SNP.PP.H4, c(0.1, 0.3, 0.6, 0.3, 0.5, 0.2)) }) test_that("ColocResult: keeps each pair's LD reference", { @@ -90,7 +158,7 @@ test_that("ColocResult: rejects a variants list that is not parallel", { test_that("ColocResult: an empty result still carries the column schema", { x <- ColocResult(.cr_pairs()[0, , drop = FALSE], list()) expect_equal(nrow(x), 0L) - expect_true(is_in("PP.H4.abf", colnames(x))) + expect_true(is_in("PP.H4.abf", colnames(colocPairs(x)))) expect_equal(nrow(colocPairs(x)), 0L) }) @@ -268,6 +336,29 @@ test_that(".crPivotColocResults: maps results column K to summary row K", { expect_equal(out[[2L]]$SNP.PP.H4, c(0.2, 0.8)) }) +test_that(".crPivotColocResults: reads a lone pair's SNP.PP.H4.abf", { + # coloc.bf_bf names the column SNP.PP.H4.abf, not .row1, when it scores + # a single pair -- every region with one kept effect on each side. + results <- data.frame( + snp = c("chr1:100:A:G", "chr1:200:C:T"), + SNP.PP.H4.abf = c(0.7, 0.3) + ) + out <- .crPivotColocResults(results, 1L) + expect_equal(out[[1L]]$variant_id, results$snp) + expect_equal(out[[1L]]$SNP.PP.H4, c(0.7, 0.3)) +}) + +test_that("a pair coloc scores alone keeps its variants", { + skip_if_not_installed("coloc") + ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + bf1 <- matrix(c(2, 0.5, -1), 1L, 3L, dimnames = list(NULL, ids)) + bf2 <- matrix(c(1.5, 0.2, -0.5), 1L, 3L, dimnames = list(NULL, ids)) + res <- suppressWarnings(coloc::coloc.bf_bf(bf1, bf2)) + out <- .crPivotColocResults(res$results, 1L) + expect_equal(out[[1L]]$variant_id, ids) + expect_equal(sum(out[[1L]]$SNP.PP.H4), 1, tolerance = 1e-8) +}) + test_that(".crPivotColocResults: empty results give empty variant tables", { out <- .crPivotColocResults(NULL, 2L) expect_length(out, 2L) @@ -416,24 +507,85 @@ test_that("validity names missing pair columns", { test_that("validity names missing posterior columns", { bad <- ColocResult(.cr_pairs(), .cr_variants()) - mcols(bad)$PP.H4.abf <- NULL + flat <- unlist(bad$pairs, use.names = FALSE) + flat$PP.H4.abf <- NULL + md <- mcols(bad) + md$pairs <- IRanges::relist(flat, bad$pairs) expect_error( - methods::validObject(bad), + { + mcols(bad) <- md + methods::validObject(bad) + }, "missing posterior columns: .*missing elements \\{'PP.H4.abf'\\}" ) }) -test_that("validity names elements whose variants lack SNP.PP.H4", { - # The expectation wraps the ASSIGNMENT: `[[<-` on the GRangesList - # re-validates, so the object never survives long enough for a separate - # validObject() call to see it. +test_that("validity names pairs whose SNP.PP.H4 misses their variants", { + bad <- ColocResult(.cr_pairs(), .cr_variants()) + flat <- unlist(bad$pairs, use.names = FALSE) + flat$SNP.PP.H4 <- IRanges::NumericList(c(0.5, 0.5)) + md <- mcols(bad) + md$pairs <- IRanges::relist(flat, bad$pairs) + expect_error( + { + mcols(bad) <- md + methods::validObject(bad) + }, + "not aligned to their element's variants" + ) +}) + +test_that("validity refuses pairs that are not one table per element", { bad <- ColocResult(.cr_pairs(), .cr_variants()) + md <- mcols(bad) + md$pairs <- as.list(md$pairs) expect_error( - mcols(bad[[1L]])$SNP.PP.H4 <- NULL, - "have no SNP.PP.H4 column in their variant metadata" + { + mcols(bad) <- md + methods::validObject(bad) + }, + "must be a SplitDataFrameList" ) }) +test_that("ColocResult: refuses variant tables with different columns", { + pairs <- rbind(.cr_pairs(), .cr_pairs(gwasCs = 2L)) + variants <- .cr_variants(2L) + variants[[2L]]$extra <- 1 + expect_error(ColocResult(pairs, variants), "carry the same columns") +}) + +test_that("an element operation that keeps the variants keeps the pairs", { + pairs <- rbind(.cr_pairs(), .cr_pairs(gwasCs = 2L, pp4 = 0.3)) + x <- ColocResult(pairs, .cr_variants(2L, pp = c(0.2, 0.5, 0.3))) + same <- endoapply(x, .cr_same) + expect_equal(colocPairs(same), colocPairs(x)) + expect_equal(colocVariants(same), colocVariants(x)) +}) + +test_that("updateObject folds a result saved with one LD reference", { + ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + ldm <- LdMatrix( + matrix(0.1, 3, 3, dimnames = list(ids, ids)) + diag(0.9, 3) + ) + x <- ColocResult(.cr_pairs(), .cr_variants(), ldReference = ldm) + saved <- .cr_savedPerPair(x) + methods::slot(saved, "ldReference", check = FALSE) <- ldm + md <- attr(saved, "elementMetadata") + md$ldReference <- NULL + attr(saved, "elementMetadata") <- md + up <- updateObject(saved) + expect_identical(ldReference(up), list(ld1 = ldm)) + expect_identical(colocPairs(up), colocPairs(x)) +}) + +test_that("updateObject folds a result saved one element per pair", { + pairs <- rbind(.cr_pairs(), .cr_pairs(gwasCs = 2L, pp4 = 0.3)) + x <- ColocResult(pairs, .cr_variants(2L)) + expect_identical(updateObject(.cr_savedPerPair(x)), x) + expect_identical(updateObject(x), x) +}) + # =========================================================================== # Empty-input paths diff --git a/tests/testthat/test_CtwasResult.R b/tests/testthat/test_CtwasResult.R index 279311e9a..23e5bcc39 100644 --- a/tests/testthat/test_CtwasResult.R +++ b/tests/testthat/test_CtwasResult.R @@ -24,7 +24,7 @@ context("CtwasResult") ) } -test_that("CtwasResult: constructor keyed by (gwasStudy, study, context, method)", { +test_that("CtwasResult rows are keyed by (gwasStudy, study, context, method)", { cr <- CtwasResult( gwasStudy = c("D1", "D1"), studyName = c("Q1", "Q1"), @@ -39,7 +39,26 @@ test_that("CtwasResult: constructor keyed by (gwasStudy, study, context, method) expect_equal(studyName(cr), "Q1") }) -test_that("CtwasResult: ctwasPosteriors aggregates rows tagged with run identity", { +test_that("CtwasResult: c() appends runs, their tables kept", { + run <- function(context, entry) { + CtwasResult( + gwasStudy = "D1", + studyName = "Q1", + context = context, + method = "susie", + entry = list(entry) + ) + } + brain <- run("brain", .cr_entry()) + liver <- run("liver", .cr_entry(ids = "g3", pip = 0.5)) + both <- c(brain, liver) + expect_s4_class(both, "CtwasResult") + expect_identical(as.character(both$context), c("brain", "liver")) + expect_identical(both$regionInfo, c(brain$regionInfo, liver$regionInfo)) + expect_identical(length(ctwasPosteriors(both)), 3L) +}) + +test_that("ctwasPosteriors aggregates rows tagged with run identity", { cr <- CtwasResult( gwasStudy = c("D1", "D1"), studyName = c("Q1", "Q1"), @@ -60,7 +79,7 @@ test_that("CtwasResult: ctwasPosteriors aggregates rows tagged with run identity expect_equal(fm$context, c("brain", "brain", "liver")) }) -test_that("CtwasResult: susieAlpha aggregates the per-effect table with identity", { +test_that("susieAlpha aggregates the per-effect table with identity", { cr <- CtwasResult( gwasStudy = c("D1", "D1"), studyName = c("Q1", "Q1"), @@ -302,6 +321,123 @@ test_that("a run splits into one element per cTWAS region", { expect_s4_class(one, "CtwasResult") }) +# =========================================================================== +# One set of group priors per run +# =========================================================================== + +test_that("a run's rows must carry one set of group priors", { + run <- function(chrom, prior, method = "susie") { + gr <- GenomicRanges::GRanges( + chrom, + IRanges::IRanges(100L, width = 1L), + id = "g1", + susie_pip = 0.9 + ) + CtwasResult( + gwasStudy = "D1", + studyName = "Q1", + context = "brain", + method = method, + entry = list(CtwasResultEntry( + posteriors = gr, + groupPriors = list(group_prior = c(gene = prior)) + )) + ) + } + # Fitted chromosome by chromosome: one identity, two fits. + expect_error( + c(run("chr1", 0.01), run("chr2", 0.05)), + "\\(D1, Q1, brain, susie\\) carry different group priors" + ) + # Under distinct identities they are two runs. + both <- c(run("chr1", 0.01), run("chr2", 0.05, method = "lasso")) + expect_equal(methodNames(both), c("susie", "lasso")) + # One fit's regions taken apart and put back together are still one run. + whole <- CtwasResult( + gwasStudy = "D1", + studyName = "Q1", + context = "brain", + method = "susie", + entry = list(.cr_twoRegionEntry()) + ) + expect_equal(length(c(whole[1L], whole[2L])), 2L) +}) + +test_that("ctwasGroupPriors() tabulates each run's priors once, by group", { + prior <- list( + group_prior = c(SNP = 1e-4, brain = 0.01), + group_prior_var = c(SNP = 10, brain = 20), + group_size = c(SNP = 5000, brain = 30), + converged = TRUE + ) + cr <- CtwasResult( + gwasStudy = c("D1", "D1"), + studyName = c("Q1", "Q1"), + context = c("brain", "liver"), + method = c("susie", "susie"), + entry = list(.cr_entry(prior = prior), .cr_entry(ids = "g3", pip = 0.5)) + ) + tab <- ctwasGroupPriors(cr) + expect_s3_class(tab, "tbl_df") + expect_named( + tab, + c( + "gwasStudy", + "study", + "context", + "method", + "group", + "group_size", + "group_prior", + "group_prior_var" + ) + ) + # The liver run recorded no priors, so it adds no rows. + expect_equal(tab$context, c("brain", "brain")) + expect_equal(tab$group, c("SNP", "brain")) + expect_equal(tab$group_size, c(5000, 30)) + expect_equal(tab$group_prior, c(1e-4, 0.01)) + expect_equal(tab$group_prior_var, c(10, 20)) + # No run with priors: no rows, the same columns. + expect_equal(ctwasGroupPriors(cr[2L]), tab[0L, ]) + # A run over two regions is listed once; what it did not record is NA. + two <- CtwasResult( + gwasStudy = "D1", + studyName = "Q1", + context = "brain", + method = "susie", + entry = list(.cr_twoRegionEntry()) + ) + expect_equal(length(two), 2L) + expect_equal( + ctwasGroupPriors(two)[, c("group", "group_prior", "group_prior_var")], + tibble::tibble( + group = "gene", + group_prior = 0.01, + group_prior_var = NA_real_ + ) + ) +}) + +test_that("ctwasGroupPriors() lists a joint run's shared priors per context", { + prior <- list(group_prior = c(SNP = 1e-4, brain = 0.01, liver = 0.02)) + cr <- CtwasResult( + gwasStudy = c("D1", "D1"), + studyName = c("Q1", "Q1"), + context = c("brain", "liver"), + method = c("susie", "susie"), + entry = list( + .cr_entry(prior = prior), + .cr_entry(ids = "g3", pip = 0.5, prior = prior) + ), + jointContexts = c("brain,liver", "brain,liver") + ) + tab <- ctwasGroupPriors(cr) + expect_equal(tab$context, rep(c("brain", "liver"), each = 3L)) + expect_equal(unique(tab$jointContexts), "brain,liver") + expect_equal(tab$group_prior, rep(c(1e-4, 0.01, 0.02), 2L)) +}) + test_that("updateObject rebuilds a CtwasResult saved as a table of runs", { # The earlier shape: a DFrame of whole runs, one entry per row. old <- S4Vectors::DataFrame( diff --git a/tests/testthat/test_CtwasResultEntry.R b/tests/testthat/test_CtwasResultEntry.R index e00eb53b5..9c16f49e9 100644 --- a/tests/testthat/test_CtwasResultEntry.R +++ b/tests/testthat/test_CtwasResultEntry.R @@ -38,7 +38,7 @@ test_that("as(entry, 'GRanges') gives placed posteriors only", { ) }) -test_that("CtwasResultEntry: an empty entry is valid and its accessors return NULL", { +test_that("an empty CtwasResultEntry is valid; its accessors return NULL", { e <- CtwasResultEntry() expect_s4_class(e, "CtwasResultEntry") expect_null(ctwasPosteriors(e)) diff --git a/tests/testthat/test_GenotypeMixture.R b/tests/testthat/test_GenotypeMixture.R index 00ebe0ff4..c1add457c 100644 --- a/tests/testthat/test_GenotypeMixture.R +++ b/tests/testthat/test_GenotypeMixture.R @@ -7,6 +7,29 @@ list(a = panel[, 1:40], b = panel[, 41:100], full = panel) } +test_that(".updatePanel drops the copies of labels a mixture's panels kept", { + p <- .gmPanels() + mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.3, 0.7)) + panels <- pecotmr:::.gmComponents(mix) + saved <- MultiAssayExperiment::`experiments<-`( + mix, + value = MultiAssayExperiment::ExperimentList( + map(panels, .savedLabelledPanel) + ) + ) + first <- pecotmr:::.gmComponents(saved)[[1L]] + expect_false(is.null(dimnames(pecotmr:::.panelSeed(first))[[1L]])) + slim <- pecotmr:::.updatePanel(saved) + slimFirst <- pecotmr:::.gmComponents(slim)[[1L]] + expect_null(dimnames(pecotmr:::.panelSeed(slimFirst))[[1L]]) + expect_identical(dimnames(slimFirst), dimnames(panels[[1L]])) + expect_equal( + as.matrix(SummarizedExperiment::assay(slimFirst)[1:5, ]), + as.matrix(SummarizedExperiment::assay(panels[[1L]])[1:5, ]) + ) + expect_identical(pecotmr:::.updatePanel(slim), slim) +}) + test_that("GenotypeMixture aligns its panels to the variants they share", { p <- .gmPanels() mix <- GenotypeMixture(list(a = p$a, b = p$b), mixtureWeights = c(0.3, 0.7)) diff --git a/tests/testthat/test_GwasFineMappingResult.R b/tests/testthat/test_GwasFineMappingResult.R index 6e8813405..36ddfd65e 100644 --- a/tests/testthat/test_GwasFineMappingResult.R +++ b/tests/testthat/test_GwasFineMappingResult.R @@ -80,7 +80,7 @@ test_that("GwasFineMappingResult: a window comes from region, not blockId", { }) -test_that("GwasFineMappingResult: validity does not recurse on key subset (#546)", { +test_that("GWAS result validity does not recurse on a key subset (#546)", { # The validity method builds a key-column data.frame to check tuple # uniqueness. Doing so via `object[, keyCols]` preserves the # GwasFineMappingResult class while dropping the required `entry` column; @@ -189,7 +189,7 @@ test_that("GwasFineMappingResult: contexts/traitNames return NULL", { }) -test_that("GwasFineMappingResult: credibleSets/topLoci/susieFit/variantIds dispatch", { +test_that("GWAS result dispatch: credibleSets, topLoci, susieFit, variantIds", { e <- .ca_makeFmEntry(3) res <- GwasFineMappingResult( studyName = "g1", @@ -207,7 +207,7 @@ test_that("GwasFineMappingResult: credibleSets/topLoci/susieFit/variantIds dispa expect_equal(length(variantIds(res)), 3L) }) -test_that("GwasFineMappingResult: topLoci aggregates per-block rows genome-wide", { +test_that("GwasFineMappingResult topLoci aggregates per-block rows", { # A genome-wide collection: same (study, method) across two region blocks. # With no selectors topLoci now stacks both blocks, tagging each variant # with its blockId; context/trait are NA-filled (GWAS keys on region). @@ -306,7 +306,7 @@ test_that("GwasFineMappingResult: credibleSets aggregates CS across blocks", { }) -test_that("GwasFineMappingResult: .tupleSelectRowGwasFmr requires both selectors for multi-row", { +test_that(".tupleSelectRowGwasFmr needs both selectors for several rows", { e <- .ca_makeFmEntry(3) res <- GwasFineMappingResult( studyName = c("g1", "g2"), @@ -337,7 +337,7 @@ test_that("GwasFineMappingResult: studyName/methodNames inherit from base", { }) -test_that("GwasFineMappingResult: marginalEffects with study/method selectors", { +test_that("GwasFineMappingResult marginalEffects by study, method selector", { e1 <- .ca_makeFmEntry(3) e2 <- .ca_makeFmEntry(4) res <- GwasFineMappingResult( diff --git a/tests/testthat/test_GwasSumStats.R b/tests/testthat/test_GwasSumStats.R index c1767d3c4..bba4a103f 100644 --- a/tests/testthat/test_GwasSumStats.R +++ b/tests/testthat/test_GwasSumStats.R @@ -639,7 +639,7 @@ test_that("combineGwasSumStats() row-binds per-block pieces in order", { }) -test_that("combineGwasSumStats() accepts a list and passes a lone input through", { +test_that("combineGwasSumStats() takes a list, passes a lone input through", { a <- makeGwasBlock("chr1_1_1000", 100L) b <- makeGwasBlock("chr1_1001_2000", 1100L) expect_identical( @@ -945,7 +945,7 @@ test_that("GwasSumStats() keeps the caller's metadata and QC options", { # nCase and nControl # =========================================================================== -test_that("GwasSumStats: nCase/nControl are optional columns (absent by default)", { +test_that("GwasSumStats nCase and nControl are optional, absent by default", { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges( @@ -971,7 +971,8 @@ test_that("GwasSumStats: nCase/nControl are optional columns (absent by default) expect_false(any( c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g0)) )) - g1 <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) + caseControlArgs <- c(base, list(nCase = 500, nControl = 1500)) + g1 <- exec(GwasSumStats, !!!caseControlArgs) expect_true(all(c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g1)))) expect_equal(g1$nCase, 500) expect_equal(g1$nControl, 1500) diff --git a/tests/testthat/test_H2Estimate.R b/tests/testthat/test_H2Estimate.R index 20407a6af..8ebd86097 100644 --- a/tests/testthat/test_H2Estimate.R +++ b/tests/testthat/test_H2Estimate.R @@ -1,150 +1,154 @@ -test_that("H2Estimate constructs with all slots", { - obj <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.01, - interceptSe = 0.02, - localBlocks = NULL, - enrichment = NULL, - annotationJackknifeCoefs = NULL, - scoreStats = NULL, - method = "lder", - nSnps = 10000L, - traitName = "height" +# One estimate covering `window` (none for a genome-wide estimate), with +# `...` replacing any of its columns. +.h2Est <- function(window = GenomicRanges::GRanges(), ...) { + cols <- list_assign( + list( + study = "s1", + context = NA_character_, + trait = NA_character_, + method = "lder", + h2 = 0.3, + h2_se = 0.05, + intercept = 1, + intercept_se = 0.01, + p_value = NA_real_, + n_snps = 100L, + n_components = NA_integer_, + scale = NA_real_, + enrichment = list(NULL), + jackknife = list(NULL), + score_stats = list(NULL) + ), + ... ) - expect_s4_class(obj, "H2Estimate") - expect_equal(heritabilityEstimate(obj), 0.3) - expect_equal(methodNames(obj), "lder") -}) - -test_that("show(H2Estimate) does not error", { - h2 <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - localBlocks = NULL, - enrichment = NULL, - annotationJackknifeCoefs = NULL, - scoreStats = NULL, - method = "lder", - nSnps = 1000L, - traitName = "test" + .h2EstimateNew( + list(window), + cols[setdiff(names(cols), .H2_OBJECT_COLS)], + cols[.H2_OBJECT_COLS], + GenomicRanges::GRanges() ) - expect_output(show(h2), "H2Estimate") +} + +test_that("H2Estimate holds each estimate's values in mcols", { + x <- .h2Est() + expect_s4_class(x, "H2Estimate") + expect_identical(length(x), 1L) + # A genome-wide estimate's element holds no ranges. + expect_length(x[[1]], 0L) + expect_equal(heritabilityEstimate(x), 0.3) + expect_equal(heritabilityEstimateSe(x), 0.05) + expect_equal(heritabilityIntercept(x), 1) + expect_equal(heritabilityInterceptSe(x), 0.01) + expect_identical(nSnps(x), 100L) + expect_identical(methodNames(x), "lder") + expect_identical(studyName(x), "s1") + # A GWAS estimate has no trait. + expect_identical(traitNames(x), character(0)) + expect_output(show(x), "H2Estimate: 1 estimate\\(s\\)") + expect_output(show(x[0]), "0 estimate") + # A cis estimate's element is the window it covers. + window <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, 900L)) + cis <- .h2Est(window, trait = "ENSG1", method = "lava") + expect_identical(IRanges::ranges(cis[[1]]), IRanges::ranges(window)) + expect_identical(traitNames(cis), "ENSG1") }) -test_that("H2Estimate types its optional slots", { - # Each optional slot is a type-or-NULL union, so a tibble fills the table - # slots while a value of the wrong type is refused when the object is - # built. - h2 <- function(...) { - new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - method = "lder", - nSnps = 1000L, - traitName = "test", - ... - ) - } - local <- tibble::tibble(blockId = 1L, h2Local = 0.1, h2LocalSe = 0.01) - expect_identical(localH2Blocks(h2(localBlocks = local)), local) - expect_null(localH2Blocks(h2())) - expect_error( - h2(localBlocks = list(blockId = 1L)), - 'invalid object for slot "localBlocks"' - ) - expect_error( - h2(enrichment = "none"), - 'invalid object for slot "enrichment"' - ) +test_that("H2Estimate refuses a missing or mistyped column", { + x <- .h2Est() + md <- S4Vectors::mcols(x) expect_error( - h2(annotationJackknifeCoefs = c(0.1, 0.2)), - 'invalid object for slot "annotationJackknifeCoefs"' + validObject(S4Vectors::`mcols<-`( + x, + value = md[-match("scale", colnames(md))] + )), + "scale" ) + expect_error(.h2Est(h2 = "high"), "`h2` column must be double") + expect_error(.h2Est(n_snps = 100), "`n_snps` column must be integer") + bad <- md + bad$enrichment <- "none" expect_error( - h2(scoreStats = c(z = 1.5)), - 'invalid object for slot "scoreStats"' + validObject(S4Vectors::`mcols<-`(x, value = bad)), + "`enrichment` column must be a list" ) }) -# =========================================================================== -# H2Estimate accessors -# =========================================================================== - -test_that("stratifiedHeritabilityEnrichment returns the enrichment slot", { - h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) - result <- stratifiedHeritabilityEnrichment(h2_obj) - expect_true(is.data.frame(result)) - expect_equal(result$annotation, c("annot1", "annot2")) +test_that("H2Estimate holds one row per estimate", { + x <- .h2Est() + expect_error(c(x, x), "tuple uniqueness violated") + # A second method on the same study is a second estimate. + both <- c(x, .h2Est(method = "hdl", h2 = 0.2)) + expect_identical(length(both), 2L) + expect_equal(heritabilityEstimate(both), c(0.3, 0.2)) + expect_identical(methodNames(both), c("lder", "hdl")) + expect_output(show(both), "2 estimate\\(s\\)") }) -test_that("scoreStats returns the scoreStats slot", { - scoreStats <- list( - z = c(1.5, -0.8), - R = diag(2), - annotationNames = c("a1", "a2") - ) - h2_obj <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - localBlocks = NULL, - enrichment = NULL, - annotationJackknifeCoefs = NULL, - scoreStats = scoreStats, - method = "lder", - nSnps = 100L, - traitName = "test" +test_that("the per-estimate accessors follow the rows", { + enrich <- tibble(annotation = "a1", tau = 1e-7, enrichment = 2) + jk <- matrix(0.1, 3L, 1L, dimnames = list(NULL, "a1")) + ss <- list(z = 1.5, R = diag(1), annotationNames = "c1") + x <- c( + .h2Est(), + .h2Est( + study = "s2", + h2 = 0.2, + enrichment = list(enrich), + jackknife = list(jk), + score_stats = list(ss) + ) ) - expect_identical(scoreStats(h2_obj), scoreStats) + expect_equal(heritabilityEstimate(x), c(0.3, 0.2)) + expect_identical(studyName(x), c("s1", "s2")) + expect_identical(annotationJackknifeCoefs(x), list(NULL, jk)) + expect_identical(scoreStats(x), list(NULL, ss)) + # Each stratified estimate's table, behind its identity. + tbl <- stratifiedHeritabilityEnrichment(x) + expect_identical(tbl$study, "s2") + expect_identical(tbl$annotation, "a1") + expect_identical(colnames(tbl)[1:4], .H2_ID_COLS) + # None stratified: no rows, the identity columns still there. + none <- stratifiedHeritabilityEnrichment(.h2Est()) + expect_identical(nrow(none), 0L) + expect_named(none, .H2_ID_COLS) }) -test_that("accessors return NULL when slots are NULL", { - h2_obj <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - localBlocks = NULL, - enrichment = NULL, - annotationJackknifeCoefs = NULL, - scoreStats = NULL, - method = "lder", - nSnps = 100L, - traitName = "test" - ) - expect_null(localH2Blocks(h2_obj)) - expect_null(stratifiedHeritabilityEnrichment(h2_obj)) - expect_null(scoreStats(h2_obj)) -}) +# =========================================================================== +# updateObject: estimates saved in slots +# =========================================================================== + +# H2Estimates saved before it held its estimates as rows: the shipped example +# (stratified) and an LDER estimate with per-block local estimates, as +# estimateH2() returned them. +.h2Saved <- function() { + readRDS(test_path("test_data", "h2EstimateSaved.rds")) +} -test_that("updateObject() moves an H2Estimate's estimates off the old names", { - h2Obj <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - localBlocks = data.frame(blockId = "b1", h2Local = 0.1, h2LocalSe = 0), - enrichment = NULL, - annotationJackknifeCoefs = matrix(0.2, nrow = 2L, ncol = 1L), - scoreStats = NULL, - method = "sldsc", - nSnps = 100L, - traitName = "test" +test_that("updateObject() rebuilds an H2Estimate saved in slots as a row", { + saved <- .h2Saved()$example + expect_no_warning(up <- updateObject(saved)) + expect_s4_class(up, "H2Estimate") + expect_true(validObject(up)) + expect_identical(length(up), 1L) + expect_length(up[[1]], 0L) + expect_identical(studyName(up), "test") + expect_identical(methodNames(up), "lder") + expect_equal(heritabilityEstimate(up), 0.3) + expect_equal(heritabilityIntercept(up), 1.01) + expect_identical(nSnps(up), 100L) + expect_identical( + annotationJackknifeCoefs(up), + list(methods::slot(saved, "annotationJackknifeCoefs")) ) - saved <- .savedUnder( - h2Obj, + expect_equal( + as.data.frame(stratifiedHeritabilityEnrichment(up)[-(1:4)]), + methods::slot(saved, "enrichment") + ) + expect_identical(updateObject(up), up) + expect_message(updateObject(up, verbose = TRUE), "H2Estimate") + # ...and one saved under the slots' earlier names, the same way. + older <- .savedUnder( + saved, c( h2 = "estimate", h2Se = "estimateSe", @@ -152,10 +156,18 @@ test_that("updateObject() moves an H2Estimate's estimates off the old names", { tauBlocks = "annotationJackknifeCoefs" ) ) - # The inherited update alone drops slots the class no longer has, with a - # warning, and leaves the estimate empty. - expect_no_warning(up <- updateObject(saved)) - expect_identical(up, h2Obj) - expect_identical(updateObject(h2Obj), h2Obj) - expect_message(updateObject(h2Obj, verbose = TRUE), "H2Estimate") + expect_identical(updateObject(older), up) +}) + +test_that("updateObject() drops the per-block local estimates", { + saved <- .h2Saved()$local + expect_warning( + up <- updateObject(saved), + "per-block local estimates are dropped" + ) + expect_identical(length(up), 1L) + expect_equal( + heritabilityEstimate(up), + methods::slot(saved, "estimate") + ) }) diff --git a/tests/testthat/test_LdEigen.R b/tests/testthat/test_LdEigen.R index 58eadaef8..e11be7dca 100644 --- a/tests/testthat/test_LdEigen.R +++ b/tests/testthat/test_LdEigen.R @@ -211,20 +211,24 @@ test_that("LdEigen: argument guards fire", { nSamples = 500L, eigenList = eigen_list ) + badSnpInfo <- list_modify(ok, snpInfo = "not-a-df") expect_error( - exec(LdEigen, !!!list_modify(ok, !!!list(snpInfo = "not-a-df"))), + exec(LdEigen, !!!badSnpInfo), "snpInfo.*Must be of type 'data.frame'" ) + badEigenList <- list_modify(ok, eigenList = "not-a-list") expect_error( - exec(LdEigen, !!!list_modify(ok, !!!list(eigenList = "not-a-list"))), + exec(LdEigen, !!!badEigenList), "eigenList.*Must be of type 'list'" ) + zeroSamples <- list_modify(ok, nSamples = 0L) expect_error( - exec(LdEigen, !!!list_modify(ok, !!!list(nSamples = 0L))), + exec(LdEigen, !!!zeroSamples), "nSamples.*Must be >= 1" ) + textSamples <- list_modify(ok, nSamples = "500") expect_error( - exec(LdEigen, !!!list_modify(ok, !!!list(nSamples = "500"))), + exec(LdEigen, !!!textSamples), "nSamples.*Must be of type 'count'" ) }) diff --git a/tests/testthat/test_LdMatrix.R b/tests/testthat/test_LdMatrix.R index b9189ccf9..d54880557 100644 --- a/tests/testthat/test_LdMatrix.R +++ b/tests/testthat/test_LdMatrix.R @@ -62,6 +62,13 @@ test_that("LdMatrix takes its variants from a table or a GRanges", { as.character(GenomicRanges::seqnames(fromRanges))[[1L]], "chr22" ) + # Alleles enter in upper case; the labels stay as given. + lower <- .ldmTable(f$ids) + lower$A1 <- str_to_lower(lower$A1) + lower$A2 <- str_to_lower(lower$A2) + fromLower <- LdMatrix(unname(f$R), variants = lower) + expect_identical(S4Vectors::mcols(fromLower)$A1, parseVariantId(f$ids)$A1) + expect_identical(variantIds(fromLower), f$ids) }) test_that("as.matrix() and as(x, 'matrix') return the correlation matrix", { @@ -171,8 +178,11 @@ test_that("validity catches a part changed after construction", { relabelled@correlation <- `dimnames<-`(f$R, list(rev(f$ids), rev(f$ids))) expect_error(validObject(relabelled), "names must be the variant ids") withNa <- ld - withNa@correlation[1, 2] <- NA + withNa@correlation <- `[<-`(ldMatrix(ld), 1, 2, NA) expect_error(validObject(withNa), "holds missing values") + packedNa <- ld + packedNa@correlation <- .packedLd(`[<-`(ldMatrix(ld), 1, 2, NA)) + expect_error(validObject(packedNa), "holds missing values") noSize <- ld noSize@nSamples <- 0L expect_error(validObject(noSize), "one positive count") @@ -286,7 +296,7 @@ test_that("a mixture needs LdMatrix components and valid weights", { ) }) -test_that("a Matrix-package matrix is made dense", { +test_that("a Matrix-package matrix is taken, and handed back dense", { skip_if_not_installed("Matrix") f <- .ldmFixture() ld <- LdMatrix(Matrix::Matrix(f$R), nSamples = 10) @@ -294,6 +304,34 @@ test_that("a Matrix-package matrix is made dense", { expect_equal(ldMatrix(ld), f$R) }) +test_that("the matrix is stored packed and read back exactly", { + f <- .ldmFixture() + ld <- LdMatrix(f$R, nSamples = 10) + expect_s4_class(ld@correlation, "dspMatrix") + expect_null(dimnames(ld@correlation)[[1L]]) + expect_identical(ldMatrix(ld), f$R) + idx <- c(5L, 2L, 7L) + expect_identical(.ldmBlock(ld, idx), unname(f$R[idx, idx])) + # A matrix packed by its lower triangle is read the same way. + lower <- ld + lower@correlation <- Matrix::pack( + Matrix::forceSymmetric(unname(f$R), uplo = "L") + ) + expect_identical(.ldmBlock(lower, idx), unname(f$R[idx, idx])) +}) + +test_that("updateObject packs an LdMatrix saved with a full matrix", { + f <- .ldmFixture() + ld <- LdMatrix(f$R, nSamples = 10) + saved <- ld + saved@correlation <- f$R + # Read as saved, the full matrix serves as the packed one does. + expect_identical(ldMatrix(saved), f$R) + expect_identical(.ldmBlock(saved, c(3L, 1L)), unname(f$R[c(3, 1), c(3, 1)])) + expect_identical(updateObject(saved), ld) + expect_identical(updateObject(ld), ld) +}) + test_that("show reports the size, a mixture and missing frequencies", { f <- .ldmFixture() out <- capture.output(show(LdMatrix(f$R, nSamples = 30))) @@ -307,3 +345,31 @@ test_that("show reports the size, a mixture and missing frequencies", { ) expect_true(any(grepl("mixture of 2 panels", capture.output(show(mix))))) }) + +test_that("an LdMatrix's blocks are read packed, whichever triangle it holds", { + f <- .ldmFixture() + ld <- LdMatrix(f$R, nSamples = 10) + idx <- c(5L, 2L, 7L) + want <- unname(f$R[idx, idx]) + block <- pecotmr:::.ldmPackedBlock(ld, idx) + expect_s4_class(block, "dspMatrix") + expect_equal(methods::as(block, "matrix"), want) + # One saved before packing reads the same. + saved <- ld + saved@correlation <- f$R + expect_equal( + methods::as(pecotmr:::.ldmPackedBlock(saved, idx), "matrix"), + want + ) + # One packed by its lower triangle too: the Matrix package misreads a + # lower triangle under indices out of order, so it is read transposed. + lower <- ld + lower@correlation <- Matrix::pack( + Matrix::forceSymmetric(unname(f$R), uplo = "L") + ) + shuffled <- c(8L, 1L, 4L) + expect_equal( + pecotmr:::.ldmBlock(lower, shuffled), + unname(f$R[shuffled, shuffled]) + ) +}) diff --git a/tests/testthat/test_LdScore.R b/tests/testthat/test_LdScore.R index d0a3562de..11df9ea99 100644 --- a/tests/testthat/test_LdScore.R +++ b/tests/testthat/test_LdScore.R @@ -221,6 +221,25 @@ test_that("buildLdScore keeps per-block LD matrices for g-LDSC by default", { ) }) +test_that("an LdScore stores block matrices packed and hands them out whole", { + ld <- makeTestLdMatrixBlocks(sizes = c(4L, 3L)) + scores <- buildLdScore(ld) + stored <- methods::slot(scores, "ldMatrixList") + expect_s4_class(stored[[1L]]$R, "dspMatrix") + mats <- ldMatrixList(scores) + expect_true(is.matrix(mats[[1L]]$R)) + expect_identical(mats[[1L]]$R, unname(ldMatrix(ld[[1L]]))) +}) + +test_that("updateObject packs the block matrices of a saved LdScore", { + scores <- buildLdScore(makeTestLdMatrixBlocks(sizes = c(4L, 3L))) + saved <- scores + methods::slot(saved, "ldMatrixList") <- ldMatrixList(scores) + expect_true(is.matrix(methods::slot(saved, "ldMatrixList")[[1L]]$R)) + expect_identical(updateObject(saved), scores) + expect_identical(updateObject(scores), scores) +}) + test_that("buildLdScore defaults weights to 1/max(l2, 1)", { ld <- makeTestLdMatrix(n = 6L) ref <- buildLdScore(ld) diff --git a/tests/testthat/test_LdStatistic.R b/tests/testthat/test_LdStatistic.R index d7c40eaf0..f02dc682e 100644 --- a/tests/testthat/test_LdStatistic.R +++ b/tests/testthat/test_LdStatistic.R @@ -323,8 +323,8 @@ test_that("a block's LD and decomposition are read as stored", { stored <- list(idx = seq_along(idx), R = want) lazy <- list(idx = seq_along(idx), rows = idx) expect_equal(pecotmr:::.ldStatBlockLd(stored, NULL), list(R = want)) - F <- pecotmr:::.ldStatBlockLd(lazy, fx$panel)$F - expect_equal(unname(crossprod(F)) / (nrow(F) - 1), want) + ldFactor <- pecotmr:::.ldStatBlockLd(lazy, fx$panel)$ldFactor + expect_equal(unname(crossprod(ldFactor)) / (nrow(ldFactor) - 1), want) # 140 variants and 100 samples: the SVD lists 100 directions and counts # the other 40, whose eigenvalue is exactly zero, unless they would be # truncated away anyway. diff --git a/tests/testthat/test_MashPrior.R b/tests/testthat/test_MashPrior.R index 612286e8b..d3194344c 100644 --- a/tests/testthat/test_MashPrior.R +++ b/tests/testthat/test_MashPrior.R @@ -1,6 +1,7 @@ # Tests for R/MashPrior.R — the data-driven (mash) prior bundle: full-data prior # (fullFit) + per-fold cross-validated priors (cvFits) consumed by -# twasWeightsPipeline (mr.mash) and, transitively, fineMappingPipeline (mvSuSiE). +# twasWeightsPipeline (mr.mash) and, transitively, fineMappingPipeline +# (mvSuSiE). test_that("MashPrior: construct + accessors (full + cv)", { U <- list(U1 = diag(2)) diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index 677c89366..beb84d91c 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -115,7 +115,7 @@ test_that(".qtlResidualizeQr: intercept-only residualization centers Y", { expect_equal(unname(colMeans(res)), c(0, 0), tolerance = 1e-10) }) -test_that(".qtlResidualizeQr: covariate residualization removes the covariate signal", { +test_that(".qtlResidualizeQr removes the covariate signal", { set.seed(1) n <- 50 C <- matrix( @@ -138,7 +138,7 @@ test_that(".qtlResidualizeQr: covariate residualization removes the covariate si expect_lt(abs(cor(res[, 1], C[, 2])), 1e-8) }) -test_that(".qtlResidualizeQr: scaleResiduals = TRUE gives unit variance per column", { +test_that(".qtlResidualizeQr: scaleResiduals gives each column unit variance", { set.seed(2) Y <- matrix(rnorm(30), nrow = 10, ncol = 3) res <- pecotmr:::.qtlResidualizeQr(Y, C = NULL, scaleResiduals = TRUE) @@ -146,14 +146,14 @@ test_that(".qtlResidualizeQr: scaleResiduals = TRUE gives unit variance per colu expect_equal(sds, c(1, 1, 1), tolerance = 1e-10) }) -test_that(".qtlResidualizeQr: constant residual columns survive the rescale step", { +test_that(".qtlResidualizeQr: constant residual columns survive the rescale", { # Y is exactly its own mean -> residuals are 0, sd is 0 (and clamped to 1). Y <- matrix(5, nrow = 5, ncol = 1) res <- pecotmr:::.qtlResidualizeQr(Y, C = NULL, scaleResiduals = TRUE) expect_true(all(abs(res) < 1e-10)) }) -test_that(".qtlResidualizeQr: rank-deficient covariates are dropped by pivoted QR", { +test_that(".qtlResidualizeQr drops rank-deficient covariates by pivoted QR", { set.seed(3) n <- 30 c1 <- rnorm(n) @@ -209,7 +209,7 @@ test_that(".qtlResolveVariantRegion: traitId requires cisWindow", { ) }) -test_that(".qtlResolveVariantRegion: traitId expands by cisWindow on each side", { +test_that(".qtlResolveVariantRegion: traitId widens by cisWindow each side", { qd <- .qh_makeDataset() gr <- pecotmr:::.qtlResolveVariantRegion( qd, @@ -270,7 +270,7 @@ test_that(".qtlResolveVariantRegion: traits across chromosomes error", { ) }) -test_that(".qtlResolveVariantRegion: region must be a GRanges; multi-range is allowed", { +test_that(".qtlResolveVariantRegion takes a GRanges region, of any length", { qd <- .qh_makeDataset() expect_error( pecotmr:::.qtlResolveVariantRegion(qd, region = "chr1:100-200"), @@ -283,7 +283,8 @@ test_that(".qtlResolveVariantRegion: region must be a GRanges; multi-range is al ), "at least one range" ) - # A multi-range region is now taken literally (joint multi-region extraction). + # A multi-range region is now taken literally (joint multi-region + # extraction). multi <- GenomicRanges::GRanges( c("chr1", "chr1"), IRanges::IRanges(c(1, 100), c(50, 200)) @@ -345,16 +346,18 @@ test_that(".qtlVariantIndices: returns integer(0) when no overlap", { # traitPosition / .qtlTraitPos # =========================================================================== -test_that("traitPosition returns each trait's union genomic span across contexts", { - # .qh_makeSe places ENSG1 @ chr1:1000-1500 and ENSG2 @ chr1:2000-2500 in every - # context, so each trait's cross-context union span is that single interval. +test_that("traitPosition gives each trait's span over all its contexts", { + # .qh_makeSe places ENSG1 @ chr1:1000-1500 and ENSG2 @ chr1:2000-2500 in + # every context, so each trait's cross-context union span is that single + # interval. qd <- .qh_makeDataset(contexts = c("brain", "liver")) gr <- traitPosition(qd) expect_s4_class(gr, "GRanges") expect_setequal(names(gr), c("ENSG1", "ENSG2")) expect_equal(as.character(GenomicRanges::seqnames(gr["ENSG1"])), "chr1") expect_equal(GenomicRanges::start(gr["ENSG1"]), 1000L) - expect_equal(GenomicRanges::end(gr["ENSG1"]), 1499L) # start 1000 + width 500 - 1 + # start 1000 + width 500 - 1 + expect_equal(GenomicRanges::end(gr["ENSG1"]), 1499L) expect_equal(GenomicRanges::start(gr["ENSG2"]), 2000L) # single-trait selection routes through the traitId branch of the method one <- traitPosition(qd, trait = "ENSG2") @@ -419,7 +422,7 @@ test_that("an unset filter filters nothing and leaves the dataset whole", { # .qtlResolvePhenoSelection # =========================================================================== -test_that(".qtlResolvePhenoSelection: NULL returns all colData columns per context", { +test_that(".qtlResolvePhenoSelection: NULL gives every colData column", { qd <- .qh_makeDataset(contexts = c("brain", "liver")) out <- pecotmr:::.qtlResolvePhenoSelection( qd, @@ -431,7 +434,7 @@ test_that(".qtlResolvePhenoSelection: NULL returns all colData columns per conte expect_setequal(out$liver, c("sex", "age")) }) -test_that(".qtlResolvePhenoSelection: character vector applies to all contexts", { +test_that(".qtlResolvePhenoSelection: a character vector fits every context", { qd <- .qh_makeDataset(contexts = c("brain", "liver")) out <- pecotmr:::.qtlResolvePhenoSelection( qd, @@ -442,7 +445,7 @@ test_that(".qtlResolvePhenoSelection: character vector applies to all contexts", expect_equal(out$liver, "age") }) -test_that(".qtlResolvePhenoSelection: character vector with unknown name errors", { +test_that(".qtlResolvePhenoSelection errors on an unknown name", { qd <- .qh_makeDataset(contexts = "brain") expect_error( pecotmr:::.qtlResolvePhenoSelection( @@ -517,7 +520,7 @@ test_that(".qtlResolvePhenoSelection: unsupported type errors", { # .qtlResolveGenoSelection # =========================================================================== -test_that(".qtlResolveGenoSelection: NULL returns all genotypeCovariates columns", { +test_that(".qtlResolveGenoSelection: NULL gives every genotype covariate", { gc <- matrix( rnorm(12 * 3), nrow = 12, @@ -531,7 +534,7 @@ test_that(".qtlResolveGenoSelection: NULL returns all genotypeCovariates columns ) }) -test_that(".qtlResolveGenoSelection: empty genotypeCovariates returns character(0)", { +test_that(".qtlResolveGenoSelection: no genotype covariates, character(0)", { qd <- .qh_makeDataset(contexts = "brain") expect_equal( pecotmr:::.qtlResolveGenoSelection(qd, toResidualize = NULL), @@ -571,7 +574,7 @@ test_that(".qtlResolveGenoSelection: unknown name errors", { # .qtlBuildResidualizationDesign # =========================================================================== -test_that(".qtlBuildResidualizationDesign: pheno-only single-context builds the colData matrix", { +test_that(".qtlBuildResidualizationDesign: one context's colData matrix", { qd <- .qh_makeDataset(contexts = "brain") phenoSel <- list(brain = c("age", "sex")) D <- pecotmr:::.qtlBuildResidualizationDesign( @@ -587,7 +590,7 @@ test_that(".qtlBuildResidualizationDesign: pheno-only single-context builds the expect_setequal(colnames(D), c("brain.age", "brain.sex")) }) -test_that(".qtlBuildResidualizationDesign: pheno-only multi-context concatenates per context", { +test_that(".qtlBuildResidualizationDesign joins pheno covariates of contexts", { qd <- .qh_makeDataset(contexts = c("brain", "liver")) phenoSel <- list(brain = "age", liver = "sex") D <- pecotmr:::.qtlBuildResidualizationDesign( @@ -602,7 +605,7 @@ test_that(".qtlBuildResidualizationDesign: pheno-only multi-context concatenates expect_setequal(colnames(D), c("brain.age", "liver.sex")) }) -test_that(".qtlBuildResidualizationDesign: includeGeno-only returns genotype covariates", { +test_that("the design with only includeGeno holds the genotype covariates", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -622,7 +625,7 @@ test_that(".qtlBuildResidualizationDesign: includeGeno-only returns genotype cov expect_setequal(colnames(D), c("pc1", "pc2")) }) -test_that(".qtlBuildResidualizationDesign: pheno + geno concatenates both blocks", { +test_that(".qtlBuildResidualizationDesign joins pheno and geno blocks", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -642,7 +645,7 @@ test_that(".qtlBuildResidualizationDesign: pheno + geno concatenates both blocks expect_setequal(colnames(D), c("brain.age", "pc1")) }) -test_that(".qtlBuildResidualizationDesign: returns NULL when nothing to include", { +test_that(".qtlBuildResidualizationDesign: NULL when nothing is included", { qd <- .qh_makeDataset(contexts = "brain") D <- pecotmr:::.qtlBuildResidualizationDesign( qd, @@ -655,7 +658,7 @@ test_that(".qtlBuildResidualizationDesign: returns NULL when nothing to include" expect_null(D) }) -test_that(".qtlBuildResidualizationDesign: intersects sample sets across blocks", { +test_that(".qtlBuildResidualizationDesign intersects the blocks' samples", { # Build a dataset where the genotype covariates only cover samples s1..s6. gc <- matrix( rnorm(6 * 1), @@ -684,42 +687,16 @@ test_that(".qtlBuildResidualizationDesign: intersects sample sets across blocks" # requested snpIdx, drawing dosages from a per-handle-deterministic seed so # the same indices always give the same numbers. .qh_mockExtractor <- function(seed = 42, n_samples = 12L, n_snp = 6L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) # Build a (n_samples x n_snp) dosage matrix for the whole panel; the # caller's snpIdx subsets columns. panel <- matrix( rbinom(n_samples * n_snp, 2, 0.3), nrow = n_samples, - ncol = n_snp, - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - # Build the SE in variants x samples orientation (matches the real impl). - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = n_snp ) + panel[, snpIdx, drop = FALSE] } } @@ -741,10 +718,10 @@ test_that("a NULL residualization bundle scales, as an unset field does", { )) }) -test_that(".qtlExtractBlock: returns dosage matrix with kept variants and samples", { +test_that(".qtlExtractBlock gives the dosages of kept variants and samples", { qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd) @@ -763,10 +740,10 @@ test_that(".qtlExtractBlock: empty snpIdx returns a zero-column block", { expect_equal(blk$variantIds, character(0)) }) -test_that(".qtlExtractBlock: keepVariants restriction narrows the returned set", { +test_that(".qtlExtractBlock: keepVariants narrows the variants returned", { qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock( @@ -776,32 +753,32 @@ test_that(".qtlExtractBlock: keepVariants restriction narrows the returned set", expect_setequal(blk$variantIds, c("rs2", "rs4")) }) -test_that(".qtlExtractBlock: keepSamples restriction narrows the returned set", { +test_that(".qtlExtractBlock: keepSamples narrows the samples returned", { qd <- .qh_makeDataset() qd <- pecotmr:::.qtlRestrictSamples(qd, paste0("s", 1:6)) local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd) expect_setequal(blk$sampleIds, paste0("s", 1:6)) }) -test_that(".qtlExtractBlock: per-call samples arg further narrows the sample set", { +test_that(".qtlExtractBlock: a call's samples argument narrows them further", { qd <- .qh_makeDataset() qd <- pecotmr:::.qtlRestrictSamples(qd, paste0("s", 1:6)) local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd, samples = c("s1", "s3", "s5")) expect_setequal(blk$sampleIds, c("s1", "s3", "s5")) }) -test_that(".qtlExtractBlock: keepVariants with empty intersection returns empty block", { +test_that(".qtlExtractBlock: keepVariants sharing none gives an empty block", { qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock( @@ -812,14 +789,14 @@ test_that(".qtlExtractBlock: keepVariants with empty intersection returns empty expect_equal(nrow(blk$geno), 0L) }) -test_that(".qtlExtractBlock: keepIndel = FALSE drops multi-base (indel) variants", { +test_that(".qtlExtractBlock: keepIndel = FALSE drops indels", { # rs2 an insertion, rs4 a deletion; the rest stay SNPs. qd <- .qh_makeDataset( a1 = replace(rep("A", 6L), 2L, "AT"), a2 = replace(rep("G", 6L), 4L, "GC") ) local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock( @@ -832,7 +809,7 @@ test_that(".qtlExtractBlock: keepIndel = FALSE drops multi-base (indel) variants test_that(".qtlExtractBlock: keepIndel = TRUE (default) keeps indel variants", { qd <- .qh_makeDataset(a1 = replace(rep("A", 6L), 2L, "AT")) local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd) @@ -851,7 +828,7 @@ test_that(".qtlExtractBlock: mafCutoff drops low-MAF variants", { # drops everything. qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd, filter = .qh_filter(mafCutoff = 0.51)) @@ -862,7 +839,7 @@ test_that(".qtlExtractBlock: mafCutoff retains variants above the threshold", { # realized MAFs include 0.458 and 0.5 qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd, filter = .qh_filter(mafCutoff = 0.4)) @@ -873,47 +850,29 @@ test_that(".qtlExtractBlock: mafCutoff retains variants above the threshold", { # Deterministic dosage panel so the directional (un-folded) effect-allele # frequency is exactly known: rs1 = 0.70, rs2 = 0.20, rs3 = 0.50, rest 0. .qh_directionalExtractor <- function() { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { panel <- matrix( 0, nrow = length(sampleIds(handle)), ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) + # The fixture labels variant k "rsk"; a panel's seed keeps no + # labels, so its columns are named by position. + dimnames = list( + sampleIds(handle), + str_c("rs", seq_len(nrow(snpInfo(handle)))) + ) ) panel[, "rs1"] <- c(2, 2, 2, 2, 1, 1, 1, 1, 1, 1) # sum 14 -> p = 0.70 panel[, "rs2"] <- c(1, 1, 1, 1, 0, 0, 0, 0, 0, 0) # sum 4 -> p = 0.20 panel[, "rs3"] <- 1 # sum 10 -> p = 0.50 - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - ) + panel[, snpIdx, drop = FALSE] } } -test_that(".qtlExtractBlock: returns directional af; maf is its minor-allele fold", { +test_that(".qtlExtractBlock gives directional af; maf is its folded form", { qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd) @@ -922,10 +881,10 @@ test_that(".qtlExtractBlock: returns directional af; maf is its minor-allele fol expect_equal(unname(blk$maf), pmin(unname(blk$af), 1 - unname(blk$af))) }) -test_that("af: returns directional effect-allele frequency (not folded to MAF)", { +test_that("af gives the directional effect-allele frequency, not MAF", { qd <- .qh_makeDataset(n_samples = 10L) local_mocked_bindings( - extractBlockGenotypes = .qh_directionalExtractor(), + .handleDosage = .qh_directionalExtractor(), .package = "pecotmr" ) af <- af(qd) @@ -936,10 +895,10 @@ test_that("af: returns directional effect-allele frequency (not folded to MAF)", expect_equal(unname(af[["rs3"]]), 0.50) }) -test_that("maf stays folded while af is directional (they fold into each other)", { +test_that("maf stays folded while af is directional; one folds to the other", { qd <- .qh_makeDataset(n_samples = 10L) local_mocked_bindings( - extractBlockGenotypes = .qh_directionalExtractor(), + .handleDosage = .qh_directionalExtractor(), .package = "pecotmr" ) af <- af(qd) @@ -1033,39 +992,14 @@ context("QtlDataset residualization methods") } .qr_mockExtractor <- function(seed = 42, n_samples = 12L, n_snp = 6L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * n_snp, 2, 0.3), nrow = n_samples, - ncol = n_snp, - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = n_snp ) + panel[, snpIdx, drop = FALSE] } } @@ -1095,7 +1029,7 @@ test_that("FALSE is distinguishable from unset", { # .qtlHandleCovariateNa (covariate missing-value strategy) # =========================================================================== -test_that(".qtlHandleCovariateNa: NULL and NA-free inputs pass through unchanged", { +test_that(".qtlHandleCovariateNa passes NULL and NA-free inputs through", { expect_null(pecotmr:::.qtlHandleCovariateNa(NULL)) C <- matrix(c(1, 2, 3, 4), nrow = 2) expect_identical(pecotmr:::.qtlHandleCovariateNa(C), C) @@ -1125,7 +1059,7 @@ test_that(".qtlHandleCovariateNa: impute (default) fills NA with column mean", { expect_equal(out["s1", "a"], 1) }) -test_that(".qtlHandleCovariateNa: impute fills a wholly-missing column with 0", { +test_that(".qtlHandleCovariateNa: impute fills an all-missing column with 0", { C <- matrix( c(NA_real_, NA_real_, 5, 7), nrow = 2, @@ -1137,7 +1071,7 @@ test_that(".qtlHandleCovariateNa: impute fills a wholly-missing column with 0", expect_equal(out[, "a"], c(s1 = 0, s2 = 0)) }) -test_that(".qtlHandleCovariateNa: drop removes any sample with a missing covariate", { +test_that(".qtlHandleCovariateNa: drop removes samples missing a covariate", { C <- matrix( c(1, NA, 3, 4, 5, 6), nrow = 3, @@ -1177,7 +1111,7 @@ test_that("residualizedGenotypes: unknown context errors", { test_that("residualizedGenotypes: empty genotype block short-circuits to G", { qd <- .qr_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) # region with no SNPs in the panel. @@ -1193,7 +1127,7 @@ test_that("residualizedGenotypes: empty genotype block short-circuits to G", { test_that("residualizedGenotypes: produces residualized matrix shape", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) G <- residualizedGenotypes(qd, context = "brain") @@ -1206,10 +1140,10 @@ test_that("residualizedGenotypes: produces residualized matrix shape", { expect_true(all(abs(sds[nonZero] - 1) < 1e-6)) }) -test_that("residualizedGenotypes: residualizes only against selected pheno covariate", { +test_that("residualizedGenotypes residualizes on the selected covariate only", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) G <- residualizedGenotypes( @@ -1228,7 +1162,7 @@ test_that("residualizedGenotypes: residualizes only against selected pheno covar test_that("residualizedGenotypes: respects residualizePhenotype = FALSE", { qd <- .qr_makeDataset(contexts = "brain") local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) # When pheno is disabled, the design becomes intercept-only, so the result @@ -1259,7 +1193,7 @@ test_that("residualizedGenotypes refuses a bare list for the bundle", { test_that("residualizedGenotypes: joint-context mode intersects samples", { qd <- .qr_makeDataset(contexts = c("brain", "liver")) local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) G <- residualizedGenotypes(qd, context = c("brain", "liver")) @@ -1276,7 +1210,7 @@ test_that("residualizedGenotypes: includes genotype covariates when supplied", { ) qd <- .qr_makeDataset(contexts = "brain", geno_cov = gc) local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) G <- residualizedGenotypes( @@ -1303,7 +1237,7 @@ test_that("residualizedGenotypes: mean-imputes missing covariates by default", { gc[3, "pc1"] <- NA # missing covariate cell qd <- .qr_makeDataset(contexts = "brain", geno_cov = gc) local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) # Default covariateNaAction = "impute": no error, all 12 samples retained. @@ -1318,7 +1252,7 @@ test_that("residualizedGenotypes: mean-imputes missing covariates by default", { expect_false(anyNA(G)) }) -test_that("residualizedGenotypes: covariateNaAction='drop' removes samples with missing covariates", { +test_that("residualizedGenotypes: 'drop' removes samples missing covariates", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -1328,7 +1262,7 @@ test_that("residualizedGenotypes: covariateNaAction='drop' removes samples with gc[3, "pc1"] <- NA qd <- .qr_makeDataset(contexts = "brain", geno_cov = gc) local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) G <- residualizedGenotypes( @@ -1416,7 +1350,7 @@ test_that("residualizedPhenotypes: trait subsets to requested traits", { expect_equal(colnames(Y), "ENSG1") }) -test_that("residualizedPhenotypes: scaleResiduals = FALSE skips the rescale step", { +test_that("residualizedPhenotypes: scaleResiduals = FALSE skips rescaling", { qd <- .qr_makeDataset(contexts = "brain") Y <- residualizedPhenotypes( qd, @@ -1506,7 +1440,8 @@ test_that("naAction = 'impute' mean-imputes NAs per trait", { Y <- SummarizedExperiment::assay(out) expect_equal(ncol(Y), 8L) expect_false(any(is.na(Y))) - # Imputed values equal the mean of the non-missing entries of the same trait. + # Imputed values equal the mean of the non-missing entries of the same + # trait. orig <- SummarizedExperiment::assay(se) obsMean <- mean(orig[1L, !is.na(orig[1L, ])]) expect_equal(Y[1L, 2L], obsMean) @@ -1629,7 +1564,7 @@ test_that("outlierAction = 'drop' drops residualized outliers", { expect_false("s10" %in% rownames(Y)) }) -test_that(".qtlOutlierKeepMask: single-trait reduces to z-test (drops huge value)", { +test_that(".qtlOutlierKeepMask: one trait is a z-test (drops a huge value)", { set.seed(11L) Y <- matrix( c(rnorm(29), 50), @@ -1760,7 +1695,7 @@ test_that("QtlDataset: rejects shared traits with inconsistent rowRanges", { }) -test_that("QtlDataset: tolerates chr-prefix-only seqname differences for a shared trait", { +test_that("QtlDataset tolerates seqnames differing only by chr prefix", { se1 <- .sc_makeSe(traits = c("ENSG1")) # ENSG1 at chr1:1000-1499 # se2 is the SAME locus but with a non-prefixed seqname ("1" vs "chr1"); # canonChrom() reconciliation should treat these as the same trait position. @@ -1835,6 +1770,21 @@ test_that("updateObject renames study and reads saved genotypes again", { ) }) +test_that("updateObject drops the copies of labels saved genotypes kept", { + data(qtlDatasetExample) + current <- .qtlGenotypeSe(qtlDatasetExample) + saved <- .savedLabelledPanel(current) + expect_false(is.null(SummarizedExperiment::rowData(saved)$SNP)) + old <- .qtlWithGenotypeHandle(qtlDatasetExample, saved) + geno <- .qtlGenotypeSe(updateObject(old)) + expect_identical( + SummarizedExperiment::rowRanges(geno), + .dropRedundantLabels(SummarizedExperiment::rowRanges(current)) + ) + expect_null(dimnames(.panelSeed(geno))[[1L]]) + expect_identical(dimnames(geno), dimnames(current)) +}) + test_that("updateObject refuses a QtlDataset whose genotypes cannot be read", { data(qtlDatasetExample) current <- .qtlGenotypeSe(qtlDatasetExample) @@ -2028,7 +1978,7 @@ test_that("phenotypeCovariates: requires contexts and rejects unknown ones", { # .qtlResolveVariantRegion: region-path cisWindow validation # =========================================================================== -test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative cisWindow", { +test_that(".qtlResolveVariantRegion refuses a vector or negative cisWindow", { qd <- .qh_makeDataset() region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100, 200)) expect_error( @@ -2049,11 +1999,11 @@ test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative c # .qtlExtractBlock: indel-empty / sample-empty / imiss / xvar / impute paths # =========================================================================== -test_that(".qtlExtractBlock: keepIndel = FALSE with an all-indel panel returns an empty block", { +test_that(".qtlExtractBlock: no indels from an all-indel panel, empty block", { # Every variant a multi-base allele, so the indel filter drops them all. qd <- .qh_makeDataset(a1 = rep("AT", 6L)) local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock( @@ -2066,12 +2016,12 @@ test_that(".qtlExtractBlock: keepIndel = FALSE with an all-indel panel returns a expect_equal(blk$maf, numeric(0)) }) -test_that(".qtlExtractBlock: keepSamples disjoint from the panel returns a zero-sample block", { +test_that(".qtlExtractBlock: keepSamples off the panel gives no samples", { qd <- .qh_makeDataset() # none are panel samples qd <- pecotmr:::.qtlRestrictSamples(qd, c("zzz1", "zzz2")) local_mocked_bindings( - extractBlockGenotypes = .qh_mockExtractor(), + .handleDosage = .qh_mockExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock(qd) @@ -2086,7 +2036,7 @@ test_that(".qtlExtractBlock: keepSamples disjoint from the panel returns a zero- # per-sample imiss filter), and s2/rs2 carries a single scattered NA that # survives the filter (exercising the mean-impute loop). .qh_naExtractor <- function() { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { ns <- length(sampleIds(handle)) nv <- nrow(snpInfo(handle)) set.seed(123L) @@ -2094,42 +2044,21 @@ test_that(".qtlExtractBlock: keepSamples disjoint from the panel returns a zero- rbinom(ns * nv, 2, 0.4), nrow = ns, ncol = nv, - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) + # The fixture labels variant k "rsk"; a panel's seed keeps no + # labels, so its columns are named by position. + dimnames = list(sampleIds(handle), str_c("rs", seq_len(nv))) ) panel["s1", ] <- NA_real_ # fully missing sample -> dropped by imiss panel["s2", "rs2"] <- NA_real_ # scattered NA -> kept then mean-imputed - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - ) + panel[, snpIdx, drop = FALSE] } } -test_that(".qtlExtractBlock: imissCutoff drops high-missingness samples and mean-imputes the rest", { +test_that(".qtlExtractBlock: imissCutoff drops samples, imputes the rest", { # s1 (100% NA) dropped; s2 (1 NA) kept then imputed qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_naExtractor(), + .handleDosage = .qh_naExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock( @@ -2144,7 +2073,7 @@ test_that(".qtlExtractBlock: imissCutoff drops high-missingness samples and mean # Extractor with one constant (zero-variance) column to drive the xvar filter. .qh_lowVarExtractor <- function() { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { ns <- length(sampleIds(handle)) nv <- nrow(snpInfo(handle)) set.seed(99L) @@ -2152,47 +2081,27 @@ test_that(".qtlExtractBlock: imissCutoff drops high-missingness samples and mean rbinom(ns * nv, 2, 0.4), nrow = ns, ncol = nv, - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) + # The fixture labels variant k "rsk"; a panel's seed keeps no + # labels, so its columns are named by position. + dimnames = list(sampleIds(handle), str_c("rs", seq_len(nv))) ) panel[, "rs1"] <- 1L # constant column -> variance 0 - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - ) + panel[, snpIdx, drop = FALSE] } } -test_that(".qtlExtractBlock: xvarCutoff drops near-constant (low-variance) variants", { +test_that(".qtlExtractBlock: xvarCutoff drops near-constant variants", { qd <- .qh_makeDataset() local_mocked_bindings( - extractBlockGenotypes = .qh_lowVarExtractor(), + .handleDosage = .qh_lowVarExtractor(), .package = "pecotmr" ) blk <- pecotmr:::.qtlExtractBlock( qd, filter = .qh_filter(xvarCutoff = 0.01) ) - expect_false("rs1" %in% blk$variantIds) # constant column dropped on variance + # constant column dropped on variance + expect_false("rs1" %in% blk$variantIds) expect_true(ncol(blk$geno) >= 1L) }) @@ -2229,7 +2138,8 @@ test_that("a pipeline's window keeps only the overlapping traits", { test_that("an unmatched window under naAction = 'drop' gives an empty SE", { qd <- .qr_makeDataset(contexts = "brain") - region <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1, 100)) # no overlap + # no overlap + region <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1, 100)) out <- pecotmr:::.qtlMolecularTraits( qd, contexts = "brain", @@ -2241,10 +2151,11 @@ test_that("an unmatched window under naAction = 'drop' gives an empty SE", { }) # =========================================================================== -# .qtlOutlierKeepMask: degenerate + robustbase-present-failure + robustbase-absent +# .qtlOutlierKeepMask: degenerate + robustbase-present-failure + +# robustbase-absent # =========================================================================== -test_that(".qtlOutlierKeepMask: degenerate (n==0 or p==0) short-circuits to all-TRUE", { +test_that(".qtlOutlierKeepMask keeps all when n or p is 0", { expect_equal( pecotmr:::.qtlOutlierKeepMask(matrix(numeric(0), 0L, 0L), 1e-3), logical(0) @@ -2255,7 +2166,7 @@ test_that(".qtlOutlierKeepMask: degenerate (n==0 or p==0) short-circuits to all- ) }) -test_that(".qtlOutlierKeepMask: robustbase covMcd failure falls back to colMeans/cov", { +test_that(".qtlOutlierKeepMask: a covMcd failure falls back to colMeans/cov", { skip_if_not_installed("robustbase") local_mocked_bindings( covMcd = function(...) stop("forced covMcd failure"), @@ -2281,7 +2192,7 @@ test_that(".qtlApplyPhenoOutliers: action='keep' returns the SE unchanged", { expect_identical(out, se) }) -test_that(".qtlApplyPhenoOutliers: action='drop' with clean data keeps every sample", { +test_that(".qtlApplyPhenoOutliers: 'drop' on clean data keeps every sample", { set.seed(101L) traits <- c("ENSG1", "ENSG2") n <- 40L @@ -2311,7 +2222,7 @@ test_that(".qtlApplyPhenoOutliers: action='drop' with clean data keeps every sam # .qtlBuildResidualizationDesign: empty-selection skip, rowname restore, NULL # =========================================================================== -test_that(".qtlBuildResidualizationDesign: skips contexts with an empty selection", { +test_that(".qtlBuildResidualizationDesign skips empty-selection contexts", { qd <- .qr_makeDataset(contexts = c("brain", "liver")) D <- pecotmr:::.qtlBuildResidualizationDesign( qd, @@ -2387,7 +2298,7 @@ test_that(".qtlBuildResidualizationDesign: disjoint blocks error", { # residualized{Genotypes,Phenotypes}: disjoint sample-set errors # =========================================================================== -test_that("residualizedGenotypes: errors when genotypes and covariates share no samples", { +test_that("residualizedGenotypes errors when no sample has both inputs", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -2396,7 +2307,7 @@ test_that("residualizedGenotypes: errors when genotypes and covariates share no ) qd <- .qr_makeDataset(contexts = "brain", geno_cov = gc) local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), + .handleDosage = .qr_mockExtractor(), .package = "pecotmr" ) expect_error( @@ -2412,7 +2323,7 @@ test_that("residualizedGenotypes: errors when genotypes and covariates share no ) }) -test_that("residualizedPhenotypes: errors when phenotypes and covariates share no samples", { +test_that("residualizedPhenotypes errors when no sample has both inputs", { gc <- matrix( rnorm(12 * 2), nrow = 12, @@ -2511,15 +2422,17 @@ test_that("the sampleMap records which samples each context observes", { test_that("the genotype experiment describes variants the way the readers do", { qd <- .qm_makeDataset() gr <- SummarizedExperiment::rowRanges(pecotmr:::.qtlGenotypeSe(qd)) - si <- snpInfo(genotypeHandle(qd)) + si <- snpInfo(.qr_makeHandle()) expect_equal(length(gr), nrow(si)) - # Same shape as extractBlockGenotypes() returns, so ranges from the two - # actually overlap rather than silently missing on a chr prefix. + # Spelled with the chr prefix, as extractBlockGenotypes() spells them, so + # ranges from the two actually overlap rather than silently missing on it. expect_true(all(str_detect( as.character(GenomicRanges::seqnames(gr)), "^chr" ))) - expect_equal(colnames(S4Vectors::mcols(gr)), c("SNP", "A1", "A2")) + # The file's labels name the rows, so no SNP column repeats them. + expect_equal(colnames(S4Vectors::mcols(gr)), c("A1", "A2")) + expect_equal(names(gr), si$SNP) expect_equal(GenomicRanges::start(gr), as.integer(si$BP)) }) @@ -2581,7 +2494,7 @@ test_that("subsetting by context also applies feature and sample subscripts", { } }) -test_that("the experiment subscript accepts logical and numeric, not just names", { +test_that("experiment subscripts may be logical or numeric, not just names", { qd <- .qm_makeDataset() nms <- names(MultiAssayExperiment::experiments(qd)) expect_equal(nms, c("genotype", "brain", "liver")) @@ -2628,11 +2541,11 @@ test_that("a context may not be called 'genotype'", { }) test_that("replacing the handle moves the assay's seed with it", { - # The handle is held twice -- slot and seed -- which is what makes the - # assay lazy. Moving one without the other would have the dosages - # describing a different panel from the one the accessors read. + # The handle lives in one place, the assay's seed, so replacing it moves + # the seed the dosages read through. A seed's handle keeps no variant + # table to build a panel from, so the replacement is a whole handle. qd <- .qm_makeDataset() - handle <- genotypeHandle(qd) + handle <- .qr_makeHandle() # A bundled resource that resolves: building the panel looks beside it # for a sketch's .afreq sidecar. handle@path <- "pecotmr://extdata/toy_ref" @@ -2720,8 +2633,9 @@ test_that("QtlDataset accepts the panel readGenotypes returns", { ) expect_s4_class(qd, "QtlDataset") # The slot keeps the handle either way: it is the seed the dosage assay - # reads through, not a second copy of the panel. - expect_identical(genotypeHandle(qd), gh) + # reads through, not a second copy of the panel, so its variant table + # keeps only the columns reading needs. + expect_identical(genotypeHandle(qd), pecotmr:::.readingHandle(gh)) expect_equal( dim(qd), dim(.qh_makeDataset(contexts = "brain")) @@ -2796,7 +2710,7 @@ test_that("the phenotype check reports an empty context set", { ) }) -test_that("aligning genotypes and covariates errors when they share no samples", { +test_that("aligning genotypes and covariates errors with no shared samples", { G <- matrix(0, 2L, 2L, dimnames = list(c("a", "b"), c("v1", "v2"))) C <- matrix(0, 2L, 1L, dimnames = list(c("x", "y"), "pc1")) expect_error( @@ -2829,7 +2743,7 @@ test_that("residualizing a context errors when covariates share no samples", { }) -test_that("trait-position validation skips a context whose ranges do not line up", { +test_that("trait-position validation skips a context whose ranges misalign", { # rowRanges and rownames disagreeing means the context cannot be compared # against the others; it is skipped rather than reported as a conflict. mkSe <- function(traits) { diff --git a/tests/testthat/test_QtlFineMappingResult.R b/tests/testthat/test_QtlFineMappingResult.R index b25c38c1a..26cd19600 100644 --- a/tests/testthat/test_QtlFineMappingResult.R +++ b/tests/testthat/test_QtlFineMappingResult.R @@ -18,7 +18,7 @@ test_that("QtlFineMappingResult: builds a collection keyed by 4-tuple", { }) -test_that("QtlFineMappingResult: validity does not recurse on key subset (#546)", { +test_that("QTL result validity does not recurse on a key subset (#546)", { # The validity method builds a key-column data.frame to check tuple # uniqueness. Doing so via `object[, keyCols]` preserves the # QtlFineMappingResult class while dropping the required `entry` column; @@ -57,11 +57,15 @@ test_that("QtlFineMappingResult: stores an LD sketch when supplied", { entry = list(e), ldReference = gh ) - # The reference is a panel; the handle it reads through is its seed. + # The reference is a panel; the handle it reads through is its seed, + # which keeps only the columns reading needs. refs <- ldReference(res) expect_named(refs, res$ldReference) expect_s4_class(refs[[1L]], "RangedSummarizedExperiment") - expect_identical(pecotmr:::.ldRefHandle(refs[[1L]]), gh) + expect_identical( + pecotmr:::.ldRefHandle(refs[[1L]]), + pecotmr:::.readingHandle(gh) + ) }) @@ -145,7 +149,7 @@ test_that("QtlFineMappingResult: fineMappingResult errors on missing tuple", { }) -test_that("QtlFineMappingResult: single-row collection allows omitting selectors", { +test_that("a one-row QtlFineMappingResult needs no selectors", { e <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( studyName = "s1", @@ -196,8 +200,8 @@ test_that("QtlFineMappingResult: accepts jointContexts column", { test_that("QtlFineMappingResult: jointStudies + jointTraits combine cleanly", { e <- .sc_makeFineMappingRow(3) - # Three per-context rows sharing the real (s1, c1, t1) tuple, each a slice of - # a different joint fit: univariate; a cross-study+trait mvsusieRss; a + # Three per-context rows sharing the real (s1, c1, t1) tuple, each a slice + # of a different joint fit: univariate; a cross-study+trait mvsusieRss; a # cross-context mvsusie. The joint* tags carry each fit's co-fit membership. res <- QtlFineMappingResult( studyName = c("s1", "s1", "s1"), @@ -261,7 +265,7 @@ test_that("QtlFineMappingResult: length-mismatched joint vector errors", { # === Tests migrated from test_showMethods.R (QtlFineMappingResult) === -test_that("show.QtlFineMappingResult prints entry/study/context/trait/method counts", { +test_that("show() prints a QtlFineMappingResult's entry and identity counts", { res <- QtlFineMappingResult( studyName = c("s1", "s1"), context = c("c1", "c2"), @@ -292,7 +296,7 @@ test_that("show.QtlFineMappingResult reports the ldReference source", { # === Tests migrated from test_collectionAccessors.R (QtlFineMappingResult) === -test_that("QtlFineMappingResult: pip returns named pip vector for selected tuple", { +test_that("pip gives the selected tuple's named PIP vector", { e1 <- .ca_makeFmEntry(3) e2 <- .ca_makeFmEntry(4) res <- QtlFineMappingResult( @@ -330,8 +334,9 @@ test_that("QtlFineMappingResult: pip() is one named numeric vector", { }) -test_that("QtlFineMappingResult: credibleSets aggregates every entry's credible sets with identity columns", { - # e1 (n=3) has cs_95 = susie_1/susie_1/susie_0 -> 2 CS members; e2 (n=2) -> 2. +test_that("credibleSets aggregates every entry's sets with identity columns", { + # e1 (n=3) has cs_95 = susie_1/susie_1/susie_0 -> 2 CS members; e2 (n=2) -> + # 2. e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( @@ -360,7 +365,7 @@ test_that("QtlFineMappingResult: credibleSets aggregates every entry's credible expect_equal(length(bare), 2L) }) -test_that("QtlFineMappingResult: marginalEffects aggregates every entry with identity columns", { +test_that("marginalEffects aggregates every entry with identity columns", { e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(2) res <- QtlFineMappingResult( @@ -406,7 +411,7 @@ test_that("QtlFineMappingResult: variantIds reads the entry's variantIds", { }) -test_that("QtlFineMappingResult: studyName/contexts/traitNames/methodNames are unique", { +test_that("studyName, contexts, traitNames, methodNames are each unique", { e <- .ca_makeFmEntry(3) res <- QtlFineMappingResult( studyName = c("s1", "s1", "s2"), diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 4698b9bcc..fcd19df22 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -862,7 +862,12 @@ test_that("elements bind into the object GRangesList() builds", { S4Vectors::mcols(plainColumn)$x <- 0.3 cases <- list( columnNames = list(namedColumn, plainColumn), - fineMapping = as.list(qtlFineMappingExample), + # A collection stores topLoci run-length encoded; the rows it hands + # out, which the constructors pass, hold them plain. + fineMapping = map( + as.list(qtlFineMappingExample), + pecotmr:::.rtlPlainMcols + ), sumStats = as.list(qtlSumStatsMulticontextExample), withEmpty = list( .rtl_mk("chr1", 1), @@ -1038,6 +1043,43 @@ test_that("updateObject keys every row of an old collection to its reference", { expect_identical(updateObject(sketched), new) }) +test_that("flattenTupleRanges hands out fine-mapping columns plain", { + # A collection stores its topLoci columns compactly; the ranges it + # flattens to carry them as its rows hand them out. + data(qtlFineMappingExample) + md <- S4Vectors::mcols(flattenTupleRanges(qtlFineMappingExample)) + expect_false(any(map_lgl(as.list(md), methods::is, "Rle"))) + expect_true(is_in("marginal_p", colnames(md))) +}) + +test_that("updateObject leaves the collection it is given as it was", { + data(qtlSumStatsMulticontextExample) + mc <- qtlSumStatsMulticontextExample + panel <- ldReference(mc)[[1L]] + old <- .savedWithOneLdRef(mc, panel) + md <- attr(old, "elementMetadata") + invisible(updateObject(old)) + expect_identical(methods::slot(old, "ldReference"), panel) + expect_identical(attr(old, "elementMetadata"), md) +}) + +test_that("updateObject drops the copies of labels a saved reference kept", { + data(qtlSumStatsMulticontextExample) + mc <- qtlSumStatsMulticontextExample + panel <- ldReference(mc)[[1L]] + saved <- .savedLabelledPanel(panel) + expect_false(is.null(SummarizedExperiment::rowData(saved)$SNP)) + old <- mc + methods::slot(old, "ldReference", check = FALSE) <- list(ld1 = saved) + ref <- ldReference(updateObject(old))[[1L]] + expect_identical( + SummarizedExperiment::rowRanges(ref), + .dropRedundantLabels(SummarizedExperiment::rowRanges(panel)) + ) + expect_null(dimnames(.panelSeed(ref))[[1L]]) + expect_identical(dimnames(ref), dimnames(panel)) +}) + test_that("updateObject marks every row of an old LD-free collection LD-free", { data(qtlFineMappingExample) old <- .savedWithOneLdRef(qtlFineMappingExample, NULL) @@ -1298,3 +1340,50 @@ test_that("nesting a flattened trimmed collection leaves its fits' columns", { expect_true("cs_95" %in% .fmStoredColumns(kept)) expect_true(all(S4Vectors::mcols(unlist(kept))$cs_95 == "susie_0")) }) + +# ---- Run-length storage of variant metadata ---------------------------------- + +test_that("a column is stored as an Rle only where that is smaller", { + md <- S4Vectors::DataFrame( + constant = rep(5, 10), + varying = as.numeric(1:10), + label = rep(c("a", "b"), each = 5), + flag = c(rep(TRUE, 9), NA), + f = factor(rep("x", 10)) + ) + out <- pecotmr:::.rtlRleWhereSmaller( + md, + c("constant", "varying", "label", "flag", "f", "absent") + ) + expect_s4_class(out$constant, "Rle") + expect_s4_class(out$label, "Rle") + expect_s4_class(out$flag, "Rle") + expect_true(is.numeric(out$varying)) + # A column with attributes (a factor) stays as it is. + expect_identical(out$f, md$f) + # Decoding gives the plain columns back exactly. + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1:10, width = 1L)) + plain <- pecotmr:::.rtlPlainMcols(S4Vectors::`mcols<-`(gr, value = out)) + expect_identical(as.list(mcols(plain)), as.list(md)) + # A GRanges with nothing encoded passes through. + expect_identical(pecotmr:::.rtlPlainMcols(gr), gr) +}) + +test_that("elements taken out of a collection join on the fast path", { + # Run-length encoded columns are not plain vectors, so the first join + # attempt declines them; decoded, they join as plain elements would. + mk <- function(start, v) { + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start, width = 1L), + x = v + ) + } + encoded <- list(mk(1:3, S4Vectors::Rle(c(1, 1, 2))), mk(4:5, c(3, 4))) + plain <- list(mk(1:3, c(1, 1, 2)), mk(4:5, c(3, 4))) + expect_null(pecotmr:::.rtlJoinPlainElements(encoded)) + expect_identical( + pecotmr:::.rtlBindElements(encoded), + pecotmr:::.rtlBindElements(plain) + ) +}) diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index 91e2f4971..0e341e001 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -26,39 +26,14 @@ context("causalInferencePipeline") } .cip_mockExtractor <- function(seed = 7, n_samples = 30L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -155,7 +130,7 @@ test_that("causalInferencePipeline: rejects un-QCd GwasSumStats", { ) }) -test_that("causalInferencePipeline: requires at least one of twasWeights/fineMappingResult", { +test_that("causalInferencePipeline needs twasWeights or fineMappingResult", { expect_error( causalInferencePipeline(gwasSumStats = .cip_makeGwasSumstats()), "at least one of" @@ -172,7 +147,7 @@ test_that("causalInferencePipeline: rejects non-TwasWeights twasWeights arg", { ) }) -test_that("causalInferencePipeline: rejects GwasFineMappingResult for the QTL slot", { +test_that("causalInferencePipeline refuses a GWAS result in the QTL slot", { e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), @@ -214,7 +189,7 @@ test_that(".cipRequireMatchingLdRefs: NULL twas-side ldReference is allowed", { ldReference = NULL ) local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -295,7 +270,7 @@ test_that(".cipRequireMatchingLdRefs: rows that never meet may differ", { test_that("causalInferencePipeline: returns GRanges with TWAS Z per tuple", { tw <- .cip_makeTwasWeights() local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -318,11 +293,11 @@ test_that("causalInferencePipeline: returns GRanges with TWAS Z per tuple", { # Happy path: TwasWeights + matching QtlFineMappingResult enables MR # =========================================================================== -test_that("causalInferencePipeline: with both inputs, MR fields are populated", { +test_that("causalInferencePipeline fills MR fields given both inputs", { tw <- .cip_makeTwasWeights() fmr <- .cip_makeQtlFmr() local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -342,10 +317,10 @@ test_that("causalInferencePipeline: with both inputs, MR fields are populated", # Fine-mapping-only path: weights come from topLoci$betahat # =========================================================================== -test_that("causalInferencePipeline: FMR-only path extracts weights from topLoci$betahat", { +test_that("FMR-only causal inference takes weights from topLoci$betahat", { fmr <- .cip_makeQtlFmr() local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -379,7 +354,7 @@ test_that("causalInferencePipeline: combineMethods appends combined rows", { ldReference = .cip_makeHandle() ) local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -407,7 +382,7 @@ test_that(".cipZToSe: falls back to vector of 1 when maf/n are NA", { expect_equal(res, c(1, 1)) }) -test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, SS-TWAS keeps all", { +test_that(".cipFilterEligibleMethods gates rsq and pval; SS-TWAS keeps all", { mkEntry <- function(rsq, pval = 0.01) { TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), @@ -429,7 +404,8 @@ test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, S "rsq", c("adj_rsq_pval", "pval") ) - # rsq gate only: G keeps susie(.20)+lasso(.50); enet(.05) out; G2(.01) dropped. + # rsq gate only: G keeps susie(.20)+lasso(.50); enet(.05) out; G2(.01) + # dropped. f1 <- pecotmr:::.cipFilterEligibleMethods( qtlRows, mt, @@ -490,7 +466,7 @@ test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, S ) }) -test_that(".cipSelectBestMethod: max-rsq finite Z, NA/Inf re-selection, SS-TWAS keeps all", { +test_that(".cipSelectBestMethod picks max-rsq finite Z; SS-TWAS keeps all", { lk <- c("S\rc1\rG\rsusie" = 0.5, "S\rc1\rG\rlasso" = 0.2) df <- data.frame( qtlStudy = "S", @@ -515,7 +491,7 @@ test_that(".cipSelectBestMethod: max-rsq finite Z, NA/Inf re-selection, SS-TWAS expect_equal(nrow(pecotmr:::.cipSelectBestMethod(df, lkNA)), 2L) }) -test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per group", { +test_that("causal inference picks each group's max-rsq method (rsqCutoff)", { tw <- TwasWeights( studyName = rep("Q1", 2), context = rep("c1", 2), @@ -536,7 +512,7 @@ test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per gro ldReference = .cip_makeHandle() ) local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -547,7 +523,7 @@ test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per gro expect_equal(as.character(S4Vectors::mcols(out)$method), "lasso") }) -test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", { +test_that("causalInferencePipeline reselects a method on NA/Inf TWAS-Z", { tw <- TwasWeights( studyName = rep("Q1", 2), context = rep("c1", 2), @@ -569,7 +545,7 @@ test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", ldReference = .cip_makeHandle() ) local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -581,7 +557,7 @@ test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", expect_true(is.finite(S4Vectors::mcols(out)$twasZ)) }) -test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods", { +test_that("causalInferencePipeline: rsqPvalCutoff drops high-CV-pval methods", { tw <- TwasWeights( studyName = rep("Q1", 2), context = rep("c1", 2), @@ -602,7 +578,7 @@ test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods ldReference = .cip_makeHandle() ) local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) out <- causalInferencePipeline( @@ -834,7 +810,7 @@ test_that("twasZ: combineMethods K=1 returns the per-tuple p-value unchanged", { expect_equal(res$combined$input$nValid, 1L) }) -test_that("twasZ: combineMethods K>=2 forwards to combinePValues with correlation", { +test_that("twasZ passes K>=2 methods to combinePValues with correlation", { d <- .tz_makeLd() set.seed(11) W <- cbind(method_a = rnorm(d$p), method_b = rnorm(d$p)) @@ -1097,7 +1073,7 @@ test_that(".cipCsAwareAlign: exposure scale follows the GWAS, both ways", { # dropped the variant. # --------------------------------------------------------------------------- -test_that(".cipComputeMr matches across a chr-prefix difference (tuple match)", { +test_that(".cipComputeMr matches across a chr-prefix difference", { tl <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:A:G"), pip = c(0.9, 0.9), @@ -1116,7 +1092,7 @@ test_that(".cipComputeMr matches across a chr-prefix difference (tuple match)", expect_true(is.finite(res$waldRatio)) }) -test_that(".cipComputeMr includes an allele-swapped GWAS variant and flips the sign", { +test_that(".cipComputeMr keeps an allele-swapped GWAS variant, sign flipped", { tl <- data.frame( variant_id = "chr1:100:A:G", pip = 0.9, @@ -1133,8 +1109,9 @@ test_that(".cipComputeMr includes an allele-swapped GWAS variant and flips the s .cip_gwasDf("chr1:100:A:G", z = 2.0), pipCutoff = 0.5 ) - # Same locus, ref/alt swapped on the GWAS side (same |z|): previously dropped - # (id-string mismatch); now matched with sign -1, negating the Wald ratio. + # Same locus, ref/alt swapped on the GWAS side (same |z|): previously + # dropped (id-string mismatch); now matched with sign -1, negating the Wald + # ratio. rSwap <- pecotmr:::.cipComputeMr( NULL, .cip_gwasDf("chr1:100:G:A", z = 2.0), @@ -1144,7 +1121,7 @@ test_that(".cipComputeMr includes an allele-swapped GWAS variant and flips the s expect_equal(rSwap$waldRatio, -rSame$waldRatio) }) -test_that(".cipComputeMr with alleleFlip = FALSE drops an allele-swapped GWAS variant", { +test_that(".cipComputeMr(alleleFlip = FALSE) drops a swapped GWAS variant", { tl <- data.frame( variant_id = "chr1:100:A:G", pip = 0.9, @@ -1156,7 +1133,8 @@ test_that(".cipComputeMr with alleleFlip = FALSE drops an allele-swapped GWAS va .cipTopLociTable = function(x) tl, .package = "pecotmr" ) - # GWAS variant is the ref/alt swap; with flipping disabled it is not matched. + # GWAS variant is the ref/alt swap; with flipping disabled it is not + # matched. rSwap <- pecotmr:::.cipComputeMr( NULL, .cip_gwasDf("chr1:100:G:A", z = 2.0), @@ -1202,7 +1180,7 @@ test_that(".cipComputeTwasZ gives a Z from a panel's factor or an LdMatrix", { expect_equal(viaPanel, viaMatrix) }) -test_that(".cipComputeTwasZ reconciles a chr-prefix mismatch (previously dropped)", { +test_that(".cipComputeTwasZ reconciles a chr-prefix mismatch", { idsGwas <- c("1:100:A:G", "1:200:A:G", "1:300:A:G") # GWAS / panel coding idsWt <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") # QTL weight ids h <- .cip_makeHandle(snp_n = 3L) @@ -1211,7 +1189,7 @@ test_that(".cipComputeTwasZ reconciles a chr-prefix mismatch (previously dropped h@snpInfo$A1 <- rep("G", 3) g <- .cip_gwasDf(idsGwas, z = c(2, -1.5, 0.8)) local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) res <- pecotmr:::.cipComputeTwasZ(c(0.2, -0.1, 0.3), idsWt, g, h) @@ -1297,7 +1275,7 @@ test_that(".cipComputeMrCsAware: CS-aware composite Wald + heterogeneity", { expect_equal(res$nCs, 2L) # both CSs clear cpip }) -test_that(".cipComputeMrCsAware: credible-set column found via the ^cs fallback", { +test_that(".cipComputeMrCsAware finds the CS column by the ^cs fallback", { # The shape a stored result has: no bare `cs`, and cs_95 holding # "_" labels rather than integers. tl <- data.frame( @@ -1385,7 +1363,7 @@ test_that("the MR paths abort naming the exposure columns they lack", { ) }) -test_that(".cipComputeMrCsAware: naResult on empty / no-CS / no-overlap / low-cpip", { +test_that(".cipComputeMrCsAware: NA on empty, no CS, no overlap, low cpip", { g <- .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:4))) isNa <- function(r) expect_true(is.na(r$waldRatio)) local_mocked_bindings( @@ -1437,6 +1415,44 @@ test_that(".cipComputeMrCsAware: naResult on empty / no-CS / no-overlap / low-cp isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, cpipCutoff = 0.5)) }) +test_that(".cipExtractWeights scores one column of weights, not several", { + ids <- sprintf("chr1:%d:A:G", 100L * (1:5)) + w <- c(0.1, 0.05, -0.2, 0.3, 0.0) + weightsOf <- function(weights) { + TwasWeights( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(TwasWeightsRow(variantIds = ids, weights = weights)), + ldReference = .cip_makeHandle() + ) + } + one <- pecotmr:::.cipExtractWeights( + weightsOf(matrix(w, ncol = 1L, dimnames = list(NULL, "susie"))), + NULL, + "Q1", + "c1", + "t1", + "susie", + useFmr = FALSE + ) + expect_equal(one$weights, w) + expect_warning( + several <- pecotmr:::.cipExtractWeights( + weightsOf(cbind(w, -w)), + NULL, + "Q1", + "c1", + "t1", + "susie", + useFmr = FALSE + ), + "a matrix with 2 columns" + ) + expect_null(several) +}) + test_that(".cipExtractWeights: NULL on missing tuples and bad topLoci", { tw <- .cip_makeTwasWeights(method = "susie") fmr <- .cip_makeQtlFmr() @@ -1517,7 +1533,7 @@ test_that(".cipExtractWeights: NULL on missing tuples and bad topLoci", { expect_null(out) }) -test_that(".cipCombineAcrossMethods: a single-method group yields no combined rows", { +test_that(".cipCombineAcrossMethods: one-method groups give no combined rows", { gr <- pecotmr:::.cipDfToGranges(data.frame( qtlStudy = "Q1", context = "c1", @@ -1663,7 +1679,7 @@ test_that("selecting the best method over an empty frame is a no-op", { expect_equal(nrow(pecotmr:::.cipSelectBestMethod(df0, c(a = 1))), 0L) }) -test_that("a credible set below the cumulative-PIP cutoff contributes nothing", { +test_that("a credible set below the cumulative-PIP cutoff adds nothing", { # cpip is the SUM of member PIPs; a set that does not reach the cutoff is # dropped rather than contributing a poorly-supported Wald ratio. inst <- tibble( @@ -1941,6 +1957,7 @@ test_that(".cipCvMetric returns NA when the CV result cannot be read", { }) test_that("CV selection warns once about narrowed weights; scoring does not", { + ids <- sprintf("chr1:%d:A:G", 100L * (1:5)) tw <- TwasWeights( studyName = rep("Q1", 2), context = rep("c1", 2), @@ -1948,13 +1965,15 @@ test_that("CV selection warns once about narrowed weights; scoring does not", { method = c("susie", "lasso"), entry = list( TwasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), + variantIds = ids, weights = c(0.1, 0.05, -0.2, 0.3, 0.0), + methodFits = list(variantIds = ids), cvResult = list(metrics = c(rsq = 0.2, pval = 0.001)) ), TwasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), + variantIds = ids, weights = c(0.2, 0.1, -0.1, 0.2, 0.1), + methodFits = list(variantIds = ids), cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) ) ), @@ -1962,7 +1981,7 @@ test_that("CV selection warns once about narrowed weights; scoring does not", { ) narrowed <- endoapply(tw, utils::head, 4L) local_mocked_bindings( - extractBlockGenotypes = .cip_mockExtractor(), + .handleDosage = .cip_mockExtractor(), .package = "pecotmr" ) selected <- .fitCoverageMessages(causalInferencePipeline( @@ -2127,3 +2146,16 @@ test_that("a gene is scored once per GWAS study, over the rows it overlaps", { expect_equal(length(out), 1L) expect_equal(as.character(S4Vectors::mcols(out)$gwasStudy), "G1") }) + +test_that("a TWAS z against an LdMatrix reads its packed LD", { + data(eqtlRegionExample, envir = environment()) + X <- eqtlRegionExample$X[, 1:8] + ldm <- LdMatrix(cor(X), nSamples = 100) + ids <- colnames(X)[c(3L, 1L, 7L)] + w <- c(0.2, -0.1, 0.05) + z <- c(1.2, -0.4, 2.1) + expect_equal( + pecotmr:::.cipTwasZ(w, z, ldm, ids), + twasZ(weights = w, z = z, R = pecotmr:::.ldFromRef(ldm, ids, "test")) + ) +}) diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index 3941fcfa6..3d973459a 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -294,7 +294,7 @@ test_that("colocPipeline: returns one row per (QTL tuple, GWAS tuple) pair", { qtlFineMappingResult = qfmr, gwasInput = gfmr )) - expect_equal(nrow(out), 4L) # 2 QTL tuples * 2 GWAS tuples + expect_equal(nrow(colocPairs(out)), 4L) # 2 QTL tuples * 2 GWAS tuples expect_setequal(out$study, "Q1") expect_setequal(out$context, c("c1", "c2")) expect_setequal(out$gwasStudy, c("G1", "G2")) @@ -356,7 +356,7 @@ test_that("colocPipeline: pairs two QTL fine-mapping results", { qtlFineMappingResult = qfmr, gwasInput = other )) - expect_equal(nrow(out), 2L) + expect_equal(nrow(colocPairs(out)), 2L) expect_setequal(out$gwasStudy, "Q2") expect_setequal(out$gwasContext, "c1") expect_setequal(out$gwasTrait, c("t1", "t2")) @@ -370,7 +370,7 @@ test_that("colocPipeline: pairs two GWAS fine-mapping results", { qtlFineMappingResult = first, gwasInput = second )) - expect_equal(nrow(out), 1L) + expect_equal(nrow(colocPairs(out)), 1L) expect_equal(as.character(out$study), "G1") expect_equal(as.character(out$gwasStudy), "G2") # Neither side has a context or trait axis, so all four are reported as NA @@ -425,7 +425,7 @@ test_that("colocPipeline: rejects an un-QCd QtlSumStats second side", { ) }) -test_that("colocPipeline: resolves GwasSumStats via fineMappingPipeline (mocked)", { +test_that("colocPipeline fine-maps GwasSumStats via fineMappingPipeline", { qfmr <- .cp_makeQtlFmr() gss <- .cp_makeGwasSumstats() local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") @@ -526,9 +526,9 @@ test_that("colocPipeline: empty result has the documented schema", { out <- suppressWarnings( colocPipeline(qtlFineMappingResult = qfmr, gwasInput = gfmr) ) - expect_equal(nrow(out), 0L) + expect_equal(nrow(colocPairs(out)), 0L) expect_setequal( - colnames(out), + colnames(colocPairs(out)), c( "study", "context", @@ -620,6 +620,36 @@ test_that(".colocExtractLbfFromEntry: filterLbfCs subsets by cs_index", { expect_equal(nrow(out$lbf), 2L) }) +test_that(".colocExtractLbfFromEntry: a trimmed fit's sets select by row", { + # Trimming keeps effects 1 and 3 of three, on rows 1 and 2, while + # cs_index still numbers them 1 and 3: used as rows, effect 3 ran past + # the end of the LBF matrix. + vids <- sprintf("chr1:%d:A:G", 100L * (1:4)) + lbf <- matrix(c(5, 0, 0, 0, 0, 0, 4, 0), 2L, byrow = TRUE) + fit <- list( + alpha = matrix(0.25, 2L, 4L, dimnames = list(NULL, vids)), + pip = set_names(c(0.9, 0.1, 0.5, 0.2), vids), + V = c(0.1, 0.1), + lbf_variable = `colnames<-`(lbf, vids), + effect_index = c(1L, 3L), + sets = list(cs_index = 3L) + ) + e <- FineMappingRow( + variantIds = vids, + susieFit = fit, + topLoci = data.frame(variant_id = vids, pip = fit$pip) + ) + out <- pecotmr:::.colocExtractLbfFromEntry( + e, + colocLbfFilterParam = ColocLbfFilterParam(filterLbfCs = TRUE) + ) + expect_equal(unname(out$lbf), lbf[2L, , drop = FALSE]) + # The result names the set by the effect's own index, as its L3 label + # does, and a later block's effects are numbered after it. + expect_equal(out$effect, 3L) + expect_equal(out$nEffects, 3L) +}) + test_that(".colocAlignLbf: aligned matrices share the common variant set", { q <- matrix( 0, @@ -641,7 +671,7 @@ test_that(".colocAlignLbf: aligned matrices share the common variant set", { expect_setequal(colnames(aligned$gwas), c("chr1:20:A:G", "chr1:30:A:G")) }) -test_that(".colocAlignLbf aligns non-autosomal columns across a chr-prefix difference", { +test_that(".colocAlignLbf aligns non-autosomal columns across chr prefixes", { # chrX ids: alignVariantNames' numeric-chrom regex could not parse these and # fell back to a raw intersect (no overlap); tuple matching resolves them. q <- matrix( @@ -669,7 +699,7 @@ test_that(".colocStandardiseRow: fills in missing PP columns with NA", { # .colocLookupEnrichment # =========================================================================== -test_that(".colocLookupEnrichment: returns the value for a (gwasStudy, qtlStudy, qtlContext) hit", { +test_that(".colocLookupEnrichment finds a (GWAS, QTL study, context) value", { enr <- data.frame( gwasStudy = c("G1", "G2"), qtlStudy = c("Q1", "Q1"), @@ -714,11 +744,13 @@ test_that(".colocLookupEnrichment: returns NA when no row matches", { # .colocEmptyResult(enriched = TRUE) # =========================================================================== -test_that(".colocEmptyResult(enriched=TRUE): includes enrichment + p12Used schema", { +test_that(".colocEmptyResult(enriched = TRUE) has enrichment + p12Used", { out <- pecotmr:::.colocEmptyResult(enriched = TRUE) expect_s4_class(out, "ColocResult") - expect_equal(nrow(out), 0L) - expect_true(all(c("enrichment", "p12Used") %in% colnames(out))) + expect_equal(nrow(colocPairs(out)), 0L) + expect_true(all( + c("enrichment", "p12Used") %in% colnames(colocPairs(out)) + )) }) @@ -794,14 +826,14 @@ test_that("colocPipeline: enrichment takes table priors and reports RCP/LCP", { # Enrichment mode scores every (QTL effect, GWAS effect) pair itself # rather than calling coloc.bf_bf, so the fixture's 2 x 2 effects give # four rows; the mock used elsewhere collapses them to one. - expect_equal(nrow(out), 4L) - expect_true(all(c("enrichment", "p12Used") %in% colnames(out))) - expect_equal(unique(out$enrichment), 2.0) + pairs <- colocPairs(out) + expect_equal(nrow(pairs), 4L) + expect_true(all(c("enrichment", "p12Used") %in% colnames(pairs))) + expect_equal(unique(pairs$enrichment), 2.0) # qtlEnrichmentPipeline derives p12 = P_eqtl * expit(a0 + a1) the way # fastenloc does; the pipeline uses that, rather than scaling a default. - expect_equal(unique(out$p12Used), 2.5e-5) + expect_equal(unique(pairs$p12Used), 2.5e-5) # RCP and LCP are reported alongside the hypotheses. - pairs <- colocPairs(out) expect_true(all(c("RCP", "LCP") %in% colnames(pairs))) # The two names for the same quantities: fastenloc's RCP is the posterior # of one shared causal variant, and LCP adds the distinct-variant case. @@ -914,12 +946,13 @@ test_that("colocPipeline: an enrichment miss warns and drops to plain priors", { ) ) expect_match(w, "no enrichment entry", all = FALSE) - expect_equal(nrow(out), 4L) + pairs <- colocPairs(out) + expect_equal(nrow(pairs), 4L) # A miss means there is no enrichment estimate for this pair, so it is # scored with the unconditional priors rather than a fabricated factor # of zero applied to a default. - expect_true(is.na(unique(out$enrichment))) - expect_equal(unique(out$p12Used), 5e-6) + expect_true(is.na(unique(pairs$enrichment))) + expect_equal(unique(pairs$p12Used), 5e-6) }) # --- returnGwasFineMapping attached on the empty-pair early return ---------- @@ -995,7 +1028,7 @@ test_that("colocPipeline: skips a QTL entry with no usable LBF", { ) ) # bad entry (c1) skipped; only the good entry (c2) yields a row. - expect_equal(nrow(out), 1L) + expect_equal(nrow(colocPairs(out)), 1L) expect_equal(unique(out$context), "c2") }) @@ -1021,7 +1054,7 @@ test_that("colocPipeline: skips a pair with no shared variants", { # --- .colocFilterCsByConcentration ----------------------------------------- -test_that(".colocFilterCsByConcentration: keeps narrow CS, drops diffuse ones", { +test_that(".colocFilterCsByConcentration keeps narrow CSs, drops diffuse", { fit <- list(alpha = matrix(0.1, nrow = 3, ncol = 10)) # 10 variants # maxSize = ncol * coverage * concentration = 10 * 0.5 * 0.5 = 2.5 local_mocked_bindings( @@ -1077,7 +1110,7 @@ test_that(".colocExtractLbfFromEntry: stacks fSuSiE lBF list into a matrix", { expect_setequal(colnames(out$lbf), sprintf("chr1:%d:A:G", 100L * (1:4))) }) -test_that(".colocExtractLbfFromEntry: stacks nested fSuSiE lBF (fit[[1]] path)", { +test_that(".colocExtractLbfFromEntry stacks nested fSuSiE lBF (fit[[1]])", { m1 <- matrix( rnorm(8), 2, @@ -1191,10 +1224,11 @@ test_that(".colocExtractLbfFromEntry: secondary CS filter subsets rows", { ) ) expect_equal(nrow(out$lbf), 1L) - expect_equal(as.numeric(out$lbf), c(2, 5, 8, 11)) # row 2 of matrix(1:12, 3, 4) + # row 2 of matrix(1:12, 3, 4) + expect_equal(as.numeric(out$lbf), c(2, 5, 8, 11)) }) -test_that(".colocExtractLbfFromEntry: assigns colnames from variantIds when fit lacks them", { +test_that(".colocExtractLbfFromEntry names columns by variantIds if unnamed", { fit <- list(lbf_variable = matrix(1:8, 2, 4)) # no dimnames e <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -1212,7 +1246,7 @@ test_that(".colocExtractLbfFromEntry: assigns colnames from variantIds when fit expect_equal(colnames(out$lbf), sprintf("chr1:%d:A:G", 100L * (1:4))) }) -test_that(".colocExtractLbfFromEntry: NULL when every variant column is NA-named", { +test_that(".colocExtractLbfFromEntry: NULL when every column is NA-named", { fit <- list( lbf_variable = matrix( 1:8, @@ -1320,15 +1354,16 @@ test_that("colocPipeline reports the retained mass of the scored effects", { gwasInput = gfmr, adjustPips = TRUE )) - skip_if(nrow(out) == 0L, "fixture produced no coloc pairs") - expect_true(is_in("qtlRetainedMass", colnames(out))) + pairs <- colocPairs(out) + skip_if(nrow(pairs) == 0L, "fixture produced no coloc pairs") + expect_true(is_in("qtlRetainedMass", colnames(pairs))) expect_true(all( - is.na(out$qtlRetainedMass) | - (out$qtlRetainedMass >= 0 & out$qtlRetainedMass <= 1) + is.na(pairs$qtlRetainedMass) | + (pairs$qtlRetainedMass >= 0 & pairs$qtlRetainedMass <= 1) )) expect_true(all( - is.na(out$gwasRetainedMass) | - (out$gwasRetainedMass >= 0 & out$gwasRetainedMass <= 1) + is.na(pairs$gwasRetainedMass) | + (pairs$gwasRetainedMass >= 0 & pairs$gwasRetainedMass <= 1) )) }) diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index 7a827b3b8..17ad3adf1 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -18,39 +18,14 @@ context("colocboostPipeline (S4 dispatch)") # =========================================================================== .cbp_mockExtractor <- function(seed = 11, n_samples = 30L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -276,11 +251,11 @@ test_that(".cbEmptyResult: is the internal per-analysis accumulator", { # colocboostPipeline(QtlDataset) # =========================================================================== -test_that("colocboostPipeline(QtlDataset): runs xqtl-only ColocBoost with mocked engine", { +test_that("colocboostPipeline(QtlDataset): xQTL-only run, mocked engine", { qd <- .cbp_makeQtlDataset() capturedArgs <- NULL local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -306,10 +281,10 @@ test_that("colocboostPipeline(QtlDataset): runs xqtl-only ColocBoost with mocked expect_true("X" %in% names(capturedArgs)) }) -test_that("colocboostPipeline(QtlDataset): no QTL bundle and no GWAS returns empty result", { +test_that("colocboostPipeline(QtlDataset): no QTL bundle, no GWAS -> empty", { qd <- .cbp_makeQtlDataset() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) # A signal screen no outcome clears skips every context; the bundle @@ -371,12 +346,12 @@ test_that("colocboostPipeline(ANY): unsupported input class errors", { # Driver: jointGwas / separateGwas paths via QtlSumStats + GwasSumStats # =========================================================================== -test_that("colocboostPipeline: jointGwas merges qtl + gwas sumstats and runs once", { +test_that("jointGwas colocboost merges QTL and GWAS sumstats, runs once", { ss <- .cbp_makeQtlSumStats() gs <- .cbp_makeGwasSumStats() capturedArgs <- NULL local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -403,7 +378,7 @@ test_that("colocboostPipeline: separateGwas runs once per GWAS study", { gs <- .cbp_makeGwasSumStats() seen <- list() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -443,7 +418,7 @@ test_that("colocboostPipeline: separateGwas runs once per GWAS study", { test_that("separateGwas refuses a QTL-only sumstat input", { ss <- .cbp_makeQtlSumStats() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) # Guarded on GWAS presence, not on "any summary statistics": the old @@ -468,7 +443,7 @@ test_that("separateGwas refuses a QTL-only sumstat input", { test_that("colocboostPipeline: no analysis flag set is an error", { ss <- .cbp_makeQtlSumStats() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) # All three FALSE is the one combination that is not a request. It used @@ -490,10 +465,8 @@ test_that("colocboostPipeline: no analysis flag set is an error", { c("xqtlColoc", "jointGwas", "separateGwas") ) args[[flag]] <- TRUE - expect_silent(exec( - pecotmr:::.cbAssertAnyRun, - !!!set_names(unname(args), NULL) - )) + unnamedArgs <- set_names(unname(args), NULL) + expect_silent(exec(pecotmr:::.cbAssertAnyRun, !!!unnamedArgs)) } }) @@ -506,7 +479,7 @@ test_that("a GWAS on a different LD reference runs, and both are recorded", { ) seen <- list() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -541,7 +514,7 @@ test_that("a panel and an LdMatrix on opposite sides reach colocboost as LD", { gs <- .cbp_makeGwasSumStats(ldReference = ldm) seen <- list() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -608,7 +581,7 @@ test_that(".cbResultLdRefs keys each outcome to its pair's reference", { # GWAS case/control: optional nCase/nControl columns + effective-N wiring # =========================================================================== -test_that("colocboost GWAS bundle: effective N for case/control, per-variant N otherwise", { +test_that("GWAS bundle N: effective for case/control, else per-variant", { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges( @@ -631,11 +604,12 @@ test_that("colocboost GWAS bundle: effective N for case/control, per-variant N o qcOptions = list(ok = 1) ) local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) # case/control -> effective N = 4 / (1/500 + 1/1500) = 1500 - gcc <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) + caseControlArgs <- c(base, list(nCase = 500, nControl = 1500)) + gcc <- exec(GwasSumStats, !!!caseControlArgs) bcc <- pecotmr:::.cbGwasSumStatsBundle(gcc) expect_true(all(bcc[["G1"]]$sumstat$n == 4 / (1 / 500 + 1 / 1500))) # quantitative (no nCase/nControl) -> per-variant N (1000) @@ -647,7 +621,7 @@ test_that("colocboost GWAS bundle: effective N for case/control, per-variant N o # pipCutoffToSkip: per-context single-trait (L=1 SuSiE) outcome skip # =========================================================================== -test_that(".cbPipSkipOutcomes: keeps signal outcomes, drops noise, honours cutoff", { +test_that(".cbPipSkipOutcomes keeps signal, drops noise, honours the cutoff", { skip_if_not_installed("susieR") set.seed(1) n <- 200L @@ -721,7 +695,7 @@ test_that("colocboostPipeline(MultiStudy): context selection skips a study", { # As in fineMappingPipeline: a context only some studies have is skipped # for the others, with a warning, and one no study has is refused. local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -744,11 +718,11 @@ test_that("colocboostPipeline(MultiStudy): context selection skips a study", { ) }) -test_that("colocboostPipeline(MultiStudyQtlDataset): combines per-study bundles + embedded sumstats", { +test_that("colocboostPipeline(MultiStudyQtlDataset) joins studies + sumstats", { mt <- .cbp_makeMultiStudy() capturedArgs <- NULL local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -766,14 +740,15 @@ test_that("colocboostPipeline(MultiStudyQtlDataset): combines per-study bundles )) expect_s4_class(out, "ColocBoostResult") expect_true(is_in("xqtl_coloc", computingTime(out)$analysis)) - # The individual study's outcome is prefixed "study1:" in the combined bundle. + # The individual study's outcome is prefixed "study1:" in the combined + # bundle. expect_true(any(grepl("study1:", names(capturedArgs$Y)))) }) test_that(".cbRun: an engine failure is caught -> message + NULL", { qd <- .cbp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -793,7 +768,7 @@ test_that(".cbIndividualBundle: multi-context outcomes get context prefixes", { qd <- .cbp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") capturedArgs <- NULL local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -824,7 +799,7 @@ test_that(".cbIndividualBundle: multi-context outcomes get context prefixes", { test_that("colocboostPipeline(QtlDataset): unknown context errors", { qd <- .cbp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) expect_error( @@ -833,10 +808,10 @@ test_that("colocboostPipeline(QtlDataset): unknown context errors", { ) }) -test_that("colocboostPipeline(QtlDataset): pipCutoffToSkip dropping every outcome -> empty", { +test_that("colocboost: pipCutoffToSkip dropping every outcome -> empty", { qd <- .cbp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) out <- suppressMessages(suppressWarnings( @@ -869,10 +844,10 @@ test_that(".cbSumstatPair: NULL / empty df -> NULL", { expect_null(pecotmr:::.cbSumstatPair(data.frame(), .cbp_makeHandle())) }) -test_that(".cbQtlSumStatsBundle: NULL / context / trait filters and empty result", { +test_that(".cbQtlSumStatsBundle: NULL, context, trait filters; empty result", { ss <- .cbp_makeQtlSumStats() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) expect_equal(pecotmr:::.cbQtlSumStatsBundle(NULL), list()) @@ -885,9 +860,9 @@ test_that(".cbGwasSumStatsBundle: NULL -> empty list", { expect_equal(pecotmr:::.cbGwasSumStatsBundle(NULL), list()) }) -test_that(".cbSumstatPair: varY attaches var_y; NA variant ids fall back to chr:pos", { +test_that(".cbSumstatPair: varY sets var_y; NA ids fall back to chr:pos", { local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) h <- .cbp_makeHandle() # panel SNPs v1..v6 @@ -914,13 +889,14 @@ test_that(".cbSumstatPair: varY attaches var_y; NA variant ids fall back to chr: expect_null(pecotmr:::.cbSumstatPair(dfNA, h)) }) -test_that(".cbSumstatPair canonicalizes variant ids to chr-prefixed for name alignment", { +test_that(".cbSumstatPair gives chr-prefixed ids so names align", { local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) h <- .cbp_makeHandle(snp_n = 3L) - h@snpInfo$SNP <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") # chr-prefixed panel + # chr-prefixed panel + h@snpInfo$SNP <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") # sumstat carries the same variants without the "chr" prefix; the pipeline # should canonicalize them so the sumstat / LD ids align by name with other # sources (previously the returned ids kept the caller's convention). @@ -938,7 +914,7 @@ test_that(".cbSumstatPair canonicalizes variant ids to chr-prefixed for name ali expect_identical(colnames(pair$LD), pair$sumstat$variant) }) -test_that(".cbFlipPairToCanonical flips z + LD for swapped variants, relabels to canonical", { +test_that(".cbFlipPairToCanonical flips swapped variants' z and LD, relabels", { ss <- data.frame( z = c(2, -1), n = c(1000, 1000), @@ -947,11 +923,13 @@ test_that(".cbFlipPairToCanonical flips z + LD for swapped variants, relabels to ) LD <- matrix(c(1, 0.5, 0.5, 1), 2, dimnames = list(ss$variant, ss$variant)) p <- list(sumstat = ss, LD = LD, variantIds = ss$variant) - canonical <- c("chr1:100:G:A", "chr1:200:C:T") # variant 1 swapped, 2 identical + # variant 1 swapped, 2 identical + canonical <- c("chr1:100:G:A", "chr1:200:C:T") out <- pecotmr:::.cbFlipPairToCanonical(p, canonical) expect_equal(out$sumstat$variant, c("chr1:100:G:A", "chr1:200:C:T")) expect_equal(out$sumstat$z, c(-2, -1)) # v1 z flipped; v2 unchanged - expect_equal(out$LD["chr1:100:G:A", "chr1:200:C:T"], -0.5) # one endpoint flipped + # one endpoint flipped + expect_equal(out$LD["chr1:100:G:A", "chr1:200:C:T"], -0.5) expect_equal(unname(diag(out$LD)), c(1, 1)) # diagonal preserved }) @@ -976,20 +954,21 @@ test_that(".cbFlipPairToCanonical negates a factor's swapped columns", { ) }) -test_that(".cbFlipMatrixToCanonical negates residualized dosage for swapped columns", { +test_that(".cbFlipMatrixToCanonical negates swapped columns' dosage", { X <- matrix( c(1, -1, 2, 0.5, -0.5, 1), nrow = 3, dimnames = list(paste0("s", 1:3), c("chr1:100:A:G", "chr1:200:C:T")) ) - canonical <- c("chr1:100:G:A", "chr1:200:C:T") # col 1 swapped, col 2 identical + # col 1 swapped, col 2 identical + canonical <- c("chr1:100:G:A", "chr1:200:C:T") out <- pecotmr:::.cbFlipMatrixToCanonical(X, canonical) expect_equal(colnames(out), c("chr1:100:G:A", "chr1:200:C:T")) expect_equal(unname(out[, "chr1:100:G:A"]), -c(1, -1, 2)) # negated expect_equal(unname(out[, "chr1:200:C:T"]), c(0.5, -0.5, 1)) }) -test_that(".cbHarmonizeAlleles aligns opposite-coded sumstats to one canonical (invariance)", { +test_that(".cbHarmonizeAlleles aligns opposite-coded sumstats canonically", { mkPair <- function(v, z) { ss <- data.frame(z = z, n = 1000, variant = v, stringsAsFactors = FALSE) list( @@ -998,10 +977,12 @@ test_that(".cbHarmonizeAlleles aligns opposite-coded sumstats to one canonical ( variantIds = v ) } - # Same locus, opposite ref/alt coding across two sumstats, same underlying z. + # Same locus, opposite ref/alt coding across two sumstats, same underlying + # z. pairs <- list(A = mkPair("chr1:100:A:G", 3), B = mkPair("chr1:100:G:A", 3)) h <- pecotmr:::.cbHarmonizeAlleles(NULL, pairs) - expect_equal(h$pairs$A$sumstat$variant, "chr1:100:A:G") # first-seen = canonical + # first-seen = canonical + expect_equal(h$pairs$A$sumstat$variant, "chr1:100:A:G") expect_equal(h$pairs$B$sumstat$variant, "chr1:100:A:G") # B relabeled to it expect_equal(h$pairs$A$sumstat$z, 3) # A already canonical expect_equal(h$pairs$B$sumstat$z, -3) # B flipped to match @@ -1011,7 +992,7 @@ test_that("colocboostPipeline(MultiStudy): a study with no bundle is skipped", { mt <- .cbp_makeMultiStudy() # qd (study1, ENSG_A) + ss (Q1, t1) seen <- list() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -1697,7 +1678,7 @@ test_that("colocboostPipeline forwards residualizationParam to both sides", { test_that("a GWAS study is one outcome over the rows the QTL data reach", { local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) gws <- .cbp_makeBlockedGwas() @@ -1731,7 +1712,7 @@ test_that("a GWAS study is one outcome over the rows the QTL data reach", { test_that("a GWAS study's overlapped rows must share one LD reference", { local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) gws <- pecotmr:::.withRowLdRefs( @@ -1804,7 +1785,7 @@ test_that(".cbResolveFocal: the one QTL outcome named, or none", { test_that("the joint run is non-focal; focalOutcome reaches xQTL-only", { seen <- list() local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( @@ -2004,7 +1985,7 @@ test_that("colocboostPipeline(QtlSumStats) lays a cisWindow around traitPos", { test_that("colocboostPipeline(MSQD) lays cisWindow on its summary statistics", { local_mocked_bindings( - extractBlockGenotypes = .cbp_mockExtractor(), + .handleDosage = .cbp_mockExtractor(), .package = "pecotmr" ) ss <- .cbp_makeQtlSumStats() diff --git a/tests/testthat/test_cpp11.R b/tests/testthat/test_cpp11.R index 353583c7b..0ad340549 100644 --- a/tests/testthat/test_cpp11.R +++ b/tests/testthat/test_cpp11.R @@ -2,6 +2,7 @@ # only thin .Call() wrappers around the compiled routines in src/. The # behaviour of each routine is tested through its R-level wrapper # (test_rrLassosum.R, test_rrPrsCs.R, test_rrSdpr.R, test_rrPenalizedRss.R, +# test_rrBayesAlphabet.R, # test_sumstatsQc.R for DENTIST, test_qtlEnrichmentPipeline.R, # test_ld.R for the pruning components, test_genotypeIo.R for the BGEN # decoder, test_GenotypeDosageSeed.R for VCF GT calls) or, for the solvers' @@ -16,11 +17,13 @@ # "object '_pecotmr_x' not found" from deep inside a pipeline. .cpp_wrappers <- c( + "bayesAlphabetFactorCpp", "bgenDosageCpp", "bgenSampleIdsCpp", "dentistIterativeImpute", "dentistIterativeImputeFactor", "ldThresholdComponents", + "ldpred2FactorCpp", "penalizedRssCpp", "penalizedRssFactorCpp", "prsCsCpp", diff --git a/tests/testthat/test_crossValidation.R b/tests/testthat/test_crossValidation.R index c49fcacb8..0ed79903a 100644 --- a/tests/testthat/test_crossValidation.R +++ b/tests/testthat/test_crossValidation.R @@ -44,6 +44,29 @@ mkXY <- function(n = 30, p = 6, k = 1, seed = 1) { list(X = X, Y = Y) } +test_that("the CV codec leaves shapes it does not split as they are", { + ids <- c("s1", "s2", "s3") + expect_identical( + pecotmr:::.cvUnnameRows(c(0.1, 0.2, 0.3), ids), + c(0.1, 0.2, 0.3) + ) + named <- matrix(1:3, 3L, 1L, dimnames = list(ids, NULL)) + expect_identical(pecotmr:::.cvNameRows(named, ids), named) + # A TWAS matrix of predictions, one column per condition, keeps its row + # names, whatever its width. + for (k in 1:2) { + cv <- list( + predictions = matrix(seq_len(3L * k), 3L, k, dimnames = list(ids)) + ) + expect_identical(pecotmr:::.cvNamePredictions(cv, ids), cv) + } + # A collection saved before partitions were shared has no dictionary. + data(qtlFineMappingExample) + old <- qtlFineMappingExample + attr(old, "cvPartition") <- NULL + expect_identical(pecotmr:::.cvPartitionDict(old), list()) +}) + test_that("input is validated", { d <- mkXY() expect_error( @@ -284,7 +307,7 @@ test_that("X without rownames inherits the sample names (from Y)", { expect_equal(rownames(r$prediction$mock_predicted), rownames(d$Y)) }) -test_that("maxNumVariants subsamples from variantsToKeep when it already exceeds the cap", { +test_that("maxNumVariants subsamples variantsToKeep when it exceeds the cap", { d <- mkXY(p = 6) expect_message( cv( @@ -300,7 +323,7 @@ test_that("maxNumVariants subsamples from variantsToKeep when it already exceeds ) }) -test_that("a NULL per-method weight matrix yields an all-NA prediction, not an error", { +test_that("a NULL method weight matrix predicts all NA, not an error", { d <- mkXY() fit_with_null <- function(Xtr, Ytr, j, ...) { list( @@ -541,7 +564,7 @@ test_that("a BiocParallel report without a worker error is raised as is", { # .cvSamplePartition and .cvMetricRow # =========================================================================== -test_that(".cvSamplePartition partitions every sample into the requested folds", { +test_that(".cvSamplePartition puts every sample in the requested folds", { part <- pecotmr:::.cvSamplePartition(paste0("s", 1:20), fold = 4L) expect_setequal(part$Sample, paste0("s", 1:20)) expect_setequal(sort(unique(part$Fold)), 1:4) @@ -553,3 +576,191 @@ test_that(".cvMetricRow: < 3 usable predictions -> all-NA row", { ok <- pecotmr:::.cvMetricRow(c(1, 2, 3, 4, 5), c(1.1, 2, 2.9, 4, 5)) expect_false(is.na(ok[["rsq"]])) }) + +# ---- CV results in a collection ---------------------------------------------- +# A CV run's rows share its fold partition and the order its predictions are +# held in; a collection keeps each such pair once (.cvStoredColumn()). + +.cvp_partition <- function() { + tibble::tibble( + Sample = c("s3", "s1", "s4", "s2"), + Fold = c(1L, 1L, 2L, 2L) + ) +} + +# One method's fine-mapping CV payload (its `prediction` matrices name the +# samples by row), as fineMappingPipeline() attaches it to a row. +.cvp_fm <- function(key = "susie", sp = .cvp_partition()) { + pred <- matrix( + c(0.1, 0.2, 0.3, 0.4), + 4L, + 1L, + dimnames = list(c("s1", "s2", "s3", "s4"), "y1") + ) + list( + samplePartition = sp, + prediction = set_names(list(pred), str_c(key, "_predicted")), + performance = set_names( + list(matrix(0.5, 1L, 6L)), + str_c(key, "_performance") + ) + ) +} + +# One condition's TWAS CV payload (its `predictions` vector names them). +.cvp_twas <- function(sp = .cvp_partition()) { + list( + samplePartition = sp, + predictions = c(s1 = 0.1, s2 = 0.2, s3 = 0.3, s4 = 0.4), + metrics = c(corr = 0.5, rsq = 0.25), + foldFits = NULL + ) +} + +test_that("a CV payload splits from its partition and joins back as it was", { + for (payload in list(.cvp_fm(), .cvp_twas())) { + s <- pecotmr:::.cvSplitPartition(payload) + expect_null(s$stored$samplePartition) + expect_identical(s$partition$samplePartition, payload$samplePartition) + expect_identical(s$partition$sampleIds, c("s1", "s2", "s3", "s4")) + expect_identical( + pecotmr:::.cvJoinPartition(s$stored, s$partition), + payload + ) + } + # Stored without the sample names the partition entry holds. + fm <- pecotmr:::.cvSplitPartition(.cvp_fm())$stored + expect_null(rownames(fm$prediction$susie_predicted)) + expect_equal(colnames(fm$prediction$susie_predicted), "y1") + twas <- pecotmr:::.cvSplitPartition(.cvp_twas())$stored + expect_null(names(twas$predictions)) +}) + +test_that("a split keeps the samples outside every fold, in place", { + # A supplied partition may leave samples out; their predictions stay. + payload <- .cvp_fm(sp = .cvp_partition()[1:3, ]) + s <- pecotmr:::.cvSplitPartition(payload) + expect_identical(s$partition$sampleIds, c("s1", "s2", "s3", "s4")) + expect_identical(pecotmr:::.cvJoinPartition(s$stored, s$partition), payload) +}) + +test_that("a merged row's regions split and join one by one", { + payload <- list(region1 = .cvp_fm(), region2 = NULL) + s <- pecotmr:::.cvSplitPartition(payload) + expect_named(s$partition, c("region1", "region2")) + expect_null(s$partition$region2) + expect_identical(pecotmr:::.cvJoinPartition(s$stored, s$partition), payload) +}) + +test_that("a payload with no partition is stored as it is", { + for (payload in list(NULL, list(rsq = 0.5), list(samplePartition = NULL))) { + s <- pecotmr:::.cvSplitPartition(payload) + expect_identical(s$stored, payload) + expect_null(s$partition) + expect_identical(pecotmr:::.cvJoinPartition(payload, NULL), payload) + } +}) + +# Two fine-mapping rows of one CV run: they share its partition. +.cvp_fmr <- function(sp = .cvp_partition()) { + tl <- data.frame(variant_id = "chr1:100:A:G", pip = 0.5) + QtlFineMappingResult( + studyName = c("S", "S"), + context = c("C", "C"), + trait = c("T", "T"), + method = c("susie", "susieInf"), + entry = list( + FineMappingRow("chr1:100:A:G", list(), tl, .cvp_fm("susie", sp)), + FineMappingRow( + "chr1:100:A:G", + list(), + tl, + .cvp_fm("susie_inf", sp) + ) + ) + ) +} + +.cvp_cvOf <- function(x, method) { + cvResult(x, studyName = "S", context = "C", trait = "T", method = method) +} + +test_that("a collection keeps each CV partition once; its rows get it back", { + fmr <- .cvp_fmr() + expect_length(pecotmr:::.cvPartitionDict(fmr), 1L) + expect_equal(fmr$cvPartition, c("cv1", "cv1")) + stored <- fmr$cvResult[[1L]] + expect_null(stored$samplePartition) + expect_null(rownames(stored$prediction$susie_predicted)) + expect_identical(.cvp_cvOf(fmr, "susie"), .cvp_fm("susie")) + # A subset keeps it, and a combine keeps one copy of what both share. + expect_identical( + cvResult(fmr[2L], method = "susieInf"), + .cvp_fm("susie_inf") + ) + both <- c(fmr[1L], fmr[2L]) + expect_length(pecotmr:::.cvPartitionDict(both), 1L) + expect_identical(.cvp_cvOf(both, "susieInf"), .cvp_fm("susie_inf")) + # A different partition is a second entry. + other <- .cvp_fmr(sp = .cvp_partition()[c(2L, 1L, 3L, 4L), ]) + expect_length(pecotmr:::.cvPartitionDict(c(fmr[1L], other[2L])), 2L) + # Every row's key must name an entry. + expect_error( + { + fmr$cvPartition <- c("cv1", "cv9") + validObject(fmr) + }, + "cv9" + ) +}) + +test_that("TwasWeights keeps each CV partition once; its rows get it back", { + rows <- list( + TwasWeightsRow("chr1:100:A:G", 0.1, cvResult = .cvp_twas()), + TwasWeightsRow("chr1:100:A:G", 0.2, cvResult = .cvp_twas()) + ) + tw <- TwasWeights( + studyName = c("S", "S"), + context = c("C", "C"), + trait = c("T", "T"), + method = c("lasso", "enet"), + entry = rows + ) + expect_length(pecotmr:::.cvPartitionDict(tw), 1L) + expect_null(names(tw$cvResult[[1L]]$predictions)) + expect_identical(.cvp_cvOf(tw, "enet"), .cvp_twas()) +}) + +# Row `i`'s CV as the collection hands it out. +.cvp_rowCv <- function(i, x) { + cvResult(pecotmr:::.collectionEntry(x, i)) +} + +test_that("updateObject() keeps a saved collection's CV partitions once", { + fmr <- .cvp_fmr() + tw <- TwasWeights( + studyName = "S", + context = "C", + trait = "T", + method = "lasso", + entry = list( + TwasWeightsRow("chr1:100:A:G", 0.1, cvResult = .cvp_twas()) + ) + ) + # As saved before rows shared their partitions: each row's own, in full, + # and no key or dictionary. A TwasWeights was then saved one row per + # method, which already holds each row's full cvResult. + full <- map(seq_along(fmr), .cvp_rowCv, x = fmr) + savedFmr <- fmr + savedFmr$cvPartition <- NULL + savedFmr$cvResult <- S4Vectors::SimpleList(full) + attr(savedFmr, "cvPartition") <- NULL + expect_identical(map(seq_along(savedFmr), .cvp_rowCv, x = savedFmr), full) + savedTw <- .savedTwasPerMethod(tw) + attr(savedTw, "cvPartition") <- NULL + for (case in list(list(fmr, savedFmr), list(tw, savedTw))) { + up <- updateObject(case[[2L]]) + expect_identical(up, case[[1L]]) + expect_identical(updateObject(up), up) + } +}) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index d15dd4e4b..1ccf2b8cb 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -59,39 +59,14 @@ context("ctwasPipeline") .ctp_snpId <- function(i) sprintf("chr1:%d:G:A", 100L * i) .ctp_mockExtractor <- function(seed = 5, n_samples = 30L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -243,7 +218,7 @@ test_that("ctwasPipeline: rejects un-QCd GwasSumStats in any region", { ) }) -test_that("ctwasPipeline: rejects twasWeights keys not present in gwasSumStats", { +test_that("ctwasPipeline refuses twasWeights keys absent from gwasSumStats", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() tw <- .ctp_makeTwasWeights() @@ -259,11 +234,11 @@ test_that("ctwasPipeline: rejects twasWeights keys not present in gwasSumStats", ) }) -test_that("assembleCtwasInputs: allows twasWeights keys to be a subset of gwasSumStats", { +test_that("assembleCtwasInputs accepts a subset of gwasSumStats' keys", { ss <- .ctp_makeGwasSumstats() tw <- .ctp_makeTwasWeights() local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) # Two blocks supply zSnp; only block1 supplies TwasWeights, whose panel @@ -285,11 +260,12 @@ test_that("assembleCtwasInputs: allows twasWeights keys to be a subset of gwasSu expect_true(all(grepl("^block1\\|", names(inputs$weights)))) }) -test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (topLoci posterior effect)", { +test_that("assembleCtwasInputs takes a QtlFineMappingResult weight source", { ss <- .ctp_makeGwasSumstats() - # The FMR topLoci posterior effect is on the STANDARDIZED scale, so it matches - # a standardized TwasWeights carrying the same effect vector (both skip cTWAS's - # variance scaling). Compare against that, not the default (unstandardized) one. + # The FMR topLoci posterior effect is on the STANDARDIZED scale, so it + # matches a standardized TwasWeights carrying the same effect vector (both + # skip cTWAS's variance scaling). Compare against that, not the default + # (unstandardized) one. tw_std <- TwasWeights( studyName = "Q1", context = "c1", @@ -304,7 +280,7 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to ) fmr <- .ctp_makeFmrWeightSource() local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) itw <- assembleCtwasInputs( @@ -317,7 +293,8 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to twasWeights = list(block1 = fmr, block2 = fmr), method = "susie" ) - # Same gene keys, and the resolved weights match the standardized TwasWeights. + # Same gene keys, and the resolved weights match the standardized + # TwasWeights. expect_equal(names(ifmr$weights), names(itw$weights)) expect_true(length(ifmr$weights) > 0L) expect_equal(ifmr$weights[[1L]], itw$weights[[1L]]) @@ -368,7 +345,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { ldReference = .ctp_makeHandle() ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) both <- c(ss1, ss2) @@ -394,7 +371,7 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { expect_equal(entry$p1, 500L) }) -test_that("ctwasPipeline: a bare TwasWeights is a FLAT source, placed by region", { +test_that("ctwasPipeline places a bare TwasWeights (flat source) by region", { skip_if_not_installed("ctwas") # A bare TwasWeights is now accepted as a flat weight source and placed into # LD blocks by region; the fixture carries no region, so placement errors @@ -555,7 +532,7 @@ test_that(".ctwasBuildZSnp: leaves variants absent from the panel untouched", { expect_equal(none$z, plain$z) }) -test_that(".ctwasFilterVariants: a CS member the fine-mapping spells flipped still survives the cap", { +test_that(".ctwasFilterVariants: CS member spelled flipped survives the cap", { # The weights arrive in the panel frame, the fine-mapping auxiliaries in # the fine-mapping result's. An exact-string join lost the credible-set # member's must-keep protection, so the cap dropped the variant the @@ -630,7 +607,7 @@ test_that(".ctwasBuildSingleRegionInfo: a given region bounds the block", { expect_equal(ri$stop, 1001L) }) -test_that(".ctwasBuildSingleRegionInfo: uses the block entry span, not the wider shared LD sketch", { +test_that(".ctwasBuildSingleRegionInfo: block span, not the shared sketch's", { # Regression: many LD blocks can share one whole-chromosome LD payload, so # the sketch span (here BP 100-1200) is NOT the block's span. The entry # here covers only 200-400; region bounds must follow the entry, otherwise @@ -688,7 +665,7 @@ test_that(".ctwasBuildSingleRegionInfo: multi-chromosome block entry errors", { ) }) -test_that(".ctwasSnpInfoForBlock: returns ctwas-required columns chrom/id/pos/alt/ref", { +test_that(".ctwasSnpInfoForBlock gives ctwas's chrom/id/pos/alt/ref columns", { df <- pecotmr:::.ctwasSnpInfoForBlock(.ctp_makeHandle()) # ctwas's read_snp_info_files asserts these exact column names expect_setequal(colnames(df), c("chrom", "id", "pos", "alt", "ref")) @@ -705,7 +682,7 @@ test_that(".ctwasSnpInfoForBlock: repairs a tag-allele panel id from A1/A2", { expect_equal(df$alt[2L], "A") # the LD matrix and variance vector are keyed the same way local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) panel <- .ctp_fullPanel(h) @@ -776,8 +753,12 @@ test_that(".ctwasLdPanelKey: a mixture checks each panel; memory needs none", { pecotmr:::.ctwasLdPanelKey(gone), "could not find the file behind the LD panel" ) - # A panel held in memory reads no file, so there is none to find. - inMemory <- .ctp_mockExtractor()(.ctp_makeHandle(snp_n = 6L), 1:6) + # A panel held in memory, recording no file, reads none, so there is + # none to find. + inMemory <- SummarizedExperiment::SummarizedExperiment( + assays = list(dosage = as.matrix(SummarizedExperiment::assay(panel))), + rowRanges = SummarizedExperiment::rowRanges(panel) + ) expect_null(pecotmr:::.ctwasLdPanelKey(inMemory)) }) @@ -829,7 +810,7 @@ test_that(".ctwasTokenSlug: sanitizes ids and keeps duplicates apart", { test_that("assembleCtwasInputs: each region gets its own block-sized panel", { inp <- .ctp_makeMultiBlockInputs() local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) out <- assembleCtwasInputs( @@ -850,7 +831,7 @@ test_that("assembleCtwasInputs: each region gets its own block-sized panel", { test_that(".ctwasResolveLdPaths: re-mints sentinels lost with the session", { inp <- .ctp_makeMultiBlockInputs() local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) out <- assembleCtwasInputs( @@ -1024,7 +1005,7 @@ test_that(".ctwasPlaceByAnchor: a block holds its whole window", { ) }) -test_that(".ctwasIsPreBucketed / .ctwasCombineWeightSources: dispatch flat vs pre-bucketed", { +test_that(".ctwasCombineWeightSources tells flat from pre-bucketed sources", { tw <- .ctp_makeTwasWeights() grid <- list(block1 = 1, block2 = 2) expect_true(pecotmr:::.ctwasIsPreBucketed(list(block1 = tw))) # named list @@ -1037,7 +1018,7 @@ test_that(".ctwasIsPreBucketed / .ctwasCombineWeightSources: dispatch flat vs pr ) }) -test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks", { +test_that(".ctwasBucketWeights places a flat 2-gene source in its blocks", { mkE <- function() { TwasWeightsRow( variantIds = map_chr(1:5, .ctp_snpId), @@ -1152,7 +1133,7 @@ test_that(".ctwasRunToRows: single-context run -> one row, no jointContexts", { ) }) -test_that(".ctwasRunToRows: multi-context run -> per-context rows sharing jointContexts + param", { +test_that(".ctwasRunToRows: multi-context run -> rows sharing jointContexts", { ids <- c( "blk|Q1|brain|gA|susie", "blk|Q1|brain|gB|susie", @@ -1181,7 +1162,7 @@ test_that(".ctwasRunToRows: multi-context run -> per-context rows sharing jointC ) }) -test_that(".ctwasRunToRows: rejects multi-context runs with unshared gene sets", { +test_that(".ctwasRunToRows refuses multi-context runs with unshared genes", { run <- .ctp_runResult( c("blk|Q1|brain|gA|susie", "blk|Q1|liver|gC|susie"), c(0.9, 0.8), @@ -1218,7 +1199,7 @@ test_that(".ctwasRunToRows: susieAlpha subset mirrors finemap per context", { expect_true("susie_alpha" %in% names(sa)) }) -test_that(".ctwasRunToRows: keepSnps adds a dedicated SNP row; default drops SNPs", { +test_that(".ctwasRunToRows: keepSnps adds a SNP row; by default none", { ids <- c("blk|Q1|c1|gA|susie", "blk|Q1|c1|gB|susie") run <- .ctp_runResult( ids, @@ -1230,7 +1211,8 @@ test_that(".ctwasRunToRows: keepSnps adds a dedicated SNP row; default drops SNP rowsOff <- pecotmr:::.ctwasRunToRows(run, "D1", "susie") expect_length(rowsOff, 1L) expect_true(all(ctwasPosteriors(rowsOff[[1L]]$entry)$type == "gene")) - # keepSnps: one extra study = context = "SNP" row carrying the SNP background. + # keepSnps: one extra study = context = "SNP" row carrying the SNP + # background. rowsOn <- pecotmr:::.ctwasRunToRows(run, "D1", "susie", keepSnps = TRUE) expect_length(rowsOn, 2L) snpRow <- rowsOn[[2L]] @@ -1265,7 +1247,7 @@ test_that(".ctwasFilterMethod: subsets rows to the requested method", { ) twSub <- pecotmr:::.ctwasFilterMethod(tw, "susie") expect_equal(nrow(twSub), 1L) - expect_equal(as.character(twSub$method), "susie") + expect_equal(methodNames(twSub), "susie") }) # Build an ldPanel fixture (the materialized shape, R included) @@ -1345,10 +1327,10 @@ test_that(".ctwasHarmonizeWeights: sign-flips weights for swapped A1/A2", { variant_id = panel$snpInfo$id, stringsAsFactors = FALSE ) - # Variant 1: alleles match panel ("1:100:C:T" — same A2/A1 ordering) - # Variant 2: A1/A2 swapped vs panel ("1:200:A:G" — flips relative to "1:200:G:A") - # Output variant_id values are rebuilt via formatVariantId(), which - # always emits a `chr` prefix. + # Variant 1: alleles match panel ("1:100:C:T" — same A2/A1 ordering) Variant + # 2: A1/A2 swapped vs panel ("1:200:A:G" — flips relative to "1:200:G:A") + # Output variant_id values are rebuilt via formatVariantId(), which always + # emits a `chr` prefix. res <- pecotmr:::.ctwasHarmonizeWeights( origVids = c("1:100:C:T", "1:200:A:G"), origW = c(0.5, 0.3), @@ -1468,7 +1450,7 @@ test_that(".ctwasRenormalizeSusieWeights: honours a non-uniform prior", { ) }) -test_that(".ctwasSnpInfoForGwasBlock: restricts panel snpInfo to block GWAS variants", { +test_that(".ctwasSnpInfoForGwasBlock keeps the block's GWAS variants", { # Block 1's GWAS rows (variants 1..6) against the whole 12-variant panel. ss <- .ctp_makeGwasSumstats(blockIds = "block1") panelInfo <- data.frame( @@ -1560,7 +1542,7 @@ test_that(".ctwasBuildWeights: intersects with gwasSnpIds when supplied", { test_that(".ctwasPanelFor: cheap fields eagerly, correlation on request", { local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) out <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) @@ -1584,7 +1566,7 @@ test_that(".ctwasPanelFor: cheap fields eagerly, correlation on request", { test_that(".ctwasPanelWeightLd: refuses a variant absent from the panel", { local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) @@ -1599,7 +1581,7 @@ test_that(".ctwasPanelWeightLd: refuses a variant absent from the panel", { test_that(".ctwasPanelWeightLd: a panel's factor, or the R it carries", { local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) @@ -1608,19 +1590,19 @@ test_that(".ctwasPanelWeightLd: a panel's factor, or the R it carries", { # A sketch gives its factor: the LD over vids without forming it. viaFactor <- pecotmr:::.ctwasPanelWeightLd(panel, vids) expect_null(viaFactor$R) - expect_identical(colnames(viaFactor$F), vids) + expect_identical(colnames(viaFactor$ldFactor), vids) expect_equal( - crossprod(viaFactor$F) / (nrow(viaFactor$F) - 1), + crossprod(viaFactor$ldFactor) / (nrow(viaFactor$ldFactor) - 1), full[vids, vids] ) # A panel that already carries R is sliced, not re-read. withR <- pecotmr:::.ctwasPanelWeightLd(c(panel, list(R = full)), vids) - expect_null(withR$F) + expect_null(withR$ldFactor) expect_equal(withR$R, full[vids, vids]) # An LdMatrix has no factor to give: its matrix is read over vids. ldPanel <- pecotmr:::.ctwasPanelFor(LdMatrix(full, nSamples = 30)) viaMatrix <- pecotmr:::.ctwasPanelWeightLd(ldPanel, vids) - expect_null(viaMatrix$F) + expect_null(viaMatrix$ldFactor) expect_equal(viaMatrix$R, full[vids, vids]) }) @@ -1663,7 +1645,7 @@ test_that(".ctwasGlobalPanelInfo: NULL when the collection has no sketch", { test_that(".ctwasWeightVariances: w'Rw from the factor matches the matrix", { local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) panel <- pecotmr:::.ctwasPanelFor(.ctp_makeHandle(snp_n = 6L)) @@ -1738,7 +1720,7 @@ test_that(".ctwasGeneZ: none without weights; an infinite z is dropped", { expect_equal(out$z, 0.5 * 2 + 0.2) }) -test_that(".ctwasBuildZGene: builds z_gene from a TWAS-Z GRanges", { +test_that(".ctwasBuildZGene: each weighted gene's z under its weight id", { gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100, 200)) S4Vectors::mcols(gr) <- S4Vectors::DataFrame( qtlStudy = "Q1", @@ -1747,13 +1729,25 @@ test_that(".ctwasBuildZGene: builds z_gene from a TWAS-Z GRanges", { method = "susie", twasZ = 1.5 ) - df <- pecotmr:::.ctwasBuildZGene(gr) - expect_equal(nrow(df), 1L) - expect_setequal( - colnames(df), - c("id", "z", "type", "context", "gene_name", "study", "method") + entry <- list( + type = "c1", + context = "c1", + gene_name = "t1", + study = "Q1", + method = "susie" ) - expect_equal(df$id, "Q1|c1|t1|susie") + weights <- list(`block1|Q1|c1|t1|susie` = entry) + expect_equal( + pecotmr:::.ctwasBuildZGene(gr, weights, NA_character_), + data.frame( + id = "block1|Q1|c1|t1|susie", + z = 1.5, + type = "c1", + context = "c1", + group = "c1|c1" + ) + ) + expect_null(pecotmr:::.ctwasBuildZGene(gr, list(), NA_character_)) }) # =========================================================================== @@ -1812,14 +1806,29 @@ test_that(".ctwasMultiBlockSnpInfoLoader: dispatches by LD_file token", { expect_error(loader("unknown_token"), "no cached panel") }) +test_that("a saved payload holds each region's LD once, and no source", { + # Both loaders carried the whole panel cache, so a saved payload held + # every region's LD twice; and a function loaded with source references + # carried its whole source file along. + panels <- list( + tokenA = list(R = diag(2), snpInfo = data.frame(id = c("a", "b"))) + ) + ld <- pecotmr:::.ctwasMultiBlockLdLoader(panels) + info <- pecotmr:::.ctwasMultiBlockSnpInfoLoader(panels) + expect_identical(attr(ld, "ldPanelsByRegion"), panels) + expect_identical(names(attr(info, "ldPanelsByRegion")$tokenA), "snpInfo") + expect_null(attr(ld, "srcref")) + expect_null(attr(info, "srcref")) +}) + # =========================================================================== # Input-assembly shape checks via assembleCtwasInputs (no ctwas engine needed) # =========================================================================== -test_that("assembleCtwasInputs: assembles the documented input shape for ctwas", { +test_that("assembleCtwasInputs builds ctwas's documented input shape", { inp <- .ctp_makeMultiBlockInputs() local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) inputs <- assembleCtwasInputs( @@ -1854,7 +1863,7 @@ test_that("assembleCtwasInputs: forwards a twasZ argument as z_gene", { twasZ = 1.5 ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) inputs <- assembleCtwasInputs( @@ -1863,14 +1872,86 @@ test_that("assembleCtwasInputs: forwards a twasZ argument as z_gene", { twasZ = twasZ, method = "susie" ) - expect_equal(inputs$z_gene$id, "Q1|c1|t1|susie") + # ctwas keeps only the genes whose weight id z_gene names, so each row + # takes its weight's id and the columns ctwas reads. + expect_equal(inputs$z_gene$id, names(inputs$weights)) + expect_equal(inputs$z_gene$z, rep(1.5, length(inputs$weights))) + expect_named(inputs$z_gene, c("id", "z", "type", "context", "group")) + expect_equal(unique(inputs$z_gene$group), "c1|c1") +}) + +# A twasZ as causalInferencePipeline() returns it: one row per (qtlStudy, +# context, trait, method, gwasStudy). +.ctp_twasZ <- function(method, gwasStudy, z) { + n <- length(method) + twasZ <- GenomicRanges::GRanges( + rep("chr1", n), + IRanges::IRanges(rep(100L, n), width = 100L) + ) + S4Vectors::mcols(twasZ) <- S4Vectors::DataFrame( + qtlStudy = rep("Q1", n), + context = rep("c1", n), + trait = rep("t1", n), + method = method, + gwasStudy = gwasStudy, + twasZ = z + ) + twasZ +} + +test_that("assembleCtwasInputs reads each gene's z for its run alone", { + inp <- .ctp_makeMultiBlockInputs() + study <- pecotmr:::.ctwasGwasStudy(inp$gwasSumStats) + local_mocked_bindings( + .handleDosage = .ctp_mockExtractor(), + .package = "pecotmr" + ) + assemble <- function(twasZ) { + assembleCtwasInputs( + gwasSumStats = inp$gwasSumStats, + twasWeights = inp$twasWeights, + twasZ = twasZ, + method = "susie" + ) + } + # Another method's row and another GWAS study's row are not this run's. + twasZ <- .ctp_twasZ( + c("susie", "lasso", "susie"), + c(study, study, "otherGwas"), + c(1.5, 9, 7) + ) + expect_equal(assemble(twasZ)$z_gene$z, rep(1.5, 2L)) + # A weighted gene with no z would be dropped by ctwas: refused. + expect_error( + assemble(.ctp_twasZ("lasso", study, 9)), + "no z-score for 2 weighted gene" + ) + # Two z-scores for one gene cannot both be its. + expect_error( + assemble(.ctp_twasZ(c("susie", "susie"), c(study, study), c(1, 2))), + "more than one z-score" + ) +}) + +test_that(".ctwasTwasZForStudy refuses a choice the run cannot make", { + rows <- tibble::tibble(gwasStudy = c("g1", "g2"), twasZ = c(1, 2)) + expect_error( + pecotmr:::.ctwasTwasZForStudy(rows, NA_character_), + "several GWAS studies" + ) + expect_equal(pecotmr:::.ctwasTwasZForStudy(rows, "g2")$twasZ, 2) + one <- tibble::tibble(gwasStudy = "g1", twasZ = 1) + expect_identical(pecotmr:::.ctwasTwasZForStudy(one, NA_character_), one) + noStudy <- tibble::tibble(twasZ = 1) + expect_identical(pecotmr:::.ctwasTwasZForStudy(noStudy, "g1"), noStudy) }) # =========================================================================== -# Step-wise dispatch: estCtwasGroupPriors → screenCtwasRegions → finemapCtwasRegions +# Step-wise dispatch: estCtwasGroupPriors → screenCtwasRegions → +# finemapCtwasRegions # =========================================================================== -test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and accumulates state", { +test_that("ctwasPipeline runs assemble, est, screen, finemap; keeps state", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() capturedAssemble <- list() @@ -1923,7 +2004,7 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and .package = "ctwas" ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) out <- ctwasPipeline( @@ -1970,7 +2051,7 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and )) }) -test_that("ctwasPipeline: keepSnps retains the SNP background as a dedicated row", { +test_that("ctwasPipeline keepSnps keeps the SNP background as its own row", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() local_mocked_bindings( @@ -2009,7 +2090,7 @@ test_that("ctwasPipeline: keepSnps retains the SNP background as a dedicated row .package = "ctwas" ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) out <- ctwasPipeline( @@ -2120,7 +2201,7 @@ test_that("mergeCtwasBoundaryRegions passes no unnamed argument to ctwas", { expect_false(any(names(captured) == "")) }) -test_that("mergeCtwasBoundaryRegions: no-LD path uses postprocess_region_merging_noLD", { +test_that("mergeCtwasBoundaryRegions without LD uses the noLD merge", { skip_if_not_installed("ctwas") usedNoLd <- FALSE local_mocked_bindings( @@ -2138,7 +2219,7 @@ test_that("mergeCtwasBoundaryRegions: no-LD path uses postprocess_region_merging expect_equal(out$finemap_res$susie_pip, 0.99) }) -test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into CtwasResult", { +test_that("ctwasPipeline mergeBoundary re-fine-maps into the CtwasResult", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() merged <- FALSE @@ -2191,7 +2272,7 @@ test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into Ctwas .package = "ctwas" ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) out <- ctwasPipeline( @@ -2209,7 +2290,7 @@ test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into Ctwas # =========================================================================== # asCtwasResult — structure a granular finemap result (the wrapper path) # =========================================================================== -test_that("asCtwasResult: structures a granular finemap result into a CtwasResult", { +test_that("asCtwasResult turns a granular finemap result into a CtwasResult", { fmr <- .ctp_finemapResult() fmr$z_snp$study <- "D1" # GWAS study read from z_snp cr <- asCtwasResult(fmr) @@ -2248,7 +2329,7 @@ test_that("asCtwasResult: errors when the weights mix methods", { expect_error(asCtwasResult(fmr), "mixes weight methods") }) -test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN divergence", { +test_that("fallbackToPrefit recovers from accurate-EM NaN divergence", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() # Mock est_param to throw the documented NaN error, and fit_EM to @@ -2282,7 +2363,7 @@ test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN d .package = "ctwas" ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) # Assembled once; the two estimation calls below differ only in the @@ -2312,10 +2393,10 @@ test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN d expect_equal(unname(est$param$group_prior_var), c(4.0, 5.0)) }) -test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", { - # Regression for the ctwas >= 0.6.0 breakage: the prefit fallback used to hand - # ALL regions to ctwas::fit_EM, so a degenerate region (empty gid/sid, whose - # `sid` ctwas::extract_region_data now requires) crashed with +test_that("the prior fallback drops degenerate regions before fit_EM", { + # Regression for the ctwas >= 0.6.0 breakage: the prefit fallback used to + # hand ALL regions to ctwas::fit_EM, so a degenerate region (empty gid/sid, + # whose `sid` ctwas::extract_region_data now requires) crashed with # "regiondata$sid ... target is NULL". The fallback must mirror est_param's # min_var / min_gene skip and fit only the qualifying regions. skip_if_not_installed("ctwas") @@ -2324,7 +2405,8 @@ test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", local_mocked_bindings( assemble_region_data = function(...) { list( - good = list(gid = "t1", sid = c("s1", "s2")), # 1 gene + 2 SNPs -> kept + # 1 gene + 2 SNPs -> kept + good = list(gid = "t1", sid = c("s1", "s2")), degenerate = list(gid = character(0), sid = NULL) ) }, # no variables -> dropped @@ -2344,7 +2426,7 @@ test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", .package = "ctwas" ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) est <- estCtwasGroupPriors( @@ -2355,7 +2437,8 @@ test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", ), ctwasPriorParam = CtwasPriorParam(fallbackToPrefit = TRUE) ) - # only the qualifying region reached fit_EM; the degenerate region was filtered + # only the qualifying region reached fit_EM; the degenerate region was + # filtered expect_equal(seen, "good") # ...but every region is still accounted for in the returned p_single_effect expect_setequal( @@ -2364,14 +2447,15 @@ test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", ) }) -test_that("(real ctwas) prefit fallback skips a degenerate region fit_EM would reject", { +test_that("real ctwas: prefit fallback skips a region fit_EM would reject", { # No-mock guard for the ctwas >= 0.6.0 contract. Runs the REAL ctwas::fit_EM # (via .ctwasFitPrefitEm) on a genuine assemble_region_data fixture with one # valid region (1 gene, 108 SNPs) and one degenerate region (0 genes/SNPs, - # unset `sid`). Handing the degenerate region to fit_EM crashes ctwas >= 0.6.0 - # in extract_region_data ("regiondata$sid ... target is NULL"); the fallback - # must filter it. Unlike the mocked tests above, this exercises the real engine, - # so it would catch a FUTURE ctwas contract change (which the mocks cannot). + # unset `sid`). Handing the degenerate region to fit_EM crashes ctwas >= + # 0.6.0 in extract_region_data ("regiondata$sid ... target is NULL"); the + # fallback must filter it. Unlike the mocked tests above, this exercises the + # real engine, so it would catch a FUTURE ctwas contract change (which the + # mocks cannot). skip_if_not_installed("ctwas") region_data <- readRDS(test_path( "test_data", @@ -2389,14 +2473,15 @@ test_that("(real ctwas) prefit fallback skips a degenerate region fit_EM would r ), "EM did not converge in 3 iterations" ) - # the prefit EM ran on the valid region only and returns finite real group priors + # the prefit EM ran on the valid region only and returns finite real group + # priors expect_true("SNP" %in% names(res$group_prior)) expect_true(all(is.finite(res$group_prior))) # every region (valid + degenerate) is still listed in p_single_effect expect_setequal(res$p_single_effect$region_id, names(region_data)) }) -test_that("estCtwasGroupPriors / screenCtwasRegions / finemapCtwasRegions can be called independently", { +test_that("the three ctwas stages can each be called on their own", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() local_mocked_bindings( @@ -2424,7 +2509,7 @@ test_that("estCtwasGroupPriors / screenCtwasRegions / finemapCtwasRegions can be .package = "ctwas" ) local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) # Step 1 @@ -2476,7 +2561,7 @@ test_that("estCtwasGroupPriors / screenCtwasRegions / finemapCtwasRegions can be # (mocked tests only construct the closures, never invoke them). # =========================================================================== -test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", { +test_that("ctwasPipeline end to end on the real engine and bundled panel", { skip_if_not_installed("ctwas") data(gwasSumStatsS4Example) data(qtlDatasetExample) @@ -2603,7 +2688,7 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", # 3. minPipCutoff — high-PIP rescue (must-keep) # 4. maxNumVariants — per-gene cap, prioritized by PIP then |w| -test_that(".ctwasFilterVariants: twasWeightCutoff drops low-magnitude variants", { +test_that(".ctwasFilterVariants: twasWeightCutoff drops small weights", { vids <- sprintf("chr1:%d:A:G", 100L * (1:6)) w <- c(0.5, 0.001, 0.3, 0.0005, -0.4, 0) out <- pecotmr:::.ctwasFilterVariants( @@ -2635,7 +2720,7 @@ test_that(".ctwasFilterVariants: maxNumVariants caps by |w| when no PIP", { expect_setequal(out$vids, c("chr1:200:A:G", "chr1:400:A:G", "chr1:300:A:G")) }) -test_that(".ctwasFilterVariants: minPipCutoff rescues high-PIP variants from cap", { +test_that(".ctwasFilterVariants: minPipCutoff saves high-PIP variants", { vids <- sprintf("chr1:%d:A:G", 100L * (1:5)) w <- c(0.5, 0.4, 0.3, 0.2, 0.1) finemapAux <- list( @@ -2656,7 +2741,7 @@ test_that(".ctwasFilterVariants: minPipCutoff rescues high-PIP variants from cap expect_setequal(out$vids, c("chr1:300:A:G", "chr1:500:A:G")) }) -test_that(".ctwasFilterVariants: csMinCor rescues high-purity CS members from cap", { +test_that(".ctwasFilterVariants: csMinCor saves high-purity CS members", { vids <- sprintf("chr1:%d:A:G", 100L * (1:6)) w <- c(0.5, 0.4, 0.3, 0.2, 0.1, 0.05) finemapAux <- list( @@ -2726,7 +2811,8 @@ test_that(".ctwasBuildWeights: the variant cap and weight cutoff apply", { entry = list(TwasWeightsRow(variantIds = vids, weights = cs[[1L]])), ldReference = gh ) - wl <- exec(pecotmr:::.ctwasBuildWeights, tw, ldPanel, !!!cs[[2L]]) + secondCase <- cs[[2L]] + wl <- exec(pecotmr:::.ctwasBuildWeights, tw, ldPanel, !!!secondCase) expect_equal(wl[[1L]]$n_wgt, 3L, info = nm) expect_equal(nrow(wl[[1L]]$wgt), 3L, info = nm) expect_equal( @@ -2741,7 +2827,7 @@ test_that(".ctwasBuildWeights: the variant cap and weight cutoff apply", { # mergeCtwasBoundaryRegions (step 4: boundary-gene region merging) # =========================================================================== -test_that("mergeCtwasBoundaryRegions: no first-pass finemap_res returns unchanged", { +test_that("mergeCtwasBoundaryRegions: no first-pass finemap_res, no change", { skip_if_not_installed("ctwas") fmr <- list(finemap_res = NULL, region_data = "rd") expect_message( @@ -2752,7 +2838,7 @@ test_that("mergeCtwasBoundaryRegions: no first-pass finemap_res returns unchange expect_identical(suppressMessages(mergeCtwasBoundaryRegions(fmr0)), fmr0) }) -test_that("mergeCtwasBoundaryRegions: LD path forwards carried state + splices updated_*", { +test_that("boundary merge with LD carries state and splices updated_*", { skip_if_not_installed("ctwas") captured <- NULL local_mocked_bindings( @@ -2812,7 +2898,7 @@ test_that("mergeCtwasBoundaryRegions: LD path forwards carried state + splices u # guard would surface a different error). # =========================================================================== -test_that("assembleCtwasInputs: an unnamed twasWeights list is a FLAT source (needs region)", { +test_that("an unnamed twasWeights list is a flat source needing a region", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() tw <- .ctp_makeTwasWeights() # no region provenance @@ -2841,7 +2927,7 @@ test_that("assembleCtwasInputs: rejects a non-GwasSumStats gwas input", { ) }) -test_that("assembleCtwasInputs: rejects a weight source that is neither TwasWeights nor QtlFineMappingResult", { +test_that("assembleCtwasInputs refuses a weight source of any other class", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() expect_error( @@ -2886,7 +2972,7 @@ test_that("assembleCtwasInputs: the rescue source is a QtlFineMappingResult", { ) }) -test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolved method", { +test_that("assembleCtwasInputs skips a block lacking the resolved method", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() ids5 <- map_chr(1:5, .ctp_snpId) @@ -2904,7 +2990,7 @@ test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolv ) } local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) # Resolved method is "ensemble" (present in block1); block2 carries only @@ -2931,7 +3017,7 @@ test_that(".ctwasFilterMethod: returns NULL when no row matches the method", { # .ctwasHarmonizeWeights early NULL returns # =========================================================================== -test_that(".ctwasHarmonizeWeights: returns NULL when there is nothing to parse", { +test_that(".ctwasHarmonizeWeights: NULL when there is nothing to parse", { panel <- .ctp_makeAllelePanel() refVariants <- data.frame( chrom = panel$snpInfo$chrom, @@ -2973,7 +3059,7 @@ test_that(".ctwasHarmonizeWeights: returns NULL when harmonizeAlleles fails", { # .ctwasBuildWeights: per-gene skip branches + variance / renorm paths # =========================================================================== -test_that(".ctwasBuildWeights: skips a gene when harmonization yields nothing", { +test_that(".ctwasBuildWeights skips a gene harmonization leaves empty", { local_mocked_bindings( .ctwasHarmonizeWeights = function(...) NULL, .package = "pecotmr" @@ -2987,7 +3073,7 @@ test_that(".ctwasBuildWeights: skips a gene when harmonization yields nothing", ) }) -test_that(".ctwasBuildWeights: skips a gene when no variant survives gwasSnpIds intersect", { +test_that(".ctwasBuildWeights skips a gene with no variant in gwasSnpIds", { expect_length( pecotmr:::.ctwasBuildWeights( .ctp_makeTwasWeights(), @@ -2998,7 +3084,7 @@ test_that(".ctwasBuildWeights: skips a gene when no variant survives gwasSnpIds ) }) -test_that(".ctwasBuildWeights: SuSiE renormalization fires when variants are dropped", { +test_that(".ctwasBuildWeights renormalizes SuSiE when variants are dropped", { panel <- .ctp_makeLdPanel() ids4 <- map_chr(1:4, .ctp_snpId) bogus <- "chr1:99900:G:A" # absent from the 6-SNP panel @@ -3036,7 +3122,7 @@ test_that(".ctwasBuildWeights: SuSiE renormalization fires when variants are dro ) }) -test_that(".ctwasBuildWeights: errors when the LD panel lacks a kept variant's variance", { +test_that(".ctwasBuildWeights errors on a kept variant missing its variance", { panel <- .ctp_makeLdPanel() panel$variance <- panel$variance[1:4] # drop variance for ids 5, 6 expect_error( @@ -3045,7 +3131,7 @@ test_that(".ctwasBuildWeights: errors when the LD panel lacks a kept variant's v ) }) -test_that(".ctwasBuildWeights: skips a gene when the filter removes every variant", { +test_that(".ctwasBuildWeights skips a gene the filter empties", { expect_length( pecotmr:::.ctwasBuildWeights( .ctp_makeTwasWeights(), @@ -3088,7 +3174,7 @@ test_that(".ctwasGetFinemapAux: parses pip + cs_95 membership + purity", { expect_equal(aux$csPurity, c(0.95, 0.7)) }) -test_that(".ctwasGetFinemapAux: cs_95 without a purity column yields NA purity", { +test_that(".ctwasGetFinemapAux: cs_95 without purity column gives NA purity", { tl <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), pip = c(0.1, 0.5, 0.9), @@ -3172,7 +3258,7 @@ test_that(".ctwasFixMolecularId: rows without a gene id are left alone", { expect_identical(pecotmr:::.ctwasFixMolecularId(snps), snps) }) -test_that(".ctwasGetFinemapAux: NULL input, no-match tuple, and empty topLoci all return NULL", { +test_that(".ctwasGetFinemapAux: NULL input, no match or empty topLoci: NULL", { expect_null(pecotmr:::.ctwasGetFinemapAux(NULL, "Q1", "c1", "t1")) tl <- data.frame( variant_id = "chr1:100:A:G", @@ -3215,7 +3301,7 @@ test_that(".ctwasFilterVariants: returns NULL for an empty variant set", { )) }) -test_that(".ctwasSnpInfoForGwasBlock: returns an empty frame when the block has no SNP ids", { +test_that(".ctwasSnpInfoForGwasBlock: empty frame for a block with no SNPs", { # GRanges entry with no mcols -> no SNP column -> blockIds is empty. gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 1L)) gss <- GwasSumStats( @@ -3257,7 +3343,7 @@ test_that(".ctwasCombineWeightSources: type + emptiness guards; FMR list", { ) }) -test_that(".ctwasGwasStudy / .ctwasGwasStudyFromZSnp: NA when no study present", { +test_that(".ctwasGwasStudy and .ctwasGwasStudyFromZSnp: NA with no study", { expect_true(is.na(pecotmr:::.ctwasGwasStudy(list( a = data.frame(study = NA_character_) )))) @@ -3267,7 +3353,7 @@ test_that(".ctwasGwasStudy / .ctwasGwasStudyFromZSnp: NA when no study present", )))) }) -test_that(".ctwasSubsetById / .ctwasSubsetSnp: NULL on empty / no type column", { +test_that(".ctwasSubsetById, .ctwasSubsetSnp: NULL on empty or no type", { df <- data.frame( id = c("a", "b"), type = c("gene", "SNP"), @@ -3275,7 +3361,8 @@ test_that(".ctwasSubsetById / .ctwasSubsetSnp: NULL on empty / no type column", ) expect_null(pecotmr:::.ctwasSubsetById(df, "zzz")) expect_null(pecotmr:::.ctwasSubsetById(NULL, "a")) - expect_null(pecotmr:::.ctwasSubsetSnp(data.frame(id = "a"))) # no type column + # no type column + expect_null(pecotmr:::.ctwasSubsetSnp(data.frame(id = "a"))) expect_equal(nrow(pecotmr:::.ctwasSubsetSnp(df)), 1L) }) @@ -3291,7 +3378,7 @@ test_that(".ctwasRowsToResult / .ctwasMethodFromWeights: empty-input guards", { ) }) -test_that(".ctwasRunToRows: empty weights -> no rows; a context mixing studies errors", { +test_that(".ctwasRunToRows: no weights, no rows; mixed-study context errors", { expect_equal( pecotmr:::.ctwasRunToRows( list(weights = setNames(list(), character(0))), @@ -3316,7 +3403,7 @@ test_that(".ctwasRunToRows: empty weights -> no rows; a context mixing studies e ) }) -test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped", { +test_that(".ctwasBucketWeights warns on unplaced genes; skips empty blocks", { mkE <- function() { TwasWeightsRow( variantIds = map_chr(1:5, .ctp_snpId), @@ -3389,7 +3476,7 @@ test_that("assembleCtwasInputs: single-block + NULL twasWeights guards", { ) }) -test_that("weight-source / method / gwas-study guards reject degenerate input", { +test_that("weight-source, method and GWAS-study guards refuse bad input", { expect_error( pecotmr:::.ctwasRequireNamedLists(.ctp_makeGwasSumstats(), 42), "must be a TwasWeights" @@ -3401,7 +3488,7 @@ test_that("weight-source / method / gwas-study guards reject degenerate input", ) }) -test_that("finemapCtwasRegions: an empty screened-region set returns a NULL finemap", { +test_that("finemapCtwasRegions: no screened regions gives a NULL finemap", { skip_if_not_installed("ctwas") screenStub <- list( screened_region_data = list(), @@ -3517,7 +3604,7 @@ test_that("finemapCtwasRegions runs from the bundled est payload", { # than surfacing an S4 dispatch error from deep inside. # ============================================================================= -test_that("ctwas LD assembly reports a missing LD sketch like everything else", { +test_that("ctwas LD assembly reports a missing LD sketch like the rest", { expect_error( pecotmr:::.ctwasPanelFor(NULL), "carries no ldReference" @@ -3783,7 +3870,8 @@ test_that("each weight entry must be a TwasWeights or QtlFineMappingResult", { # fail later inside the assembly with a far less specific message. expect_error( pecotmr:::.ctwasValidateWeightEntries(list(r1 = "not a TwasWeights")), - "twasWeights\\[\\['r1'\\]\\] must be a TwasWeights or QtlFineMappingResult" + "twasWeights[['r1']] must be a TwasWeights or QtlFineMappingResult", + fixed = TRUE ) }) @@ -3930,6 +4018,46 @@ test_that(".ctwasAlignGeneWeights returns NULL when the row has no variants", { expect_null(pecotmr:::.ctwasAlignGeneWeights(row, NULL, NULL)) }) +test_that("cTWAS models a one-column weight matrix as one weight per variant", { + panel <- .ctp_makeAllelePanel() + si <- panel$snpInfo + refVariants <- data.frame( + chrom = si$chrom, + pos = si$pos, + A2 = si$ref, + A1 = si$alt, + variant_id = si$id, + stringsAsFactors = FALSE + ) + w <- c(0.1, -0.2, 0.3, 0.05) + harmonized <- pecotmr:::.ctwasHarmonizeWeights(si$id, w, refVariants) + panelSnps <- harmonized$variant_id + asVector <- TwasWeightsRow(variantIds = si$id, weights = w) + want <- pecotmr:::.ctwasAlignGeneWeights(asVector, refVariants, panelSnps) + expect_false(is.null(want)) + oneColumn <- TwasWeightsRow( + variantIds = si$id, + weights = matrix(w, ncol = 1L, dimnames = list(NULL, "susie")) + ) + expect_equal( + pecotmr:::.ctwasAlignGeneWeights(oneColumn, refVariants, panelSnps), + want + ) + # Several columns (one per feature or outcome) are still skipped. + twoColumns <- TwasWeightsRow(variantIds = si$id, weights = cbind(w, -w)) + expect_null(suppressMessages( + pecotmr:::.ctwasAlignGeneWeights(twoColumns, refVariants, panelSnps) + )) +}) + +test_that("cTWAS refuses weights holding two fits of one gene", { + expect_null(pecotmr:::.ctwasRequireUniqueGenes(c("s|c|g1|m", "s|c|g2|m"))) + expect_error( + pecotmr:::.ctwasRequireUniqueGenes(c("s|c|g1|m", "s|c|g1|m")), + "more than one fit of s\\|c\\|g1\\|m" + ) +}) + test_that(".ctwasTraitPosAt is bounded by the traitPos column length", { row <- FineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:C:T"), @@ -3951,6 +4079,95 @@ test_that(".ctwasTraitPosAt is bounded by the traitPos column length", { expect_null(pecotmr:::.ctwasTraitPosAt(res, 2L)) }) +test_that(".ctwasRenormFit reads a fine-mapping method's fit from the result", { + # A fine-mapping method's TWAS rows keep none of its fit, which the + # fine-mapping result already holds; renormalization reads it there. + withr::local_options(rlib_message_verbosity = "verbose") + ids <- c("chr1:100:A:G", "chr1:200:A:G") + fit <- list( + alpha = matrix(0.5, 1L, 2L), + mu = matrix(0.1, 1L, 2L), + X_column_scale_factors = c(1, 1) + ) + fmr <- QtlFineMappingResult( + studyName = "s", + context = "c", + trait = "g", + method = "susie", + entry = list(FineMappingRow( + variantIds = ids, + susieFit = fit, + topLoci = data.frame(variant_id = ids, pip = c(0.5, 0.5)) + )) + ) + row <- TwasWeightsRow(variantIds = ids, weights = c(0.05, 0.05)) + meta <- list(study = "s", context = "c", trait = "g", method = "susie") + expect_identical(pecotmr:::.ctwasRenormFit(row, fmr, meta)$alpha, fit$alpha) + # Another method's gene, or another gene, finds nothing there. + expect_null(pecotmr:::.ctwasRenormFit( + row, + fmr, + list(study = "s", context = "c", trait = "g", method = "susieInf") + )) + # A row keeping its own fit, as other methods do, uses it. + own <- TwasWeightsRow( + variantIds = ids, + weights = c(0.05, 0.05), + methodFits = list(variantIds = ids) + ) + expect_identical( + pecotmr:::.ctwasRenormFit(own, fmr, list(method = "lasso"))$variantIds, + ids + ) + # Without a fine-mapping result there is nothing to read, and it says so. + expect_message( + expect_null(pecotmr:::.ctwasRenormFit(row, NULL, meta)), + "fineMappingResult" + ) + # A fine-mapping row as the weight source has no fit by design. + expect_null(pecotmr:::.ctwasRenormFit( + pecotmr:::.fmrRowParts(fmr, 1L), + fmr, + meta + )) +}) + +test_that(".ctwasRenormFit cuts a joint mvSuSiE fit to the row's condition", { + # The rows of a joint fit share it whole, mu L x p x R; each records its + # position in the fit's conditions, which picks its own L x p. + ids <- c("chr1:100:A:G", "chr1:200:A:G") + fit <- list( + alpha = matrix(0.5, 1L, 2L), + mu = array(c(0.1, 0.2, 0.3, 0.4), dim = c(1L, 2L, 2L)), + X_column_scale_factors = c(1, 1) + ) + entry <- FineMappingRow( + variantIds = ids, + susieFit = fit, + topLoci = data.frame(variant_id = ids, pip = c(0.5, 0.5)) + ) + fmr <- QtlFineMappingResult( + studyName = c("s", "s"), + context = c("c1", "c2"), + trait = c("g", "g"), + method = c("mvsusie", "mvsusie"), + entry = list(entry, entry), + jointContexts = c("c1;c2", "c1;c2") + ) + fmr$jointIndex <- c(1L, 2L) + row <- TwasWeightsRow(variantIds = ids, weights = c(0.15, 0.2)) + meta <- list(study = "s", context = "c2", trait = "g", method = "mvsusie") + cut <- pecotmr:::.ctwasRenormFit(row, fmr, meta) + expect_equal(cut$mu, matrix(c(0.3, 0.4), 1L, 2L)) + expect_true(pecotmr:::.ctwasRenormalizable(cut, 2L)) + # A row recording no position keeps the whole fit, which the + # renormalization then leaves alone. + fmr$jointIndex <- NULL + whole <- pecotmr:::.ctwasRenormFit(row, fmr, meta) + expect_identical(dim(whole$mu), c(1L, 2L, 2L)) + expect_false(pecotmr:::.ctwasRenormalizable(whole, 2L)) +}) + test_that(".ctwasRenormalizeSusieWeights skips fits it cannot slice", { alpha <- matrix(c(0.5, 0.5, 0.3, 0.7), nrow = 2L, byrow = TRUE) mu <- matrix(1, nrow = 2L, ncol = 2L) @@ -3968,10 +4185,11 @@ test_that(".ctwasRenormalizeSusieWeights skips fits it cannot slice", { harmonizedW ) } - # Any missing susie field: nothing to renormalize from. + # A missing alpha or mu: nothing to renormalize from. expect_null(run(list(mu = mu, X_column_scale_factors = c(1, 1)))) expect_null(run(list(alpha = alpha, X_column_scale_factors = c(1, 1)))) - expect_null(run(list(alpha = alpha, mu = mu))) + # Absent scale factors are all 1s: a stored fit drops them when they are. + expect_equal(run(list(alpha = alpha, mu = mu)), c(0.8, 1.2)) # susieInf / susieAsh carry an infinitesimal term that alpha and mu alone # cannot reproduce, so those fits take the plain subset path instead. expect_null(run(c(good, list(theta = 1)))) @@ -3982,6 +4200,13 @@ test_that(".ctwasRenormalizeSusieWeights skips fits it cannot slice", { mu = matrix(1, nrow = 2L, ncol = 3L), X_column_scale_factors = c(1, 1, 1) ))) + # An mvSuSiE mu is L x p x R. Its p passed the dimension check, and the + # 2-D slice of a 3-D array then failed the cTWAS run. + expect_null(run(list( + alpha = alpha, + mu = array(1, dim = c(2L, 2L, 2L)), + X_column_scale_factors = c(1, 1) + ))) # An all-zero alpha has no finite row maximum in log space. expect_null(run(list( alpha = matrix(0, nrow = 2L, ncol = 2L), @@ -4163,23 +4388,27 @@ test_that("an ensemble gene is rescued by the fine-mapping method named", { # =========================================================================== # One gene's SuSiE weights on variants `variantIdx`, fitted on all five and -# narrowed to the first four; `fits` is the stored fit. +# narrowed to the first four; `fits` is the stored fit, by default a SuSiE fit +# naming its variants on alpha's columns, as susieR's do. .ctp_narrowedSusieWeights <- function( variantIdx = 1:5, method = "susie", - fits = list( - alpha = matrix(0.2, 1L, 5L), - mu = matrix(0.1, 1L, 5L), - X_column_scale_factors = rep(1, 5L) - ) + fits = NULL ) { + vids <- map_chr(variantIdx, .ctp_snpId) + fits <- fits %||% + list( + alpha = matrix(0.2, 1L, 5L, dimnames = list(NULL, vids)), + mu = matrix(0.1, 1L, 5L), + X_column_scale_factors = rep(1, 5L) + ) tw <- TwasWeights( studyName = "Q1", context = "c1", trait = "t1", method = method, entry = list(TwasWeightsRow( - variantIds = map_chr(variantIdx, .ctp_snpId), + variantIds = vids, weights = c(0.1, 0.05, -0.2, 0.3, 0.0), methodFits = fits )), @@ -4231,7 +4460,7 @@ test_that("the narrowed rows checked are SuSiE-fitted rows of the method", { test_that("assembleCtwasInputs warns about narrowed SuSiE weights", { skip_if_not_installed("ctwas") local_mocked_bindings( - extractBlockGenotypes = .ctp_mockExtractor(), + .handleDosage = .ctp_mockExtractor(), .package = "pecotmr" ) cnd <- .fitCoverageCondition(assembleCtwasInputs( diff --git a/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.9col.bim b/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.9col.bim deleted file mode 100644 index f90fbbbbd..000000000 --- a/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.9col.bim +++ /dev/null @@ -1,5 +0,0 @@ -1 chr1:1000_A_G 0 1000 A G 0.42 0.3 500 -1 chr1:1040_A_G 0 1040 A G 0.48 0.4 500 -1 chr1:1080_A_G 0 1080 A G 0.36 0.2 500 -1 chr1:1120_A_G 0 1120 A G 0.50 0.5 500 -1 chr1:1160_A_G 0 1160 A G 0.32 0.15 500 diff --git a/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.bim b/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.bim deleted file mode 100644 index 91e59820e..000000000 --- a/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.bim +++ /dev/null @@ -1,5 +0,0 @@ -1 chr1:1000_A_G 0 1000 A G -1 chr1:1040_A_G 0 1040 A G -1 chr1:1080_A_G 0 1080 A G -1 chr1:1120_A_G 0 1120 A G -1 chr1:1160_A_G 0 1160 A G diff --git a/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.txt.xz b/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.txt.xz deleted file mode 100644 index f760e35c1..000000000 Binary files a/tests/testthat/test_data/LD_block_1.chr1_1000_1200.float16.txt.xz and /dev/null differ diff --git a/tests/testthat/test_data/LD_block_2.chr1_1200_1400.float16.bim b/tests/testthat/test_data/LD_block_2.chr1_1200_1400.float16.bim deleted file mode 100644 index b991185a9..000000000 --- a/tests/testthat/test_data/LD_block_2.chr1_1200_1400.float16.bim +++ /dev/null @@ -1,5 +0,0 @@ -1 chr1:1200_A_G 0 1200 A G -1 chr1:1240_A_G 0 1240 A G -1 chr1:1280_A_G 0 1280 A G -1 chr1:1320_A_G 0 1320 A G -1 chr1:1360_A_G 0 1360 A G diff --git a/tests/testthat/test_data/LD_block_2.chr1_1200_1400.float16.txt.xz b/tests/testthat/test_data/LD_block_2.chr1_1200_1400.float16.txt.xz deleted file mode 100644 index 85d39382d..000000000 Binary files a/tests/testthat/test_data/LD_block_2.chr1_1200_1400.float16.txt.xz and /dev/null differ diff --git a/tests/testthat/test_data/LD_block_3.chr1_1400_1600.float16.bim b/tests/testthat/test_data/LD_block_3.chr1_1400_1600.float16.bim deleted file mode 100644 index 8d2a533ce..000000000 --- a/tests/testthat/test_data/LD_block_3.chr1_1400_1600.float16.bim +++ /dev/null @@ -1,5 +0,0 @@ -1 chr1:1400_A_G 0 1400 A G -1 chr1:1440_A_G 0 1440 A G -1 chr1:1480_A_G 0 1480 A G -1 chr1:1520_A_G 0 1520 A G -1 chr1:1560_A_G 0 1560 A G diff --git a/tests/testthat/test_data/LD_block_3.chr1_1400_1600.float16.txt.xz b/tests/testthat/test_data/LD_block_3.chr1_1400_1600.float16.txt.xz deleted file mode 100644 index fafe113fb..000000000 Binary files a/tests/testthat/test_data/LD_block_3.chr1_1400_1600.float16.txt.xz and /dev/null differ diff --git a/tests/testthat/test_data/LD_block_4.chr1_1600_1800.float16.bim b/tests/testthat/test_data/LD_block_4.chr1_1600_1800.float16.bim deleted file mode 100644 index 2db404e49..000000000 --- a/tests/testthat/test_data/LD_block_4.chr1_1600_1800.float16.bim +++ /dev/null @@ -1,5 +0,0 @@ -1 chr1:1600_A_G 0 1600 A G -1 chr1:1640_A_G 0 1640 A G -1 chr1:1680_A_G 0 1680 A G -1 chr1:1720_A_G 0 1720 A G -1 chr1:1760_A_G 0 1760 A G diff --git a/tests/testthat/test_data/LD_block_4.chr1_1600_1800.float16.txt.xz b/tests/testthat/test_data/LD_block_4.chr1_1600_1800.float16.txt.xz deleted file mode 100644 index b6ec83075..000000000 Binary files a/tests/testthat/test_data/LD_block_4.chr1_1600_1800.float16.txt.xz and /dev/null differ diff --git a/tests/testthat/test_data/LD_block_5.chr1_1800_2000.float16.bim b/tests/testthat/test_data/LD_block_5.chr1_1800_2000.float16.bim deleted file mode 100644 index 9675bd20e..000000000 --- a/tests/testthat/test_data/LD_block_5.chr1_1800_2000.float16.bim +++ /dev/null @@ -1,5 +0,0 @@ -1 chr1:1800_A_G 0 1800 A G -1 chr1:1840_A_G 0 1840 A G -1 chr1:1880_A_G 0 1880 A G -1 chr1:1920_A_G 0 1920 A G -1 chr1:1960_A_G 0 1960 A G diff --git a/tests/testthat/test_data/LD_block_5.chr1_1800_2000.float16.txt.xz b/tests/testthat/test_data/LD_block_5.chr1_1800_2000.float16.txt.xz deleted file mode 100644 index ba67085c1..000000000 Binary files a/tests/testthat/test_data/LD_block_5.chr1_1800_2000.float16.txt.xz and /dev/null differ diff --git a/tests/testthat/test_data/h2EstimateSaved.rds b/tests/testthat/test_data/h2EstimateSaved.rds new file mode 100644 index 000000000..87c3bb6d1 Binary files /dev/null and b/tests/testthat/test_data/h2EstimateSaved.rds differ diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index 0a88a8dfe..afe67f78b 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -31,39 +31,14 @@ context("fineMappingPipeline") } .fmp_mockExtractor <- function(seed = 3, n_samples = 40L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -338,29 +313,40 @@ test_that(".fmNormalizeMethods: rejects NULL / empty / non-character/list", { ) }) -test_that(".fmNormalizeMethods: char-vector form deduplicates + seeds susie L defaults", { +test_that(".fmNormalizeMethods: a char vector dedups and seeds susie L", { res <- pecotmr:::.fmNormalizeMethods( c("susie", "susie", "susieInf"), inputKind = "QtlDataset" ) expect_equal(res$tokens, c("susie", "susieInf")) expect_equal(names(res$methodArgs), c("susie", "susieInf")) - # SuSiE-family tokens get the pipeline L default (pecotmr owns these, not the - # CLI wrappers). L_greedy defaults to NULL (greedy off), so it is left unset. + # SuSiE-family tokens get the pipeline L default (pecotmr owns these, not + # the CLI wrappers). L_greedy defaults to NULL (greedy off), so it is left + # unset. expect_equal(res$methodArgs$susie$L, 10L) expect_null(res$methodArgs$susie$L_greedy) expect_equal(res$methodArgs$susieInf$L, 10L) - # Non-susie-family tokens are left untouched. + # mvSuSiE is SuSiE-family too. MvsusieOptions refuses `L` as pecotmr's to + # supply, and this seeding is the only way it arrives. + expect_equal( + pecotmr:::.fmNormalizeMethods( + c("mvsusie"), + maxNumSingleEffects = 3L, + inputKind = "QtlDataset" + )$methodArgs$mvsusie$L, + 3L + ) + # fSuSiE takes maxNumSingleEffects as a formal of its own instead. expect_length( pecotmr:::.fmNormalizeMethods( - "mvsusie", + "fsusie", inputKind = "QtlDataset" - )$methodArgs$mvsusie, + )$methodArgs$fsusie, 0L ) }) -test_that(".fmNormalizeMethods: a methods record keeps kwargs + fills susie L", { +test_that(".fmNormalizeMethods: a record keeps kwargs and fills susie L", { res <- pecotmr:::.fmNormalizeMethods( FineMappingMethodsParam( qtlDatasetMethods = list( @@ -373,7 +359,8 @@ test_that(".fmNormalizeMethods: a methods record keeps kwargs + fills susie L", expect_equal(res$tokens, c("susie", "susieInf")) expect_equal(res$methodArgs$susie$L, 1) # explicit kwarg wins expect_false(res$methodArgs$susie$refine) - expect_null(res$methodArgs$susie$L_greedy) # greedy off by default (Lgreedy = NULL) + # greedy off by default (Lgreedy = NULL) + expect_null(res$methodArgs$susie$L_greedy) expect_equal(res$methodArgs$susieInf$L, 10L) # both filled }) @@ -459,7 +446,7 @@ test_that(".fmCheckMethodCapabilities: mrmash always rejected", { ) }) -test_that(".fmCheckMethodCapabilities: fsusie on QtlSumStats rejected (no sumstatImpl)", { +test_that(".fmCheckMethodCapabilities refuses fsusie on QtlSumStats", { expect_error( pecotmr:::.fmCheckMethodCapabilities("fsusie", "QtlSumStats"), "individual-only" @@ -477,7 +464,7 @@ test_that(".fmCheckMethodCapabilities: mvsusie on GwasSumStats rejected", { # .fmResolveSusieChain # =========================================================================== -test_that(".fmResolveSusieChain: chains susie from susieInf when both are requested", { +test_that(".fmResolveSusieChain chains susie from susieInf when both asked", { res <- pecotmr:::.fmResolveSusieChain( c("susieInf", "susie"), initializeWithSusieInf = TRUE @@ -712,7 +699,7 @@ test_that(".rbindFineMappingResult: rejects mixed Qtl/Gwas inputs", { ) }) -test_that(".rbindFineMappingResult: concatenates two GwasFineMappingResult collections", { +test_that(".rbindFineMappingResult joins two GwasFineMappingResults", { e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), @@ -737,7 +724,7 @@ test_that(".rbindFineMappingResult: concatenates two GwasFineMappingResult colle expect_equal(nrow(out), 2L) }) -test_that("combineFineMappingResults: row-binds same-class collections; rejects mixed class/empty", { +test_that("combineFineMappingResults binds one class; refuses mixed or empty", { e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), @@ -796,7 +783,7 @@ test_that(".fmExtractZn: errors on missing SNP / Z / N columns", { test_that("fineMappingPipeline(QtlDataset): univariate rows record traitPos", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -840,10 +827,10 @@ test_that("fineMappingPipeline(QtlDataset): univariate rows record traitPos", { expect_lte(re[["ENSG_B"]], 3499L) # traitPos 2499 + cisWindow }) -test_that(".fmAfForX: returns directional effect-allele af aligned to colnames(X)", { +test_that(".fmAfForX gives effect-allele af aligned to colnames(X)", { qd <- .fmp_qdA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .package = "pecotmr" ) region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 100000L)) @@ -871,7 +858,7 @@ test_that(".fmAfForX: returns directional effect-allele af aligned to colnames(X expect_equal(af, unname(setNames(blk$af, blk$variantIds)[colnames(X)])) }) -test_that(".fmAfForX: returns NULL for an empty block or a non-QtlDataset source", { +test_that(".fmAfForX: NULL for an empty block or a non-QtlDataset source", { qd <- .fmp_qdA emptyX <- matrix(numeric(0), nrow = 0L, ncol = 0L) expect_null(pecotmr:::.fmAfForX(qd, emptyX)) @@ -884,9 +871,9 @@ test_that(".fmAfForX: returns NULL for an empty block or a non-QtlDataset source expect_null(pecotmr:::.fmAfForX(list(not = "a dataset"), X)) }) -test_that("fineMappingPipeline(QtlDataset): threads directional af into postprocess", { - # Regression for af = NA in credibleSets: the individual-level univariate path must - # forward a non-NULL, directional effect-allele frequency to the +test_that("fineMappingPipeline(QtlDataset) passes af into postprocessing", { + # Regression for af = NA in credibleSets: the individual-level univariate + # path must forward a non-NULL, directional effect-allele frequency to the # post-processor (which writes it into the topLoci `af` column). qd <- .fmp_qdA captured <- new.env(parent = emptyenv()) @@ -922,7 +909,7 @@ test_that("fineMappingPipeline(QtlDataset): threads directional af into postproc ) } local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = recordingPostprocess, .package = "pecotmr" @@ -943,10 +930,10 @@ test_that("fineMappingPipeline(QtlDataset): threads directional af into postproc expect_true(all(captured$af >= 0 & captured$af <= 1, na.rm = TRUE)) }) -test_that("fineMappingPipeline(QtlDataset): seed argument is accepted and runs", { +test_that("fineMappingPipeline(QtlDataset) accepts a seed and runs", { qd <- .fmp_qdA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -974,7 +961,8 @@ test_that(".fmTopPcScores: samples x min(nPCs, traits) scores, else NULL", { dimnames = list(paste0("s", seq_len(n)), c("ta", "tb", "tc")) ) fn <- function(...) pecotmr:::.fmTopPcScores(...) - # (a) 3 traits, nPCs >= traits -> 3 columns named topPC1..topPC3, rows = samples. + # (a) 3 traits, nPCs >= traits -> 3 columns named topPC1..topPC3, rows = + # samples. sc <- fn(Y, 10L) expect_true(is.matrix(sc)) expect_equal(ncol(sc), 3L) @@ -1010,10 +998,20 @@ test_that("fineMappingPipeline(QtlDataset, usePCA): rows keyed topPC{i}", { contexts = "brain", traits = c("ENSG_A", "ENSG_B", "ENSG_C") ) + # The PCA path builds a window's block from all the context's traits; the + # univariate fits, from one trait each. + realBlock <- pecotmr:::.fmResidGenoBlock + pcaBuilds <- 0L local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), + .fmResidGenoBlock = function(ctx, traits, ...) { + if (length(traits) > 1L) { + pcaBuilds <<- pcaBuilds + 1L + } + realBlock(ctx, traits, ...) + }, .package = "pecotmr" ) res <- suppressMessages( @@ -1033,6 +1031,9 @@ test_that("fineMappingPipeline(QtlDataset, usePCA): rows keyed topPC{i}", { expect_equal(sum(pcRows), 2L) expect_setequal(as.character(res$trait)[pcRows], c("topPC1", "topPC2")) expect_setequal(as.character(res$method)[pcRows], "susie") + # The PCs differ only in the response, so they share their window's + # block: one build for the window, not one per PC. + expect_equal(pcaBuilds, 1L) }) test_that(".fmLookupMrmashFit: finds the mr.mash fit by (study, trait)", { @@ -1064,7 +1065,7 @@ test_that(".fmLookupMrmashFit: finds the mr.mash fit by (study, trait)", { expect_null(lk(NULL, "S", "G")) # no TwasWeights supplied }) -test_that(".fmLookupMrmashCv: finds the per-fold CV payload by (study, trait)", { +test_that(".fmLookupMrmashCv finds the per-fold CV payload by study, trait", { mkEntry <- function(cv) { TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), @@ -1140,7 +1141,7 @@ test_that(".fmBuildMvsusiePriorCv: mode B reweights each fold's own fit", { expect_equal(out[["3"]]$residualVariance, diag(2) * 30) # fold 3's own V }) -test_that(".fmBuildMvsusiePriorCv: mode C reuses full-fit w0/V with per-fold U", { +test_that(".fmBuildMvsusiePriorCv mode C: full-fit w0/V, per-fold U", { sp <- data.frame( Sample = paste0("s", 1:4), Fold = rep(1:2, each = 2), @@ -1182,16 +1183,18 @@ test_that(".fmBuildMvsusiePriorCv: mode C reuses full-fit w0/V with per-fold U", ) expect_equal(names(out), c("1", "2")) expect_equal(out[["1"]]$residualVariance, diag(2) * 99) # full fit's V - expect_equal(captured[[1]]$mixture_prior$matrices$Z, diag(2) * 2) # fold 1's U - expect_equal(captured[[2]]$mixture_prior$matrices$Z, diag(2) * 3) # fold 2's U + # fold 1's U + expect_equal(captured[[1]]$mixture_prior$matrices$Z, diag(2) * 2) + # fold 2's U + expect_equal(captured[[2]]$mixture_prior$matrices$Z, diag(2) * 3) }) -test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips no-signal univariate traits", { +test_that("pipCutoffToSkip skips univariate traits without signal", { qd <- .fmp_qdAB # Stateful screen: reject the first block (ENSG_A), keep the rest (ENSG_B). seen <- 0L local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .fmSerScreen = function(X, y, cutoff) { @@ -1218,11 +1221,11 @@ test_that("fineMappingPipeline(QtlDataset): CV folds attach a cvResult", { skip_if_not_installed("susieR") qd <- .fmp_qdA # Real susie fits drive CV; the genotype extraction and the full-data - # post-processor are mocked (the mock SNP ids are not chr:pos:a1:a2, which the - # real buildTopLoci requires). CV runs its own real .fmFitSusieIndiv, so the - # cvResult is genuine. + # post-processor are mocked (the mock SNP ids are not chr:pos:a1:a2, which + # the real buildTopLoci requires). CV runs its own real .fmFitSusieIndiv, so + # the cvResult is genuine. local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1252,10 +1255,32 @@ test_that("fineMappingPipeline(QtlDataset): CV folds attach a cvResult", { expect_false(anyNA(cv$prediction[["susie_predicted"]])) }) +test_that("a CV run keeps each fold's weights on the row's own variants", { + # Unmocked, so the fold weights are the ones the fold fits gave and the + # row's variants are the ones the folds were fit over. + data(qtlDatasetExample, envir = environment()) + res <- suppressMessages(fineMappingPipeline( + qtlDatasetExample, + methods = "susie", + cisWindow = 50000L, + initializeWithSusieInf = FALSE, + crossValidationParam = CrossValidationParam(folds = 3), + verbose = 0, + seed = 1 + )) + stored <- res$cvResult[[1L]]$foldWeights + expect_null(rownames(stored)) + row <- pecotmr:::.collectionEntry(res, 1L) + fw <- cvResult(row)$foldWeights + expect_identical(rownames(fw), variantIds(row)) + expect_equal(colnames(fw), c("fold_1", "fold_2", "fold_3")) + expect_false(anyNA(fw)) +}) + test_that("fineMappingPipeline(QtlDataset): no CV folds leaves cvResult NULL", { qd <- .fmp_qdA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -1283,7 +1308,7 @@ test_that("fineMappingPipeline(QtlDataset): no CV folds leaves cvResult NULL", { # tests above). # =========================================================================== -test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake method", { +test_that(".fmWeightsCv gives twasWeightsCv output keyed by snake method", { skip_if_not_installed("susieR") set.seed(42) n <- 60L @@ -1310,7 +1335,13 @@ test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake metho ) expect_named( cv, - c("samplePartition", "prediction", "performance", "foldFits") + c( + "samplePartition", + "prediction", + "performance", + "foldWeights", + "variantIds" + ) ) expect_setequal(colnames(cv$samplePartition), c("Sample", "Fold")) # Keyed by the TWAS snake method name (adapter methodKey base). @@ -1318,7 +1349,8 @@ test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake metho expect_true("susie_performance" %in% names(cv$performance)) pred <- cv$prediction[["susie_predicted"]] expect_equal(dim(pred), c(n, 1L)) - # Every sample is held out exactly once => no missing out-of-fold predictions. + # Every sample is held out exactly once => no missing out-of-fold + # predictions. expect_false(anyNA(pred)) perf <- cv$performance[["susie_performance"]] expect_equal( @@ -1359,7 +1391,7 @@ test_that(".fmWeightsCv reuses a supplied samplePartition verbatim", { expect_identical(cv$samplePartition, part) }) -test_that(".fmSliceCv / .fmAttachCv slice one method and round-trip onto an entry", { +test_that(".fmSliceCv and .fmAttachCv round-trip one method onto an entry", { full <- list( samplePartition = data.frame(Sample = c("s1", "s2"), Fold = c(1L, 2L)), prediction = list( @@ -1407,14 +1439,14 @@ test_that("fineMappingPipeline(QtlDataset): empty trait filter errors", { ) }) -test_that("fineMappingPipeline(QtlDataset): mvsusie with single trait/context rejected", { +test_that("fineMappingPipeline refuses mvsusie on one trait and context", { expect_error( fineMappingPipeline(.fmp_qdA, methods = "mvsusie"), "mvsusie requires multi-trait or multi-context" ) }) -test_that("fineMappingPipeline(QtlDataset): fsusie with single trait rejected", { +test_that("fineMappingPipeline refuses fsusie on a single trait", { expect_error( fineMappingPipeline(.fmp_qdA, methods = "fsusie"), "fsusie requires multi-trait" @@ -1429,8 +1461,17 @@ test_that("fineMappingPipeline(QtlDataset): fsusie with single trait rejected", # without actually fitting. Returns a stub fit object tagged with the input # shape so the test can assert it was constructed as expected. .fmp_mockMvsusie <- function() { - function(X, Y, prior_variance, coverage) { - list(token = "mvsusie", n_X_cols = ncol(X), n_Y_cols = ncol(Y)) + # L / L_greedy are refused by MvsusieOptions as pipeline-owned, so record + # what arrives for a test to assert. + function(X, Y, prior_variance, coverage, L = NULL, L_greedy = NULL) { + list( + token = "mvsusie", + n_X_cols = ncol(X), + n_Y_cols = ncol(Y), + coverage = coverage, + L = L, + L_greedy = L_greedy + ) } } .fmp_mockMixturePrior <- function() { @@ -1454,10 +1495,10 @@ test_that("fineMappingPipeline(QtlDataset): fsusie with single trait rejected", } } -test_that("fineMappingPipeline(QtlDataset): mvsusie multi-trait single-context dispatch", { +test_that("fineMappingPipeline dispatches mvsusie: traits in one context", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1474,10 +1515,11 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie multi-trait single-context d expect_equal(nrow(res), 2L) expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) expect_setequal(methodNames(res), "mvsusie") - # Engine-built (multivariate) FM rows carry BOTH provenance columns, derived in - # the shared .runJointCell seam: traitPos = the bare trait position, region = - # traitPos +/- cisWindow (1000). This is the path the univariate pushRow - # threading never touches, so it is the regression guard for the engine fix. + # Engine-built (multivariate) FM rows carry BOTH provenance columns, derived + # in the shared .runJointCell seam: traitPos = the bare trait position, + # region = traitPos +/- cisWindow (1000). This is the path the univariate + # pushRow threading never touches, so it is the regression guard for the + # engine fix. tp <- traitPosition(res) reg <- genomicRegion(res) expect_s4_class(tp, "GRanges") @@ -1496,10 +1538,10 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie multi-trait single-context d expect_false(identical(unname(regS), c(1L, 1000L))) # not the window }) -test_that("fineMappingPipeline(QtlDataset): mvsusie multi-context single-trait dispatch", { +test_that("fineMappingPipeline dispatches mvsusie: contexts of one trait", { qd <- .fmp_qdTwoCtxA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1517,13 +1559,13 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie multi-context single-trait d expect_setequal(traitNames(res), "ENSG_A") }) -test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip drops null contexts before joint mvsusie", { +test_that("pipCutoffToSkip drops null contexts before a joint mvsusie", { qd <- .fmp_makeQtlDataset( contexts = c("brain", "liver", "heart"), traits = "ENSG_A" ) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), # Drop the middle context (liver); keep brain + heart. .fmSerScreenColumns = function(X, Y, cutoff) c(TRUE, FALSE, TRUE), @@ -1547,15 +1589,17 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip drops null contexts expect_setequal(contexts(res), c("brain", "heart")) }) -test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < 2 contexts survive", { - # susie runs alongside so the result still has rows after mvsusie is skipped. +test_that("pipCutoffToSkip skips mvsusie when under 2 contexts survive", { + # susie runs alongside so the result still has rows after mvsusie is + # skipped. qd <- .fmp_qdTwoCtxA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .fmSerScreen = function(X, y, cutoff) TRUE, # keep univariate susie - .fmSerScreenColumns = function(X, Y, cutoff) c(TRUE, FALSE), # only brain + # only brain + .fmSerScreenColumns = function(X, Y, cutoff) c(TRUE, FALSE), .package = "pecotmr" ) local_mocked_bindings( @@ -1572,15 +1616,16 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < signalScreenParam = SignalScreenParam(pip = -1) ) ) - # mvsusie skipped (only 1 context survives); susie still produced per-context. + # mvsusie skipped (only 1 context survives); susie still produced + # per-context. expect_setequal(methodNames(res), "susie") expect_false("mvsusie" %in% methodNames(res)) }) -test_that("fineMappingPipeline(QtlDataset): mvsusie both multi falls back to per-context multi-trait", { +test_that("mvsusie with both multi falls back to per-context multi-trait", { qd <- .fmp_qdTwoCtxAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1603,7 +1648,7 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie both multi falls back to per ))) }) -test_that("fineMappingPipeline(QtlDataset): multi-trait auto-detection USES the data-driven mr.mash prior", { +test_that("multi-trait auto-detection uses the data-driven mr.mash prior", { # Regression for the original bug: the old multi-trait path hardcoded the # canonical create_mixture_prior(R=ncol). Routed through the engine, it now # looks up a prior cross-trait mr.mash fit (study, context fixed; trait @@ -1632,7 +1677,7 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait auto-detection USES the ) sawMixturePrior <- FALSE local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), rescaleCovW0 = function(w0) c(K = 1), .package = "pecotmr" @@ -1661,12 +1706,12 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait auto-detection USES the expect_true(sawMixturePrior) # data-driven prior built, not canonical }) -test_that("fineMappingPipeline(QtlDataset): multi-trait without mrmashPrior keeps the canonical prior", { +test_that("multi-trait without mrmashPrior keeps the canonical prior", { qd <- .fmp_qdAB sawMixturePrior <- FALSE sawCanonical <- FALSE local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1691,7 +1736,7 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait without mrmashPrior keep expect_true(sawCanonical) }) -test_that("fineMappingPipeline(QtlDataset): mvsusie resume cache short-circuits the joint fitter", { +test_that("the mvsusie resume cache short-circuits the joint fitter", { # All conditions of the cross-trait group are already in the prior partial # result -> the engine reuses the cached entries and never calls mvsusie. qd <- .fmp_qdAB @@ -1715,7 +1760,7 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie resume cache short-circuits ) mv_calls <- 0 local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1739,10 +1784,10 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie resume cache short-circuits expect_equal(nrow(res), 2L) }) -test_that("fineMappingPipeline(QtlDataset): jointSpec='context' produces one joint row per trait", { +test_that("jointSpec = 'context' gives one joint row per trait", { qd <- .fmp_qdTwoCtxAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1772,10 +1817,10 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' produces one joi ))) }) -test_that("fineMappingPipeline(QtlDataset): jointSpec='context' + univariate compose without double-fitting mvsusie", { +test_that("jointSpec = 'context' plus univariate fits mvsusie once", { qd <- .fmp_qdTwoCtxA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -1794,21 +1839,22 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' + univariate com initializeWithSusieInf = FALSE ) ) - # susie -> 2 univariate rows (one per context); mvsusie joint over 2 contexts - # -> 2 per-context rows sharing the joint fit. 4 rows total. + # susie -> 2 univariate rows (one per context); mvsusie joint over 2 + # contexts -> 2 per-context rows sharing the joint fit. 4 rows total. expect_equal(nrow(res), 4L) expect_equal(sum(as.character(res$method) == "mvsusie"), 2L) expect_equal(sum(as.character(res$method) == "susie"), 2L) - # Univariate rows have NA in jointContexts; both mvsusie rows carry membership. + # Univariate rows have NA in jointContexts; both mvsusie rows carry + # membership. jc <- as.character(res$jointContexts) expect_equal(sum(is.na(jc)), 2L) expect_equal(sum(!is.na(jc)), 2L) }) -test_that("fineMappingPipeline(QtlDataset): jointSpec='context' with only one context skips with message", { +test_that("jointSpec = 'context' with one context skips with a message", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1830,10 +1876,10 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' with only one co ) }) -test_that("fineMappingPipeline(QtlDataset): jointSpec='trait' produces one joint row per context", { +test_that("jointSpec = 'trait' gives one joint row per context", { qd <- .fmp_qdTwoCtxAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1858,10 +1904,10 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='trait' produces one joint expect_setequal(as.character(res$context), c("brain", "liver")) }) -test_that("fineMappingPipeline(QtlDataset): jointSpec='trait' with fsusie wires fsusieR::susiF", { +test_that("jointSpec = 'trait' with fsusie calls fsusieR::susiF", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1891,7 +1937,7 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='trait' with fsusie wires expect_true("jointTraits" %in% pecotmr:::.tupleColumnNames(res)) }) -test_that("fineMappingPipeline(QtlDataset): fsusie receives the CredibleSetParam settings", { +test_that("fineMappingPipeline gives fsusie the CredibleSetParam settings", { # Regression: .fmOwnedEngineArgs() refuses L / cov_lev / min_purity in # FsusieOptions on the grounds that the pipeline supplies them, but for a # while nothing did -- the row described the retired fsusieWrapper() while @@ -1899,7 +1945,7 @@ test_that("fineMappingPipeline(QtlDataset): fsusie receives the CredibleSetParam # ran at its own default. The mocked susiF records what it was handed. qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1927,10 +1973,43 @@ test_that("fineMappingPipeline(QtlDataset): fsusie receives the CredibleSetParam expect_equal(recorded$min_purity, 0.4) }) -test_that("fineMappingPipeline(QtlDataset): fsusie multi-trait per context dispatch", { +test_that("fineMappingPipeline passes mvsusie the CredibleSetParam settings", { + # The same gap fsusie had: MvsusieOptions refuses L / L_greedy as + # pipeline-owned, but only the univariate SuSiE tokens were seeded, so + # mvsusie always ran at its own default of ten effects. qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + local_mocked_bindings( + mvsusie = .fmp_mockMvsusie(), + create_mixture_prior = .fmp_mockMixturePrior(), + .package = "mvsusieR" + ) + res <- suppressMessages( + fineMappingPipeline( + qd, + methods = "mvsusie", + cisWindow = 1000L, + credibleSetParam = CredibleSetParam( + maxNumSingleEffects = 3L, + maxNumSingleEffectsGreedy = 2L, + coverage = 0.9 + ) + ) + ) + recorded <- susieFit(res[1, ])$payload + expect_equal(recorded$L, 3L) + expect_equal(recorded$L_greedy, 2L) + expect_equal(recorded$coverage, 0.9) +}) + +test_that("fineMappingPipeline dispatches fsusie on traits per context", { + qd <- .fmp_qdAB + local_mocked_bindings( + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -1976,9 +2055,9 @@ test_that("fineMappingPipeline(QtlDataset): fsusie multi-trait per context dispa ) ) -test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across constituent QtlDatasets", { +test_that("multi-study fine-mapping aggregates its QtlDatasets' results", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2022,7 +2101,7 @@ test_that("fineMappingPipeline(MultiStudy): list selections stay per study", { ) ) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2048,7 +2127,7 @@ test_that("fineMappingPipeline(MultiStudy): list selections stay per study", { test_that("fineMappingPipeline(QtlDataset): trait chosen per context", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2067,7 +2146,7 @@ test_that("fineMappingPipeline(QtlDataset): trait chosen per context", { ) }) -test_that("fineMappingPipeline(MultiStudyQtlDataset): per-study options are not dropped", { +test_that("multi-study fine-mapping keeps per-study options", { # fitRetention was declared on the multi-study method and passed nowhere; # genotypeFilter / usePCA / nPCs were reachable only through `...`. capX <- new.env(parent = emptyenv()) @@ -2106,7 +2185,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): per-study options are not expect_equal(capSs$cfg$fitRetention, "full") }) -test_that("fineMappingPipeline(MultiStudyQtlDataset): a misspelled option errors", { +test_that("multi-study fine-mapping errors on a misspelled option", { # The method no longer takes `...`, so a typo cannot be swallowed. expect_error( fineMappingPipeline( @@ -2124,7 +2203,7 @@ test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { capX <- new.env(parent = emptyenv()) capRss <- new.env(parent = emptyenv()) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(capture = capX), .fmFitSusieRss = .fmp_mockFitRssDiag(capture = capRss), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -2152,9 +2231,9 @@ test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { expect_equal(capRss$userArgs$L_greedy, 2L) }) -test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges per region in each study", { +test_that("multi-study jointRegions = FALSE merges per region in each study", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2187,7 +2266,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges test_that("fineMappingPipeline(MSQD): embedded sumstats record ldReference", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -2213,7 +2292,7 @@ test_that("fineMappingPipeline(MSQD): embedded sumstats record ldReference", { test_that("fineMappingPipeline(*SumStats): runs with mocked RSS fitters", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2265,7 +2344,7 @@ test_that("fineMappingPipeline(QtlSumStats): empty selection rejected", { test_that("fineMappingPipeline(GwasSumStats): a blockId gives no window", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2295,7 +2374,7 @@ test_that("fineMappingPipeline(GwasSumStats): a blockId gives no window", { test_that("fineMappingPipeline(GwasSumStats): a range keeps its origin", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2395,7 +2474,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { ) } local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = recording, .package = "pecotmr" @@ -2412,7 +2491,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { expect_equal(as.integer(captured$n), perVarN) }) -# ---- PIP-screen graceful skip: a screened region -> empty result, not error ---- +# ---- PIP-screen graceful skip: a screened region -> empty result, not error -- # A collection whose rows QC audited as `audits` (one list per row). .fmp_withAudits <- function(x, audits) { @@ -2420,8 +2499,8 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { x } -# A GwasSumStats whose (single) entry was emptied by summaryStatsQc's PIP screen: -# 0-variant entry + an audit with pipScreenSkipped = TRUE (+ reason). +# A GwasSumStats whose (single) entry was emptied by summaryStatsQc's PIP +# screen: 0-variant entry + an audit with pipScreenSkipped = TRUE (+ reason). .fmp_makeScreenedGwas <- function( studyName = "G1", reason = "no signals above PIP threshold 0.025" @@ -2439,7 +2518,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { ) } -test_that("fineMappingPipeline(GwasSumStats): a PIP-screened region yields an empty result, not an error", { +test_that("GWAS fine-mapping: a PIP-screened region is empty, not an error", { gss <- .fmp_makeScreenedGwas() expect_message( res <- fineMappingPipeline( @@ -2472,7 +2551,7 @@ test_that("fineMappingPipeline(GwasSumStats): a PIP-screened region yields an em ) }) -test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only the real region", { +test_that("GWAS fine-mapping: screened plus real keeps only the real region", { gss <- .fmp_withAudits( GwasSumStats( studyName = c("Gskip", "Greal"), @@ -2487,7 +2566,7 @@ test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only t ) ) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2499,11 +2578,12 @@ test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only t initializeWithSusieInf = FALSE ) ) - expect_equal(unique(as.character(res$study)), "Greal") # screened study absent + # screened study absent + expect_equal(unique(as.character(res$study)), "Greal") expect_gt(nrow(res), 0L) }) -test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even without the flag", { +test_that("GWAS fine-mapping skips a 0-variant entry even without the flag", { gss <- GwasSumStats( studyName = "G1", entry = list(GenomicRanges::GRanges()), @@ -2522,7 +2602,7 @@ test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even expect_equal(nrow(res), 0L) }) -test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefully", { +test_that("QTL sumstat fine-mapping skips a screened trait gracefully", { qss <- .fmp_withAudits( QtlSumStats( studyName = "Q1", @@ -2546,14 +2626,14 @@ test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefu expect_equal(nrow(res), 0L) }) -# ---- SER fallback (shared sumstat SuSiE-RSS path: GwasSumStats + QtlSumStats) ---- +# ---- SER fallback (shared SuSiE-RSS path: GwasSumStats + QtlSumStats) ---- # # Both summary-statistics inputs reach the same SuSiE-RSS block, so each test # runs it once per input kind. test_that("fineMappingPipeline(*SumStats): serFallback keeps a reliable fit", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2576,7 +2656,7 @@ test_that("fineMappingPipeline(*SumStats): serFallback keeps a reliable fit", { test_that("fineMappingPipeline(*SumStats): unreliable R falls back to SER", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(flag = TRUE), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2600,7 +2680,7 @@ test_that("fineMappingPipeline(*SumStats): unreliable R falls back to SER", { test_that("fineMappingPipeline(*SumStats): serFallback=FALSE changes nothing", { cap <- new.env(parent = emptyenv()) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(flag = TRUE, capture = cap), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2628,7 +2708,7 @@ test_that("fineMappingPipeline(*SumStats): SusieRssParam reaches the fitter", { # through unrestricted, and with no control the fitter sees NULL. cap <- new.env(parent = emptyenv()) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(capture = cap), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2664,7 +2744,7 @@ test_that("fineMappingPipeline(*SumStats): SusieRssParam reaches the fitter", { test_that("fineMappingPipeline(*SumStats): keepFullFit='all' retains the fit", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2683,10 +2763,10 @@ test_that("fineMappingPipeline(*SumStats): keepFullFit='all' retains the fit", { } }) -test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the susie fit", { +test_that("QTL sumstat fine-mapping: top-level L, Lgreedy reach the fit", { cap <- new.env(parent = emptyenv()) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(capture = cap), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2708,10 +2788,10 @@ test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the sus expect_equal(cap$userArgs$L_greedy, 2L) }) -test_that("fineMappingPipeline(QtlSumStats): per-method L beats the top-level L", { +test_that("QTL sumstat fine-mapping: per-method L beats the top-level L", { cap <- new.env(parent = emptyenv()) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(capture = cap), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2727,7 +2807,7 @@ test_that("fineMappingPipeline(QtlSumStats): per-method L beats the top-level L" expect_equal(cap$userArgs$L, 7L) }) -test_that("fineMappingPipeline(GwasSumStats): non-RSS family rejected by capability check", { +test_that("GWAS fine-mapping: the capability check refuses non-RSS methods", { expect_error( fineMappingPipeline(.fmp_gss, methods = "fsusie"), "not supported on GwasSumStats" @@ -2738,7 +2818,7 @@ test_that("fineMappingPipeline(GwasSumStats): non-RSS family rejected by capabil test_that("fineMappingPipeline(*SumStats): ser runs via .fmFitSusieSer", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieSer = .fmp_mockFitSer(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -2751,7 +2831,7 @@ test_that("fineMappingPipeline(*SumStats): ser runs via .fmFitSusieSer", { } }) -test_that("ser is sumstat-only: rejected on QtlDataset, allowed on all sumstat kinds", { +test_that("ser is sumstat-only: refused on QtlDataset, allowed on sumstats", { expect_error( pecotmr:::.fmCheckMethodCapabilities("ser", "QtlDataset"), "sumstat-only" @@ -2825,12 +2905,13 @@ test_that("fineMappingPipeline(QtlSumStats): mvsusie needs two contexts", { }) test_that("fineMappingPipeline(QtlSumStats): mvsusie auto-joins contexts", { - # Multi-context (c1, c2) single-trait collection: mvsusie without an explicit - # jointSpecification routes through the joint engine -> per-context rows that - # share the cross-context RSS fit, each tagged with the co-fit membership. + # Multi-context (c1, c2) single-trait collection: mvsusie without an + # explicit jointSpecification routes through the joint engine -> per-context + # rows that share the cross-context RSS fit, each tagged with the co-fit + # membership. ss <- .fmp_makeMultiCtxQtlSumStats() local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -2849,7 +2930,7 @@ test_that("fineMappingPipeline(QtlSumStats): mvsusie auto-joins contexts", { expect_true(all(grepl("c1;c2|c2;c1", as.character(res$jointContexts)))) }) -test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fitter", { +test_that("QTL sumstat fine-mapping: a cache hit skips the RSS fitter", { ss <- .fmp_qss cachedEntry <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), @@ -2870,7 +2951,7 @@ test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fi ) rss_calls <- 0 local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = function(...) { rss_calls <<- rss_calls + 1L .fmp_mockFitRss()(...) @@ -2894,7 +2975,7 @@ test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fi # GwasSumStats: cache hit by (study, method) # =========================================================================== -test_that("fineMappingPipeline(GwasSumStats): cache hit short-circuits the RSS fitter", { +test_that("GWAS fine-mapping: a cache hit skips the RSS fitter", { gss <- .fmp_gss cachedEntry <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), @@ -2918,7 +2999,7 @@ test_that("fineMappingPipeline(GwasSumStats): cache hit short-circuits the RSS f ) rss_calls <- 0 local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = function(...) { rss_calls <<- rss_calls + 1L .fmp_mockFitRss()(...) @@ -2938,7 +3019,7 @@ test_that("fineMappingPipeline(GwasSumStats): cache hit short-circuits the RSS f expect_equal(nrow(res), 1L) }) -test_that("fineMappingPipeline(GwasSumStats): wrong-shape cache (QtlFineMappingResult) is ignored", { +test_that("GWAS fine-mapping ignores a QtlFineMappingResult cache", { # When `fineMappingResult` is a QtlFineMappingResult the GwasSumStats # method's cache-lookup branch should treat it as a cache miss and # still invoke the RSS fitter. @@ -2961,7 +3042,7 @@ test_that("fineMappingPipeline(GwasSumStats): wrong-shape cache (QtlFineMappingR ) rss_calls <- 0 local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = function(...) { rss_calls <<- rss_calls + 1L .fmp_mockFitRss()(...) @@ -3002,7 +3083,7 @@ test_that("fineMappingPipeline(QtlDataset): cache hit avoids the fitter", { ) fitter_calls <- 0 local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = function(...) { fitter_calls <<- fitter_calls + 1L .fmp_mockFitIndiv()(...) @@ -3103,7 +3184,7 @@ test_that(".fmCsIdx / .fmRelabelCs parse and renumber _ labels", { ) }) -test_that(".fmMergeEntries concatenates variants, renumbers CS, lists susieFit", { +test_that(".fmMergeEntries joins variants, renumbers CSs, lists susieFit", { # Ids must encode coordinates: the merge now emits a row payload, whose # element is built from the range and alleles the id renders. mk <- function(vids, cs95, fit) { @@ -3191,10 +3272,10 @@ test_that("fineMappingPipeline(QtlDataset): region + cisWindow is rejected", { ) }) -test_that("fineMappingPipeline(QtlDataset): jointRegions=FALSE merges per-region fits", { +test_that("fine-mapping with jointRegions = FALSE merges per-region fits", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -3224,10 +3305,10 @@ test_that("fineMappingPipeline(QtlDataset): jointRegions=FALSE merges per-region expect_equal(names(fit), c("region1", "region2")) # per-region fit list }) -test_that("fineMappingPipeline(QtlDataset): jointRegions=TRUE fits one concatenated block", { +test_that("fine-mapping with jointRegions = TRUE fits one joined block", { qd <- .fmp_qdA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -3256,10 +3337,10 @@ test_that("fineMappingPipeline(QtlDataset): jointRegions=TRUE fits one concatena expect_false(identical(names(fit), c("region1", "region2"))) }) -test_that("fineMappingPipeline(QtlDataset): mvsusie jointRegions=FALSE merges per-region fits", { +test_that("mvsusie with jointRegions = FALSE merges per-region fits", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -3287,13 +3368,14 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie jointRegions=FALSE merges pe trait = "ENSG_A", method = "mvsusie" ) - expect_equal(names(fit), c("region1", "region2")) # per-region merged fit list + # per-region merged fit list + expect_equal(names(fit), c("region1", "region2")) }) -test_that("fineMappingPipeline(QtlDataset): fsusie jointRegions=FALSE merges per-region fits", { +test_that("fsusie with jointRegions = FALSE merges per-region fits", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -3322,12 +3404,12 @@ test_that("fineMappingPipeline(QtlDataset): fsusie jointRegions=FALSE merges per expect_equal(names(fit), c("region1", "region2")) }) -test_that("fineMappingPipeline(QtlDataset): jointSpec + jointRegions=FALSE merges per region", { +test_that("jointSpec with jointRegions = FALSE merges per region", { # One trait: the cross-context joint and the per-region merge are what is # tested, and each further trait only repeats them. qd <- .fmp_qdTwoCtxA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) @@ -3393,7 +3475,7 @@ test_that(".fmCacheLookupGwas: NULL / non-GwasFineMappingResult -> NULL", { expect_null(pecotmr:::.fmCacheLookupGwas(fmr, "S", "susie", "chr1:1-100")) }) -test_that(".fmBuildMvsusiePriorCv: NULL CV -> NULL; NULL fold fits are skipped", { +test_that(".fmBuildMvsusiePriorCv: NULL for no CV; skips NULL fold fits", { expect_null(pecotmr:::.fmBuildMvsusiePriorCv(NULL, NULL, c("c1", "c2"))) local_mocked_bindings( .buildMvsusieReweightedPrior = function(...) "PRIOR", @@ -3428,7 +3510,8 @@ test_that(".fmFoldFitAt finds a fold's fit by name, else by position", { test_that(".fmTwasMethodKey: bare token without adapter returned unchanged", { expect_equal(pecotmr:::.fmTwasMethodKey("lasso"), "lasso") # no adapter - expect_equal(pecotmr:::.fmTwasMethodKey("susie"), "susie") # adapter -> stripped + # adapter -> stripped + expect_equal(pecotmr:::.fmTwasMethodKey("susie"), "susie") }) test_that(".fmSliceCv: NULL cv or missing predicted key -> NULL", { @@ -3444,7 +3527,7 @@ test_that(".fmSliceCv: NULL cv or missing predicted key -> NULL", { ) }) -test_that(".fmAttachCv: NULL entry or NULL cvResult returns the entry unchanged", { +test_that(".fmAttachCv leaves a NULL entry or NULL cvResult unchanged", { e <- FineMappingRow( "chr1:100:A:G", list(), @@ -3464,7 +3547,7 @@ test_that(".fmAttachCv: NULL entry or NULL cvResult returns the entry unchanged" # (dispatchers mocked; the real joint fitting is covered in # test_jointSpecification.R) -test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec returns the joint result", { +test_that("QTL sumstats: mvsusie-only jointSpec returns the joint result", { ss <- .fmp_qss jr <- QtlFineMappingResult( studyName = "Q1", @@ -3509,7 +3592,7 @@ test_that("fineMappingPipeline(QtlSumStats): joint spec plus per-entry susie", { ) local_mocked_bindings( .fmDispatchJointSpecsQtlSumStats = function(...) jr, - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -3539,7 +3622,7 @@ test_that("fineMappingPipeline(QtlSumStats): no auto-joint fit is an error", { ) }) -test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec with no fits -> error", { +test_that("QTL sumstats: mvsusie-only jointSpec with no fits errors", { local_mocked_bindings( .fmDispatchJointSpecsQtlSumStats = function(...) NULL, .package = "pecotmr" @@ -3594,7 +3677,7 @@ test_that("MultiStudyQtlDataset forwards the mvsusie prior settings", { test_that("fineMappingPipeline(MSQD) lays cisWindow on its sumstats", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -3624,7 +3707,7 @@ test_that("fineMappingPipeline(MSQD) lays cisWindow on its sumstats", { ) }) -test_that("fineMappingPipeline(MultiStudyQtlDataset): region + cisWindow is rejected", { +test_that("multi-study fine-mapping refuses region with cisWindow", { expect_error( fineMappingPipeline( .fmp_msqd, @@ -3636,7 +3719,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): region + cisWindow is reje ) }) -test_that("fineMappingPipeline(MultiStudyQtlDataset): mvsusie-only jointSpec returns the joint result", { +test_that("multi-study: mvsusie-only jointSpec returns the joint result", { mt <- .fmp_msqd jr <- QtlFineMappingResult( studyName = "study1", @@ -3681,7 +3764,7 @@ test_that("fineMappingPipeline(MultiStudy): joint spec, rest per component", { ) local_mocked_bindings( .fmDispatchJointSpecsMultiStudy = function(...) jr, - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -3704,7 +3787,7 @@ test_that("fineMappingPipeline(MultiStudy): an unselected component sits out", { # none of its tuples and contributes no rows. mt <- .fmp_msqd local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -3736,7 +3819,7 @@ test_that("fineMappingPipeline(MultiStudy): trait selection skips a study", { # the traits sits out, and the run is refused only when none carries any. mt <- .fmp_msqd local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -3805,7 +3888,7 @@ test_that(".fmRelabelCs returns non-matching labels unchanged", { expect_equal(out, c("susie_3", "nomatch", "susie_0")) }) -test_that(".fmWeightsCv + .fmFoldWeights cover the mvSuSiE CV path (mocked fitter)", { +test_that(".fmWeightsCv and .fmFoldWeights on the mvSuSiE CV path (mocked)", { # Mock one level below the orchestration: fitMvsusie/mvsusieWeights return # canned outputs (sized to the per-fold training columns), so the real # .fmFoldWeights mvsusie branch + .fmWeightsCv fold loop run at ~no cost. @@ -3848,7 +3931,13 @@ test_that(".fmWeightsCv + .fmFoldWeights cover the mvSuSiE CV path (mocked fitte ) expect_named( cv, - c("samplePartition", "prediction", "performance", "foldFits") + c( + "samplePartition", + "prediction", + "performance", + "foldWeights", + "variantIds" + ) ) expect_true("mvsusie_performance" %in% names(cv$performance)) expect_equal(dim(cv$prediction[["mvsusie_predicted"]]), c(n, R)) @@ -3947,7 +4036,7 @@ test_that(".fmWeightsCv: fold prior else mvPrior; weightless folds give NA", { # (all 1) on the test variants; fold 2 has its own prior but its fit # returns no weights; fold 3 has no prior of its own, so it takes the # full-data mvPrior, and its weights share no variant with the test - # genotypes. Each fold fit records the prior it was handed. + # genotypes. The mocked fit records the prior each fold was handed. set.seed(3) X <- matrix( rbinom(60, 2, 0.4), @@ -3962,6 +4051,7 @@ test_that(".fmWeightsCv: fold prior else mvPrior; weightless folds give NA", { "1" = list(priorVariance = diag(2)), "2" = list(priorVariance = diag(2) * 2) ) + seen <- new.env(parent = emptyenv()) local_mocked_bindings( .fmFoldWeights = function( token, @@ -3974,12 +4064,12 @@ test_that(".fmWeightsCv: fold prior else mvPrior; weightless folds give NA", { ) { trained <- sp$Fold[is_in(sp$Sample, rownames(Xtr))] heldOut <- setdiff(sp$Fold, trained) + seen[[as.character(heldOut)]] <- mvPrior if (heldOut == 2L) { return(NULL) } vars <- if (heldOut == 1L) colnames(Xtr) else "not_a_variant" - W <- matrix(1, length(vars), ncol(Ytr), dimnames = list(vars, NULL)) - `attr<-`(W, "fit", list(prior = mvPrior)) + matrix(1, length(vars), ncol(Ytr), dimnames = list(vars, NULL)) }, .package = "pecotmr" ) @@ -3995,10 +4085,13 @@ test_that(".fmWeightsCv: fold prior else mvPrior; weightless folds give NA", { mvPriorCv = foldPriors ) # A fold takes its own prior when mvPriorCv has one, else mvPrior. - expect_identical(cv$foldFits$fold_1$mvsusie$prior, foldPriors[["1"]]) - expect_identical(cv$foldFits$fold_3$mvsusie$prior, fullPrior) - # A fold whose fit returns no weights keeps no fit either. - expect_length(cv$foldFits$fold_2, 0L) + expect_identical(seen[["1"]], foldPriors[["1"]]) + expect_identical(seen[["2"]], foldPriors[["2"]]) + expect_identical(seen[["3"]], fullPrior) + # A fold whose fit returns no weights keeps none: NA, not zero. + fw <- pecotmr:::.fmSliceCv(cv, "mvsusie")$foldWeights + expect_true(all(is.na(fw[, "fold_2"]))) + expect_equal(unname(fw[, "fold_1"]), c(1, 1)) # Only fold 1 predicts: X %*% W, the dosage row sums. NULL weights (fold # 2) and weights on no test variant (fold 3) leave their samples NA ... pred <- cv$prediction[["mvsusie_predicted"]] @@ -4017,7 +4110,7 @@ test_that(".fmWeightsCv: fold prior else mvPrior; weightless folds give NA", { test_that("fineMappingPipeline(*SumStats): susieInf RSS chain (mocked)", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -4037,7 +4130,7 @@ test_that("fineMappingPipeline(*SumStats): susieInf RSS chain (mocked)", { } }) -test_that(".fmFoldWeights covers mvPrior residual var, missing rownames, unknown token", { +test_that(".fmFoldWeights: mvPrior residual var, no rownames, unknown token", { local_mocked_bindings( fitMvsusie = function(X, Y, ...) { list(vn = colnames(X), R = ncol(as.matrix(Y))) @@ -4111,16 +4204,20 @@ test_that(".fmWeightsCv fills Y rownames and reports per-fold fit failures", { ) }) -test_that("fineMappingPipeline CV retains a lean per-fold fit", { +test_that("fineMappingPipeline CV keeps each fold's weights, not its fit", { + # Only the weights are ever read: TWAS cross-validates a SuSiE-family + # method from them, and nothing reads the fold's fit itself. f <- .twcvFixture - expect_false(is.null(f$cv$foldFits)) - expect_equal(names(f$cv$foldFits), c("fold_1", "fold_2", "fold_3")) - # lean: only the fields the weight extractors read - fit1 <- f$cv$foldFits[["fold_1"]][["susie"]] - expect_true(all(c("pip", "alpha", "mu") %in% names(fit1))) - expect_false("lbf_variable" %in% names(fit1)) - # and it slices per method onto the row payload - expect_equal(names(f$slice$foldFits), c("fold_1", "fold_2", "fold_3")) + expect_null(f$cv$foldFits) + fw <- f$slice$foldWeights + expect_equal( + dimnames(fw), + list(colnames(f$X), c("fold_1", "fold_2", "fold_3")) + ) + expect_identical( + attr(fw, "partitionKey"), + pecotmr:::.cvPartitionKey(f$slice$samplePartition) + ) }) # --- method-level branches (drive the pipeline methods with mocked fitters) --- @@ -4150,7 +4247,7 @@ test_that(".fmAfForX returns NULL when af yields nothing", { test_that("fineMappingPipeline(QtlDataset): a valid context is honored", { qd <- .fmp_qdTwoCtxA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -4169,9 +4266,9 @@ test_that("fineMappingPipeline(QtlDataset): a valid context is honored", { expect_setequal(contexts(res), "brain") }) -test_that("fineMappingPipeline(QtlDataset): region selects traits by rowRanges overlap", { +test_that("fine-mapping's region selects traits by rowRanges overlap", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" @@ -4193,7 +4290,7 @@ test_that("fineMappingPipeline(QtlDataset): region selects traits by rowRanges o test_that("fineMappingPipeline(QtlDataset): too few shared samples errors", { qd <- .fmp_qdA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), # residualized X carries a sample absent from Y -> < 2 shared samples .fmResidGeno = function(x, ...) { matrix( @@ -4219,10 +4316,10 @@ test_that("fineMappingPipeline(QtlDataset): too few shared samples errors", { ) }) -test_that("fineMappingPipeline(QtlDataset): errors when no tuple produces a result", { +test_that("fineMappingPipeline errors when no tuple produces a result", { qd <- .fmp_qdA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmSerScreen = function(...) FALSE, # screen out every block .package = "pecotmr" ) @@ -4237,10 +4334,10 @@ test_that("fineMappingPipeline(QtlDataset): errors when no tuple produces a resu ) }) -test_that("fineMappingPipeline(QtlDataset): usePCA skips single-trait contexts", { +test_that("fineMappingPipeline usePCA skips single-trait contexts", { qd <- .fmp_qdA local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .fmSerScreen = function(...) TRUE, @@ -4261,7 +4358,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips single-trait contexts", expect_false(any(grepl("PC", as.character(res$trait)))) }) -test_that("fineMappingPipeline(MultiStudyQtlDataset): jointSpec with no intersecting scope errors", { +test_that("multi-study jointSpec errors with no shared scope", { mt <- .fmp_msqd # The joint engine yields nothing for this scope -> the no-joint-fits stop. local_mocked_bindings( @@ -4295,10 +4392,10 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointSpec with no intersec ) } -test_that("fineMappingPipeline(QtlDataset): usePCA skips a context whose PCA yields no scores", { +test_that("usePCA skips a context whose PCA gives no scores", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .fmTopPcScores = function(...) NULL, # PCA yields no scores @@ -4329,7 +4426,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA reuses a cached PC entry", { )) ) local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .fmTopPcScores = function(Y, nPCs) { @@ -4354,10 +4451,10 @@ test_that("fineMappingPipeline(QtlDataset): usePCA reuses a cached PC entry", { expect_true(any(as.character(res$trait) == "topPC1")) # from the cache }) -test_that("fineMappingPipeline(QtlDataset): usePCA + region uses the region genotype block", { +test_that("usePCA with a region uses the region's genotype block", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .fmSerScreen = function(...) TRUE, @@ -4375,10 +4472,10 @@ test_that("fineMappingPipeline(QtlDataset): usePCA + region uses the region geno expect_true(any(grepl("PC", as.character(res$trait)))) }) -test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block with too few shared samples", { +test_that("usePCA skips a PC block with too few shared samples", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmResidGeno = function(x, ...) { matrix( 0, @@ -4403,10 +4500,10 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block with too few expect_false(any(grepl("PC", as.character(res$trait)))) }) -test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block screened out by SER", { +test_that("usePCA skips a PC block the SER screens out", { qd <- .fmp_qdAB local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmSerScreen = function(...) FALSE, # the PC block is screened out .fmDispatchJointSpecsQtlDataset = function(...) .fmp_jr(), .package = "pecotmr" @@ -4509,11 +4606,7 @@ test_that(".fmExtractZn keeps z, ids and n aligned after filtering", { expect_equal(filtered$variantIds, unfiltered$variantIds[keep]) }) -test_that(".fmLeanFoldFit passes a NULL fit straight through", { - expect_null(pecotmr:::.fmLeanFoldFit(NULL, "susie")) -}) - -test_that(".fmPerStudy / .fmSumStats answer NULL when no method fits the kind", { +test_that(".fmPerStudy and .fmSumStats: NULL when no method fits the kind", { # No individual / sumstat method in the list means there is nothing for # that route to run, which is a NULL rather than an empty result object. expect_null(pecotmr:::.fmPerStudy(NULL, list(methods = list()))) @@ -4846,12 +4939,12 @@ test_that("every recursion forwards each cfg field its callee accepts", { ), list( site = ".twasPerStudy", - builder = ".twasMsCfg", + builder = ".twasPipelineMultiStudy", callee = ".twasPipelineQtlDataset" ), list( site = ".twasSumStats", - builder = ".twasMsCfg", + builder = ".twasPipelineMultiStudy", callee = ".twasPipelineQtlSumStats" ) ) @@ -4903,7 +4996,7 @@ test_that("QtlDataset: a CV-only run keeps the CV and skips the full fit", { # The full-data post-processor stops the test if it is reached: a # cross-validation-only run must not fit, or summarize, the full data. local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmPostprocessOne = function(...) stop("the full-data fit ran"), .package = "pecotmr" ) @@ -5742,7 +5835,7 @@ test_that(".fmWarnChromosomeRows flags rows spanning a chromosome's worth", { test_that("fineMappingPipeline(QtlSumStats): cisWindow sets each window", { local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), + .handleDosage = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index 7b71c5b9e..7c5679e8c 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -28,6 +28,21 @@ test_that("as(row, 'GRanges') is the element a collection stores", { # adjustPips: renormalize PIPs on a kept subset of variants # ============================================================================= +test_that("fold fits become fold weights whatever each fold kept", { + noFolds <- list(metrics = c(rsq = 0.2)) + expect_identical(pecotmr:::.cvPayloadFoldWeights(noFolds, "v1"), noFolds) + expect_null(pecotmr:::.foldFitWeights(NULL)) + coef <- matrix(c(0.5, -0.2), 2L, 1L, dimnames = list(c("v1", "v2"), "y")) + expect_identical( + pecotmr:::.foldFitWeights(list(coef = coef)), + c(v1 = 0.5, v2 = -0.2) + ) + expect_identical( + pecotmr:::.alignFoldWeights(NULL, c("v1", "v2")), + c(NA_real_, NA_real_) + ) +}) + test_that("adjustPips renormalizes PIPs on a kept FineMappingRow subset", { vids <- paste0("chr1:", 1:6, ":A:G") entry <- .makeAdjustEntry(vids) @@ -54,7 +69,7 @@ test_that("adjustPips errors when the intersection is empty", { ) }) -test_that("adjustPips tolerates a chr-prefix difference between entry and keepVariants", { +test_that("adjustPips tolerates a chr-prefix difference with keepVariants", { vids <- paste0("chr1:", 1:6, ":A:G") entry <- .makeAdjustEntry(vids) keep <- paste0("1:", 2:5, ":A:G") # same variants, no "chr" prefix @@ -66,7 +81,7 @@ test_that("adjustPips tolerates a chr-prefix difference between entry and keepVa # === Tests migrated from test_s4Constructors.R (FineMappingRow) === -test_that("FineMappingRow: constructor stores slots and accessors return them", { +test_that("FineMappingRow stores its slots and the accessors return them", { tl <- .sc_makeTopLoci(3) tl$variant_id <- sprintf("chr9:%d:A:G", 100L * (1:3)) entry <- FineMappingRow( @@ -92,7 +107,7 @@ test_that("FineMappingRow: pip returns named pip vector keyed by variant_id", { expect_equal(names(pip), paste0("chr1:", 100 * 1:3, ":A:G")) }) -test_that("FineMappingRow: resolveWeights returns topLoci posterior effect aligned to variant_id", { +test_that("resolveWeights gives the row's posterior effect by variant_id", { entry <- .sc_makeFineMappingRow(3) # topLoci posterior_mean = 0.05 for all wr <- .fmrRowResolveWeights(entry) expect_equal(wr$variantIds, paste0("chr1:", 100 * 1:3, ":A:G")) @@ -130,10 +145,10 @@ test_that("FineMappingRow: credibleSets filters to rows in any credible set", { expect_equal(nrow(res), 2L) }) -test_that("FineMappingRow: credibleSets/topLoci surface the directional af column", { +test_that("a row's credibleSets and topLoci carry the directional af", { # Regression: the posterior view must carry the topLoci `af` (effect-allele - # frequency) through to .fmrRowCs() / .fmrRowTopLoci(), not drop it to NA. The - # value is directional (0.87 > 0.5), so a folded MAF would be a bug. + # frequency) through to .fmrRowCs() / .fmrRowTopLoci(), not drop it to NA. + # The value is directional (0.87 > 0.5), so a folded MAF would be a bug. entry <- .sc_makeFineMappingRow(3) cs <- .fmrRowCs(entry) expect_true("af" %in% names(cs)) @@ -145,7 +160,7 @@ test_that("FineMappingRow: credibleSets/topLoci surface the directional af colum expect_equal(unname(tl$af), rep(0.87, nrow(tl))) }) -test_that("FineMappingRow: validity errors when topLoci is missing required cols", { +test_that("FineMappingRow validity errors on topLoci missing a column", { expect_error( FineMappingRow( variantIds = "chr1:100:A:G", @@ -242,7 +257,7 @@ test_that("show.FineMappingRow reports variant count and CS count", { # === credibleSets empty / cs-less topLoci projections === -test_that("FineMappingRow: credibleSets returns empty posterior view when topLoci is empty", { +test_that("credibleSets of a row with empty topLoci is an empty view", { entry <- FineMappingRow( variantIds = character(0), susieFit = list(), @@ -258,7 +273,7 @@ test_that("FineMappingRow: credibleSets returns empty posterior view when topLoc expect_true(all(c("variant_id", "pip") %in% names(res))) }) -test_that("FineMappingRow: credibleSets returns empty posterior view when the cs column is absent", { +test_that("credibleSets of a row without its cs column is an empty view", { tl <- data.frame( variant_id = c("chr9:100:A:G", "chr9:200:A:G"), pip = c(0.1, 0.2), @@ -293,7 +308,7 @@ test_that("FineMappingRow: adjustPips errors when susieFit lacks alpha", { ) }) -test_that("FineMappingRow: adjustPips subsets mu2 and recomputes posterior_sd", { +test_that("adjustPips on a row subsets mu2 and recomputes posterior_sd", { vids <- paste0("chr1:", 1:5, ":A:G") p <- length(vids) L <- 2L @@ -325,15 +340,58 @@ test_that("FineMappingRow: adjustPips subsets mu2 and recomputes posterior_sd", expect_s4_class(adj, "FineMappingRow") # mu2 carried through the variant subsetting alongside lbf/mu. expect_equal(ncol(susieFit(adj)$mu2), 3L) - # posterior_mean / posterior_sd recomputed from the subset alpha/mu/mu2. - expect_equal(nrow(.fmrPartsTopLoci(adj)), 3L) - expect_true("posterior_sd" %in% names(.fmrPartsTopLoci(adj))) - expect_equal(length(.fmrPartsTopLoci(adj)$posterior_sd), 3L) - expect_true(all(.fmrPartsTopLoci(adj)$posterior_sd >= 0)) + # posterior_mean / posterior_sd recomputed from the subset alpha/mu/mu2, + # the single effects' variances adding. + tl <- .fmrPartsTopLoci(adj) + sub <- susieFit(adj) + expect_equal(nrow(tl), 3L) + expect_equal(tl$posterior_mean, as.numeric(colSums(sub$alpha * sub$mu))) + expect_equal( + tl$posterior_sd, + as.numeric(sqrt(colSums( + sub$alpha * sub$mu2 - (sub$alpha * sub$mu)^2 + ))) + ) }) -test_that("credibleSets / topLoci minPurity filters CS by purity, independent of coverage + pip", { - # Two 0.95 credible sets: CS1 (v1,v2) pure (0.9), CS2 (v3,v4) impure (0.3); v5 non-CS. +test_that("adjustPips reports the posterior on topLoci's scale", { + # mu and mu2 are stored for the standardized X, and buildTopLoci() divides + # by X_column_scale_factors. The recomputation did not, so adjusted rows + # switched to standardized units. + vids <- paste0("chr1:", 1:4, ":A:G") + alpha <- matrix(c(0.7, 0.1, 0.1, 0.1, 0.1, 0.1, 0.7, 0.1), 2L, byrow = TRUE) + mu <- matrix(c(1, 2, 3, 4, -1, -2, -3, -4), 2L, byrow = TRUE) + mu2 <- mu^2 + 0.5 + sf <- c(2, 4, 5, 10) + entry <- FineMappingRow( + variantIds = vids, + susieFit = list( + pip = as.numeric(1 - apply(1 - alpha, 2, prod)), + alpha = alpha, + mu = mu, + mu2 = mu2, + X_column_scale_factors = sf + ), + topLoci = data.frame(variant_id = vids, pip = 0.5) + ) + tl <- .fmrPartsTopLoci(adjustPips(entry, vids[1:3])) + sub <- susieFit(adjustPips(entry, vids[1:3])) + expect_equal( + tl$posterior_mean, + as.numeric(colSums(sub$alpha * sub$mu) / sf[1:3]) + ) + expect_equal( + tl$posterior_sd, + as.numeric( + sqrt(colSums(sub$alpha * sub$mu2 - (sub$alpha * sub$mu)^2)) / + sf[1:3] + ) + ) +}) + +test_that("minPurity filters CSs by purity alone, not coverage or pip", { + # Two 0.95 credible sets: CS1 (v1,v2) pure (0.9), CS2 (v3,v4) impure (0.3); + # v5 non-CS. vn <- paste0("chr1:", (1:5) * 100, ":A:G") L <- 2L P <- 5L @@ -361,7 +419,8 @@ test_that("credibleSets / topLoci minPurity filters CS by purity, independent of tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") e <- FineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) - # credibleSets: minPurity is orthogonal to coverage -> keeps only the pure CS members + # credibleSets: minPurity is orthogonal to coverage -> keeps only the pure + # CS members expect_equal(nrow(.fmrRowCs(e, coverage = 0.95)), 4L) expect_equal( .fmrRowCs(e, coverage = 0.95, minPurity = 0.8)$variant_id, @@ -373,7 +432,8 @@ test_that("credibleSets / topLoci minPurity filters CS by purity, independent of .fmrRowTopLoci(e, signalCutoff = 0, minPurity = 0.8)$variant_id, vn[c(1, 2, 5)] ) - expect_equal(nrow(.fmrRowTopLoci(e, signalCutoff = 0)), 5L) # default (NULL) unchanged + # default (NULL) unchanged + expect_equal(nrow(.fmrRowTopLoci(e, signalCutoff = 0)), 5L) }) # =========================================================================== @@ -421,7 +481,7 @@ test_that("credibleSets / topLoci minPurity filters CS by purity, independent of ) } -test_that("adjustPips renormalizes stored alpha, honouring a non-uniform prior", { +test_that("adjustPips renormalizes alpha, honouring a non-uniform prior", { vids <- paste0("chr1:", 1:6, ":A:G") prior <- c(0.5, 0.2, 0.1, 0.1, 0.05, 0.05) built <- .makeNonUniformPriorEntry(vids, prior) @@ -499,7 +559,7 @@ test_that("adjustPips keeps the null_weight column in the renormalization", { expect_equal(unname(adjAlpha), unname(expected / rowSums(expected))) }) -test_that("adjustPips errors when alpha's width matches neither variant count", { +test_that("adjustPips errors when alpha's width matches no variant count", { vids <- paste0("chr1:", 1:4, ":A:G") entry <- .makeAdjustEntry(vids) fit <- .fmrPartsSusieFit(entry) @@ -623,7 +683,8 @@ test_that("adjustPips subsets mvsusie-shaped coef rows and 3-D clfsr", { test_that("lbf returns the wide variant x effect lbf matrix", { vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - lbf <- matrix(c(3.0, 2.5, 0.1, 0.1, 0.1, 2.0), nrow = 2, byrow = TRUE) # L=2 x p=3 + # L=2 x p=3 + lbf <- matrix(c(3.0, 2.5, 0.1, 0.1, 0.1, 2.0), nrow = 2, byrow = TRUE) fit <- list( alpha = matrix(0.2, 2, 3), mu = matrix(0.1, 2, 3), @@ -666,7 +727,7 @@ test_that("lbf is empty when the fit carries no lbf matrix", { # when R/credibleSetSummary.R was folded in) # =========================================================================== -test_that("credibleSetSummary returns one row per CS with size/purity/V/logBF/lead", { +test_that("credibleSetSummary gives each CS's size, purity, V, logBF, lead", { vn <- paste0("chr1:", (1:5) * 100, ":A:G") L <- 2L P <- 5L @@ -720,7 +781,8 @@ test_that("credibleSetSummary returns one row per CS with size/purity/V/logBF/le expect_equal(s$V, c(0.8, 0.5)) # cs_log10bf = max member logBF (per-variant max single-effect lbf) expect_equal(s$cs_log10bf, c(3.0, 2.0)) - # cs_log_bf = true per-effect single-effect logBF = logSumExp(lbf[L, ]) - log(P) + # cs_log_bf = true per-effect single-effect logBF = logSumExp(lbf[L, ]) - + # log(P) expect_equal(s$cs_log_bf, c(1.9597, 1.2031), tolerance = 1e-3) # cs_pip = summed member PIP (inclusion mass captured) expect_equal(s$cs_pip, c(1.1, 0.8), tolerance = 1e-6) @@ -753,9 +815,9 @@ test_that("credibleSetSummary is empty when there are no credible sets", { expect_equal(nrow(.fmrRowCredibleSetSummary(e)), 0L) }) -test_that("credibleSetSummary is empty when the requested coverage column is absent", { - # topLoci carries only cs_95 / cs_70 / cs_50; asking for coverage 0.99 finds no - # cs_99 column -> the .csSummaryFit guard returns the empty summary. +test_that("credibleSetSummary is empty without the requested coverage column", { + # topLoci carries only cs_95 / cs_70 / cs_50; asking for coverage 0.99 finds + # no cs_99 column -> the .csSummaryFit guard returns the empty summary. vn <- c("chr1:100:A:G", "chr1:200:C:T") tl <- data.frame( variant_id = vn, @@ -769,9 +831,10 @@ test_that("credibleSetSummary is empty when the requested coverage column is abs expect_equal(nrow(.fmrRowCredibleSetSummary(e, coverage = 0.99)), 0L) }) -test_that("credibleSetSummary reports NA cs_log_bf when the fit carries no lbf matrix", { - # A trimmed fit drops lbf_variable: the per-effect single-effect logBF degrades - # to NA while the max-member cs_log10bf still comes from the topLoci. +test_that("credibleSetSummary: NA cs_log_bf when the fit has no lbf matrix", { + # A trimmed fit drops lbf_variable: the per-effect single-effect logBF + # degrades to NA while the max-member cs_log10bf still comes from the + # topLoci. vn <- c("chr1:100:A:G", "chr1:200:C:T") tl <- data.frame( variant_id = vn, @@ -792,7 +855,7 @@ test_that("credibleSetSummary reports NA cs_log_bf when the fit carries no lbf m expect_equal(s$cs_log10bf, 2.5) }) -test_that("credibleSetSummary reports NA cs_log_bf when the effect's lbf row is all non-finite", { +test_that("credibleSetSummary: NA cs_log_bf for an all-non-finite lbf row", { # effect 1's lbf row is entirely -Inf, so the finite subset is empty and the # logSumExp path short-circuits to NA. vn <- c("chr1:100:A:G", "chr1:200:C:T") @@ -815,7 +878,7 @@ test_that("credibleSetSummary reports NA cs_log_bf when the effect's lbf row is # test_fsusieAccessors.R when R/fsusieAccessors.R was folded in) # =========================================================================== -test_that("fsusieCredibleBand returns a long effect + band table (lower <= effect <= upper)", { +test_that("fsusieCredibleBand gives a long table, lower <= effect <= upper", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") cb <- .fmrRowFsusieCredibleBand(.fsa_entry(.fsa_fits$none)) @@ -877,7 +940,7 @@ test_that("trimmed fSuSiE keeps curves, bands and coloc inputs", { } }) -test_that("fsusieAffectedRegions returns a GRanges with cs / purity / direction", { +test_that("fsusieAffectedRegions gives a GRanges of cs, purity, direction", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") gr <- .fmrRowFsusieAffectedRegions(.fsa_entry( @@ -890,13 +953,13 @@ test_that("fsusieAffectedRegions returns a GRanges with cs / purity / direction" c("cs", "purity", "direction") %in% names(S4Vectors::mcols(gr)) )) expect_true(all(S4Vectors::mcols(gr)$direction %in% c("pos", "neg", NA))) - # purity sourced from the entry's cs_95_purity (matched by CS variant membership), - # NOT the (nonexistent) fit$purity slot + # purity sourced from the entry's cs_95_purity (matched by CS variant + # membership), NOT the (nonexistent) fit$purity slot expect_true(all(S4Vectors::mcols(gr)$purity == 0.85)) expect_true(all(grepl("^fsusie_", S4Vectors::mcols(gr)$cs))) }) -test_that("fsusie accessors degrade to empty for a non-fSuSiE / trimmed fit (no wavelet slots)", { +test_that("fsusie accessors are empty for a fit without wavelet slots", { e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), @@ -972,7 +1035,7 @@ test_that("fsusieTraitEffects evaluates the curve at each joint trait", { ) }) -test_that("fsusieTraitEffects refuses a fit whose positions and names disagree", { +test_that("fsusieTraitEffects refuses a fit whose positions, names disagree", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") fit <- .fsa_fits$none @@ -1008,11 +1071,12 @@ test_that("fsusieTraitEffects returns zero rows for a non-fsusie fit", { }) test_that(".fsusieChrom returns NA when the fit has no named variants", { - expect_true(is.na(pecotmr:::.fsusieChrom(list(csd_X = c(1, 2, 3))))) # unnamed + # unnamed + expect_true(is.na(pecotmr:::.fsusieChrom(list(csd_X = c(1, 2, 3))))) expect_true(is.na(pecotmr:::.fsusieChrom(list()))) # no csd_X }) -test_that(".fsusieCsMapFromTopLoci falls back to index labels when topLoci lacks CS columns", { +test_that(".fsusieCsMapFromTopLoci uses index labels without CS columns", { fit <- list( cs = list(1L, 2L), csd_X = stats::setNames(1:3, paste0("chr1:", 1:3 * 100, ":A:G")) @@ -1020,7 +1084,8 @@ test_that(".fsusieCsMapFromTopLoci falls back to index labels when topLoci lacks m <- pecotmr:::.fsusieCsMapFromTopLoci(fit, topLoci = NULL) expect_equal(unname(m$label), c("fsusie_1", "fsusie_2")) expect_true(all(is.na(m$purity))) - # a topLoci missing the required cs_95 / cs_95_purity columns takes the same path + # a topLoci missing the required cs_95 / cs_95_purity columns takes the same + # path m2 <- pecotmr:::.fsusieCsMapFromTopLoci( fit, topLoci = data.frame(variant_id = "x") @@ -1028,8 +1093,8 @@ test_that(".fsusieCsMapFromTopLoci falls back to index labels when topLoci lacks expect_equal(unname(m2$label), c("fsusie_1", "fsusie_2")) }) -# A minimal object that passes .isFsusieFit (the wavelet-slot gate) so the band / -# affected-region degradation paths can be exercised with the (untrimmed) band +# A minimal object that passes .isFsusieFit (the wavelet-slot gate) so the band +# / affected-region degradation paths can be exercised with the (untrimmed) band # computation replaced by a mock returning a controlled, degenerate fit. .fsa_fakeFit <- function() { list(fitted_wc2 = 1, fitted_func = list(1), outing_grid = 1:2, alpha = 1) @@ -1062,7 +1127,7 @@ test_that("fsusieCredibleBand skips NULL effect bands and degrades to empty", { expect_equal(nrow(.fmrRowFsusieCredibleBand(.fsa_bareEntry())), 0L) }) -test_that("fsusieAffectedRegions degrades to empty when affected_reg finds nothing", { +test_that("fsusieAffectedRegions is empty when affected_reg finds nothing", { skip_if_not_installed("fsusieR") testthat::local_mocked_bindings( .fsusiePopulateCredibleBand = function(fit) { @@ -1081,7 +1146,7 @@ test_that("fsusieAffectedRegions degrades to empty when affected_reg finds nothi expect_equal(length(.fmrRowFsusieAffectedRegions(.fsa_bareEntry())), 0L) }) -test_that("fsusieAffectedRegions yields NA direction for a region outside the grid", { +test_that("fsusieAffectedRegions: NA direction for a region off the grid", { skip_if_not_installed("fsusieR") testthat::local_mocked_bindings( .fsusiePopulateCredibleBand = function(fit) { @@ -1093,8 +1158,8 @@ test_that("fsusieAffectedRegions yields NA direction for a region outside the gr }, .package = "pecotmr" ) - # Region [500, 600] lies outside the grid [100, 200]: no grid points fall in it, - # so the per-region effect-direction summary is NA. + # Region [500, 600] lies outside the grid [100, 200]: no grid points fall in + # it, so the per-region effect-direction summary is NA. testthat::local_mocked_bindings( affected_reg = function(...) { data.frame(CS = 1L, Start = 500, End = 600) @@ -1107,7 +1172,7 @@ test_that("fsusieAffectedRegions yields NA direction for a region outside the gr expect_true(is.na(S4Vectors::mcols(gr)$direction)) }) -test_that("credibleSets warns when the coverage has no purity column to filter on", { +test_that("credibleSets warns when the coverage has no purity column", { # minPurity is orthogonal to coverage, so asking for it at a coverage that # produced no credible sets leaves nothing to filter. Skipping silently # would look like "the filter ran and kept everything". @@ -1192,6 +1257,174 @@ test_that("topLoci must list the variants in the same order", { ) }) +# =========================================================================== +# Fold weights: the row holds their variant ids once +# =========================================================================== + +.fmr_cv <- function(ids, folds = 2L) { + fw <- matrix( + seq_len(length(ids) * folds) / 10, + length(ids), + folds, + dimnames = list(ids, str_c("fold_", seq_len(folds))) + ) + list( + samplePartition = data.frame(Sample = "s1", Fold = 1L), + foldWeights = fw + ) +} + +.fmr_tl <- function(ids) { + data.frame(variant_id = ids, pip = rep(0.1, length(ids))) +} + +test_that("a row stores its own fold weights unnamed; cvResult() names them", { + vids <- .fmr_vids(3L) + cv <- .fmr_cv(vids) + row <- FineMappingRow(vids, NULL, .fmr_tl(vids), cvResult = cv) + expect_null(rownames(pecotmr:::.fmRowCvStored(row)$foldWeights)) + expect_identical(cvResult(row), cv) + # Weights on other variants keep their ids: a cross-validation-only row + # has no variants to name them by, and a row in another order cannot + # name them positionally. + cvOnly <- pecotmr:::.fmCvOnlyRow(cv) + expect_identical(pecotmr:::.fmRowCvStored(cvOnly), cv) + expect_identical(cvResult(cvOnly), cv) + swapped <- FineMappingRow(rev(vids), NULL, .fmr_tl(rev(vids)), cv) + expect_identical(cvResult(swapped), cv) + # A payload of any other shape passes through. + other <- FineMappingRow(vids, NULL, .fmr_tl(vids), list(rsq = 0.5)) + expect_identical(cvResult(other), list(rsq = 0.5)) +}) + +test_that("a merged row names each region's fold weights by its variants", { + a <- .fmr_vids(3L)[1:2] + b <- .fmr_vids(3L)[3L] + rows <- list( + FineMappingRow(a, NULL, .fmr_tl(a), cvResult = .fmr_cv(a)), + FineMappingRow(b, NULL, .fmr_tl(b), cvResult = .fmr_cv(b)) + ) + merged <- pecotmr:::.fmMergeEntries(rows) + stored <- pecotmr:::.fmRowCvStored(merged) + expect_named(stored, c("region1", "region2")) + expect_null(rownames(stored$region1$foldWeights)) + expect_null(rownames(stored$region2$foldWeights)) + expect_identical( + cvResult(merged), + list(region1 = .fmr_cv(a), region2 = .fmr_cv(b)) + ) + # A region without CV leaves the others unable to say whose variants + # they cover, so they keep their ids. + rows[[2L]] <- FineMappingRow(b, NULL, .fmr_tl(b)) + partial <- pecotmr:::.fmMergeEntries(rows) + expect_identical( + pecotmr:::.fmRowCvStored(partial), + list(region1 = .fmr_cv(a), region2 = NULL) + ) + expect_identical(cvResult(partial), pecotmr:::.fmRowCvStored(partial)) +}) + +# =========================================================================== +# topLoci in a collection: stored compact, handed out plain +# =========================================================================== + +# A topLoci table in the order the fine-mapping post-processor writes it. +.fmr_fullTl <- function(ids, p = NULL) { + z <- seq(-2, 2, length.out = length(ids)) + tibble::tibble( + variant_id = ids, + N = rep(100, length(ids)), + marginal_z = z, + marginal_z_supplied = rep(FALSE, length(ids)), + marginal_p = p %||% pecotmr:::.fmDerivedP(z), + pip = seq(0.1, 0.5, length.out = length(ids)), + cs_95 = c("susie_1", rep("susie_0", length(ids) - 1L)), + method = rep("susie", length(ids)) + ) +} + +.fmr_tlRes <- function(tl) { + ids <- tl$variant_id + QtlFineMappingResult( + studyName = "S", + context = "C", + trait = "T", + method = "susie", + entry = list(FineMappingRow(ids, list(pip = tl$pip), tl)) + ) +} + +test_that("a collection stores topLoci compactly and hands it back plain", { + tl <- .fmr_fullTl(.fmr_vids(6L)) + res <- .fmr_tlRes(tl) + stored <- mcols(unlist(res, use.names = FALSE)) + # marginal_p is the p marginal_z gives, and the pip the fit's, so both + # are left out ... + expect_false(any(is_in(c("marginal_p", "pip"), colnames(stored)))) + # ... and the repeating columns are run-length encoded, the rest plain. + expect_s4_class(stored$N, "Rle") + expect_s4_class(stored$cs_95, "Rle") + expect_s4_class(stored$method, "Rle") + expect_true(is.numeric(stored$marginal_z)) + # The row handed out holds them plain, marginal_p back in its place. + back <- pecotmr:::.fmrPartsTopLoci(pecotmr:::.collectionEntry(res, 1L)) + expect_identical(back[names(tl)], tl) + expect_identical( + names(back)[1:8], + c( + "variant_id", + "chrom", + "pos", + "A1", + "A2", + "N", + "marginal_z", + "marginal_z_supplied" + ) + ) + expect_equal(match("marginal_p", names(back)), 9L) +}) + +test_that("a supplied marginal_p that differs from the derived one is kept", { + ids <- .fmr_vids(4L) + p <- c(0.01, 0.2, 0.5, 0.9) + res <- .fmr_tlRes(.fmr_fullTl(ids, p = p)) + stored <- mcols(unlist(res, use.names = FALSE)) + expect_equal(as.vector(stored$marginal_p), p) + back <- pecotmr:::.fmrPartsTopLoci(pecotmr:::.collectionEntry(res, 1L)) + expect_equal(back$marginal_p, p) +}) + +test_that("marginal_p out of its place, or without marginal_z, is kept", { + md <- S4Vectors::DataFrame( + marginal_p = 0.5, + marginal_z = 0, + marginal_z_supplied = FALSE + ) + expect_identical(pecotmr:::.fmDropDerivedP(md), md) + noZ <- S4Vectors::DataFrame(marginal_p = 0.5) + expect_identical(pecotmr:::.fmDropDerivedP(noZ), noZ) + expect_true(is.na(pecotmr:::.fmDerivedPPosition("pip"))) + # Without marginal_z_supplied, marginal_p sits right after marginal_z. + expect_equal( + pecotmr:::.fmDerivedPPosition(c("N", "marginal_z", "pip")), + 3L + ) +}) + +test_that("updateObject() stores a saved collection's topLoci compactly", { + res <- .fmr_tlRes(.fmr_fullTl(.fmr_vids(6L))) + # As saved before collections stored topLoci compactly. + flat <- unlist(res, use.names = FALSE) + plain <- pecotmr:::.fmPlainElement(flat) + saved <- res + attr(saved, "unlistData") <- plain + expect_false(methods::is(mcols(unlist(saved))$N, "Rle")) + up <- updateObject(saved) + expect_identical(up, res) + expect_identical(updateObject(up), up) +}) + # =========================================================================== # adjustPips: fits this code cannot slice safely # =========================================================================== @@ -1323,6 +1556,60 @@ test_that("the summary carries the fit's true (gapped) effect index", { expect_equal(big$cs, "susie_2") }) +test_that("a trimmed fit's summary reads each set's own effect", { + # Trimming keeps the non-null effects, so effects 1 and 3 of three sit on + # rows 1 and 2. Looking V and the log BF up by effect index read past the + # end for L3, and would have read L3's row for an L2. + vn <- str_c("chr1:", (1:4) * 100, ":A:G") + fit <- list( + pip = c(0.6, 0.3, 0.05, 0.05), + alpha = matrix( + c(0.7, 0.1, 0.1, 0.1, 0.1, 0.7, 0.1, 0.1), + 2L, + byrow = TRUE, + dimnames = list(NULL, vn) + ), + lbf_variable = matrix(c(3, 0, 0, 0, 0, 2, 0, 0), 2L, byrow = TRUE), + V = c(0.4, 0.2), + effect_index = c(1L, 3L), + sets = list( + cs = list(L1 = 1L, L3 = 2L), + cs_index = c(1L, 3L), + requested_coverage = 0.95 + ) + ) + class(fit) <- "susie" + tl <- data.frame( + variant_id = vn, + pip = fit$pip, + logBF = c(3, 2, 0, 0), + cs_95 = c("susie_1", "susie_3", "susie_0", "susie_0") + ) + s <- .csSummaryFit(tl, fit, 0.95) + s <- s[order(s$effect_id), , drop = FALSE] + expect_equal(s$effect_id, c("L1", "L3")) + expect_equal(s$V, c(0.4, 0.2)) + expect_equal( + s$cs_log_bf, + c(log(mean(exp(c(3, 0, 0, 0)))), log(mean(exp(c(0, 2, 0, 0))))) + ) +}) + +test_that("adjustPips names a trimmed fit's rebuilt sets by effect", { + # The rebuilt sets took their L names and cs_index from varAlpha's + # rows, so on a trimmed fit holding effects 1 and 3 an L3 came back as + # L2 -- relabelling topLoci's susie_3 as susie_2. + varAlpha <- matrix(c(0.9, 0.1, 0.1, 0.9), 2L, byrow = TRUE) + sets <- .adjustPipsCsAtCoverage(varAlpha, c(0.4, 0.2), 0.8, c(1L, 3L)) + expect_equal(names(sets$cs), c("L1", "L3")) + expect_equal(sets$cs_index, c(1L, 3L)) + fit <- list(V = c(0.4, 0.2), effect_index = c(1L, 3L)) + expect_equal( + .adjustPipsCsLabels(varAlpha, fit$V, "cs_80", "susie", 2L, c(1L, 3L)), + c("susie_1", "susie_3") + ) +}) + test_that("a fit with no stored sets falls back to the per-variant column", { # Minimal / hand-built fits carry no sets$cs; the column is then the only # source of membership there is. @@ -1754,11 +2041,13 @@ test_that("a rebuilt row stores no credible-set column its fit reproduces", { expect_true(all(.fpd_csColumns %in% .fmStoredColumns(x))) new <- .fmRebuildExample(x) expect_false(any(.fpd_csColumns %in% .fmStoredColumns(new))) - # The row as GRanges derives them back, in buildTopLoci()'s order. + # The row as GRanges derives them back, in buildTopLoci()'s order: the + # order the example's own row hands them out in. restored <- as(.fmExampleRow(x, 1L), "GRanges") + held <- as(pecotmr:::.fmrRowParts(x, 1L), "GRanges") expect_identical( colnames(S4Vectors::mcols(restored)), - colnames(S4Vectors::mcols(x[[1L]])) + colnames(S4Vectors::mcols(held)) ) }) diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index e04e097a7..9f6c8ead7 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -12,8 +12,8 @@ context("susie_finemapping") .fmp_capturingSusie <- function(captured) { function(X, y, ...) { captured$lastArgs <<- list(X = X, y = y, ...) - # Return a minimal "fit" shape downstream cares about; .setFinemappingFitClass - # only attaches an S3 class, so any list works. + # Return a minimal "fit" shape downstream cares about; + # .setFinemappingFitClass only attaches an S3 class, so any list works. list(token = "test", V = 0.1) } } @@ -233,7 +233,8 @@ test_that("get_cs_info maps variants to CS numbers", { susie_cs <- list(L1 = c(1, 2), L3 = c(4, 5, 6)) top_idx <- c(1, 3, 5) result <- pecotmr:::csInfo(susie_cs, top_idx) - # Now returns data.frame(variant_idx, cs_idx) with one row per (variant, CS) pair + # Now returns data.frame(variant_idx, cs_idx) with one row per (variant, CS) + # pair expect_true(is.data.frame(result)) expect_equal(result$variant_idx, c(1, 3, 5)) expect_equal(result$cs_idx, c(1L, 0L, 3L)) @@ -308,7 +309,7 @@ test_that("susieInfWeights returns zeros without proper fit structure", { }) # ---- susieWeights ---- -test_that("susieWeights with alpha/mu/X_column_scale_factors calls coef.susie", { +test_that("susieWeights with alpha, mu and scale factors calls coef.susie", { p <- 5 L <- 2 mock_fit <- list( @@ -450,7 +451,7 @@ test_that("postprocessFinemappingFits keeps all effects when V is NULL", { # postprocessFinemappingFits: mvsusie output (outcome_names, coef, clfsr) # ============================================================================= -test_that("postprocessFinemappingFits stores outcome_names, coef, and clfsr for mvsusie", { +test_that("postprocessing keeps mvsusie's outcome_names, coef and clfsr", { skip_if_not_installed("susieR") skip_if_not_installed("mvsusieR") p <- 5 @@ -557,7 +558,7 @@ test_that("formatFinemappingOutput does not duplicate top loci variants", { list(X = X, y = y) } -test_that(".translate_legacy_top_loci_cs_columns renames pip_susie -> pip for legacy callers", { +test_that(".translate_legacy_top_loci_cs_columns renames pip_susie to pip", { new_format <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:A:G"), pip_susie = c(0.9, 0.1), @@ -575,7 +576,7 @@ test_that(".translate_legacy_top_loci_cs_columns renames pip_susie -> pip for le expect_true("CS_95_susie_inf" %in% colnames(out)) }) -test_that(".translate_legacy_top_loci_cs_columns leaves existing pip column alone", { +test_that(".translate_legacy_top_loci_cs_columns leaves a pip column alone", { legacy <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:A:G"), pip = c(0.9, 0.1), @@ -802,7 +803,7 @@ test_that("buildTopLoci returns the fixed schema in order with stable dtypes", { expect_true(is.integer(out$grange_end)) }) -test_that("buildTopLoci: conditionIdx slices the 3-D mvsusie posterior per condition", { +test_that("buildTopLoci conditionIdx slices mvsusie's 3-D posterior", { set.seed(1) L <- 2L p <- 3L @@ -838,7 +839,8 @@ test_that("buildTopLoci: conditionIdx slices the 3-D mvsusie posterior per condi conditionIdx = 2L ) tl0 <- buildTopLoci(fit, cst, variantNames = vids, method = "mvsusie") - # Each conditionIdx yields THAT condition's posterior (colSums(alpha*mu[,,r])). + # Each conditionIdx yields THAT condition's posterior + # (colSums(alpha*mu[,,r])). expect_equal(tl1$posterior_mean, colSums(alpha * mu[,, 1])) expect_equal(tl2$posterior_mean, colSums(alpha * mu[,, 2])) expect_false(isTRUE(all.equal(tl1$posterior_mean, tl2$posterior_mean))) @@ -865,7 +867,8 @@ test_that("buildTopLoci: mvsusie per-condition lfsr + effect (long)", { R, dimnames = list(vids, c("c1", "c2")) ) - # conditional_lfsr is the raw-fit field name (trimmed fits rename it `clfsr`). + # conditional_lfsr is the raw-fit field name (trimmed fits rename it + # `clfsr`). clfsr <- array(0.5, c(L, p, R)) clfsr[1, 1, 1] <- 0.001 clfsr[1, 2, 1] <- 0.02 @@ -905,7 +908,8 @@ test_that("buildTopLoci: mvsusie per-condition lfsr + effect (long)", { # `conditional_effect` is gone: it was coef[, condition] / pip, and the # posterior mean is on coef()'s scale now, so the table already held it. expect_false(is_in("conditional_effect", names(tl1))) - # lfsr populated ONLY for the 0.95 CS variants, from clfsr[L, variant, condition] + # lfsr populated ONLY for the 0.95 CS variants, from clfsr[L, variant, + # condition] expect_equal(tl1$lfsr[1:2], c(0.001, 0.02)) expect_true(all(is.na(tl1$lfsr[3:4]))) # conditionIdx = 2 selects the other condition's coef + clfsr slice @@ -956,7 +960,7 @@ test_that("a fit with no infinitesimal term reports theta = 0, not NA", { expect_false(anyNA(tl$posterior_theta)) }) -test_that("buildTopLoci derives CS columns from the ACTUAL coverages (no hardcoded 0.95/0.70/0.50)", { +test_that("buildTopLoci takes CS columns from the actual coverages", { vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") fit <- list( alpha = matrix(c(0.7, 0.2, 0.1), 1, 3), @@ -968,7 +972,8 @@ test_that("buildTopLoci derives CS columns from the ACTUAL coverages (no hardcod mkCt <- function(cs, pu) { list(sets = list(cs = cs, purity = data.frame(min.abs.corr = pu))) } - # Non-default coverages must NOT be silently dropped or mislabeled as 0.95/0.70/0.50. + # Non-default coverages must NOT be silently dropped or mislabeled as + # 0.95/0.70/0.50. cst <- list(mkCt(list(L1 = c(1L, 2L)), 0.85), mkCt(list(), numeric())) attr(cst, "coverage") <- c(0.9, 0.8) tl <- buildTopLoci(fit, cst, variantNames = vids, method = "susie") @@ -978,7 +983,8 @@ test_that("buildTopLoci derives CS columns from the ACTUAL coverages (no hardcod expect_false(any(c("cs_95", "cs_70", "cs_50") %in% names(tl))) expect_equal(tl$cs_90, c("susie_1", "susie_1", "susie_0")) expect_equal(tl$cs_90_purity, c(0.85, 0.85, 0)) - # Default coverages still yield cs_95/70/50 plus a purity column per coverage. + # Default coverages still yield cs_95/70/50 plus a purity column per + # coverage. cst2 <- list( mkCt(list(L1 = c(1L, 2L)), 0.9), mkCt(list(), numeric()), @@ -1001,7 +1007,8 @@ test_that("buildTopLoci derives CS columns from the ACTUAL coverages (no hardcod test_that("buildTopLoci: per-variant logBF is the max single-effect lbf", { vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - lbf <- matrix(c(2.0, 0.1, -1.0, 0.5, 3.0, 0.2), nrow = 2, byrow = TRUE) # L=2 effects x p=3 + # L=2 effects x p=3 + lbf <- matrix(c(2.0, 0.1, -1.0, 0.5, 3.0, 0.2), nrow = 2, byrow = TRUE) fit <- list( alpha = matrix(c(0.7, 0.2, 0.1, 0.3, 0.4, 0.3), 2, 3), mu = matrix(0.3, 2, 3), @@ -1143,7 +1150,7 @@ test_that("buildTopLoci: individual-level vector dataY fills N with nSamples", { expect_true(all(is.na(tl(list(z = rnorm(length(variant_ids))))$N))) }) -test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", { +test_that("buildTopLoci fullFit: within_cs_pip and wide per-CS matrices", { vn <- paste0("chr1:", (1:5) * 100, ":A:G") L <- 2L P <- 5L @@ -1189,13 +1196,15 @@ test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", ) attr(cst, "coverage") <- c(0.95, 0.7, 0.5) - # Default: within_cs_pip = alpha in the assigned CS's effect (NA for non-CS row 5). + # Default: within_cs_pip = alpha in the assigned CS's effect (NA for non-CS + # row 5). tl0 <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") expect_true("within_cs_pip" %in% names(tl0)) expect_false(any(grepl("_cs[0-9]", names(tl0)))) expect_equal(tl0$within_cs_pip, c(0.5, 0.4, 0.5, 0.4, NA_real_)) - # fullFit + all matrices: wide per-CS alpha / lbf / effect / effect-variance. + # fullFit + all matrices: wide per-CS alpha / lbf / effect / + # effect-variance. tl1 <- buildTopLoci( fit, cst, @@ -1206,7 +1215,8 @@ test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", expect_equal(tl1$within_cs_pip_cs1, alpha[1, ]) expect_equal(tl1$cs_logbf_cs1, lbf[1, ]) expect_equal(tl1$cs_effect_cs1, 0.3 / scale) # mu / scale - expect_equal(tl1$cs_effect_var_cs1, (1.2 - 0.09) / scale^2) # (mu2 - mu^2) / scale^2 + # (mu2 - mu^2) / scale^2 + expect_equal(tl1$cs_effect_var_cs1, (1.2 - 0.09) / scale^2) # perCsColumns = "alpha": only alpha widened, both passing CS. tl2 <- buildTopLoci( @@ -1223,7 +1233,7 @@ test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", ) }) -test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS)", { +test_that("buildTopLoci fullFit on qtlFineMappingExample's real CS", { # A genuine chr22 SuSiE fit shipped as a package dataset: region_1/context_1 # carries a real 42-variant credible set. Exercises within_cs_pip + the # alpha-wide column on REAL data (the synthetic case above pins the exact @@ -1295,7 +1305,7 @@ test_that("buildTopLoci fullFit on the committed qtlFineMappingExample (real CS) expect_true("within_cs_pip_cs1" %in% names(tlF)) }) -test_that("buildTopLoci exports af (not MAF) and carries the supplied af values", { +test_that("buildTopLoci exports af (not MAF), carrying the supplied values", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") inp <- .fakeFitAndCs( variant_ids, @@ -1314,7 +1324,7 @@ test_that("buildTopLoci exports af (not MAF) and carries the supplied af values" expect_equal(out$af, c(0.12, 0.87)) }) -test_that("buildTopLoci sets af = NA when no af is supplied (no silent coercion)", { +test_that("buildTopLoci sets af = NA when none is supplied", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") inp <- .fakeFitAndCs( variant_ids, @@ -1334,7 +1344,7 @@ test_that("buildTopLoci sets af = NA when no af is supplied (no silent coercion) length(setdiff(unique(as.character(post$top_loci$cs_95)), c(NA, ""))) } -test_that("postprocessFinemappingFits forwards medianAbsCorr to susie_get_cs (OR-logic admits >= sets)", { +test_that("postprocessing passes medianAbsCorr to susie_get_cs (OR logic)", { # medianAbsCorr is only meaningful when the installed susieR's susie_get_cs # accepts median_abs_corr (GitHub-HEAD susieR; the CRAN/conda-forge build # does not yet). Skip rather than error where it is unavailable. @@ -1369,7 +1379,7 @@ test_that("postprocessFinemappingFits forwards medianAbsCorr to susie_get_cs (OR expect_gte(.n_cs95(pOr), .n_cs95(pStrict)) }) -test_that("cs_95 / cs_70 / cs_50 are character strings of the form '_'", { +test_that("cs_95, cs_70 and cs_50 are strings '_'", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:T:C") # Variants 1 and 2 in CS 1 (at 95), variant 3 in CS 2 (at 95). All three # also appear at 70/50 with the same memberships. @@ -1387,7 +1397,7 @@ test_that("cs_95 / cs_70 / cs_50 are character strings of the form '__0' at every coverage and cs_95_purity = 0", { +test_that("PIP-only variants get '_0' everywhere and purity 0", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") # No CS at any coverage; variant 2 has high PIP so it is retained via # signal_cutoff and produces a "_0" row. @@ -1402,7 +1412,7 @@ test_that("PIP-only retained variants carry '_0' at every coverage and c expect_true(all(out$cs_95_purity == 0)) }) -test_that("per-method CS indices are independent across susie and susieInf (postprocessFinemappingFits)", { +test_that("CS indices are independent across susie and susieInf", { d <- .makeUnivariateData(seed = 21, effect_idx = c(15, 35)) fits <- fitSusieInfThenSusie(d$X, d$y) post <- postprocessFinemappingFits( @@ -1441,7 +1451,7 @@ test_that("per-method CS indices are independent across susie and susieInf (post expect_equal(anyDuplicated(tl[, c("variant_id", "method")]), 0L) }) -test_that("cs_95_purity = 0 when cs_95 is '_0', and in (0, 1] otherwise", { +test_that("cs_95_purity is 0 for '_0', else in (0, 1]", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:T:C") # Variant 1 in CS 1 at 95-cov; variant 2 PIP-only retained; variant 3 # PIP-only retained. @@ -1461,7 +1471,7 @@ test_that("cs_95_purity = 0 when cs_95 is '_0', and in (0, 1] otherwise" expect_true(all(in_cs$cs_95_purity > 0 & in_cs$cs_95_purity <= 1)) }) -test_that("overlapping CS within one method: one row per variant; smallest cs_idx wins", { +test_that("overlapping CSs of one method: a row per variant, smallest wins", { variant_ids <- c("chr1:100:A:G") # One variant belongs to CS 1 AND CS 2 at 95-cov (overlap). cs_at_cov <- list( @@ -1479,7 +1489,7 @@ test_that("overlapping CS within one method: one row per variant; smallest cs_id expect_equal(out$cs_95, "susie_1") }) -test_that("formatFinemappingOutput exposes exactly one top_loci field; no top_loci_long, no wide top_loci, no top_loci_export", { +test_that("formatFinemappingOutput exposes exactly one top_loci field", { d <- .makeUnivariateData(seed = 23, effect_idx = c(15, 40)) fits <- fitSusieInfThenSusie(d$X, d$y) post <- postprocessFinemappingFits( @@ -1512,7 +1522,8 @@ test_that("postprocessFinemappingFits does not return top_loci_long anywhere", { expect_true("top_loci" %in% names(post)) expect_false("top_loci_long" %in% names(post)) expect_equal(names(post$top_loci), .UNIFIED_TOP_LOCI_COLS) - # No per-method finemappingResults entry should carry a top_loci_long either. + # No per-method finemappingResults entry should carry a top_loci_long + # either. for (name in names(post$finemappingResults)) { expect_false( "top_loci_long" %in% names(post$finemappingResults[[name]]), @@ -1521,7 +1532,7 @@ test_that("postprocessFinemappingFits does not return top_loci_long anywhere", { } }) -test_that("buildTopLoci raises an explicit error on invalid variant_id rather than silently filling NA", { +test_that("buildTopLoci errors on an invalid variant_id, never fills NA", { variant_ids <- c("not_a_valid_id") cs_at_cov <- list("0.95" = list(1L), "0.7" = list(1L), "0.5" = list(1L)) inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = 0.9) @@ -1542,7 +1553,7 @@ test_that("buildTopLoci requires `method`", { ) }) -test_that("formatFinemappingOutput exposes finemappingEntry with S4 accessors", { +test_that("formatFinemappingOutput gives finemappingEntry with S4 accessors", { d <- .makeUnivariateData(seed = 25, effect_idx = c(20)) fit <- susieR::susie(d$X, d$y, L = 5) post <- postprocessFinemappingFits( @@ -1564,7 +1575,7 @@ test_that("formatFinemappingOutput exposes finemappingEntry with S4 accessors", expect_true(is.list(fit) && !is.null(fit$pip)) }) -test_that("missing region produces NA grange columns rather than silent omission", { +test_that("a missing region gives NA grange columns, not silent omission", { variant_ids <- c("chr1:100:A:G") cs_at_cov <- list("0.95" = list(1L), "0.7" = list(1L), "0.5" = list(1L)) inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = 0.9) @@ -1594,9 +1605,9 @@ test_that("posterior_mean is colSums(alpha*mu) when the fit records no scale", { inp <- .fakeFitAndCs(variant_ids, cs_at_cov, pip = c(0.8, 0.6)) out <- .runBuildTopLoci(inp, method = "susie") expected_mean <- colSums(inp$fit$alpha * inp$fit$mu) - expected_se <- sqrt(pmax( - colSums(inp$fit$alpha * inp$fit$mu2) - expected_mean^2, - 0 + # The single effects' variances add (susieR's posterior SD). + expected_se <- sqrt(colSums( + inp$fit$alpha * inp$fit$mu2 - (inp$fit$alpha * inp$fit$mu)^2 )) # Match per variant index by looking up via variant string. for (i in seq_along(variant_ids)) { @@ -1634,12 +1645,20 @@ test_that("posterior_mean and posterior_sd are on the SUPPLIED X scale", { X_column_scale_factors = c(0.5, 2, 4) ) meanStd <- colSums(fit$alpha * fit$mu) - sdStd <- sqrt(pmax(colSums(fit$alpha * fit$mu2) - meanStd^2, 0)) + sdStd <- sqrt(colSums(fit$alpha * fit$mu2 - (fit$alpha * fit$mu)^2)) post <- pecotmr:::.btlPosterior(fit, NULL, nV) expect_equal(post$postMean, meanStd / fit$X_column_scale_factors) # An SD rescales the way its mean does, but the mu2 identity only holds # in the units mu2 is stored in -- so it is computed there, then divided. expect_equal(post$postSd, sdStd / fit$X_column_scale_factors) + # The single effects' variances add, as in susieR's own posterior SD. + # Both effects weigh every variant here, so squaring the summed mean + # instead would differ. + expect_equal(post$postSd, susieR::susie_get_posterior_sd(fit)) + expect_false(isTRUE(all.equal( + sdStd, + sqrt(pmax(colSums(fit$alpha * fit$mu2) - meanStd^2, 0)) + ))) # susieInf / susieAsh carry an infinitesimal term that coef.susie adds in; # dropping it would silently change what the posterior effect means. @@ -1771,7 +1790,7 @@ test_that("formatPipColumn prefixes the method", { expect_equal(pecotmr:::formatPipColumn("susieInf"), "pip_susieInf") }) -test_that("resolvePipColumn covers NULL/empty/method/pip/single/multi branches", { +test_that("resolvePipColumn: NULL, empty, method, pip, single, multi", { expect_null(pecotmr:::resolvePipColumn(NULL)) expect_null(pecotmr:::resolvePipColumn(data.frame(pip = numeric(0)))) # method-specific column present -> returned directly @@ -1808,7 +1827,7 @@ test_that("resolvePipColumn covers NULL/empty/method/pip/single/multi branches", }) # ---- formatCsColumn / legacy column translation ---- -test_that("formatCsColumn formats integer and fractional coverage, errors on non-numeric", { +test_that("formatCsColumn formats whole, fractional coverage; refuses text", { expect_equal(pecotmr:::formatCsColumn(0.95, "susie"), "CS_95_susie") expect_equal(pecotmr:::formatCsColumn(0.7, "susie"), "CS_70_susie") expect_equal( @@ -1821,7 +1840,7 @@ test_that("formatCsColumn formats integer and fractional coverage, errors on non ) }) -test_that(".translateLegacyCsColumnName converts cs_coverage_* and passes others through", { +test_that(".translateLegacyCsColumnName converts cs_coverage_*, passes rest", { expect_null(pecotmr:::.translateLegacyCsColumnName(NULL)) expect_equal( pecotmr:::.translateLegacyCsColumnName(c( @@ -1833,14 +1852,14 @@ test_that(".translateLegacyCsColumnName converts cs_coverage_* and passes others ) }) -test_that(".translateLegacyTopLociCsColumns returns non-data.frame inputs unchanged", { +test_that(".translateLegacyTopLociCsColumns returns non-frames unchanged", { x <- list(a = 1) expect_identical(pecotmr:::.translateLegacyTopLociCsColumns(x), x) expect_null(pecotmr:::.translateLegacyTopLociCsColumns(NULL)) }) # ---- .camelToSnakeMethod ---- -test_that(".camelToSnakeMethod handles NULL, empty, and vectors of method ids", { +test_that(".camelToSnakeMethod handles NULL, empty and vectors of method ids", { expect_null(pecotmr:::.camelToSnakeMethod(NULL)) expect_equal(pecotmr:::.camelToSnakeMethod(character(0)), character(0)) expect_equal( @@ -1856,7 +1875,7 @@ test_that(".camelToSnakeMethod handles NULL, empty, and vectors of method ids", }) # ---- .setFinemappingFitClass ---- -test_that(".setFinemappingFitClass assigns method classes and handles NULL/unknown", { +test_that(".setFinemappingFitClass sets classes; handles NULL and unknown", { expect_null(pecotmr:::.setFinemappingFitClass(NULL, "susie")) expect_true( "susiF" %in% @@ -1895,7 +1914,7 @@ test_that("prepareSusieFromInfArgs sets none-branch defaults", { expect_null(a$convergence_method) }) -test_that("prepareSusieFromInfArgs ash branch sets convergence, caps L_greedy, keeps preset refine", { +test_that("prepareSusieFromInfArgs ash: convergence, L_greedy cap, refine", { fit <- list(V = rep(1, 5)) a <- pecotmr:::prepareSusieFromInfArgs( list(L = 3, L_greedy = 10), @@ -1965,7 +1984,7 @@ test_that(".parseGrange reads a window's bounds, NA without one", { }) # ---- selectEffects ---- -test_that("selectEffects returns integer(0) for empty alpha, V-filtered or all effects", { +test_that("selectEffects: none for empty alpha, else V-filtered or all", { expect_equal(pecotmr:::selectEffects(list(alpha = NULL)), integer(0)) expect_equal( pecotmr:::selectEffects(list( @@ -1995,7 +2014,7 @@ test_that(".csPurityVec uses sets$purity, else NA", { }) # ---- extractVariantNames ---- -test_that("extractVariantNames reads pip names, then alpha colnames, then a fallback", { +test_that("extractVariantNames tries pip names, alpha colnames, a fallback", { expect_equal( pecotmr:::extractVariantNames(list( pip = setNames(c(0.1, 0.2), c("chr1:100:A:G", "chr1:200:C:T")) @@ -2020,7 +2039,7 @@ test_that("extractVariantNames reads pip names, then alpha colnames, then a fall }) # ---- extractSumstats ---- -test_that("extractSumstats returns NULL / passthrough across non-regression branches", { +test_that("extractSumstats: NULL or passthrough on non-regression branches", { expect_null(pecotmr:::extractSumstats(NULL, NULL)) expect_equal( pecotmr:::extractSumstats( @@ -2045,7 +2064,7 @@ test_that("extractSumstats returns NULL / passthrough across non-regression bran )) # multi-col dataY }) -test_that("extractSumstats runs univariate regression and applies x/y scalars", { +test_that("extractSumstats runs univariate regression, applies x/y scalars", { skip_if_not_installed("susieR") set.seed(1) X <- matrix(rnorm(60), 20, 3) @@ -2086,7 +2105,7 @@ test_that("computeCsTable X and Xcorr branches return sets/pip", { expect_true(all(c("sets", "pip") %in% names(ctc))) }) -test_that("computeCsTables names tables, sets coverage attr, defaults coverage from fit", { +test_that("computeCsTables names tables; coverage attr defaults to the fit's", { skip_if_not_installed("susieR") d <- .makeUnivariateData(seed = 7, n = 200, p = 8, effect_idx = c(2)) fit <- susieR::susie(d$X, d$y, L = 4) @@ -2115,7 +2134,7 @@ test_that("computeCsTables names tables, sets coverage attr, defaults coverage f }) # ---- trimFinemappingFit ---- -test_that("trimFinemappingFit (susie) trims to selected effects and keeps scalar slots", { +test_that("trimFinemappingFit (susie) keeps selected effects, scalar slots", { fit <- list( pip = setNames(c(0.5, 0.3), c("chr1:100:A:G", "chr1:200:C:T")), alpha = matrix(c(0.5, 0.5, 0.3, 0.7), nrow = 2, byrow = TRUE), @@ -2148,10 +2167,22 @@ test_that("trimFinemappingFit (susie) trims to selected effects and keeps scalar expect_equal(tr$V, 1) expect_equal(tr$theta, c(1, 2)) expect_equal(tr$omega_weights, c(0.5, 0.5)) - expect_equal(tr$X_column_scale_factors, c(1, 1)) + # All-1 scale factors are not stored; the readers take absent for 1s. + expect_null(tr$X_column_scale_factors) + expect_equal(pecotmr:::.fitScaleFactors(tr, 2L), c(1, 1)) + # Factors that rescale are kept. + scaled <- pecotmr:::trimFinemappingFit( + list_assign(fit, X_column_scale_factors = c(2, 0.5)), + eff, + "susie", + csTables + ) + expect_equal(scaled$X_column_scale_factors, c(2, 0.5)) expect_equal(tr$niter, 5) expect_equal(tr$max_L, 2L) expect_equal(tr$n_effects, 2L) + # The kept effect's own index, which its row no longer gives. + expect_equal(tr$effect_index, 1L) expect_equal(class(tr), "susie") # secondary tables drop the pip element expect_length(tr$sets_secondary, 1L) @@ -2188,6 +2219,15 @@ test_that("trimFinemappingFit keeps non-effect-indexed reconciliation fields", { expect_true(tr[["converged"]]) expect_equal(tr[["pi"]], c(0.4, 0.6)) expect_equal(tr[["XtXr"]], c(1.5, 2.5)) + # Uniform prior weights are not stored: absent is what every reader takes + # for uniform. + uniform <- pecotmr:::trimFinemappingFit( + list_assign(fit, pi = c(0.5, 0.5)), + pecotmr:::selectEffects(fit), + "susie", + csTables + ) + expect_null(uniform[["pi"]]) # A fit missing them trims cleanly rather than storing NULLs. bare <- fit[setdiff( @@ -2205,7 +2245,7 @@ test_that("trimFinemappingFit keeps non-effect-indexed reconciliation fields", { )) }) -test_that("trimFinemappingFit (fsusie) retains coef and sets the fsusie/susie class", { +test_that("trimFinemappingFit (fsusie) keeps coef, sets fsusie/susie class", { fit <- list( pip = setNames(c(0.4, 0.6), c("chr1:100:A:G", "chr1:200:C:T")), alpha = matrix(0.5, 2, 2), @@ -2222,7 +2262,7 @@ test_that("trimFinemappingFit (fsusie) retains coef and sets the fsusie/susie cl expect_null(tr$V) }) -test_that("trimFinemappingFit (mvsusie) slices 3-D mu/mu2/mu2_diag/clfsr and stores coef", { +test_that("trimFinemappingFit slices mvsusie's 3-D arrays and stores coef", { skip_if_not_installed("mvsusieR") L <- 2L p <- 3L @@ -2254,14 +2294,52 @@ test_that("trimFinemappingFit (mvsusie) slices 3-D mu/mu2/mu2_diag/clfsr and sto tr <- pecotmr:::trimFinemappingFit(fit, eff, "mvsusie", csTables) expect_equal(dim(tr$mu), c(1L, p, R)) expect_equal(dim(tr$mu2), c(1L, p, R)) - expect_equal(dim(tr$mu2_diag), c(1L, p, R)) + # mu2_diag has no reader once topLoci is built. + expect_null(tr$mu2_diag) expect_equal(dim(tr$clfsr), c(1L, p, R)) expect_equal(tr$coef, fake_coef[-1, , drop = FALSE]) expect_equal(class(tr), c("mvsusie", "susie")) }) +test_that("trimFinemappingFit keeps an mvsusie fit with only null effects", { + skip_if_not_installed("mvsusieR") + # With no effect to report, mvsusieR leaves NA where the lfsr arrays go; + # slicing that as an L x p x R array failed the whole fine-mapping run. + L <- 2L + p <- 3L + R <- 2L + fit <- list( + pip = setNames( + rep(0, p), + c("chr1:1:A:G", "chr1:2:A:G", "chr1:3:A:G") + ), + alpha = matrix(1 / p, L, p), + mu = array(0, dim = c(L, p, R)), + mu2 = array(0, dim = c(L, p, R)), + mu2_diag = array(0, dim = c(L, p, R)), + V = c(0, 0), + conditional_lfsr = NA_real_, + niter = 3 + ) + eff <- pecotmr:::selectEffects(fit) + expect_length(eff, 0L) + csTables <- list(list( + sets = list(cs = list()), + cs_corr = NULL, + pip = fit$pip + )) + local_mocked_bindings( + coef.mvsusie = function(...) matrix(0, p + 1L, R), + .package = "mvsusieR" + ) + tr <- pecotmr:::trimFinemappingFit(fit, eff, "mvsusie", csTables) + expect_null(tr$clfsr) + expect_equal(nrow(tr$alpha), 0L) + expect_equal(tr$coef, matrix(0, p, R)) +}) + # ---- postprocessFinemappingFit S3 methods ---- -test_that("postprocessFinemappingFit.susiF post-processes an fsusie fit (empty-CS path)", { +test_that("postprocessFinemappingFit.susiF handles an fsusie fit with no CS", { fit <- pecotmr:::.setFinemappingFitClass( list( pip = setNames(c(0.5, 0.3), c("chr1:100:A:G", "chr1:200:C:T")), @@ -2297,7 +2375,7 @@ test_that("postprocessFinemappingFit.susiF post-processes an fsusie fit (empty-C ) }) -test_that("postprocessFinemappingFit.susieInf labels credible sets with the susie_inf_ prefix", { +test_that("postprocessFinemappingFit.susieInf labels CSs with susie_inf_", { skip_if_not_installed("susieR") d <- .makeUnivariateData(seed = 7, n = 200, p = 8, effect_idx = c(2)) fits <- fitSusieInfThenSusie(d$X, d$y) @@ -2316,7 +2394,7 @@ test_that("postprocessFinemappingFit.susieInf labels credible sets with the susi expect_true(all(grepl("^susie_inf_\\d+$", res$top_loci$cs_95))) }) -test_that(".postprocessFinemappingFitCommon trim=FALSE stores the untrimmed fit", { +test_that(".postprocessFinemappingFitCommon(trim = FALSE) keeps the full fit", { fit <- pecotmr:::.setFinemappingFitClass( list( pip = setNames(c(0.5, 0.3), c("chr1:100:A:G", "chr1:200:C:T")), @@ -2406,7 +2484,8 @@ test_that("lbfToAlpha handles a single-column matrix", { colnames(lbf) <- "chr1:100:A:G" res <- pecotmr:::lbfToAlpha(lbf) expect_equal(dim(res), c(3L, 1L)) - expect_true(all(res == 1)) # single column -> the only entry carries all weight + # single column -> the only entry carries all weight + expect_true(all(res == 1)) }) # ---- fitSusieInfThenSusie ---- @@ -2438,7 +2517,7 @@ test_that("fitMvsusie forwards arguments to mvsusieR::mvsusie", { skip_if_not_installed("mvsusieR") local_mocked_bindings( mvsusie = function(X, Y, prior_variance, coverage, ...) { - list(tag = "mv", coverage = coverage) + list(tag = "mv", coverage = coverage, dots = list(...)) }, .package = "mvsusieR" ) @@ -2450,6 +2529,29 @@ test_that("fitMvsusie forwards arguments to mvsusieR::mvsusie", { ) expect_equal(r$tag, "mv") expect_equal(r$coverage, 0.9) + # L is pecotmr's to set (MvsusieOptions refuses it), so it always + # reaches the engine; L_greedy only when one is given. + expect_equal(r$dots, list(L = 10L)) + r <- fitMvsusie( + matrix(0, 4, 2), + matrix(0, 4, 2), + prior_variance = 1, + L = 3L, + L_greedy = 2L + ) + expect_equal(r$dots, list(L = 3L, L_greedy = 2L)) + # A record whose last setting is NULL reaches the engine whole: rlang's + # splice of the record itself would drop that NULL. + r <- fitMvsusie( + matrix(0, 4, 2), + matrix(0, 4, 2), + prior_variance = 1, + methodArgs = MvsusieOptions(max_iter = 50, residual_variance = NULL) + ) + expect_equal( + r$dots, + list(L = 10L, max_iter = 50, residual_variance = NULL) + ) }) test_that(".fmFitSusieRss rejects a non-named-list rssControl", { @@ -2526,13 +2628,26 @@ test_that("fitMvsusieRss forwards arguments to mvsusieR::mvsusie_rss", { skip_if_not_installed("mvsusieR") local_mocked_bindings( mvsusie_rss = function(Z, R, N, prior_variance, coverage, ...) { - list(tag = "rss", N = N) + list(tag = "rss", N = N, dots = list(...)) }, .package = "mvsusieR" ) r <- fitMvsusieRss(matrix(0, 2, 1), diag(2), N = 100, prior_variance = 1) expect_equal(r$tag, "rss") expect_equal(r$N, 100) + expect_equal(r$dots, list(L = 10L)) + r <- fitMvsusieRss( + matrix(0, 2, 1), + diag(2), + N = 100, + prior_variance = 1, + L = 3L, + L_greedy = 2L + ) + expect_equal(r$dots, list(L = 3L, L_greedy = 2L)) + # Supplied by pecotmr, so the options bag refuses it, as MvsusieOptions + # does. + expect_error(MvsusieRssOptions(L = 3), "maxNumSingleEffects") }) test_that("fitFsusie forwards arguments to fsusieR::susiF", { @@ -2547,7 +2662,8 @@ test_that("fitFsusie forwards arguments to fsusieR::susiF", { }) # =========================================================================== -# SuSiE / mvSuSiE / fSuSiE weight-extractor tests (relocated to match the source move) +# SuSiE / mvSuSiE / fSuSiE weight-extractor tests (relocated to match the source +# move) # =========================================================================== test_that(".susie_rss_extract_weights returns correct-length vector", { @@ -2756,7 +2872,7 @@ test_that("mvsusieWeights errors when mvsusieR package is not available", { "mvsusieR is installed; skipping missing-package test" ) - expect_error(mvsusieWeights(mvsusieFit = NULL), "mvsusieR") + expect_error(mvsusieWeights(mvsusieFit = list(alpha = 1)), "mvsusieR") }) test_that("mvsusieWeights refuses to fine-map when no fit is supplied", { @@ -2791,6 +2907,70 @@ test_that("mvsusieWeights returns coefficients from provided fit", { expect_equal(result, fake_coef[-1, ]) }) +test_that("mvsusieWeights keeps the fit, naming its variants once", { + skip_if_not( + requireNamespace("mvsusieR", quietly = TRUE), + "mvsusieR not installed" + ) + ids <- sprintf("chr1:%d:A:G", 100L * (1:3)) + coefs <- matrix( + rnorm(8), + nrow = 4L, + dimnames = list(c("(Intercept)", ids), c("c1", "c2")) + ) + local_mocked_bindings( + coef.mvsusie = function(...) coefs, + .package = "mvsusieR" + ) + # A fit naming none of its variants takes the weights' row names. + kept <- mvsusieWeights( + mvsusieFit = list(alpha = matrix(0.5, 1L, 3L)), + fitRetention = "slim" + ) + expect_equal(attr(kept, "fit")$variantIds, ids) + # One that names them keeps its own names alone. + named <- list(pip = set_names(c(0.1, 0.2, 0.3), ids)) + expect_identical( + attr(mvsusieWeights(mvsusieFit = named, fitRetention = "full"), "fit"), + named + ) + expect_null(attr(mvsusieWeights(mvsusieFit = named), "fit")) +}) + +test_that("mvsusieWeights accepts the X and Y learnTwasWeights passes", { + skip_if_not( + requireNamespace("mvsusieR", quietly = TRUE), + "mvsusieR not installed" + ) + # learnTwasWeights() calls every multivariate method with X and Y. As a + # pure extractor mvsusieWeights() had dropped them, so a real fit never + # reached TWAS. + coefs <- matrix(rnorm(8), nrow = 4L) + local_mocked_bindings( + coef.mvsusie = function(...) coefs, + .package = "mvsusieR" + ) + X <- matrix(0, 5L, 3L) + Y <- matrix(0, 5L, 2L) + expect_identical( + mvsusieWeights(X = X, Y = Y, mvsusieFit = "precomputed_fit"), + mvsusieWeights(mvsusieFit = "precomputed_fit") + ) +}) + +test_that("mvsusieWeights reads a trimmed fit's precomputed weights", { + # Trimming drops the intercept and all but the kept effects, so + # coef.mvsusie() cannot run on the fit a fine-mapping result stores; the + # trim records the full fit's weights as `coef` instead. + ids <- sprintf("chr1:%d:A:G", 100L * (1:3)) + coefs <- matrix(c(0.5, 0, 0, 0, 0.2, 0), 3L, dimnames = list(ids, NULL)) + trimmed <- structure( + list(alpha = matrix(1 / 3, 1L, 3L), coef = coefs), + class = c("mvsusie", "susie") + ) + expect_identical(mvsusieWeights(mvsusieFit = trimmed), coefs) +}) + .fw_makeFsusieFit <- function( seed = 1, n = 150L, @@ -2836,7 +3016,7 @@ test_that("mvsusieWeights returns coefficients from provided fit", { .fw_makeFsusieFit() } -test_that("fsusieWeights returns a variants x features matrix with variant rownames", { +test_that("fsusieWeights gives a variants x features matrix, rows named", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") obj <- .fw_fsusieDefault @@ -2859,13 +3039,13 @@ test_that("computeCsTable (fsusie): within-CS purity, not cal_cor_cs", { ) calP <- as.numeric(unlist(fsusieR::cal_purity(ct$sets$cs, obj$X))) pv <- .csPurityVec(ct) - # exactly one purity per CS (bug: previously iterated the fit's ~36 slots), and - # equal to fsusieR's own cal_purity (min |corr| within each CS) + # exactly one purity per CS (bug: previously iterated the fit's ~36 slots), + # and equal to fsusieR's own cal_purity (min |corr| within each CS) expect_equal(length(pv), length(ct$sets$cs)) expect_equal(pv, calP, tolerance = 1e-6) }) -test_that("fsusieWeights matches fsusieR's own out_prep reconstruction (post_processing='none')", { +test_that("fsusieWeights matches fsusieR's out_prep reconstruction", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") obj <- .fw_fsusieDefault @@ -2896,6 +3076,45 @@ test_that("fsusieWeights matches fsusieR's own out_prep reconstruction (post_pro expect_lt(maxErr, 1e-8) }) +test_that("fsusieWeights undoes the response scaling fsusieR records", { + skip_if_not_installed("fsusieR") + skip_if_not_installed("wavethresh") + fit <- .fw_fsusieDefault$fit + nWac <- fit$n_wac + # What an fsusieR that standardizes the response keeps on the fit: a + # factor per wavelet coefficient and one per position. + set.seed(5) + scaled <- fit + scaled$csd_Yf <- runif(nWac, 0.5, 2) + scaled$csd_Y_pos <- runif(nWac, 0.5, 2) + W <- fsusieWeights(fsusieFit = scaled) + # fsusieR's own fitted_func (post_processing = "none", its + # operation_on_susiF_obj.R): collapse over SNPs, scale each coefficient + # by csd_Yf, invert the wavelet transform, scale each position by + # csd_Y_pos. Summed over effects, that is the weights' column sums. + perScale <- "mixture_normal_per_scale" %in% + class(fsusieR::get_G_prior(fit)) + indxLst <- fsusieR::gen_wavelet_indx(log2(length(fit$outing_grid))) + cIdx <- if (perScale) indxLst[[length(indxLst)]] else nWac + temp <- wavethresh::wd(rep(0, nWac)) + curve <- numeric(nWac) + for (l in seq_along(fit$fitted_wc)) { + wc <- as.numeric((fit$alpha[[l]] / fit$csd_X) %*% fit$fitted_wc[[l]]) + wc <- wc * scaled$csd_Yf + temp$D <- wc[-cIdx] + temp$C[length(temp$C)] <- wc[cIdx] + curve <- curve + wavethresh::wr(temp) * scaled$csd_Y_pos + } + expect_equal(unname(colSums(W)), curve, tolerance = 1e-8) + # A fit without the factors was never scaled. + expect_false(isTRUE(all.equal(W, fsusieWeights(fsusieFit = fit)))) + # A factor that does not fit the basis is refused, not recycled. + expect_error( + fsusieWeights(fsusieFit = `$<-`(scaled, "csd_Yf", scaled$csd_Yf[-1])), + "`csd_Yf` has" + ) +}) + test_that("fsusieWeights concentrates weight on the causal SNPs", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") @@ -2906,7 +3125,7 @@ test_that("fsusieWeights concentrates weight on the causal SNPs", { expect_setequal(top2, c("chr1:300:A:G", "chr1:1000:A:G")) }) -test_that("fsusieWeights fast path returns precomputed $coef for a trimmed fit", { +test_that("fsusieWeights returns a trimmed fit's precomputed $coef", { # A trimmed fSuSiE fit drops fitted_wc but keeps the precomputed weight # matrix in $coef; fsusieWeights returns it without touching wavelet slots. W0 <- matrix( @@ -2923,7 +3142,7 @@ test_that("fsusieWeights fast path returns precomputed $coef for a trimmed fit", expect_identical(W, W0) }) -test_that("fsusieWeights errors without a fit and on an unusable (trimmed, no coef) fit", { +test_that("fsusieWeights errors with no fit or a trimmed fit lacking coef", { expect_error(fsusieWeights(fsusieFit = NULL), "is required") bad <- list(pip = c(0.1, 0.9)) # no coef, no fitted_wc class(bad) <- c("fsusie", "susie") @@ -2951,7 +3170,7 @@ test_that("fsusieWeights errors without a fit and on an unusable (trimmed, no co ) } -test_that("mergeSusieCs: non-overlapping CSs keep distinct per-condition labels", { +test_that("mergeSusieCs: disjoint CSs keep distinct per-condition labels", { fmr <- .msc_fmr(list( .msc_entry( c("chr1:100:A:G", "chr1:200:A:G"), @@ -2976,7 +3195,7 @@ test_that("mergeSusieCs: non-overlapping CSs keep distinct per-condition labels" expect_equal(res$maxPip, c(0.8, 0.6, 0.9, 0.7)) }) -test_that("mergeSusieCs: a variant shared across conditions merges their credible sets", { +test_that("mergeSusieCs: a variant two conditions share merges their CSs", { fmr <- .msc_fmr(list( .msc_entry( c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), @@ -3018,7 +3237,7 @@ test_that("mergeSusieCs: coverage selects the cs_ column", { expect_equal(res$credibleSetNames, c("cs_1_1", "cs_1_1")) }) -test_that("mergeSusieCs: a condition with no usable CS is skipped, valid ones kept", { +test_that("mergeSusieCs skips a condition with no usable CS, keeps the rest", { valid <- .msc_entry( c("chr1:100:A:G", "chr1:200:A:G"), c(0.9, 0.8), @@ -3585,7 +3804,7 @@ test_that("susieRss weight extraction rejects a fit of another block", { ) }) -test_that("susieRss weights are zero when the fit lacks the coefficient fields", { +test_that("susieRss weights are zero when the fit lacks coefficient fields", { # Without alpha/mu there is nothing to form coefficients from, so the # contribution is zero rather than an error or a partial answer. w <- pecotmr:::.susieRssExtractWeights( @@ -4647,7 +4866,7 @@ test_that("serWeights extracts weights from a single-effect fit", { expect_error(serWeights(), "no 'ser' fit supplied") }) -test_that(".fmSerScreen: disables on 0, skips no-signal, keeps signal + adaptive", { +test_that(".fmSerScreen: off at 0, skips no signal, keeps signal, adaptive", { skip_if_not_installed("susieR") set.seed(1) n <- 150L @@ -4747,8 +4966,9 @@ test_that("buildMvsusieMixturePrior: methodArgs forwarded, list refused", { test_that("MvsusieMixturePriorOptions refuses the arguments the builder owns", { for (owned in c("mixture_prior", "R", "include_indices", "weights_tol")) { + ownedArg <- set_names(list(1), owned) expect_error( - exec(MvsusieMixturePriorOptions, !!!set_names(list(1), owned)), + exec(MvsusieMixturePriorOptions, !!!ownedArg), "supplied by pecotmr" ) } @@ -4767,7 +4987,6 @@ test_that(".fmFoldWeightsMv: NULL mvPrior uses buildMvsusieMixturePrior", { mvsusieWeights = function(mvsusieFit) { matrix(0, 2, 2, dimnames = list(c("v1", "v2"), NULL)) }, - .fmLeanFoldFit = function(fit, token) NULL, .package = "pecotmr" ) pecotmr:::.fmFoldWeightsMv(Xtr, Ytr, 0.95, NULL, NULL) @@ -4776,18 +4995,19 @@ test_that(".fmFoldWeightsMv: NULL mvPrior uses buildMvsusieMixturePrior", { expect_equal(args$include_indices, c("c1", "c2")) }) -test_that(".buildMvsusieReweightedPrior: canonical fallback when no usable fit", { +test_that(".buildMvsusieReweightedPrior falls back to canonical with no fit", { bp <- function(...) pecotmr:::.buildMvsusieReweightedPrior(...) # No fit at all -> canonical prior, residualVariance NULL. p1 <- bp(NULL, c("c1", "c2")) expect_false(is.null(p1$priorVariance)) expect_null(p1$residualVariance) - # Fit with no data-driven matrices -> canonical prior, but V carried through. + # Fit with no data-driven matrices -> canonical prior, but V carried + # through. p2 <- bp(list(dataDrivenPriorMatrices = NULL, V = diag(2)), c("c1", "c2")) expect_equal(p2$residualVariance, diag(2)) }) -test_that(".buildMvsusieReweightedPrior: reweights matrices by rescaleCovW0(w0)", { +test_that(".buildMvsusieReweightedPrior reweights by rescaleCovW0(w0)", { ddpm <- list( U = list(compA = diag(2), compB = diag(2) * 2), w = c(compA = 0.5, compB = 0.5) @@ -4824,7 +5044,7 @@ test_that(".buildMvsusieReweightedPrior: reweights matrices by rescaleCovW0(w0)" expect_equal(captured$weights_tol, 1e-8) }) -test_that(".buildMvsusieReweightedPrior: overrideU swaps matrices, keeps fit w0/V", { +test_that(".buildMvsusieReweightedPrior: overrideU swaps U, keeps w0 and V", { fit <- list( dataDrivenPriorMatrices = list(U = list(K = diag(2)), w = c(K = 1)), w0 = c(K_grid1 = 1), @@ -4848,11 +5068,12 @@ test_that(".buildMvsusieReweightedPrior: overrideU swaps matrices, keeps fit w0/ c("c1", "c2"), overrideU = override ) - expect_equal(captured$mixture_prior$matrices$K, diag(2) * 5) # the override U + # the override U + expect_equal(captured$mixture_prior$matrices$K, diag(2) * 5) expect_equal(res$residualVariance, diag(2) * 7) # the fit's own V }) -test_that(".fmSerScreen supports absZ / bf / logBf metrics and the legacy pip scalar", { +test_that(".fmSerScreen takes absZ, bf, logBf metrics and the pip scalar", { skip_if_not_installed("susieR") set.seed(11) n <- 200L @@ -4921,7 +5142,7 @@ test_that(".fmFitSusieSer calls susieR::susie_ser with z + n and no R / L", { expect_true("susieRss" %in% class(fit)) }) -test_that(".fmFitSusieIndiv: susieInf branch passes convergence_method='pip', refine=FALSE, model_init=NULL", { +test_that(".fmFitSusieIndiv susieInf: pip convergence, no refine, no init", { captured <- new.env(parent = emptyenv()) X <- matrix(rnorm(20), 10, 2) y <- rnorm(10) @@ -4940,7 +5161,8 @@ test_that(".fmFitSusieIndiv: a chained token starts from the susieInf fit", { captured <- new.env(parent = emptyenv()) X <- matrix(rnorm(20), 10, 2) y <- rnorm(10) - # Build a stub susieInf fit with a V slot so prepareSusieFromInfArgs can read L. + # Build a stub susieInf fit with a V slot so prepareSusieFromInfArgs can + # read L. infFit <- list(V = c(0.1, 0.2)) local_mocked_bindings( susie = .fmp_capturingSusie(captured), @@ -4960,7 +5182,7 @@ test_that(".fmFitSusieIndiv: a chained token starts from the susieInf fit", { } }) -test_that(".fmFitSusieIndiv: unchained susieAsh branch sets convergence_method='pip'", { +test_that(".fmFitSusieIndiv unchained susieAsh: pip convergence", { captured <- new.env(parent = emptyenv()) X <- matrix(rnorm(20), 10, 2) y <- rnorm(10) @@ -4984,7 +5206,7 @@ test_that(".fmFitSusieIndiv: rejects non-SuSiE-family token", { ) }) -test_that(".fmFitSusieRss: susieInf branch passes convergence_method='pip', refine=FALSE, model_init=NULL", { +test_that(".fmFitSusieRss susieInf: pip convergence, no refine, no init", { captured <- new.env(parent = emptyenv()) z <- rnorm(3) R <- diag(3) @@ -5022,7 +5244,7 @@ test_that(".fmFitSusieRss: a chained token starts from the susieInf fit", { } }) -test_that(".fmFitSusieRss: unchained susieAsh branch sets convergence_method='pip'", { +test_that(".fmFitSusieRss unchained susieAsh: pip convergence", { captured <- new.env(parent = emptyenv()) z <- rnorm(3) R <- diag(3) @@ -5061,7 +5283,7 @@ test_that(".buildMvsusieReweightedPrior: empty reweighted w0 -> canonical(V)", { expect_equal(res$residualVariance, diag(2)) # w0 names disjoint from U }) -test_that(".fmFitXBlock fits the susieInf indiv chain + cross-validates (mocked)", { +test_that(".fmFitXBlock fits and cross-validates the susieInf chain (mocked)", { local_mocked_bindings( .fmFitSusieIndiv = function(...) list(), .fmPostprocessOne = function(fit, method, dataX, dataY, ...) { diff --git a/tests/testthat/test_genotypeHandle.R b/tests/testthat/test_genotypeHandle.R index 4988381f6..648547991 100644 --- a/tests/testthat/test_genotypeHandle.R +++ b/tests/testthat/test_genotypeHandle.R @@ -123,7 +123,7 @@ test_that(".plink1TripletStem: errors on non-character input", { ) }) -test_that("GenotypeHandle: pgen/pvar/psam triplet with matching stems builds plink2 handle", { +test_that("a pgen/pvar/psam triplet with one stem builds a PLINK2 handle", { skip_if_not_installed("pgenlibr") h <- GenotypeHandle( pgen = paste0(plink_prefix, ".pgen"), @@ -134,7 +134,7 @@ test_that("GenotypeHandle: pgen/pvar/psam triplet with matching stems builds pli expect_equal(genotypeFormat(h), "plink2") }) -test_that(".genotypeHandleFromPlink2Triplet: accepts .pvar.zst by stripping the .zst", { +test_that(".genotypeHandleFromPlink2Triplet strips .zst from a .pvar.zst", { skip_if_not_installed("pgenlibr") # The stems agree once the .zst is stripped, so the call gets past the # stem check and fails only in the reader, on the files not existing. @@ -329,7 +329,7 @@ test_that("GenotypeHandle constructs and validates every format it reads", { # The named-vector handle is built and checked with its extraction routing # in test_genotypeIo.R. # =========================================================================== -test_that("genoMeta meta-file resolves payloads relative to its own directory", { +test_that("a genoMeta file resolves payloads relative to its directory", { skip_if_not_installed("pgenlibr") # A meta file living in test_data referencing payloads by basename only. metafile <- file.path(test_data_dir, "tmp_chrom_meta_relative.tsv") @@ -347,7 +347,7 @@ test_that("genoMeta meta-file resolves payloads relative to its own directory", expect_equal(nrow(snpInfo(h)), 2L * 349L) }) -test_that(".parseChromMeta matches chrom/path columns by name (order- and extra-column-tolerant)", { +test_that(".parseChromMeta matches chrom/path columns by name, any order", { mk <- function(lines) { f <- tempfile(fileext = ".tsv") writeLines(lines, f) @@ -371,7 +371,7 @@ test_that(".parseChromMeta matches chrom/path columns by name (order- and extra- expect_equal(m2$path, c("/abs/a.bed", "/abs/b.bed")) }) -test_that(".parseChromMeta falls back to the first two columns when no alias header matches", { +test_that(".parseChromMeta uses the first two columns if no header matches", { mk <- function(lines) { f <- tempfile(fileext = ".tsv") writeLines(lines, f) @@ -384,7 +384,7 @@ test_that(".parseChromMeta falls back to the first two columns when no alias hea expect_equal(m$path, c("/abs/a.bed", "/abs/b.bed")) }) -test_that(".parseChromMeta errors when a chromosome maps to multiple payloads", { +test_that(".parseChromMeta errors when a chromosome maps to several payloads", { mk <- function(lines) { f <- tempfile(fileext = ".tsv") writeLines(lines, f) @@ -499,7 +499,8 @@ test_that("genoMeta chroms reads only the requested shard", { only21 <- GenotypeHandle(genoMeta = meta, chroms = "21") expect_equal(names(chromPaths(only21)), "chr21") expect_equal(nrow(snpInfo(only21)), 349L) - # chr21 is the first shard, so the kept rows/fileIdx match the full handle's. + # chr21 is the first shard, so the kept rows/fileIdx match the full + # handle's. expect_equal(snpInfo(only21)$SNP, snpInfo(full)$SNP[1:349]) expect_equal(snpInfo(only21)$fileIdx, snpInfo(full)$fileIdx[1:349]) }) @@ -533,8 +534,8 @@ test_that("genoMeta chroms falls back to all shards when none match", { test_that("genoMeta chroms skips a shard whose file does not exist", { skip_if_not_installed("pgenlibr") - # A bogus chr21 payload proves the skip: restricting to chr22 must never open - # it, while requesting chr21 too fails on the missing files. + # A bogus chr21 payload proves the skip: restricting to chr22 must never + # open it, while requesting chr21 too fails on the missing files. meta <- c( "22" = file.path(test_data_dir, "test_variants_chr22.pgen"), "21" = "/no/such/chr21/prefix" @@ -562,14 +563,11 @@ test_that("chroms is rejected for a non-genoMeta source", { # without crafting whole on-disk meta layouts. # =========================================================================== -test_that(".genotypeHandleFromLdMeta errors when no LD-meta row covers the region", { +test_that(".genotypeHandleFromLdMeta errors when no row covers the region", { local_mocked_bindings( regionalLdMeta = function(...) { list( - intersections = list( - LD_file_paths = character(0), - bimFilePaths = NULL - ) + intersections = list(paths = character(0)) ) }, .package = "pecotmr" @@ -580,14 +578,11 @@ test_that(".genotypeHandleFromLdMeta errors when no LD-meta row covers the regio ) }) -test_that(".genotypeHandleFromLdMeta errors when the region spans multiple rows", { +test_that(".genotypeHandleFromLdMeta errors when the region spans rows", { local_mocked_bindings( regionalLdMeta = function(...) { list( - intersections = list( - LD_file_paths = c("/tmp/a.bed", "/tmp/b.bed"), - bimFilePaths = NULL - ) + intersections = list(paths = c("/tmp/a.bed", "/tmp/b.bed")) ) }, .package = "pecotmr" @@ -598,14 +593,11 @@ test_that(".genotypeHandleFromLdMeta errors when the region spans multiple rows" ) }) -test_that(".genotypeHandleFromLdMeta errors on an unsupported payload extension", { +test_that(".genotypeHandleFromLdMeta errors on an unsupported extension", { local_mocked_bindings( regionalLdMeta = function(...) { list( - intersections = list( - LD_file_paths = "/tmp/foo.txt", - bimFilePaths = NULL - ) + intersections = list(paths = "/tmp/foo.txt") ) }, .package = "pecotmr" @@ -655,7 +647,7 @@ test_that(".genotypeHandleFromChromMeta errors when the meta has no rows", { # prefix sidecar probing, and the unresolvable-format error. # =========================================================================== -test_that(".resolveGenotypeShard honours explicit plink2 format and .pgen extension", { +test_that(".resolveGenotypeShard honours a plink2 format and .pgen extension", { skip_if_not_installed("pgenlibr") h1 <- pecotmr:::.resolveGenotypeShard(plink_prefix, format = "plink2") expect_s4_class(h1, "GenotypeHandle") @@ -695,7 +687,7 @@ test_that(".resolveGenotypeShard refuses a VCF, GDS or PLINK1 shard", { ) }) -test_that(".resolveGenotypeShard probes the .pgen sidecar for an extension-less prefix", { +test_that(".resolveGenotypeShard probes .pgen for an extension-less prefix", { # Only a .pgen sidecar exists (no .bed) so the prefix-probe routes to # plink2; mock the reader so we exercise the dispatch, not real IO. p <- tempfile() @@ -758,10 +750,8 @@ test_that("genotypeDelayedArray values match genotypes transposed", { truth <- t(pecotmr:::.dosageMatrix(gh, 1:5, meanImpute = FALSE)) got <- as.matrix(da[1:5, 1:4]) expect_equal(unname(got), unname(truth[, 1:4])) - expect_identical( - rownames(got), - normalizeVariantId(snpInfo(gh)$SNP[1:5]) - ) + # The seed names no variants: a panel's rowRanges name them. + expect_null(rownames(got)) expect_identical(colnames(got), sampleIds(gh)[1:4]) }) @@ -785,19 +775,20 @@ test_that("the seed answers an empty extraction on either axis", { ) }) -test_that("genotypeDelayedArray stores the sample axis once, derives it on read", { - # The sample ids are an anonymous projection dimension and would otherwise be - # duplicated between GhSeed@dn[[2]] and handle@sampleIds. The seed stores only - # the variant axis; dimnames() derives the sample axis from the handle. +test_that("genotypeDelayedArray stores samples once, derives them on read", { + # The sample ids are an anonymous projection dimension and would otherwise + # be duplicated between GhSeed@dn[[2]] and handle@sampleIds. The seed stores + # only the variant axis; dimnames() derives the sample axis from the handle. gh <- .gh_pgenHandle() seed <- genotypeDelayedArray(gh)@seed expect_null(seed@dn[[2L]]) # not stored - expect_identical(dimnames(seed)[[2L]], as.character(sampleIds(gh))) # derived + # derived + expect_identical(dimnames(seed)[[2L]], as.character(sampleIds(gh))) expect_identical(dimnames(seed)[[1L]], seed@dn[[1L]]) # variant axis stored expect_equal(dim(seed)[[2L]], length(dimnames(seed)[[2L]])) # dm consistent }) -test_that(".emptyGenotypeHandle empties the sample axis as well as the variants", { +test_that(".emptyGenotypeHandle empties the samples as well as the variants", { gh <- .gh_pgenHandle() e <- pecotmr:::.emptyGenotypeHandle(gh) expect_equal(nrow(snpInfo(e)), 0L) @@ -813,13 +804,13 @@ test_that("nothing is read until a block is actually touched", { # The point of the seed: a panel can be described without being read. gh <- .gh_pgenHandle() reads <- 0L - # Captured before mocking: calling extractBlockGenotypes by name inside - # the mock would re-enter the mock, not the reader. - realExtract <- extractBlockGenotypes + # Captured before mocking: calling .handleDosage by name inside the mock + # would re-enter the mock, not the reader. + realRead <- pecotmr:::.handleDosage local_mocked_bindings( - extractBlockGenotypes = function(handle, snpIdx, meanImpute = TRUE) { + .handleDosage = function(handle, snpIdx) { reads <<- reads + 1L - realExtract(handle, snpIdx = snpIdx, meanImpute = meanImpute) + realRead(handle, snpIdx) }, .package = "pecotmr" ) @@ -836,11 +827,11 @@ test_that("nothing is read until a block is actually touched", { test_that("only the requested variants are read", { gh <- .gh_pgenHandle() seen <- integer(0) - realExtract <- extractBlockGenotypes + realRead <- pecotmr:::.handleDosage local_mocked_bindings( - extractBlockGenotypes = function(handle, snpIdx, meanImpute = TRUE) { + .handleDosage = function(handle, snpIdx) { seen <<- c(seen, length(snpIdx)) - realExtract(handle, snpIdx = snpIdx, meanImpute = meanImpute) + realRead(handle, snpIdx) }, .package = "pecotmr" ) @@ -850,6 +841,17 @@ test_that("only the requested variants are read", { expect_lt(sum(seen), nrow(snpInfo(gh))) }) +test_that("genotypeDelayedArray leaves the handle it is given whole", { + # The seed keeps a copy cut to the columns reading needs; the caller's + # handle keeps every column. + gh <- .gh_pgenHandle() + before <- snpInfo(gh) + da <- genotypeDelayedArray(gh) + expect_identical(snpInfo(gh), before) + seedHandle <- pecotmr:::.ghSeedHandle(DelayedArray::seed(da)) + expect_identical(names(snpInfo(seedHandle)), "fileIdx") +}) + test_that("genotypeDelayedArray rejects a non-handle", { expect_error(genotypeDelayedArray("not a handle"), "GenotypeHandle") }) diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index 30ceb9840..61b63cefe 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -17,7 +17,7 @@ test_that("Test loadGenotypeRegion", { sample_ids <- read_delim( "test_data/protocol_example.genotype.fam", delim = "\t", - col_names = F + col_names = FALSE ) %>% pull(X1) expect_equal(nrow(res), length(sample_ids)) @@ -27,17 +27,17 @@ test_that("Test loadGenotypeRegion", { test_that("Test loadGenotypeRegion no indels", { res <- loadGenotypeRegion( "test_data/protocol_example.genotype", - keepIndel = F + keepIndel = FALSE ) bim_file <- read_delim( "test_data/protocol_example.genotype.bim", delim = "\t", - col_names = F + col_names = FALSE ) sample_ids <- read_delim( "test_data/protocol_example.genotype.fam", delim = "\t", - col_names = F + col_names = FALSE ) %>% pull(X1) expect_equal(nrow(res), length(sample_ids)) @@ -63,13 +63,13 @@ test_that("Test loadGenotypeRegion with region", { sample_ids <- read_delim( "test_data/protocol_example.genotype.fam", delim = "\t", - col_names = F + col_names = FALSE ) %>% pull(X1) snp_ids <- read_delim( "test_data/protocol_example.genotype.bim", delim = "\t", - col_names = F + col_names = FALSE ) %>% pull(X2) expect_equal(nrow(res), length(sample_ids)) @@ -82,17 +82,17 @@ test_that("Test loadGenotypeRegion with region and no indels", { res <- loadGenotypeRegion( "test_data/protocol_example.genotype", which = GenomicRanges::GRanges("chr22:20689453-20845958"), - keepIndel = F + keepIndel = FALSE ) bim_file <- read_delim( "test_data/protocol_example.genotype.bim", delim = "\t", - col_names = F + col_names = FALSE )[1:8, ] sample_ids <- read_delim( "test_data/protocol_example.genotype.fam", delim = "\t", - col_names = F + col_names = FALSE ) %>% pull(X1) expect_equal(nrow(res), length(sample_ids)) @@ -189,7 +189,8 @@ test_that("readStochasticMeta reads afreq.zst format", { test_that("findStochasticMeta prefers afreq over afreq.zst", { td <- test_path("test_data") - # Both .afreq and .afreq.zst exist; findStochasticMeta should return .afreq first + # Both .afreq and .afreq.zst exist; findStochasticMeta should return .afreq + # first result <- pecotmr:::findStochasticMeta(file.path( td, "test_harmonize_regions" @@ -245,7 +246,7 @@ test_that("readStochasticMeta returns NULL for nonexistent file", { # --- loadGenotypeRegion stochastic inversion test --- -test_that("loadGenotypeRegion applies stochastic inversion with explicit sidecar", { +test_that("loadGenotypeRegion applies stochastic inversion with a sidecar", { td <- test_path("test_data") metaPath <- file.path(td, "test_harmonize_regions.stochastic_meta.tsv") smeta <- pecotmr:::readStochasticMeta(metaPath) @@ -271,7 +272,8 @@ test_that("loadGenotypeRegion applies stochastic inversion with explicit sidecar file.path(td, "protocol_example.genotype"), which = GenomicRanges::GRanges("chr22:20689453-20845958") ) - # protocol_example has no sidecar, so raw values are unchanged (integer dosages) + # protocol_example has no sidecar, so raw values are unchanged (integer + # dosages) expect_true(all(raw == round(raw), na.rm = TRUE)) # The inverted matrix should NOT be all integers (u_min != 0 or u_max != 2) @@ -705,7 +707,8 @@ test_that("readGenotypes reads PLINK1, VCF and GDS files as panels", { gds = list(gds_path) ) for (format in names(sources)) { - panel <- exec(readGenotypes, !!!sources[[format]]) + sourceArgs <- sources[[format]] + panel <- exec(readGenotypes, !!!sourceArgs) expect_s4_class(panel, "RangedSummarizedExperiment") expect_equal(dim(panel), c(n_variants, n_samples), info = format) expect_equal( @@ -933,9 +936,9 @@ test_that("extractBlockGenotypes mean-imputes a missing call on request", { expect_equal(nrow(snpInfo(shard)), n21 + n22) # A chr21 request routes to the chr21 payload (== single-file chr21). expect_equal(.shardDose(shard, 1:5), .shardDose(ref21, 1:5)) - # A chr22 request routes to the chr22 payload, and the global->local index - # conversion lines up with the single-file chr22 handle. (PLINK2 is - # positional, so this is the key check for that backend.) + # A chr22 request routes to the chr22 payload, and the global->local + # index conversion lines up with the single-file chr22 handle. (PLINK2 + # is positional, so this is the key check for that backend.) expect_equal( .shardDose(shard, (n21 + 1):(n21 + 5)), .shardDose(ref22, 1:5) @@ -961,7 +964,8 @@ test_that("extractBlockGenotypes mean-imputes a missing call on request", { )), c("chr21", "chr21", "chr22", "chr22") ) - # Requested order preserved; each half matches its single-file source. + # Requested order preserved; each half matches its single-file + # source. expect_equal(dm[1:2, ], .shardDose(ref21, 1:2)) expect_equal(dm[3:4, ], .shardDose(ref22, 1:2)) } @@ -1061,7 +1065,7 @@ test_that("a PLINK1 panel errors when its trio is absent", { ) }) -# --- .extractBlockSharded: empty block + missing-chromosome stop ------------- +# --- sharded handle: empty block + missing-chromosome stop ------------------ test_that("extractBlockGenotypes on a sharded handle handles an empty block", { skip_if_not_installed("pgenlibr") @@ -1259,7 +1263,7 @@ test_that("resolvePlink2Paths errors when .psam is missing", { # --- readStochasticMeta: generic format missing required columns ------------- -test_that("readStochasticMeta errors when generic file lacks required columns", { +test_that("readStochasticMeta errors when a file lacks required columns", { tmp <- tempfile(fileext = ".tsv") on.exit(unlink(tmp), add = TRUE) writeLines(c("foo\tbar", "1\t2"), tmp) @@ -1343,7 +1347,7 @@ test_that(".withFileIdx + readers attach a sequential fileIdx to snpInfo", { expect_identical(si$fileIdx, seq_len(nrow(si))) }) -test_that(".subsetGenotypeHandle keeps PLINK2 reads correct for kept variants", { +test_that(".subsetGenotypeHandle keeps PLINK2 reads right for kept variants", { h <- readGenotypeHandle( test_path("test_data/test_variants"), format = "plink2" @@ -1351,8 +1355,8 @@ test_that(".subsetGenotypeHandle keeps PLINK2 reads correct for kept variants", si <- snpInfo(h) want <- c(2L, 4L, 5L, 9L) dosFull <- pecotmr:::.dosageMatrix(h, want, meanImpute = TRUE) - # Keep a reordered superset so the wanted variants move to NEW row positions; - # fileIdx must rescue the (now-shifted) positional PLINK2 read. + # Keep a reordered superset so the wanted variants move to NEW row + # positions; fileIdx must rescue the (now-shifted) positional PLINK2 read. keep <- c(9L, 5L, 4L, 2L, 7L, 1L) hSub <- pecotmr:::.subsetGenotypeHandle(h, keep) expect_equal(nrow(snpInfo(hSub)), length(keep)) @@ -1362,7 +1366,7 @@ test_that(".subsetGenotypeHandle keeps PLINK2 reads correct for kept variants", expect_equal(unname(dosFull), unname(dosSub)) }) -test_that(".subsetGenotypeHandle is NULL-safe and a no-op when nothing dropped", { +test_that(".subsetGenotypeHandle is NULL-safe; a no-op when nothing dropped", { expect_null(pecotmr:::.subsetGenotypeHandle(NULL, TRUE)) h <- readGenotypeHandle( test_path("test_data/test_variants"), @@ -1512,8 +1516,12 @@ test_that("the panel's assay is delayed and its seed is the handle", { test_path("test_data", "test_variants"), format = "plink2" ) - # Equal, not identical: each read opens its own pgen pointer. - expect_equal(pecotmr:::.ldRefHandle(panel), handle) + # Equal, not identical: each read opens its own pgen pointer. The seed's + # handle keeps only the columns reading needs. + expect_equal( + pecotmr:::.ldRefHandle(panel), + pecotmr:::.readingHandle(handle) + ) }) test_that("a panel answers panel questions without the handle", { @@ -1758,7 +1766,8 @@ test_that("readGenotypes names its keyword sources, not `...`", { for (nm in sources) { err <- tryCatch( { - exec(readGenotypes, !!!set_names(list("nope"), nm)) + badArg <- set_names(list("nope"), nm) + exec(readGenotypes, !!!badArg) NULL }, error = function(e) conditionMessage(e) @@ -2172,7 +2181,7 @@ test_that("a VCF panel names its variants and records where it came from", { # A record keeps its own ID when it has one and a single ALT allele; # every other row is named by its alleles. expect_equal( - rr$SNP, + pecotmr:::.panelLabels(rr), c( "chr22:100:A:G", "rs2", @@ -2223,7 +2232,7 @@ test_that("vcfArgs reach the read of the records", { readGenotypes(vcf, vcfArgs = list(row.names = FALSE)) ) expect_equal( - SummarizedExperiment::rowRanges(panel)$SNP[2:3], + pecotmr:::.panelLabels(SummarizedExperiment::rowRanges(panel))[2:3], c("chr22:200:ACGTA:A", "chr22:202:G:T") ) }) @@ -2389,6 +2398,32 @@ test_that("a PLINK1 panel reads the dosages snpStats reads", { ) }) +test_that("a panel's alleles read in upper case whatever the file's case", { + # Alleles enter in upper case, as chromosomes enter in UCSC style, so a + # lowercase file names its variants as every other source does. toy_ref's + # labels are rsIDs on chromosome 22, so lowercasing its .bim lines + # changes only the alleles. + skip_if_not_installed("PlinkMatrix") + src <- str_remove( + system.file("extdata", "toy_ref.bed", package = "pecotmr"), + "\\.bed$" + ) + stem <- file.path(withr::local_tempdir(), "lower") + file.copy(str_c(src, ".bed"), str_c(stem, ".bed")) + file.copy(str_c(src, ".fam"), str_c(stem, ".fam")) + writeLines( + str_to_lower(readLines(str_c(src, ".bim"))), + str_c(stem, ".bim") + ) + alleles <- function(p) { + S4Vectors::mcols(SummarizedExperiment::rowRanges(p))[, c("A1", "A2")] + } + lower <- readGenotypes(plink1Prefix = stem) + upper <- readGenotypes(plink1Prefix = src) + expect_identical(alleles(lower), alleles(upper)) + expect_identical(rownames(lower), rownames(upper)) +}) + # ---- Per-chromosome sets --------------------------------------------------- test_that("a per-chromosome VCF, GDS or PLINK1 set stacks into one panel", { @@ -2542,6 +2577,50 @@ test_that(".updatePanel leaves a current panel, or no panel, as it is", { expect_identical(.updatePanel(plink2), plink2) }) +test_that(".updatePanel drops the copies of labels a saved panel kept", { + skip_if_not_installed("pgenlibr") + stem <- test_path("test_data", "test_variants") + plink2 <- readGenotypes(stem, format = "plink2") + saved <- .savedLabelledPanel( + plink2, + readGenotypeHandle(stem, format = "plink2") + ) + slim <- .updatePanel(saved) + expect_identical( + SummarizedExperiment::rowRanges(slim), + SummarizedExperiment::rowRanges(plink2) + ) + seed <- .panelSeed(slim) + expect_identical(names(snpInfo(.ghSeedHandle(seed))), "fileIdx") + expect_null(dimnames(seed)[[1L]]) + expect_identical(dimnames(slim), dimnames(plink2)) + expect_equal( + as.matrix(SummarizedExperiment::assay(slim)[1:5, ]), + as.matrix(SummarizedExperiment::assay(plink2)[1:5, ]) + ) + expect_identical(.updatePanel(slim), slim) + # A panel cut from a saved one keeps its rows and samples, in order. + cut <- saved[c(7L, 2L, 9L), 3:1] + slimCut <- .updatePanel(cut) + expect_null(dimnames(.panelSeed(slimCut))[[1L]]) + expect_identical(dimnames(slimCut), dimnames(cut)) + expect_equal( + as.matrix(SummarizedExperiment::assay(slimCut)), + as.matrix(SummarizedExperiment::assay(cut)) + ) +}) + +test_that(".updatePanel drops the row names of a VCF, GDS or PLINK1 seed", { + stem <- test_path("test_data", "test_variants") + plink1 <- readGenotypes(stem, format = "plink1") + slim <- .updatePanel(.savedLabelledPanel(plink1)) + expect_identical(.panelSeed(slim), .panelSeed(plink1)) + expect_identical( + SummarizedExperiment::rowRanges(slim), + SummarizedExperiment::rowRanges(plink1) + ) +}) + test_that(".updatePanel refuses a saved panel it cannot read again", { stem <- test_path("test_data", "test_variants") fresh <- readGenotypes(stem, format = "plink1") @@ -2590,3 +2669,26 @@ test_that(".readPvarTable declines what it cannot read as a table", { path <- .gio_pvar(c("#CHROM\tPOS\tID", "1\t10\tv1")) expect_null(pecotmr:::.readPvarTable(path)) }) + +test_that("readPvar gives upper-case alleles whichever way it reads", { + want <- tibble::tibble( + chrom = "1", + id = c("rs1", "rs2"), + pos = c(100L, 200L), + A2 = c("A", "C"), + A1 = c("G", "T") + ) + # A plain-text file with a header is read as a table; a multi-allelic + # variant's first ALT is its A1. + plain <- .gio_pvar(c( + "#CHROM\tPOS\tID\tREF\tALT", + "1\t100\trs1\ta\tg", + "1\t200\trs2\tc\tt,a" + )) + expect_equal(pecotmr:::readPvar(plain), want) + # A header-less one, in .bim column order, goes through pgenlibr. + skip_if_not_installed("pgenlibr") + headerless <- .gio_pvar(c("1\trs1\t0\t100\tg\ta", "1\trs2\t0\t200\tt\tc")) + expect_null(pecotmr:::.readPvarTable(headerless)) + expect_equal(pecotmr:::readPvar(headerless), want) +}) diff --git a/tests/testthat/test_h2Annotations.R b/tests/testthat/test_h2Annotations.R index f6a87644a..082dcea84 100644 --- a/tests/testthat/test_h2Annotations.R +++ b/tests/testthat/test_h2Annotations.R @@ -269,6 +269,58 @@ test_that("readAnnotations with LDSC annot file creates AnnotationMatrix", { }) +test_that("readAnnotations stores mostly-zero annotations sparse", { + skip_if_not_installed("rtracklayer") + bed_file <- tempfile(fileext = ".bed") + on.exit(unlink(bed_file), add = TRUE) + writeLines("chr1\t100\t500\tregion1", bed_file) + snp_gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges( + start = seq(50L, by = 100L, length.out = 40L), + width = 1 + ) + ) + result <- readAnnotations(c(enhancer = bed_file), snp_gr) + stored <- assay(result, "annotations") + expect_s4_class(stored, "dgCMatrix") + expect_equal(as.numeric(stored[, 1]), as.numeric(seq_len(40) %in% 2:5)) + expect_equal(colnames(stored), "enhancer") +}) + +test_that("an LDSC annot column is typed by its values", { + snp_gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = c(100, 200, 300), width = 1) + ) + annotFile <- function(score) { + f <- tempfile(fileext = ".annot") + write.table( + data.frame( + CHR = 1, + BP = c(100, 200, 300), + SNP = str_c("rs", 1:3), + CM = 0, + my_score = score + ), + f, + sep = "\t", + row.names = FALSE, + quote = FALSE + ) + f + } + binary <- readAnnotations(c(my_score = annotFile(c(1, 0, 1))), snp_gr) + expect_equal(SummarizedExperiment::colData(binary)$type, "binary") + continuous <- readAnnotations( + c(my_score = annotFile(c(0.2, 0.7, 1.5))), + snp_gr + ) + expect_equal(SummarizedExperiment::colData(continuous)$type, "continuous") + # Dense values are kept dense. + expect_true(is.matrix(assay(continuous, "annotations"))) +}) + test_that("readAnnotations uses the provided annotationMeta", { annot_df <- data.frame( CHR = c(1, 1), @@ -400,7 +452,8 @@ test_that("readAnnotations reads a BigWig file as a continuous annotation", { }) test_that(".readLdscAnnot errors when CHR/BP columns are absent", { - # The annotation column is present but the positional CHR/BP columns are not. + # The annotation column is present but the positional CHR/BP columns are + # not. annot_df <- data.frame( SNP = c("rs1", "rs2"), CM = 0, @@ -659,7 +712,7 @@ test_that("estimateH2 takes fineMappingAnnotations as candidates", { ref, method = method, annotations = annot - ))$z + ))[[1L]]$z expect_length(z, 2L) expect_true(all(is.finite(z)), info = method) } diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index 7f5810766..4680aa522 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -208,7 +208,7 @@ test_that("computeLdScores LdEigen returns a non-negative base_l2 column", { expect_true(all(result[, "base_l2"] >= 0)) }) -test_that("computeLdScores LdEigen with annotations returns base + annotation columns", { +test_that("computeLdScores(LdEigen) with annotations: base + annotations", { eigen_ref <- makeTestEigenRef() annot <- makeTestAnnotations() result <- computeLdScores(eigen_ref, annotations = annot) @@ -284,6 +284,42 @@ test_that("LD scores read from a panel match its blocks' stored LD", { ) }) +test_that("estimators read annotations stored sparse as they read dense", { + fx <- .h2PanelFixture() + storedScore <- buildLdScore(fx$ld, genome = "hg19") + storedEigen <- buildLdEigen(fx$ld, genome = "hg19") + annot <- .h2PanelAnnotations(storedScore) + sparse <- annot + SummarizedExperiment::assay(sparse, "annotations") <- methods::as( + SummarizedExperiment::assay(annot, "annotations"), + "CsparseMatrix" + ) + n <- 2000 + z <- .h2PanelZ(fx$ld, n, h2 = 0.5) + expect_equal( + computeLdScores(storedScore, annotations = sparse), + computeLdScores(storedScore, annotations = annot) + ) + runs <- list( + lder = list(pecotmr:::lderUnivariate, storedEigen), + gldsc = list(pecotmr:::gldscUnivariate, storedScore), + sldsc = list(pecotmr:::sldscUnivariate, storedScore), + hdl = list(pecotmr:::hdlUnivariate, storedEigen) + ) + # HDL warns on this small panel that its intercept sits at its bound; + # the estimates agree either way, which is what is checked here. + for (method in names(runs)) { + fn <- runs[[method]][[1L]] + ref <- runs[[method]][[2L]] + expect_equal( + suppressWarnings(fn(z, n, ref, sparse)), + suppressWarnings(fn(z, n, ref, annot)), + tolerance = 1e-10, + label = method + ) + } +}) + test_that("estimators read a panel's LD on demand as they read stored LD", { # The same blocks two ways: read from the genotype panel one block at a # time, and stored as LdMatrix blocks. The middle block has more variants @@ -307,8 +343,8 @@ test_that("estimators read a panel's LD on demand as they read stored LD", { for (method in names(runs)) { fn <- runs[[method]][[1L]] for (an in list(NULL, annot)) { - lazy <- fn(z, n, runs[[method]][[2L]], an, TRUE) - stored <- fn(z, n, runs[[method]][[3L]], an, TRUE) + lazy <- fn(z, n, runs[[method]][[2L]], an) + stored <- fn(z, n, runs[[method]][[3L]], an) expect_equal(lazy, stored, tolerance = 1e-8, label = method) } } @@ -353,8 +389,8 @@ test_that("estimators read a panel's LD on demand as they read stored LD", { } hdl <- pecotmr:::hdlUnivariate expect_equal( - suppressWarnings(hdl(z, n, lazyEigen, NULL, TRUE)), - suppressWarnings(hdl(z, n, storedEigen, NULL, TRUE)), + suppressWarnings(hdl(z, n, lazyEigen, NULL)), + suppressWarnings(hdl(z, n, storedEigen, NULL)), tolerance = 1e-6 ) # Stratified, this fixture (a 100-sample panel, so the intercept sits at @@ -362,7 +398,7 @@ test_that("estimators read a panel's LD on demand as they read stored LD", { # ridge: the two optima have the same likelihood to 1e-7 but sit apart # along it, so only the total heritability is pinned down. stratifiedH2 <- function(ref) { - suppressWarnings(hdl(z, n, ref, annot, TRUE))$h2 + suppressWarnings(hdl(z, n, ref, annot))$h2 } expect_equal( stratifiedH2(lazyEigen), @@ -384,13 +420,13 @@ test_that("estimators read a panel's LD on demand as they read stored LD", { # computeLdScores for LdScore # =========================================================================== -test_that("computeLdScores LdScore without annotations returns stored ld_scores", { +test_that("computeLdScores(LdScore) without annotations: stored ld_scores", { score_ref <- makeTestScoreRef() result <- computeLdScores(score_ref) expect_identical(result, mcols(score_ref)$ldScores) }) -test_that("computeLdScores LdScore with annotations but no ld_matrix_list errors", { +test_that("computeLdScores(LdScore) errors on annotations without matrices", { score_ref <- makeTestScoreRef(with_ld_matrices = FALSE) annot <- makeTestAnnotations() expect_error( @@ -446,9 +482,18 @@ test_that("h2EstimateToSldscTrait errors when enrichment is NULL", { ) }) -test_that("h2EstimateToSldscTrait creates 1-row dummy when annotationJackknifeCoefs is NULL", { +test_that("h2EstimateToSldscTrait converts one estimate", { + two <- c(makeTestH2Estimate(), `$<-`(makeTestH2Estimate(), "study", "b")) + expect_error(h2EstimateToSldscTrait(two), "holds 2 estimates") + expect_identical( + h2EstimateToSldscTrait(two[two$study == "b"]), + h2EstimateToSldscTrait(makeTestH2Estimate()) + ) +}) + +test_that("h2EstimateToSldscTrait makes a 1-row dummy for NULL jackknife", { h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) - h2_obj@annotationJackknifeCoefs <- NULL + h2_obj$jackknife <- list(NULL) result <- h2EstimateToSldscTrait(h2_obj) expect_equal(nrow(result$annotationJackknifeCoefs), 1) expect_equal(result$nBlocks, 1L) @@ -513,10 +558,29 @@ test_that("estimateH2 returns an H2Estimate for lder, gldsc and hdl", { expect_true(is.numeric(heritabilityInterceptSe(result)), info = method) expect_equal(methodNames(result), method, info = method) expect_equal(nSnps(result), nSnps(ss), info = method) - expect_equal(traitNames(result), "test", info = method) + expect_equal(studyName(result), "test", info = method) + expect_identical(traitNames(result), character(0), info = method) } }) +test_that("a genome-wide estimate is one row for the study", { + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) + res <- estimateH2(ss, ref, method = "lder") + expect_identical(length(res), 1L) + # It covers the whole reference, so its element holds no ranges; the row + # takes the reference's genome. + expect_length(res[[1]], 0L) + expect_identical( + unname(GenomeInfoDb::genome(res)), + unname(GenomeInfoDb::genome(ref)) + ) + expect_equal( + heritabilityEstimate(res), + lderUnivariate(z(ss), 50000, ref)$h2 + ) +}) + # =========================================================================== # estimateH2 input alignment # @@ -568,7 +632,7 @@ test_that("estimateH2 rejects a sumstats at different coordinates", { ) }) -test_that("estimateH2 rejects a sumstats holding the right variants in the wrong order", { +test_that("estimateH2 refuses sumstats with the right variants out of order", { ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef(ref) reordered <- .reposition( @@ -594,7 +658,7 @@ test_that("estimateH2 rejects annotations that do not cover the reference", { ) }) -test_that("estimateH2 rejects annotations at other coordinates or in another order", { +test_that("estimateH2 refuses annotations elsewhere or in another order", { ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef(ref) annot <- makeTestAnnotations() @@ -708,7 +772,7 @@ test_that("S-LDSC reports an enrichment table when stratified", { ) %in% names(enr) )) - expect_false(is.null(annotationJackknifeCoefs(res))) + expect_true(is.matrix(annotationJackknifeCoefs(res)[[1]])) }) test_that("S-LDSC requires an LdScore, not an LdEigen", { @@ -905,7 +969,7 @@ test_that("estimateH2 with a varY correction runs without error", { # computeLdScores for LdScore WITH annotations # =========================================================================== -test_that("computeLdScores LdScore with annotations and ld_matrix_list returns correct matrix", { +test_that("computeLdScores(LdScore) with annotations and matrices is right", { score_ref <- makeTestScoreRef(with_ld_matrices = TRUE) annot <- makeTestAnnotations() result <- computeLdScores(score_ref, annotations = annot) @@ -1333,13 +1397,11 @@ makeCoverageAnnot <- function( stringsAsFactors = FALSE ) if (nCand > 0L) { - cand <- exec( - cbind, - !!!map( - seq_len(nCand), - function(k) as.numeric(rbinom(n_snps, 1, 0.3 + 0.1 * k)) - ) + candidateCols <- map( + seq_len(nCand), + function(k) as.numeric(rbinom(n_snps, 1, 0.3 + 0.1 * k)) ) + cand <- exec(cbind, !!!candidateCols) mat <- cbind(mat, cand) meta <- rbind( meta, @@ -1359,8 +1421,7 @@ makeCoverageAnnot <- function( # its annotations take. An all-ones baseline makes the LDER and HDL # eigenvalue-score column the eigenvalue itself; for g-LDSC and S-LDSC it # would repeat the base LD score column and leave the design singular, so -# they take a half-on/half-off baseline instead. S-LDSC reports its local -# heritability per variant rather than per block (`perBlockLocal`). +# they take a half-on/half-off baseline instead. .h2Runs <- list( lder = list( fn = pecotmr:::lderUnivariate, @@ -1380,8 +1441,7 @@ makeCoverageAnnot <- function( sldsc = list( fn = pecotmr:::sldscUnivariate, ref = "ld_score_ref", - baseline = "spatial", - perBlockLocal = FALSE + baseline = "spatial" ) ) @@ -1416,7 +1476,6 @@ test_that("each univariate estimator returns a finite h2 and a positive SE", { "h2Se", "intercept", "interceptSe", - "local", "enrichment", "annotationJackknifeCoefs", "scoreStats" @@ -1443,20 +1502,6 @@ test_that("lderUnivariate intercept is near zero for well-calibrated data", { expect_true(abs(res$intercept) < 0.01) }) -test_that("each univariate estimator with local = TRUE returns per-block h2", { - for (method in names(.h2Runs)) { - if (isFALSE(.h2Runs[[method]]$perBlockLocal)) { - next - } - res <- .h2Run(method, dat, local = TRUE) - expect_true(is.data.frame(res$local), info = method) - expect_true( - all(c("blockId", "h2Local", "h2LocalSe") %in% colnames(res$local)), - info = method - ) - } -}) - # ============================================================================= # Stratified estimates # ============================================================================= @@ -1502,23 +1547,6 @@ test_that("each univariate estimator reports enrichment and score statistics", { } }) -test_that("each estimator with annotations and local = TRUE gives local h2", { - for (method in names(.h2Runs)) { - if (isFALSE(.h2Runs[[method]]$perBlockLocal)) { - next - } - annot <- .h2RunAnnot(method, dat_annot, 1L) - res <- .h2Run(method, dat_annot, annotations = annot, local = TRUE) - expect_true(is.data.frame(res$local), info = method) - expect_true( - all(c("blockId", "h2Local", "h2LocalSe") %in% colnames(res$local)), - info = method - ) - # One row per block - expect_equal(nrow(res$local), 5L, info = method) - } -}) - # --------------------------------------------------------------------------- # Stratified score helpers — multiple-candidate (cor) branch # --------------------------------------------------------------------------- @@ -1573,14 +1601,15 @@ test_that(".rmaMeta errors when means and ses differ in length", { }) # --------------------------------------------------------------------------- -# h2EstimateToSldscTrait — annotationJackknifeCoefs present but without column names +# h2EstimateToSldscTrait — annotationJackknifeCoefs present but without column +# names # --------------------------------------------------------------------------- -test_that("h2EstimateToSldscTrait assigns category names to unnamed annotationJackknifeCoefs", { +test_that("h2EstimateToSldscTrait names unnamed jackknife categories", { h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) - tb <- annotationJackknifeCoefs(h2_obj) + tb <- annotationJackknifeCoefs(h2_obj)[[1]] colnames(tb) <- NULL - h2_obj@annotationJackknifeCoefs <- tb + h2_obj$jackknife <- list(tb) result <- h2EstimateToSldscTrait(h2_obj) expect_equal( colnames(result$annotationJackknifeCoefs), @@ -1776,7 +1805,7 @@ test_that("lderUnivariate recovers a known h2 (deterministic, seed = 1)", { .h2MethodRef(d, m), method = m, annotations = annot - )))$z + )))[[1L]]$z }, numeric(1) ) @@ -2592,19 +2621,6 @@ test_that(".lderGetRes(twostage = FALSE) returns the free-intercept fit", { expect_true(is.finite(res$a)) }) -test_that(".lderLocalBlock reports NA for a block too small to fit", { - out <- pecotmr:::.lderLocalBlock( - list(lam = c(1, 2), x = c(0.5, 0.6)), - b = 7L, - N = 1000, - a = 1 - ) - # Fewer than 3 eigenvalues: a slope cannot be identified. - expect_equal(out$blockId, 7L) - expect_true(is.na(out$h2Local)) - expect_true(is.na(out$h2LocalSe)) -}) - test_that(".sldscBlockIndex errors when no block covers a variant", { n <- 6L snpInfo <- data.frame( @@ -2660,18 +2676,6 @@ test_that(".sldscIrwls derives its own starting weights when none are given", { expect_true(all(is.finite(fit$coef))) }) -test_that(".sldscLocal clamps a negative LD score to zero", { - out <- pecotmr:::.sldscLocal( - chi2 = c(1.2, 3.4), - baseScore = c(10, -2), - fit = list(tau = c(1e-5)) - ) - expect_equal(out$variantIdx, 1:2) - expect_equal(out$ldScore, c(10, -2)) - # A negative LD score cannot contribute negative heritability. - expect_equal(out$h2Local, c(1e-4, 0)) -}) - test_that("RmaOptions refuses the estimates and the estimator choice", { expect_error(RmaOptions(yi = 1), "the per-study estimates") expect_error(RmaOptions(sei = 1), "the per-study standard errors") @@ -2742,8 +2746,11 @@ test_that("estimateH2 reads a study split across LD blocks as one study", { ) ) expect_equal(nrow(split), 2L) + est <- estimateH2(split, ref, method = "lder") + # One estimate, one row, for the study. + expect_identical(length(est), 1L) expect_equal( - heritabilityEstimate(estimateH2(split, ref, method = "lder")), + heritabilityEstimate(est), heritabilityEstimate(estimateH2(ss, ref, method = "lder")) ) # Two studies still need one named. @@ -2758,3 +2765,353 @@ test_that("estimateH2 reads a study split across LD blocks as one study", { "`studyName` is required when the GwasSumStats has 2 studies" ) }) + +# ---- HDL-L: one locus's heritability with its own intercept ---------------- + +# Real genotypes from eqtlRegionExample: the LD from 150 of its 415 people and +# statistics simulated on the other 265, over 300 variants. +.hdlLocusFixture <- function(seed, h2) { + data(eqtlRegionExample, envir = environment()) + G <- eqtlRegionExample$X + af <- colMeans(G) / 2 + G <- G[, pmin(af, 1 - af) > 0.05] + set.seed(seed) + win <- G[, (seed - 1) * 300 + 1:300] + ref <- sample(nrow(win), 150) + ldFactor <- pecotmr:::.ldFactorFromDosage(win[ref, ]) + study <- setdiff(seq_len(nrow(win)), ref) + Xs <- scale(win[study, ]) + Xs[!is.finite(Xs)] <- 0 + gamma <- replace(numeric(300), sample(300, 5), rnorm(5)) + g <- as.numeric(Xs %*% gamma) + y <- g * sqrt(h2 / var(g)) + rnorm(length(g), sd = sqrt(1 - h2)) + corInput <- as.numeric(cor(Xs, y)) + list( + ldFactor = ldFactor, + R = crossprod(ldFactor) / (nrow(ldFactor) - 1), + corInput = replace(corInput, !is.finite(corInput), 0), + n = length(study) + ) +} + +test_that(".hdlLocusFit reproduces HDL.L()'s per-locus heritability", { + # Pinned reference values from HDL.L()'s own statements (the HDL + # repository's HDL/R/HDL.L.R: its log-likelihoods, LD score regression + # start, eigen cut and optimization loops) run on these three loci. + want <- c(0.0563749163361593, 0.1002563602000716, 0.1277057381167920) + h2 <- c(0.05, 0.1, 0.2) + for (i in 1:3) { + fx <- .hdlLocusFixture(i + 1L, h2[[i]]) + expect_equal( + pecotmr:::.hdlLocusFit(fx$corInput, list(R = fx$R), fx$n, 150L)$h2, + want[[i]], + tolerance = 1e-6 + ) + # The factor's eigenpairs come from its SVD, equal to rounding. + expect_equal( + pecotmr:::.hdlLocusFit( + fx$corInput, + list(ldFactor = fx$ldFactor), + fx$n, + 150L + )$h2, + want[[i]], + tolerance = 1e-6 + ) + } +}) + +test_that(".hdlLocusFit reports HDL.L()'s p-value and intercept", { + # Pinned reference values from the same HDL.L() statements on the same + # loci: its likelihood-ratio p-value against the intercept-only null, + # and the fitted intercept. + wantP <- c(5.50193943944049e-03, 1.17185324412135e-04, 7.62771871683717e-05) + wantIntercept <- c(0.781751722851809, 1.413136925604808, 1.165862452737627) + h2 <- c(0.05, 0.1, 0.2) + for (i in 1:3) { + fx <- .hdlLocusFixture(i + 1L, h2[[i]]) + fit <- pecotmr:::.hdlLocusFit(fx$corInput, list(R = fx$R), fx$n, 150L) + expect_equal(fit$p, wantP[[i]], tolerance = 1e-6) + expect_equal(fit$intercept, wantIntercept[[i]], tolerance = 1e-6) + } +}) + +test_that(".hdlLocusFit answers NA without signal, starts a flat locus at 0", { + fx <- .hdlLocusFixture(2L, 0.05) + # No fit beats the intercept-only null when every effect is zero. + expect_true(is.na( + pecotmr:::.hdlLocusFit(numeric(300), list(R = fx$R), fx$n, 150L)$h2 + )) + # One variant: every LD score is the same, so the regression has no + # slope to start h2 from. + expect_equal(pecotmr:::.hdlLocusLdscH2(0.1, list(R = matrix(1)), 100), 0) + # A monomorphic variant leaves the trace short of the variant count, so + # no eigenvalue reaches 99% of it and every one is kept. + expect_length( + pecotmr:::.hdlLocusEigen(list(R = diag(c(1, 1, 0))))$values, + 3L + ) +}) + +# ---- per-gene cis heritability: LAVA and FastHer ---- + +test_that(".cisH2Lava is LAVA's adjusted R^2 and F test, reference-corrected", { + fx <- .hdlLocusFixture(3L, 0.1) + z <- fx$corInput * sqrt(fx$n) + fit <- pecotmr:::.cisH2Lava( + z, + rep(fx$n, length(z)), + list(ldFactor = fx$ldFactor, nSamples = 150L) + ) + # LAVA's published estimator, through the matrix's own eigenpairs. + e <- eigen(fx$R, symmetric = TRUE) + lam <- e$values[e$values > 0] + K <- which(cumsum(lam) / sum(lam) >= 0.99)[[1L]] + r <- z / sqrt(z^2 + fx$n - 2) + delta <- crossprod(e$vectors[, seq_len(K)], r) / sqrt(lam[seq_len(K)]) + dtd <- sum(delta^2) + sigma <- (1 - dtd) / (fx$n - K - 1) + scale <- (150 - K - 1) / 149 + expect_equal(fit$nComponents, K) + expect_equal(fit$h2, (dtd - K * sigma) * scale, tolerance = 1e-8) + expect_equal( + fit$p, + pf(dtd / sigma * scale / K, K, fx$n - K - 1, lower.tail = FALSE), + tolerance = 1e-8 + ) +}) + +test_that(".cisH2Lava is NA with one LD component or contradicting LD", { + # Two copies of one variant hold all the variance in one component. + x <- c(1, -1, 2, 0, -2, 1, -1, 0) + fit <- pecotmr:::.cisH2Lava( + c(2, 2), + c(100, 100), + list(ldFactor = cbind(x, x), nSamples = 8L) + ) + expect_true(is.na(fit$h2) && is.na(fit$p)) + expect_equal(fit$nComponents, 1L) + # Uncorrelated variants whose correlations with the trait are each near + # 1: their squares sum past 1, which the LD rules out. + ldFactor <- cbind(c(1, 1, -1, -1), c(1, -1, 1, -1)) + fit <- pecotmr:::.cisH2Lava( + c(30, 30), + c(100, 100), + list(ldFactor = ldFactor, nSamples = 4L) + ) + expect_true(is.na(fit$h2) && is.na(fit$p)) +}) + +test_that(".cisH2FastHer is the individual-level maximum likelihood", { + # Standardized so that X'X = n R, X'y = sqrt(n) z and y'y = n, the + # summary-statistics likelihood is that of y ~ N(0, d (h2 X X' / m + + # (1 - h2) I)) itself. + set.seed(9) + n <- 300 + m <- 8 + X <- matrix(rnorm(n * m), n, m) %*% chol(0.5^abs(outer(1:m, 1:m, "-"))) + X <- scale(X) * sqrt(n / (n - 1)) + y <- as.vector(X %*% rnorm(m, sd = 0.15)) + rnorm(n) + y <- (y - mean(y)) / sqrt(mean((y - mean(y))^2)) + fit <- pecotmr:::.cisH2FastHer( + as.vector(crossprod(X, y)) / sqrt(n), + rep(n, m), + list(R = crossprod(X) / n) + ) + e <- eigen(tcrossprod(X) / m, symmetric = TRUE) + yt <- as.vector(crossprod(e$vectors, y)) + nll <- function(par) { + v <- par[[2L]] * (par[[1L]] * pmax(e$values, 0) + 1 - par[[1L]]) + sum(log(v) + yt^2 / v) / 2 + } + opt <- optim( + c(0.3, 1), + nll, + method = "L-BFGS-B", + lower = c(1e-9, 1e-6), + upper = c(1 - 1e-9, 10), + control = list(factr = 1e2, pgtol = 0) + ) + expect_equal(fit$h2, opt$par[[1L]], tolerance = 1e-5) + expect_equal(fit$scale, opt$par[[2L]], tolerance = 1e-5) + expect_equal(fit$nComponents, m) + expect_gt(fit$h2Se, 0) +}) + +test_that(".cisH2FastHer is NA where its likelihood is undefined", { + set.seed(10) + ldFactor <- matrix(rnorm(60 * 30), 60, 30) + # A reference of rank 30 for a study of 20. + expect_true(is.na( + pecotmr:::.cisH2FastHer( + rnorm(30), + rep(20, 30), + list(ldFactor = ldFactor) + )$h2 + )) + # Statistics larger than the sample size allows. + expect_true(is.na( + pecotmr:::.cisH2FastHer( + rep(20, 30), + rep(100, 30), + list(ldFactor = ldFactor) + )$h2 + )) +}) + +# ---- estimateH2 on QTL summary statistics: one cis estimate per gene ---- + +# qtlSumStatsExample rebuilt from its parts, with the entry's sample sizes, +# the LD reference, the QC record or the trait position replaced. +.cisH2Example <- function( + N = NULL, + ref = NULL, + qcOptions = list(qc = "ok"), + traitPos = NULL +) { + data(qtlSumStatsExample, envir = environment()) + gr <- qtlSumStatsExample[[1]] + if (!is.null(N)) { + S4Vectors::mcols(gr)$N <- N + } + QtlSumStats( + studyName = "study1", + context = "brain", + trait = "ENSG_example", + entry = list(gr), + genome = "hg19", + ldReference = ref %||% ldReference(qtlSumStatsExample)[[1]], + qcOptions = qcOptions, + traitPos = traitPos + ) +} + +test_that("estimateH2 gives each QtlSumStats row its cis estimate", { + x <- .cisH2Example() + fits <- map( + c("lava", "hdlL", "fastHer"), + function(m) estimateH2(x, method = m) + ) + for (fit in fits) { + expect_s4_class(fit, "H2Estimate") + expect_identical(length(fit), 1L) + expect_identical(as.character(fit$trait), "ENSG_example") + expect_identical(nSnps(fit), 200L) + expect_true(is.finite(heritabilityEstimate(fit))) + # The element is the window the estimate covers: the row's region. + expect_identical( + IRanges::ranges(fit[[1]]), + IRanges::ranges(x$region) + ) + expect_identical(unname(GenomeInfoDb::genome(fit)), "hg19") + } + lava <- fits[[1L]] + # LAVA reports its estimate past K = 0.1 n (68 of 165 here) with its F + # test, and no standard error. + expect_identical(methodNames(lava), "lava") + expect_gt(lava$n_components / 165, 0.1) + expect_true(is.finite(lava$p_value) && is.na(lava$h2_se)) + hdl <- fits[[2L]] + expect_true(is.finite(hdl$p_value) && is.finite(hdl$intercept)) + expect_true(is.na(hdl$h2_se) && is.na(hdl$scale)) + fastHer <- fits[[3L]] + expect_true(is.finite(fastHer$h2_se) && is.finite(fastHer$scale)) + expect_true(is.na(fastHer$p_value)) + # The default is LAVA. + expect_identical(estimateH2(x), lava) + # One estimate per selected row. + two <- c(x, `$<-`(x, "trait", "ENSG_other")) + both <- estimateH2(two) + expect_identical(as.character(both$trait), c("ENSG_example", "ENSG_other")) + expect_equal(heritabilityEstimate(both), rep(heritabilityEstimate(lava), 2)) + expect_identical( + as.character(estimateH2(two, traitId = "ENSG_other")$trait), + "ENSG_other" + ) +}) + +test_that("estimateH2 analyses a row over its cis window", { + tp <- GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(15200000L, width = 1L) + ) + x <- .cisH2Example(traitPos = tp) + fit <- estimateH2(x, cisWindow = 1e5) + expect_identical( + IRanges::ranges(fit[[1]]), + IRanges::IRanges(15100000L, 15300000L) + ) + expect_lt(nSnps(fit), 200L) + expect_error( + estimateH2(.cisH2Example(), cisWindow = 1e5), + "trait position" + ) + # A window between two variants holds none: NA, with a warning. + pos <- GenomicRanges::start(x[[1]]) + gap <- which.max(diff(pos)) + between <- GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(pos[[gap]] + diff(pos)[[gap]] %/% 2L, width = 1L) + ) + empty <- expect_warning( + estimateH2(.cisH2Example(traitPos = between), cisWindow = 10), + "1 of 1 gene\\(s\\) hold no variants in their window" + ) + expect_identical(nSnps(empty), 0L) + expect_true(is.na(heritabilityEstimate(empty))) + expect_identical(IRanges::width(empty[[1]]), 21L) +}) + +test_that("estimateH2 marks the genes FastHer's likelihood cannot fit", { + # Twenty study samples against a 165-sample reference. + x <- .cisH2Example(N = 20L) + out <- expect_warning( + estimateH2(x, method = "fastHer"), + "FastHer's likelihood is undefined for 1 of 1 gene" + ) + expect_true(is.na(heritabilityEstimate(out))) +}) + +test_that("estimateH2 refuses what a cis estimate cannot be made from", { + x <- .cisH2Example() + expect_error( + estimateH2(.cisH2Example(qcOptions = list())), + "has no QC record" + ) + expect_error( + estimateH2(x, traitId = "ENSG_other"), + "no rows matched" + ) + # Any annotations are refused, before they are read. + expect_error( + estimateH2(x, annotations = list()), + "takes no `annotations`" + ) + data(qtlSumStatsExample, envir = environment()) + gr <- qtlSumStatsExample[[1]] + noRef <- QtlSumStats( + studyName = "study1", + context = "brain", + trait = "ENSG_example", + entry = list(gr), + genome = "hg19", + qcOptions = list(qc = "ok") + ) + expect_error(estimateH2(noRef), "the row has no LD reference") + # LAVA and HDL-L read the reference's sample size; FastHer does not. + R <- pecotmr:::.ldFromRef( + ldReference(qtlSumStatsExample)[[1]], + gr$SNP, + "test" + ) + unsized <- .cisH2Example(ref = LdMatrix(R)) + for (m in c("lava", "hdlL")) { + expect_error( + estimateH2(unsized, method = m), + "reads the LD reference's sample size" + ) + } + expect_true(is.finite( + heritabilityEstimate(estimateH2(unsized, method = "fastHer")) + )) +}) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index a3432f08f..651ad6750 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -1,9 +1,10 @@ -# Tests for R/jointEngine.R — the unified joint-analysis engine. A joint fit over -# N conditions is SLICED into N per-context rows (real study/context/trait) that -# carry the ";"-joined co-fit members in jointStudies/jointContexts/jointTraits -# as provenance — exactly like running the univariate method per context, except -# the per-context rows share PIP/CS (fm) / the joint fit (twas). The fits are -# mocked so these assert the engine wiring (per-context expansion), not the fit. +# Tests for R/jointEngine.R — the unified joint-analysis engine. A joint fit +# over N conditions is SLICED into N per-context rows (real study/context/trait) +# that carry the ";"-joined co-fit members in +# jointStudies/jointContexts/jointTraits as provenance — exactly like running +# the univariate method per context, except the per-context rows share PIP/CS +# (fm) / the joint fit (twas). The fits are mocked so these assert the engine +# wiring (per-context expansion), not the fit. .je_mkGroup <- function(tid, n = 10L) { X <- matrix( @@ -115,8 +116,8 @@ test_that(".runJointCell: cross-context FM expands to per-context rows", { test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { # The joint engine's fitJointGroup frame does not lexically see the pipeline # method's fullFit params, so they must ride the FmJointPipeline config. - # Assert the three flags reach .fmPostprocessOne verbatim (buildTopLoci's own - # fullFit column construction is covered in test_fineMappingWrappers.R). + # Assert the three flags reach .fmPostprocessOne verbatim (buildTopLoci's + # own fullFit column construction is covered in test_fineMappingWrappers.R). set.seed(1) cell <- .je_synthCell(list(.je_mkGroup("G1"))) pipe <- new( @@ -186,7 +187,7 @@ test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { expect_true(isTRUE(captured$includeAllCs)) # keep filtered-out CS }) -test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", { +test_that(".runJointCell: cross-context FM uses the per-fold mr.mash prior", { set.seed(2) cell <- .je_synthCell(list(.je_mkGroup("G1"))) pipe <- new( @@ -202,7 +203,8 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", ) # Prior mr.mash CV payload. Looked up by the FIXED axes (study=S, trait=G1) - # with context match-any, so a per-context OR a legacy "joint" row both match. + # with context match-any, so a per-context OR a legacy "joint" row both + # match. U <- list(K = diag(2)) fp <- list( dataDrivenPriorMatrices = list(U = U, w = c(K = 1)), @@ -280,7 +282,8 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) # per-context rows - # Per-fold priors built (one per fold) + threaded into CV, sharing the folds. + # Per-fold priors built (one per fold) + threaded into CV, sharing the + # folds. expect_false(is.null(captured$mvPriorCv)) expect_equal(names(captured$mvPriorCv), c("1", "2")) expect_identical(captured$samplePartition, sp) @@ -370,7 +373,7 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", ) } -test_that(".runJointCell: cross-context twas expands to per-context weight vectors", { +test_that(".runJointCell: cross-context TWAS gives per-context weights", { set.seed(3) cell <- .je_synthCell(list(.je_mkGroup("G1"))) pipe <- new( @@ -408,7 +411,7 @@ test_that(".runJointCell: cross-context twas expands to per-context weight vecto expect_false(is.null(methodFits(pecotmr:::.collectionEntry(res, 1L)))) }) -test_that(".runJointCell: cross-context twas attaches per-condition CV slices", { +test_that(".runJointCell: cross-context TWAS attaches per-condition CV", { set.seed(4) cell <- .je_synthCell(list(.je_mkGroup("G1"))) pipe <- new( @@ -437,14 +440,15 @@ test_that(".runJointCell: cross-context twas attaches per-condition CV slices", ) expect_equal(nrow(res), 2L) cv <- cvResult(pecotmr:::.collectionEntry(res, 1L)) - expect_equal(names(cv$foldFits), c("fold_1", "fold_2")) # shared per-fold fits + # shared per-fold fits + expect_equal(names(cv$foldFits), c("fold_1", "fold_2")) expect_false(is.null(cv$predictions)) # this context's slice expect_false(is.null(cv$samplePartition)) # per-context vector expect_false(is.matrix(weights(pecotmr:::.collectionEntry(res, 1L)))) }) -test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", { +test_that(".runJointCell: cross-context TWAS CV-only rows (no full fit)", { set.seed(5) cell <- .je_synthCell(list(.je_mkGroup("G1"))) pipe <- new( @@ -519,7 +523,7 @@ test_that(".runJointCell: cross-context twas CV-only rows (fitFullData=FALSE)", ) } -test_that(".runJointCell: cross-context FM sumstats (mvsusie_rss) -> per-context", { +test_that(".runJointCell: cross-context FM sumstats -> per-context rows", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( .ldFromRef = .je_mockSsLd, @@ -553,10 +557,11 @@ test_that(".runJointCell: cross-context FM sumstats (mvsusie_rss) -> per-context expect_equal(nrow(res), 2L) expect_equal(as.character(res$context), c("c1", "c2")) expect_equal(as.character(res$jointContexts), c("c1;c2", "c1;c2")) - expect_equal(captured$N, 110) # median(c(100, 120)) passed once to mvsusie_rss + # median(c(100, 120)) passed once to mvsusie_rss + expect_equal(captured$N, 110) }) -test_that(".runJointCell: cross-context twas sumstats (mr.mash.rss) -> per-context", { +test_that(".runJointCell: cross-context TWAS sumstats -> per-context rows", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( .ldFromRef = .je_mockSsLd, @@ -595,7 +600,7 @@ test_that(".runJointCell: cross-context twas sumstats (mr.mash.rss) -> per-conte expect_false(is.null(methodFits(pecotmr:::.collectionEntry(res, 1L)))) }) -test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regression)", { +test_that("fitJointGroup(SumStats, Twas): real mr.mash.rss reads stat$n", { skip_if_not_installed("mr.mashr") # The sibling tests above mock mrmashRssWeights, so the real reader # (.mrmashRssStats, which keys on stat$n) was never exercised. The method @@ -669,7 +674,7 @@ test_that(".lookupJointCell: present cells resolve, absent cells error", { # ---- cross-study pattern (study jointed; sumstats-only) --------------------- -test_that(".runJointCell: cross-study (twas sumstats) -> per-study rows + jointStudies", { +test_that(".runJointCell: cross-study TWAS -> per-study rows, jointStudies", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( .ldFromRef = .je_mockSsLd, @@ -731,7 +736,8 @@ test_that(".runJointCell: cross-study (twas sumstats) -> per-study rows + jointS ) expect_s4_class(res, "TwasWeights") expect_equal(nrow(res), 2L) - expect_equal(as.character(res$study), c("S1", "S2")) # study is the jointed axis + # study is the jointed axis + expect_equal(as.character(res$study), c("S1", "S2")) expect_equal(as.character(res$context), c("brain", "brain")) expect_equal(as.character(res$trait), c("G1", "G1")) expect_equal(as.character(res$jointStudies), c("S1;S2", "S1;S2")) @@ -802,7 +808,8 @@ test_that(".runJointCell: composed (context + trait vary) -> per-tuple rows", { expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 3L) # one row per tuple expect_equal(as.character(res$study), rep("S", 3L)) # constant -> fixed - expect_equal(as.character(res$context), c("c1", "c1", "c2")) # real per-tuple + # real per-tuple + expect_equal(as.character(res$context), c("c1", "c1", "c2")) expect_equal(as.character(res$trait), c("gA", "gB", "gA")) # Both varying axes carry their provenance member list on every row. expect_equal(as.character(res$jointContexts), rep("c1;c2", 3L)) @@ -975,7 +982,7 @@ test_that("fitJointGroup(Individual, Fm): fsusie keeps one entry", { expect_equal(entries[[1L]]@susieFit$trait_positions, c(100, 200)) }) -test_that("fitJointGroup(Individual, Fm): fsusie without pos errors; unknown token errors", { +test_that("joint FM refuses fsusie without pos and an unknown token", { X <- matrix( 0, 6, @@ -1002,7 +1009,7 @@ test_that("fitJointGroup(Individual, Fm): fsusie without pos errors; unknown tok ) }) -test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple rows", { +test_that(".runJointCell: composed sumstats -> per-tuple rows", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( .ldFromRef = .je_mockSsLd, @@ -1132,7 +1139,7 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro }) } -test_that(".twasEnsembleLayer: >= 2 methods passing -> per-condition ensemble entries", { +test_that(".twasEnsembleLayer: 2+ passing methods -> per-condition ensembles", { set.seed(1) g <- .je_ensGroup() pte <- list( @@ -1160,7 +1167,7 @@ test_that(".twasEnsembleLayer: >= 2 methods passing -> per-condition ensemble en expect_equal(sum(coef), 1, tolerance = 1e-6) }) -test_that(".twasEnsembleLayer: < 2 methods pass the R^2 cutoff -> NULL (skip)", { +test_that(".twasEnsembleLayer: under 2 methods past the R^2 cutoff -> NULL", { set.seed(2) g <- .je_ensGroup() pte <- list( @@ -1185,7 +1192,7 @@ test_that(".twasEnsembleLayer: < 2 methods pass the R^2 cutoff -> NULL (skip)", # ---- engine twas fitter (fitJointGroup on a TwasJointPipeline) -------------- -test_that("fitJointGroup(twas): leakage warning when a full-data mr.mash prior is reused across folds", { +test_that("joint TWAS warns of leakage reusing a full-data mr.mash prior", { set.seed(3) g <- .je_mkGroup("G1") pipe <- new( @@ -1221,7 +1228,7 @@ test_that("fitJointGroup(twas): leakage warning when a full-data mr.mash prior i ) }) -test_that("fitJointGroup(twas): spike-and-slab pi is estimated from an internal mr.ash fit", { +test_that("joint TWAS estimates spike-and-slab pi from an internal mr.ash", { set.seed(4) n <- 30L X <- matrix( @@ -1280,7 +1287,7 @@ test_that("fitJointGroup(twas): spike-and-slab pi is estimated from an internal expect_equal(as.numeric(capturedPi), 1 - 0.8, tolerance = 1e-8) }) -test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (handoff, no re-CV)", { +test_that("joint TWAS: an FM-derived method reuses fine-mapping's CV", { set.seed(5) g <- .je_mkGroup("G1") # 2 conditions (c1, c2) pipe <- new( @@ -1358,9 +1365,10 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand # ----------------------------------------------------------------------------- # The dispatch table stores each enumerator in a JointDispatchCell@enumerate # slot; the pipeline reaches them via `cell@enumerate(...)`. covr cannot trace a -# function invoked through such a stored reference, so these call the enumerators -# DIRECTLY (pecotmr:::.enum*) with the per-group X/Y/Z builders mocked, asserting -# the enumeration wiring (scope gating + per-group conditions). +# function invoked through such a stored reference, so these call the +# enumerators DIRECTLY (pecotmr:::.enum*) with the per-group X/Y/Z builders +# mocked, asserting the enumeration wiring (scope gating + per-group +# conditions). # ============================================================================= # A QtlSumStats-shaped data.frame: the sumstat enumerators only touch @@ -1424,6 +1432,12 @@ test_that("fitJointGroup(twas): FM-derived method reuses fine-mapping's CV (hand ) } +# An individual-level enumerator's units built into the groups the engine +# fits, as .runJointCell() builds them one unit at a time. +.je_build <- function(units) { + pecotmr:::.jeConcat(map(units, pecotmr:::.unitGroups)) +} + test_that(".enumCrossContextIndividual: one group per trait in >= 2 contexts", { scope <- list( studies = "S", @@ -1464,14 +1478,14 @@ test_that(".enumCrossContextIndividual: one group per trait in >= 2 contexts", { }, .package = "pecotmr" ) - g <- pecotmr:::.enumCrossContextIndividual(NULL, scope) + g <- .je_build(pecotmr:::.enumCrossContextIndividual(NULL, scope)) expect_length(g, 1L) # only G1 survives expect_s4_class(g[[1L]], "IndividualJointGroup") expect_equal(as.character(.jgConditions(g[[1L]])$context), c("c1", "c2")) expect_equal(as.character(.jgConditions(g[[1L]])$trait), c("G1", "G1")) }) -test_that(".enumCrossContextIndividual: study not in scope / < 2 contexts -> empty", { +test_that(".enumCrossContextIndividual: out-of-scope, under 2 contexts: none", { local_mocked_bindings(studyName = function(data) "S", .package = "pecotmr") expect_length( pecotmr:::.enumCrossContextIndividual( @@ -1493,7 +1507,7 @@ test_that(".enumCrossContextIndividual: study not in scope / < 2 contexts -> emp ) }) -test_that(".enumCrossContextSumstats: groups per (study, trait) with >= 2 contexts", { +test_that(".enumCrossContextSumstats groups study, trait with 2+ contexts", { df <- .je_ssDf(studies = "S", contexts = c("c1", "c2"), traits = "t1") scope <- list( studies = "S", @@ -1519,7 +1533,8 @@ test_that(".enumCrossContextSumstats: < 2 contexts and < 2 tuple rows skip", { .ldFromRef = .je_mockLd, .package = "pecotmr" ) - # study scoped to two contexts but only one row present -> < 2 tupleRows skip + # study scoped to two contexts but only one row present -> < 2 tupleRows + # skip df <- .je_ssDf(studies = "S", contexts = "c1", traits = "t1") scope <- list( studies = "S", @@ -1536,7 +1551,7 @@ test_that(".enumCrossContextSumstats: < 2 contexts and < 2 tuple rows skip", { expect_length(pecotmr:::.enumCrossContextSumstats(df, scope2), 0L) }) -test_that(".enumCrossTraitIndividual: one group per context with >= 2 traits + pos", { +test_that(".enumCrossTraitIndividual: a group per context with 2+ traits", { scope <- list( studies = "S", contexts = list(S = c("c1", "c2")), @@ -1577,7 +1592,7 @@ test_that(".enumCrossTraitIndividual: one group per context with >= 2 traits + p }, .package = "pecotmr" ) - g <- pecotmr:::.enumCrossTraitIndividual(NULL, scope) + g <- .je_build(pecotmr:::.enumCrossTraitIndividual(NULL, scope)) expect_length(g, 1L) expect_equal(as.character(.jgConditions(g[[1L]])$context), c("c1", "c1")) expect_equal(as.character(.jgConditions(g[[1L]])$trait), c("G1", "G2")) @@ -1596,7 +1611,7 @@ test_that(".enumCrossTraitIndividual: study not in scope -> empty", { ) }) -test_that(".enumCrossTraitSumstats: groups per (study, context) with >= 2 traits", { +test_that(".enumCrossTraitSumstats groups study, context with 2+ traits", { df <- .je_ssDf(studies = "S", contexts = "c1", traits = c("t1", "t2")) scope <- list( studies = "S", @@ -1617,7 +1632,7 @@ test_that(".enumCrossTraitSumstats: groups per (study, context) with >= 2 traits expect_length(pecotmr:::.enumCrossTraitSumstats(df1, scope), 0L) }) -test_that(".enumCrossStudySumstats: group per (context, trait) in >= 2 studies", { +test_that(".enumCrossStudySumstats groups context, trait in 2+ studies", { df <- .je_ssDf(studies = c("S1", "S2"), contexts = "c1", traits = "t1") scope <- list( studies = c("S1", "S2"), @@ -1642,7 +1657,7 @@ test_that(".enumCrossStudySumstats: group per (context, trait) in >= 2 studies", expect_length(pecotmr:::.enumCrossStudySumstats(df, scope1), 0L) }) -test_that(".enumComposedIndividual: one group joining every (context, trait) tuple", { +test_that(".enumComposedIndividual: one group of every (context, trait)", { scope <- list( studies = "S", contexts = list(S = c("c1", "c2")), @@ -1742,16 +1757,17 @@ test_that(".enumTopPcIndividual enumerates only the studies in scope", { .package = "pecotmr" ) scope <- list(studies = "study1", contexts = list(study1 = c("a", "b"))) - expect_identical( - pecotmr:::.enumTopPcIndividual(qd, scope), - list("a", "b") - ) + # One unit per context, built only when the engine reaches it. + units <- pecotmr:::.enumTopPcIndividual(qd, scope) + expect_length(units, 2L) + expect_length(seen, 0L) + expect_identical(.je_build(units), list("a", "b")) expect_identical(seen$a$study, "study1") # The joint engine's own phenotype QC when the run supplied none. expect_identical(seen$a$filter$naAction, "drop") }) -test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait)", { +test_that(".enumUnivariateIndividual: a 1-condition group per context, trait", { scope <- list( studies = "S", contexts = list(S = c("c1", "c2")), @@ -1787,7 +1803,7 @@ test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait) }, .package = "pecotmr" ) - g <- pecotmr:::.enumUnivariateIndividual(NULL, scope) + g <- .je_build(pecotmr:::.enumUnivariateIndividual(NULL, scope)) expect_length(g, 4L) # 2 ctx x 2 traits expect_true(all( map_int(g, function(x) nrow(.jgConditions(x))) == 1L @@ -1829,7 +1845,10 @@ test_that(".enumUnivariateIndividual: too few shared samples skips the tuple", { }, .package = "pecotmr" ) - expect_length(pecotmr:::.enumUnivariateIndividual(NULL, scope), 0L) + expect_length( + .je_build(pecotmr:::.enumUnivariateIndividual(NULL, scope)), + 0L + ) }) test_that(".enumUnivariateIndividual: study not in scope -> empty", { @@ -1914,7 +1933,7 @@ test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { # fitJointGroup branches not covered by the happy-path tests above # ============================================================================= -test_that("fitJointGroup(Individual, Fm): fsusie honest per-fold CV is attached", { +test_that("fitJointGroup(Individual, Fm) attaches fsusie's per-fold CV", { set.seed(20) n <- 8L X <- matrix( @@ -1973,7 +1992,7 @@ test_that("fitJointGroup(Individual, Fm): fsusie honest per-fold CV is attached" expect_length(entries, 1L) }) -test_that("fitJointGroup(Individual, Fm): SER pre-screen skips when < 2 survivors", { +test_that("fitJointGroup(Individual, Fm): SER screen skips under 2 survivors", { g <- .je_mkGroup("G1") pipe <- new("FmJointPipeline", config = list(coverage = 0.95, verbose = 1)) local_mocked_bindings( @@ -1988,7 +2007,7 @@ test_that("fitJointGroup(Individual, Fm): SER pre-screen skips when < 2 survivor expect_true(all(map_lgl(entries, is.null))) # all-NULL (skipped) }) -test_that("fitJointGroup(Individual, Fm): SER pre-screen keeps a subset of conditions", { +test_that("fitJointGroup(Individual, Fm): SER screen keeps some conditions", { set.seed(21) n <- 10L X <- matrix( @@ -2024,7 +2043,8 @@ test_that("fitJointGroup(Individual, Fm): SER pre-screen keeps a subset of condi ) local_mocked_bindings( .fmScreenActive = function(cut) TRUE, - .fmSerScreenColumns = function(X, Y, cut) c(TRUE, FALSE, TRUE), # drop c2 + # drop c2 + .fmSerScreenColumns = function(X, Y, cut) c(TRUE, FALSE, TRUE), fitMvsusie = function(...) list(), .fmPostprocessOne = .je_mockPostprocess, .package = "pecotmr" @@ -2051,7 +2071,7 @@ test_that("fitJointGroup(SumStats, Fm): fsusie and unknown tokens error", { ) }) -test_that("fitJointGroup(SumStats, Fm): a reweighted-prior residual variance is threaded", { +test_that("fitJointGroup(SumStats, Fm) passes a reweighted residual variance", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( .ldFromRef = .je_mockSsLd, @@ -2083,7 +2103,7 @@ test_that("fitJointGroup(SumStats, Fm): a reweighted-prior residual variance is expect_false(is.null(captured)) # residual_variance set }) -test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { +test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b pi", { set.seed(22) n <- 30L X <- matrix( @@ -2119,15 +2139,15 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { estimatePi = TRUE ) ) - capturedProbIn <- NULL + capturedPi <- NULL local_mocked_bindings( mrashWeights = function(X, y, ...) { out <- matrix(0.05, ncol(X), 1L, dimnames = list(colnames(X), NULL)) attr(out, "fit") <- list(pi = c(0.7, 0.2, 0.1)) out }, - bayesBWeights = function(X, y, probIn, ...) { - capturedProbIn <<- probIn + bayesBWeights = function(X, y, pi, ...) { + capturedPi <<- pi matrix(0, ncol(X), 1L, dimnames = list(colnames(X), NULL)) }, .package = "pecotmr" @@ -2138,10 +2158,73 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { "bayesB", list(methodList = list(bayes_b_weights = list())) ) - expect_equal(as.numeric(capturedProbIn), 1 - 0.7, tolerance = 1e-8) + expect_equal(as.numeric(capturedPi), 1 - 0.7, tolerance = 1e-8) }) -test_that("fitJointGroup(SumStats, twas): a vector weight without rownames falls back to Z rows", { +test_that("fitJointGroup(twas): a method's own arguments reach its fit", { + # They sit under the method's list key (bayes_b_weights), not its + # engine key (bayesB_weights), and were looked up only under the latter, + # so every multi-word method silently lost them. A pi the caller set + # also wins over the estimate, which then needs no mr.ash fit. + set.seed(22) + n <- 30L + X <- matrix( + rnorm(n * 3), + n, + 3, + dimnames = list( + paste0("s", seq_len(n)), + sprintf("chr1:%d:A:G", 100L * (1:3)) + ) + ) + Y <- matrix(rnorm(n), n, 1, dimnames = list(paste0("s", seq_len(n)), "c1")) + g <- new( + "IndividualJointGroup", + conditions = data.frame( + study = "S", + context = "c1", + trait = "g", + stringsAsFactors = FALSE + ), + X = X, + Y = Y + ) + pipe <- new( + "TwasJointPipeline", + config = list( + crossValidationParam = list( + folds = 0L, + threads = 1, + maxVariants = -1 + ), + ensembleParam = list(enabled = FALSE), + estimatePi = TRUE + ) + ) + capturedPi <- NULL + local_mocked_bindings( + mrashWeights = function(X, y, ...) { + stop("no mr.ash fit is needed for a caller's pi") + out <- matrix(0.05, ncol(X), 1L, dimnames = list(colnames(X), NULL)) + attr(out, "fit") <- list(pi = c(0.7, 0.2, 0.1)) + out + }, + bayesBWeights = function(X, y, pi, ...) { + capturedPi <<- pi + matrix(0, ncol(X), 1L, dimnames = list(colnames(X), NULL)) + }, + .package = "pecotmr" + ) + pecotmr:::fitJointGroup( + g, + pipe, + "bayesB", + list(methodList = list(bayes_b_weights = list(pi = 0.3))) + ) + expect_equal(capturedPi, 0.3) +}) + +test_that("joint sumstat TWAS: an unnamed weight vector takes Z's rows", { # The group carries the LD reference; supply the matrix it derives. local_mocked_bindings( .ldFromRef = .je_mockSsLd, @@ -2188,7 +2271,7 @@ test_that(".runJointCell: empty enumeration -> NULL", { expect_null(pecotmr:::.runJointCell(emptyCell, pipe, NULL, NULL, "mvsusie")) }) -test_that(".runJointCell: a fitter returning all-NULL entries yields no rows -> NULL", { +test_that(".runJointCell: a fitter's all-NULL entries give no rows: NULL", { cell <- .je_synthCell(list(.je_mkGroup("G1"))) pipe <- new("FmJointPipeline", config = list(coverage = 0.95)) local_mocked_bindings( @@ -2205,7 +2288,7 @@ test_that(".runJointCell: a fitter returning all-NULL entries yields no rows -> expect_null(pecotmr:::.runJointCell(cell, pipe, NULL, NULL, "mvsusie")) }) -test_that(".runJointCell: twas ensemble layer adds 'ensemble' rows on top of >= 2 methods", { +test_that(".runJointCell adds 'ensemble' rows on top of 2+ TWAS methods", { set.seed(30) cell <- .je_synthCell(list(.je_ensGroup(n = 40L, nCond = 2L))) pipe <- new( @@ -2240,7 +2323,7 @@ test_that(".runJointCell: twas ensemble layer adds 'ensemble' rows on top of >= tokens = c("lasso", "enet") ) expect_s4_class(res, "TwasWeights") - expect_true("ensemble" %in% as.character(res$method)) + expect_true("ensemble" %in% methodNames(res)) }) test_that(".twasEnsembleLayer: entries lacking CV predictions are skipped", { @@ -2296,7 +2379,7 @@ test_that(".twasEnsembleLayer: ensembleWeights returning NULL -> NULL entry", { expect_true(all(map_lgl(ens, is.null))) }) -test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's variant ids", { +test_that(".twasEnsembleLayer names unnamed weights by a method's variants", { set.seed(33) g <- .je_ensGroup(nCond = 1L) pte <- list( @@ -2313,7 +2396,8 @@ test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's alpha ) { list( - ensembleTwasWeights = as.numeric(rep(0.1, ncol(.jgX(g)))), # no names + # no names + ensembleTwasWeights = as.numeric(rep(0.1, ncol(.jgX(g)))), methodCoef = c(0.5, 0.5), methodPerformance = c(0.8, 0.7) ) @@ -2341,14 +2425,15 @@ test_that(".twasEnsembleLayer: unnamed ensemble weights fall back to a method's # Small slicers, .jointTwasCvResult, .twasFmHandoffCv, construct, .runJointSpecs # ============================================================================= -test_that(".fmSliceCvCondition / .sliceTwasCvResultToCondition: NULL passes through", { +test_that(".fmSliceCvCondition, .sliceTwasCvResultToCondition pass NULL", { expect_null(pecotmr:::.fmSliceCvCondition(NULL, 1L)) expect_null(pecotmr:::.sliceTwasCvResultToCondition(NULL, 1L)) }) -test_that(".jointTwasCvResult: NULL cv and empty/absent payloads degrade gracefully", { +test_that(".jointTwasCvResult copes with NULL CV and empty payloads", { expect_null(pecotmr:::.jointTwasCvResult(NULL, "mrmash")) - # Empty prediction/performance lists and all-NULL foldFits -> NULL components. + # Empty prediction/performance lists and all-NULL foldFits -> NULL + # components. cv <- list( samplePartition = data.frame(Sample = "s1", Fold = 1L), prediction = list(), @@ -2367,7 +2452,28 @@ test_that(".jointTwasCvResult: NULL cv and empty/absent payloads degrade gracefu expect_null(pecotmr:::.jointTwasCvResult(cv2, "mrmash")$predictions) }) -test_that(".twasFmHandoffCv: a token absent from the FM CV predictions -> NULL", { +test_that(".jointTwasCvResult keeps fold fits for mr.mash only", { + # mr.mash's fold fits seed each fold's mvSuSiE prior; no other method's + # fold fit is ever read, so none is kept. + cv <- list( + samplePartition = data.frame(Sample = "s1", Fold = 1L), + prediction = list(), + performance = list(), + foldFits = list( + fold_1 = list( + lasso_weights = list(a = 1), + mrmash_weights = list(b = 2) + ) + ) + ) + expect_null(pecotmr:::.jointTwasCvResult(cv, "lasso")$foldFits) + expect_equal( + pecotmr:::.jointTwasCvResult(cv, "mrmash")$foldFits, + list(fold_1 = list(b = 2)) + ) +}) + +test_that(".twasFmHandoffCv: NULL for a token the FM CV did not predict", { fmCv <- list( samplePartition = data.frame(Sample = "s1", Fold = 1L), prediction = list(susie_predicted = matrix(0, 1, 1)), @@ -2416,7 +2522,7 @@ test_that(".runJointSpecs: no methods or no specs -> NULL", { # is NULL, and .runJointSpecs' region-mode trait restriction. # ============================================================================= -test_that(".twasGroupArgs: takes the CV partition from the fine-mapping CV when none is set", { +test_that(".twasGroupArgs takes fine-mapping's CV partition when none is set", { g <- .je_mkGroup("G1") # IndividualJointGroup pipe <- new( "TwasJointPipeline", @@ -2442,7 +2548,14 @@ test_that(".twasGroupArgs: takes the CV partition from the fine-mapping CV when ) { list() }, - .twasCvResultFor = function(fmRes, s, c, t) list(samplePartition = sp), + .twasCvResultFor = function( + fineMappingResult, + studyName, + context, + trait + ) { + list(samplePartition = sp) + }, .package = "pecotmr" ) out <- pecotmr:::.twasGroupArgs(g, pipe, list(fineMappingResult = "FMR")) @@ -2459,7 +2572,25 @@ test_that(".runJointCell: a token whose fitter returns NULL is skipped", { expect_null(pecotmr:::.runJointCell(cell, pipe, NULL, NULL, "mvsusie")) }) -test_that(".runJointSpecs: region mode without traitId restricts scoped traits to the locus", { +test_that(".runJointCell reads allele frequencies for fine-mapping only", { + # They go into fine-mapping's topLoci. TWAS never reads them, and + # computing them reads each group's genotypes a second time. + cell <- .je_synthCell(list(.je_mkGroup("G1"))) + local_mocked_bindings( + fitJointGroup = function(...) NULL, + .jointAfForGroup = function(...) abort("read the genotypes again"), + .package = "pecotmr" + ) + twas <- new("TwasJointPipeline", config = list()) + expect_null(pecotmr:::.runJointCell(cell, twas, NULL, NULL, "mrmash")) + fm <- new("FmJointPipeline", config = list(coverage = 0.95)) + expect_error( + pecotmr:::.runJointCell(cell, fm, NULL, NULL, "mvsusie"), + "read the genotypes again" + ) +}) + +test_that(".runJointSpecs: region mode without traitId keeps locus traits", { pipe <- new("FmJointPipeline", config = list(ldReference = NULL)) region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 100)) captured <- NULL @@ -2740,6 +2871,125 @@ test_that("a fine-mapping CV handoff tolerates missing performance", { expect_equal(f(cv, "susie")$metrics, "PERF") }) +test_that("a fine-mapping CV handoff finds methods whose key differs", { + # fineMappingPipeline names its CV tables by the method key (susie_inf), + # not the twas token (susieInf); the handoff matches on the key. + cv <- list( + samplePartition = "SP", + prediction = set_names( + list("INF", "ASH"), + c("susie_inf_predicted", "susie_ash_predicted") + ), + performance = set_names( + list("INF_PERF", "ASH_PERF"), + c("susie_inf_performance", "susie_ash_performance") + ) + ) + inf <- pecotmr:::.twasFmHandoffCv(cv, "susieInf") + expect_equal(inf$predictions, "INF") + expect_equal(inf$metrics, "INF_PERF") + expect_equal(pecotmr:::.twasFmHandoffCv(cv, "susieAsh")$metrics, "ASH_PERF") +}) + +# A joint mvSuSiE fine-mapping row for context `ctx`, carrying that context's +# slice of the joint CV (one prediction column, one performance row). +.je_fmCvRow <- function(ctx, sp, pred, perf, withCv = TRUE) { + ids <- c("chr1:100:A:G", "chr1:200:A:G") + cv <- list( + samplePartition = sp, + prediction = list( + mvsusie_predicted = matrix( + as.numeric(pred), + ncol = 1L, + dimnames = list(sp$Sample, ctx) + ) + ), + performance = list( + mvsusie_performance = matrix( + as.numeric(perf), + nrow = 1L, + dimnames = list( + ctx, + c("corr", "rsq", "adj_rsq", "pval", "RMSE", "MAE") + ) + ) + ) + ) + FineMappingRow( + variantIds = ids, + susieFit = list(), + topLoci = data.frame(variant_id = ids, pip = c(0.9, 0.1)), + cvResult = if (withCv) cv else NULL + ) +} + +.je_fmCvResult <- function(rows) { + QtlFineMappingResult( + studyName = rep("S", 2L), + context = c("brain", "liver"), + trait = rep("G", 2L), + method = rep("mvsusie", 2L), + entry = rows + ) +} + +.je_fmCvSp <- data.frame(Sample = paste0("s", 1:4), Fold = c(1L, 1L, 2L, 2L)) + +test_that("a joint group's fine-mapping CV covers each of its conditions", { + sp <- .je_fmCvSp + fmr <- .je_fmCvResult(list( + .je_fmCvRow("brain", sp, 1:4, 1:6), + .je_fmCvRow("liver", sp, 5:8, 7:12) + )) + # The group's order, not the result's, sets the column order. + cond <- tibble( + study = c("S", "S"), + context = c("liver", "brain"), + trait = c("G", "G") + ) + cv <- pecotmr:::.twasGroupFmCv(fmr, cond) + pred <- cv$prediction$mvsusie_predicted + expect_equal(colnames(pred), c("liver", "brain")) + expect_equal(unname(pred[, "liver"]), as.numeric(5:8)) + expect_equal( + rownames(cv$performance$mvsusie_performance), + c("liver", "brain") + ) + # The first condition's row alone held one column, so the engine's + # per-condition slice ran out of bounds at the second condition. + second <- pecotmr:::.sliceTwasCvResultToCondition( + pecotmr:::.twasFmHandoffCv(cv, "mvsusie"), + 2L + ) + expect_equal(unname(second$predictions), as.numeric(1:4)) + expect_equal(unname(second$metrics), as.numeric(1:6)) +}) + +test_that("a joint group's fine-mapping CV needs one partition throughout", { + sp <- .je_fmCvSp + cond <- tibble( + study = c("S", "S"), + context = c("brain", "liver"), + trait = c("G", "G") + ) + # A condition with no CV hands off nothing. + partial <- .je_fmCvResult(list( + .je_fmCvRow("brain", sp, 1:4, 1:6), + .je_fmCvRow("liver", sp, 5:8, 7:12, withCv = FALSE) + )) + expect_null(pecotmr:::.twasGroupFmCv(partial, cond)) + # Rows from separate runs pair predictions made on different folds. + sp2 <- mutate(sp, Fold = c(2L, 1L, 2L, 1L)) + mixed <- .je_fmCvResult(list( + .je_fmCvRow("brain", sp, 1:4, 1:6), + .je_fmCvRow("liver", sp2, 5:8, 7:12) + )) + expect_error( + pecotmr:::.twasGroupFmCv(mixed, cond), + "S:brain:G, S:liver:G used different fold partitions" + ) +}) + test_that("joint specs accumulate by rbinding distinct tuples", { # runJointSpecs folds each spec's result into the accumulator; the tuple @@ -3017,11 +3267,11 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { contexts = list(S1 = "cA"), traits = list(S1 = "t1") ) - pecotmr:::.enumUnivariateIndividual( + .je_build(pecotmr:::.enumUnivariateIndividual( NULL, scope, list(region = GenomicRanges::GRanges("chr1:1-1000")) - ) + )) # An explicit region replaces the trait-anchored cis window entirely -- # neither traitId nor cisWindow is passed down. expect_equal(seen$region, GenomicRanges::GRanges("chr1:1-1000")) @@ -3227,7 +3477,7 @@ test_that(".jointCvPartition rejects a partition conflicting with the CV's", { ) }) -test_that(".twasEnsembleCollect answers empty parts when no token contributes", { +test_that(".twasEnsembleCollect gives empty parts when no token contributes", { # No tokens means nothing to gather, which is empty containers of the # right shape rather than NULL. out <- pecotmr:::.twasEnsembleCollect(NULL, list(), character(0)) @@ -3511,3 +3761,58 @@ test_that("a cross-context sumstats group refuses rows on two references", { "jointCrossContext \\(QtlSumStats\\): a joint fit uses one LD" ) }) + +# ---- joint-fit positions ---------------------------------------------------- + +test_that(".jointIndexOf numbers a joint group's fitted conditions", { + entries <- list(NULL, "a", "b") + joint <- list(js = NA_character_, jc = "c1;c2;c3", jt = NA_character_) + expect_identical(pecotmr:::.jointIndexOf(entries, joint), c(NA, 1L, 2L)) + single <- list(js = NA_character_, jc = NA_character_, jt = NA_character_) + expect_identical( + pecotmr:::.jointIndexOf(entries, single), + rep(NA_integer_, 3L) + ) +}) + +# One engine record for context `ctx` of a cross-context group. +.je_record <- function(ctx, entry, jointIndex, joint = "c1;c2") { + list( + study = "S", + context = ctx, + trait = "t1", + method = "m", + entry = entry, + jointStudies = NA_character_, + jointContexts = joint, + jointTraits = NA_character_, + traitPos = NULL, + region = NULL, + ldReference = NULL, + jointIndex = jointIndex + ) +} + +test_that("a joint fit's rows record their position in it", { + fm <- .sc_makeFineMappingRow(3) + res <- pecotmr:::.buildJointResult( + QtlFineMappingResult, + list(.je_record("c1", fm, 1L), .je_record("c2", fm, 2L)) + ) + expect_identical(S4Vectors::mcols(res)$jointIndex, c(1L, 2L)) + tw <- TwasWeightsRow("chr1:100:A:G", 0.1) + res <- pecotmr:::.buildJointResult( + TwasWeights, + list(.je_record("c1", tw, 1L), .je_record("c2", tw, 2L)) + ) + expect_identical( + as.list(S4Vectors::mcols(res)$jointIndex), + list(1L, 2L) + ) + # Rows from no joint fit record none. + plain <- pecotmr:::.buildJointResult( + QtlFineMappingResult, + list(.je_record("c1", fm, NA_integer_, joint = NA_character_)) + ) + expect_false(is_in("jointIndex", colnames(S4Vectors::mcols(plain)))) +}) diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index c1623eb93..f447addd9 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -113,6 +113,22 @@ delayedAssign(".jsQd", .js_makeQtlDataset()) # Scope helpers # ----------------------------------------------------------------------------- +test_that("a merged row's window spans its known windows, on one chromosome", { + unknown <- GenomicRanges::GRanges( + c("chrUn", "chrUn"), + IRanges::IRanges(c(1L, 1L), width = 0L) + ) + expect_identical(pecotmr:::.twasWindowSpan(1:2, unknown), unknown[1L]) + twoChrom <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(1L, 1L), width = 10L) + ) + expect_error( + pecotmr:::.twasWindowSpan(1:2, twoChrom), + "windows on 2 chromosomes" + ) +}) + test_that(".spListStudies / .spListContexts / .spListTraits: QtlDataset", { qd <- .js_makeQtlDataset( studyName = "S1", @@ -338,7 +354,7 @@ test_that("parseTraitIds: doubly-nested study->context validates per context", { # Pipeline-level wiring: jointSpecification accepted on all three methods # ----------------------------------------------------------------------------- -test_that("fineMappingPipeline(QtlDataset): composed joint dispatcher is wired", { +test_that("fineMappingPipeline(QtlDataset): composed joint dispatcher wired", { # Composed dispatcher accepts axes = c("context", "trait") for individual- # level input. On the fake fixture the genotype I/O fails when the # dispatcher reaches the extractor, which proves the dispatcher was @@ -359,7 +375,7 @@ test_that("fineMappingPipeline(QtlDataset): composed joint dispatcher is wired", ) }) -test_that("fineMappingPipeline(QtlDataset): composed joint rejects axes with 'study'", { +test_that("fineMappingPipeline(QtlDataset): composed joint refuses 'study'", { qd <- .js_makeQtlDataset( studyName = "A", contexts = c("brain", "liver"), @@ -376,7 +392,7 @@ test_that("fineMappingPipeline(QtlDataset): composed joint rejects axes with 'st ) }) -test_that("fineMappingPipeline(QtlDataset): study-axis on individual data errors", { +test_that("fineMappingPipeline(QtlDataset): study axis on individual errors", { qd <- .js_makeQtlDataset( studyName = "A", contexts = c("brain", "liver"), @@ -393,7 +409,7 @@ test_that("fineMappingPipeline(QtlDataset): study-axis on individual data errors ) }) -test_that("fineMappingPipeline(QtlDataset): invalid jointSpec errors before fit", { +test_that("fineMappingPipeline(QtlDataset): bad jointSpec errors before fit", { qd <- .js_makeQtlDataset(studyName = "A") expect_error( fineMappingPipeline( @@ -406,7 +422,7 @@ test_that("fineMappingPipeline(QtlDataset): invalid jointSpec errors before fit" ) }) -test_that("twasWeightsPipeline(QtlDataset): study-axis on individual data errors", { +test_that("twasWeightsPipeline(QtlDataset): study axis on individual errors", { qd <- .js_makeQtlDataset( studyName = "A", contexts = c("brain", "liver"), @@ -461,39 +477,14 @@ context("joint dispatchers (fineMappingPipeline / twasWeightsPipeline)") } .jd_mockExtractor <- function(seed = 11, n_samples = 30L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -550,8 +541,16 @@ context("joint dispatchers (fineMappingPipeline / twasWeightsPipeline)") } .jd_mockMvsusieRss <- function() { - function(Z, R, N, prior_variance, coverage) { - list(token = "mvsusieRss", nVariants = nrow(Z), nOutcomes = ncol(Z)) + # The real mvsusie_rss passes its `...` on to mvsusie, which is how L and + # L_greedy (the pipeline's CredibleSetParam) arrive; recorded for tests. + function(Z, R, N, prior_variance, coverage, L = NULL, L_greedy = NULL) { + list( + token = "mvsusieRss", + nVariants = nrow(Z), + nOutcomes = ncol(Z), + L = L, + L_greedy = L_greedy + ) } } @@ -632,14 +631,14 @@ context("joint dispatchers (fineMappingPipeline / twasWeightsPipeline)") # fineMappingPipeline joint dispatch: QtlSumStats # ============================================================================= -test_that("fineMappingPipeline(QtlSumStats): jointSpec='context' fits one joint per (study, trait)", { +test_that("fineMappingPipeline(QtlSumStats): context joint per study x trait", { ss <- .jd_makeQtlSumStats( studies = "Q1", contexts = c("c1", "c2"), traits = "t1" ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), .fmPostprocessOne = .jd_mockPostprocess(), .package = "pecotmr" ) @@ -652,19 +651,22 @@ test_that("fineMappingPipeline(QtlSumStats): jointSpec='context' fits one joint fineMappingPipeline( ss, methods = "mvsusie", - jointSpecification = "context" + jointSpecification = "context", + credibleSetParam = CredibleSetParam(maxNumSingleEffects = 3L) ) ) expect_s4_class(res, "QtlFineMappingResult") expect_equal(nrow(res), 2L) # per-context rows expect_setequal(as.character(res$context), c("c1", "c2")) # REAL contexts expect_true(all(grepl("c1;c2|c2;c1", as.character(res$jointContexts)))) + # maxNumSingleEffects reaches the joint RSS fit, as it does susie_rss. + expect_equal(susieFit(res[1, ])$payload$L, 3L) }) -test_that("fineMappingPipeline(QtlSumStats): jointSpec='context' with only one context skips", { +test_that("fineMappingPipeline(QtlSumStats): one context skips context joint", { ss <- .jd_makeQtlSumStats(studies = "Q1", contexts = "c1", traits = "t1") local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), .fmPostprocessOne = .jd_mockPostprocess(), .package = "pecotmr" ) @@ -685,14 +687,14 @@ test_that("fineMappingPipeline(QtlSumStats): jointSpec='context' with only one c ) }) -test_that("fineMappingPipeline(QtlSumStats): jointSpec='trait' fits one joint per (study, context)", { +test_that("fineMappingPipeline(QtlSumStats): trait joint per study x context", { ss <- .jd_makeQtlSumStats( studies = "Q1", contexts = "c1", traits = c("t1", "t2") ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), .fmPostprocessOne = .jd_mockPostprocess(), .package = "pecotmr" ) @@ -713,7 +715,7 @@ test_that("fineMappingPipeline(QtlSumStats): jointSpec='trait' fits one joint pe expect_setequal(as.character(res$trait), c("t1", "t2")) }) -test_that("fineMappingPipeline(QtlSumStats): jointSpec='trait' with fsusie errors (no RSS variant)", { +test_that("fineMappingPipeline(QtlSumStats): trait joint refuses fsusie", { ss <- .jd_makeQtlSumStats( studies = "Q1", contexts = "c1", @@ -729,14 +731,14 @@ test_that("fineMappingPipeline(QtlSumStats): jointSpec='trait' with fsusie error ) }) -test_that("fineMappingPipeline(QtlSumStats): jointSpec='study' fits one joint per (context, trait)", { +test_that("fineMappingPipeline(QtlSumStats): study joint per context x trait", { ss <- .jd_makeQtlSumStats( studies = c("Q1", "Q2"), contexts = "c1", traits = "t1" ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), .fmPostprocessOne = .jd_mockPostprocess(), .package = "pecotmr" ) @@ -757,14 +759,14 @@ test_that("fineMappingPipeline(QtlSumStats): jointSpec='study' fits one joint pe expect_setequal(as.character(res$study), c("Q1", "Q2")) }) -test_that("fineMappingPipeline(QtlSumStats): composed jointSpec axes={'study','context'} fits", { +test_that("fineMappingPipeline(QtlSumStats): study+context joint fits", { ss <- .jd_makeQtlSumStats( studies = c("Q1", "Q2"), contexts = c("c1", "c2"), traits = "t1" ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), .fmPostprocessOne = .jd_mockPostprocess(), .package = "pecotmr" ) @@ -788,7 +790,7 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec axes={'study','c expect_setequal(as.character(res$context), c("c1", "c2")) }) -test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", { +test_that("fineMappingPipeline(QtlSumStats): composed joint rejects fsusie", { ss <- .jd_makeQtlSumStats( studies = c("Q1", "Q2"), contexts = c("c1", "c2"), @@ -853,14 +855,14 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", ) } -test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' fits mr.mash per trait", { +test_that("twasWeightsPipeline(QtlDataset): context joint mr.mash per trait", { qd <- .jd_makeQtlDataset( studyName = "Q1", contexts = c("c1", "c2"), traits = "t1" ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashWeights = .jd_mockMrmashWeights(), .package = "pecotmr" ) @@ -878,14 +880,14 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' fits mr.mash per expect_true("jointContexts" %in% pecotmr:::.tupleColumnNames(res)) }) -test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' with only one context skips", { +test_that("twasWeightsPipeline(QtlDataset): one context skips context joint", { qd <- .jd_makeQtlDataset( studyName = "Q1", contexts = "c1", traits = c("t1", "t2") ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashWeights = .jd_mockMrmashWeights(), .package = "pecotmr" ) @@ -902,14 +904,14 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec='context' with only one co ) }) -test_that("twasWeightsPipeline(QtlDataset): jointSpec='trait' fits mr.mash per context", { +test_that("twasWeightsPipeline(QtlDataset): trait joint mr.mash per context", { qd <- .jd_makeQtlDataset( studyName = "Q1", contexts = "c1", traits = c("t1", "t2") ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashWeights = .jd_mockMrmashWeights(), .package = "pecotmr" ) @@ -927,14 +929,14 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec='trait' fits mr.mash per c expect_true("jointTraits" %in% pecotmr:::.tupleColumnNames(res)) }) -test_that("twasWeightsPipeline(QtlDataset): composed jointSpec axes=c('context','trait') fits", { +test_that("twasWeightsPipeline(QtlDataset): context+trait joint fits", { qd <- .jd_makeQtlDataset( studyName = "Q1", contexts = c("c1", "c2"), traits = c("t1", "t2") ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashWeights = .jd_mockMrmashWeights(), .package = "pecotmr" ) @@ -952,7 +954,7 @@ test_that("twasWeightsPipeline(QtlDataset): composed jointSpec axes=c('context', expect_setequal(as.character(res$trait), c("t1", "t2")) }) -test_that("twasWeightsPipeline(QtlDataset): composed jointSpec including 'study' errors", { +test_that("twasWeightsPipeline(QtlDataset): composed joint with study errors", { qd <- .jd_makeQtlDataset( studyName = "Q1", contexts = c("c1", "c2"), @@ -973,14 +975,14 @@ test_that("twasWeightsPipeline(QtlDataset): composed jointSpec including 'study' # twasWeightsPipeline joint dispatch: QtlSumStats # ============================================================================= -test_that("twasWeightsPipeline(QtlSumStats): jointSpec='context' fits mr.mash.rss per (study, trait)", { +test_that("twasWeightsPipeline(QtlSumStats): context joint per study x trait", { ss <- .jd_makeQtlSumStats( studies = "Q1", contexts = c("c1", "c2"), traits = "t1" ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashRssWeights = .jd_mockMrmashRssWeights(), .package = "pecotmr" ) @@ -997,14 +999,14 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec='context' fits mr.mash.rs expect_true("jointContexts" %in% pecotmr:::.tupleColumnNames(res)) }) -test_that("twasWeightsPipeline(QtlSumStats): jointSpec='trait' fits mr.mash.rss per (study, context)", { +test_that("twasWeightsPipeline(QtlSumStats): trait joint per study x context", { ss <- .jd_makeQtlSumStats( studies = "Q1", contexts = "c1", traits = c("t1", "t2") ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashRssWeights = .jd_mockMrmashRssWeights(), .package = "pecotmr" ) @@ -1020,14 +1022,14 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec='trait' fits mr.mash.rss expect_setequal(as.character(res$trait), c("t1", "t2")) }) -test_that("twasWeightsPipeline(QtlSumStats): jointSpec='study' fits mr.mash.rss per (context, trait)", { +test_that("twasWeightsPipeline(QtlSumStats): study joint per context x trait", { ss <- .jd_makeQtlSumStats( studies = c("Q1", "Q2"), contexts = "c1", traits = "t1" ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashRssWeights = .jd_mockMrmashRssWeights(), .package = "pecotmr" ) @@ -1043,14 +1045,14 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec='study' fits mr.mash.rss expect_setequal(as.character(res$study), c("Q1", "Q2")) }) -test_that("twasWeightsPipeline(QtlSumStats): composed jointSpec axes=c('study','context') fits", { +test_that("twasWeightsPipeline(QtlSumStats): study+context joint fits", { ss <- .jd_makeQtlSumStats( studies = c("Q1", "Q2"), contexts = c("c1", "c2"), traits = "t1" ) local_mocked_bindings( - extractBlockGenotypes = .jd_mockExtractor(), + .handleDosage = .jd_mockExtractor(), mrmashRssWeights = .jd_mockMrmashRssWeights(), .package = "pecotmr" ) @@ -1119,18 +1121,20 @@ test_that(".sp* helpers: MultiStudy per-study context/trait routing", { expect_setequal(pecotmr:::.spListContexts(mt, "indA"), "brain") expect_setequal(pecotmr:::.spListContexts(mt), c("brain", "DLPFC")) # all expect_equal(pecotmr:::.spListContexts(mt, "nope"), character(0)) - expect_setequal(pecotmr:::.spListTraits(mt, studyName = "ssC"), "g3") # ss branch + # The sumstats branch. + expect_setequal(pecotmr:::.spListTraits(mt, studyName = "ssC"), "g3") expect_setequal( pecotmr:::.spListTraits(mt, studyName = "indA"), c("g1", "g2") ) expect_equal(pecotmr:::.spListTraits(mt, studyName = "nope"), character(0)) # study = NULL aggregates ALL traits across individual + sumstats components - # (regression guard: a present sumStats slot must not shadow the QtlDatasets). + # (Regression guard: a present sumStats slot must not shadow the + # QtlDatasets.) expect_setequal(pecotmr:::.spListTraits(mt), c("g1", "g2", "g3")) }) -test_that(".spListTraits: study=NULL on a sumstats-free MultiStudy aggregates traits", { +test_that(".spListTraits: no study on a sumstats-free MultiStudy aggregates", { qdA <- .js_makeQtlDataset( studyName = "indA", contexts = "brain", @@ -1142,7 +1146,8 @@ test_that(".spListTraits: study=NULL on a sumstats-free MultiStudy aggregates tr traits = "g3" ) mt <- MultiStudyQtlDataset(qtlDatasets = list(indA = qdA, indB = qdB)) - expect_setequal(pecotmr:::.spListTraits(mt), c("g1", "g2", "g3")) # aggregate + # Aggregated over the studies. + expect_setequal(pecotmr:::.spListTraits(mt), c("g1", "g2", "g3")) }) test_that(".sp* helpers: unsupported class raises a labelled error", { @@ -1198,7 +1203,8 @@ test_that("parseContexts: malformed inputs error", { pecotmr:::parseContexts(list(S1 = character(0)), qd), "non-empty character vector" ) - expect_error(pecotmr:::parseContexts(list("brain"), qd), "named list") # unnamed + # Unnamed. + expect_error(pecotmr:::parseContexts(list("brain"), qd), "named list") expect_error(pecotmr:::parseContexts(42, qd), "`contexts` must be NULL") }) @@ -1253,7 +1259,7 @@ test_that("parseTraitIds: malformed inputs error", { # .fmResolveSpecScope: scope$study / scope$context / scope$trait + filters # ----------------------------------------------------------------------------- -test_that(".fmResolveSpecScope: scope + contexts + traitIds filters intersect", { +test_that(".fmResolveSpecScope: scope, contexts and traitIds intersect", { qd <- .js_makeQtlDataset( studyName = "S1", contexts = c("brain", "liver"), @@ -1421,7 +1427,7 @@ test_that("a multi-study run is refused only when no component has a trait", { # .buildJointSumstatZMatrix: SNP-order mismatch error # ----------------------------------------------------------------------------- -test_that(".buildJointSumstatZMatrix: a mismatched SNP order across entries errors", { +test_that(".buildJointSumstatZMatrix: entries in different SNP orders error", { df <- data.frame( study = "S", context = c("c1", "c2"), @@ -1461,7 +1467,7 @@ test_that(".buildJointSumstatZMatrix: a mismatched SNP order across entries erro # Individual X/Y builders: the skip paths (return NULL / message branches) # ----------------------------------------------------------------------------- -test_that(".buildIndividualCrossContextXy: skips when a trait spans < 2 contexts", { +test_that(".buildIndividualCrossContextXy: skips a trait in < 2 contexts", { se1 <- .js_makeSe(traits = "g1") # g1 present se0 <- .js_makeSe(traits = "other") # g1 absent local_mocked_bindings( @@ -1573,7 +1579,7 @@ test_that(".fmTraitsInRegion keeps overlapping traits; NULL keeps all", { ) # NULL region -> unchanged }) -test_that(".buildIndividualCrossTraitXy: skip branches (< 2 traits, region, complete)", { +test_that(".buildIndividualCrossTraitXy: < 2 traits, region, complete skip", { se2 <- .js_makeSe(traits = c("g1", "g2"), samples = paste0("s", 1:6)) samp <- paste0("s", 1:6) # < 2 scoped traits in the context -> NULL. @@ -1685,7 +1691,7 @@ test_that(".buildComposedIndividualXy: skip branches and single-context wrap", { # .enumerateComposedSumstatGroups: empty scope + all-axes (no complement) # ----------------------------------------------------------------------------- -test_that(".enumerateComposedSumstatGroups: empty scope -> NULL; no complement -> one block", { +test_that(".enumerateComposedSumstatGroups: empty scope and no complement", { df <- data.frame( study = "S", context = c("c1", "c2"), @@ -1716,7 +1722,7 @@ test_that(".enumerateComposedSumstatGroups: empty scope -> NULL; no complement - # .fmSynthesizeJointSpec # ----------------------------------------------------------------------------- -test_that(".fmSynthesizeJointSpec: trait wins over context; single/single -> empty", { +test_that(".fmSynthesizeJointSpec: trait beats context; single axes -> empty", { expect_equal(pecotmr:::.fmSynthesizeJointSpec(3L, 2L)[[1L]]$axes, "trait") expect_equal(pecotmr:::.fmSynthesizeJointSpec(2L, 1L)[[1L]]$axes, "context") expect_equal(pecotmr:::.fmSynthesizeJointSpec(1L, 1L), list()) @@ -1804,7 +1810,7 @@ test_that(".twasMergeResultsByKey: merges per-region TwasWeights entries", { # Multi-region QtlDataset dispatch (xRegions length 2 -> merge path) # ----------------------------------------------------------------------------- -test_that(".twasDispatchJointSpecsQtlDataset: two region blocks are merged by key", { +test_that(".twasDispatchJointSpecsQtlDataset: two blocks merge by key", { r1 <- GenomicRanges::GRanges("chr1", IRanges::IRanges(50, 250)) r2 <- GenomicRanges::GRanges("chr1", IRanges::IRanges(300, 500)) parsed <- list(list(axes = "context", scope = NULL)) @@ -1841,7 +1847,7 @@ test_that(".twasDispatchJointSpecsQtlDataset: two region blocks are merged by ke # .twasDispatchJointSpecsMultiStudy (leaf dispatchers mocked) # ----------------------------------------------------------------------------- -test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components, study spec to sumstats", { +test_that(".fmDispatchJointSpecsMultiStudy: study specs go to sumstats", { qd <- .js_makeQtlDataset( studyName = "indA", contexts = c("c1", "c2"), @@ -1894,7 +1900,7 @@ test_that(".fmDispatchJointSpecsMultiStudy: routes non-study specs to components expect_equal(nrow(out), 2L) # indA row + ssC row }) -test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot messages", { +test_that(".fmDispatchJointSpecsMultiStudy: study spec, no sumStats: message", { qdA <- .js_makeQtlDataset( studyName = "indA", contexts = c("c1", "c2"), @@ -1905,7 +1911,8 @@ test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot mes contexts = c("c1", "c2"), traits = "t1" ) - mt <- MultiStudyQtlDataset(qtlDatasets = list(indA = qdA, indB = qdB)) # no ss + # No sumstats. + mt <- MultiStudyQtlDataset(qtlDatasets = list(indA = qdA, indB = qdB)) parsed <- list(list(axes = "study", scope = NULL)) expect_message( out <- pecotmr:::.fmDispatchJointSpecsMultiStudy( @@ -1919,7 +1926,7 @@ test_that(".fmDispatchJointSpecsMultiStudy: study spec with no sumStats slot mes expect_null(out) }) -test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and rbinds", { +test_that(".twasDispatchJointSpecsMultiStudy: routes and rbinds by axis", { qd <- .jd_makeQtlDataset( studyName = "indA", contexts = c("c1", "c2"), @@ -1967,7 +1974,7 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r expect_equal(nrow(out), 2L) }) -test_that(".twasDispatchJointSpecsMultiStudy: study spec, no sumStats -> message + NULL", { +test_that(".twasDispatchJointSpecsMultiStudy: study spec, no sumStats: NULL", { qdA <- .jd_makeQtlDataset( studyName = "indA", contexts = c("c1", "c2"), @@ -2008,7 +2015,7 @@ test_that(".sp* QtlDataset: mismatched study / absent context return empty", { expect_equal(pecotmr:::.spListTraits(qd, context = "nope"), character(0)) }) -test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip the context", { +test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip", { se <- .js_makeSe(traits = c("g1", "g2"), samples = paste0("s", 1:6)) local_mocked_bindings( .qtlContextSe = function(data, context) se, @@ -2043,7 +2050,7 @@ test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip the context", ))) }) -test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA rows skip", { +test_that(".buildComposedIndividualXy: disjoint, missing or NA rows skip", { samp <- paste0("s", 1:6) se <- .js_makeSe(traits = c("g1", "g2"), samples = samp) scope <- list( @@ -2171,7 +2178,7 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA ))) }) -test_that(".fmMergeResultsByKey: a key missing from a later region contributes nothing", { +test_that(".fmMergeResultsByKey: a key a later region lacks adds nothing", { twoRow <- QtlFineMappingResult( studyName = c("S", "S"), context = c("c1", "c2"), @@ -2234,7 +2241,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { expect_equal(nrow(res), 2L) # the two region blocks merged by key }) -test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; all-NULL -> NULL", { +test_that(".fmDispatchJointSpecsQtlDataset: one region direct; all-NULL NULL", { qd <- .jd_makeQtlDataset( studyName = "Q1", contexts = c("c1", "c2"), @@ -2270,7 +2277,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al )) # all-NULL }) -test_that(".twasMergeResultsByKey: a key absent from a later region contributes nothing", { +test_that(".twasMergeResultsByKey keeps an entry whichever regions hold it", { twoRow <- TwasWeights( studyName = c("S", "S"), context = c("c1", "c2"), @@ -2287,37 +2294,80 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes trait = "t1", method = "lasso", entry = list(TwasWeightsRow( - variantIds = "chr1:100:A:G", - weights = 0.1 + variantIds = "chr1:300:A:G", + weights = 0.3 )) ) out <- pecotmr:::.twasMergeResultsByKey(list(twoRow, oneRow), c("rA", "rB")) expect_equal(nrow(out), 2L) # c2 kept from the first region + # Keys came from the first region alone, so one only a later region + # held was lost. + out <- pecotmr:::.twasMergeResultsByKey(list(oneRow, twoRow), c("rA", "rB")) + expect_setequal(as.character(out$context), c("c1", "c2")) }) -test_that(".twasMergedEntryAt concatenates one key's entry across regions", { - data(twasWeightsExample) - tw <- twasWeightsExample - keys <- pecotmr:::.mergeResultKeyOf(tw) - m <- pecotmr:::.twasMergedEntryAt(1L, list(tw, tw), keys, c("rA", "rB")) - expect_s4_class(m, "TwasWeightsRow") +test_that(".twasMergeResultsByKey concatenates one entry across regions", { + one <- function(pos, w) { + TwasWeights( + studyName = "S", + context = "c1", + trait = "t1", + method = "lasso", + entry = list(TwasWeightsRow( + variantIds = sprintf("chr1:%d:A:G", pos), + weights = w + )), + region = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(min(pos), max(pos)) + ) + ) + } + out <- pecotmr:::.twasMergeResultsByKey( + list(one(c(100L, 200L), c(0.1, 0.2)), one(c(300L, 400L), c(0.3, 0.4))), + c("rA", "rB") + ) + expect_equal(nrow(out), 1L) + m <- pecotmr:::.twrCellParts(out, 1L, "lasso") expect_equal(names(methodFits(m)), c("rA", "rB")) - # Same table twice: the merged entry carries both regions' variants. - one <- pecotmr:::.twasMergedEntryAt(1L, list(tw), keys, "rA") - expect_equal( - length(pecotmr:::.twrPartsVariantIds(m)), - 2L * length(pecotmr:::.twrPartsVariantIds(one)) + expect_equal(unname(weights(m)), c(0.1, 0.2, 0.3, 0.4)) + # The merged window spans both regions' windows; it used to be dropped. + expect_equal(start(genomicRegion(out)), 100L) + expect_equal(end(genomicRegion(out)), 400L) +}) + +test_that(".twasMergeResultsByKey keeps two joint groups of one gene apart", { + group <- function(jointContexts, w) { + TwasWeights( + studyName = "S", + context = "c1", + trait = "t1", + method = "mrmash", + entry = list(TwasWeightsRow( + variantIds = "chr1:100:A:G", + weights = w + )), + jointContexts = jointContexts + ) + } + perRegion <- function(w) { + combineTwasWeights(group("c1,c2", w), group("c1,c3", w + 1)) + } + out <- pecotmr:::.twasMergeResultsByKey( + list(perRegion(0.1), perRegion(0.2)), + c("rA", "rB") ) + expect_equal(nrow(out), 2L) }) test_that(".mergeEntryForKey gives NULL for a region lacking the tuple", { # NULL, not an empty row: a region that never fitted the tuple must not - # dilute the merged weights with zeros. - data(twasWeightsExample) - tw <- twasWeightsExample - key <- pecotmr:::.mergeResultKeyOf(tw)[[1L]] - expect_s4_class(pecotmr:::.mergeEntryForKey(tw, key), "TwasWeightsRow") - expect_null(pecotmr:::.mergeEntryForKey(tw, "nope\rx\ry\rz")) + # dilute the merged entry. Only the fine-mapping merge keys rows this way. + data(qtlFineMappingExample) + fm <- qtlFineMappingExample + key <- pecotmr:::.mergeResultKeyOf(fm)[[1L]] + expect_false(is.null(pecotmr:::.mergeEntryForKey(fm, key))) + expect_null(pecotmr:::.mergeEntryForKey(fm, "nope\rx\ry\rz")) }) @@ -2489,3 +2539,32 @@ test_that("the joint builders read phenotypes under the run's phenotype QC", { expect_identical(got, pf) } }) + +test_that(".twasMergeResultsByKey keeps a position its regions agree on", { + region <- function(pos, idx) { + pecotmr:::.withJointIndex( + TwasWeights( + studyName = "S", + context = "c1", + trait = "t1", + method = "mrmash", + entry = list( + TwasWeightsRow(sprintf("chr1:%d:A:G", pos), 0.1) + ), + jointContexts = "c1;c2" + ), + idx + ) + } + out <- pecotmr:::.twasMergeResultsByKey( + list(region(100L, 2L), region(200L, 2L)), + c("rA", "rB") + ) + expect_identical(as.list(S4Vectors::mcols(out)$jointIndex), list(2L)) + # Regions whose screens kept different conditions leave it unknown. + out <- pecotmr:::.twasMergeResultsByKey( + list(region(100L, 1L), region(200L, 2L)), + c("rA", "rB") + ) + expect_null(S4Vectors::mcols(out)$jointIndex) +}) diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index ff0c62dfd..ecb564d70 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -28,7 +28,7 @@ test_that("orderDedupRegions orders and deduplicates across chromosomes", { expect_true(all(diff(result$start[result$chrom == result$chrom[1]]) >= 0)) }) -test_that("orderDedupRegions sorts X/Y/MT after autosomes and keeps chrom a string", { +test_that("orderDedupRegions puts X/Y/MT after autosomes; chrom stays text", { df <- data.frame( chrom = c("chrX", "chr2", "chr1", "chrM"), start = c(1L, 1L, 1L, 1L), @@ -217,6 +217,21 @@ test_that("checkLd eigenfix does nothing when matrix is already PD", { geno_test_data_dir <- test_path("test_data") geno_region_all <- GenomicRanges::GRanges("chr21:17513228-17592874") +# An LD-meta TSV beside the genotype fixtures, one row per (start, end, path) +# on chr1, removed when the calling test ends. +.ldr_ldMeta <- function(name, rows, env = parent.frame()) { + path <- file.path(geno_test_data_dir, name) + writeLines( + c( + str_c("chrom", "start", "end", "path", sep = "\t"), + str_c("1", rows$start, rows$end, rows$path, sep = "\t") + ), + path + ) + withr::defer(unlink(path), envir = env) + path +} + test_that("resolveLdSource tells the format of the genotypes metadata names", { # One row per chromosome naming its genotype file or PLINK prefix, # resolved beside the metadata file. @@ -252,20 +267,9 @@ test_that("resolveLdSource tells a file's format as readGenotypes does", { test_that("resolveLdSource refuses a row pointing at pre-computed LD", { # pecotmr reads LD only from genotypes, so a row naming a .cor.xz matrix # is an error rather than a source type. - meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_pre_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "chr1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE + meta_file <- .ldr_ldMeta( + "ld_meta_resolve_pre_tmp.tsv", + list(start = 1000L, end = 1200L, path = "block_1.cor.xz") ) expect_error( pecotmr:::resolveLdSource(meta_file), @@ -345,77 +349,53 @@ test_that("resolveGenotypePathForRegion takes a window on one chromosome", { }) # =========================================================================== -# regionalLdMeta: real .cor.xz fixtures +# regionalLdMeta: rows naming genotype files # =========================================================================== -test_that("regionalLdMeta returns correct file paths for single block", { - meta_file <- file.path( - geno_test_data_dir, - "ld_meta_regional_single_tmp.tsv" - ) - on.exit(unlink(meta_file), add = TRUE) - lines <- c( - paste("chrom", "start", "end", "path", sep = "\t"), - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - paste( - "1", - "1200", - "1400", - "LD_block_2.chr1_1200_1400.float16.txt.xz,LD_block_2.chr1_1200_1400.float16.bim", - sep = "\t" +# Three chr1 blocks, each naming one of the genotype fixtures. +.ldr_blockFiles <- c( + "test_variants.pgen", + "test_variants.vcf.gz", + "test_variants.gds" +) + +test_that("regionalLdMeta returns the file of the block a region falls in", { + meta_file <- .ldr_ldMeta( + "ld_meta_regional_single_tmp.tsv", + list( + start = c(1000L, 1200L), + end = c(1200L, 1400L), + path = .ldr_blockFiles[1:2] ) ) - writeLines(lines, meta_file) result <- pecotmr:::regionalLdMeta( meta_file, GenomicRanges::GRanges("chr1:1050-1150") ) - expect_true(is.list(result)) - expect_true(length(result$intersections$LD_file_paths) >= 1) - # All returned paths should exist - expect_true(all(file.exists(result$intersections$LD_file_paths))) - expect_true(all(file.exists(result$intersections$bimFilePaths))) + # Found beside the metadata file, which names it relative to itself. + expect_identical( + result$intersections$paths, + file.path(geno_test_data_dir, "test_variants.pgen") + ) }) -test_that("regionalLdMeta spans multiple blocks for wide region", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_regional_multi_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - lines <- c( - paste("chrom", "start", "end", "path", sep = "\t"), - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - paste( - "1", - "1200", - "1400", - "LD_block_2.chr1_1200_1400.float16.txt.xz,LD_block_2.chr1_1200_1400.float16.bim", - sep = "\t" - ), - paste( - "1", - "1400", - "1600", - "LD_block_3.chr1_1400_1600.float16.txt.xz,LD_block_3.chr1_1400_1600.float16.bim", - sep = "\t" +test_that("regionalLdMeta returns every block's file a region spans", { + meta_file <- .ldr_ldMeta( + "ld_meta_regional_multi_tmp.tsv", + list( + start = c(1000L, 1200L, 1400L), + end = c(1200L, 1400L, 1600L), + path = .ldr_blockFiles ) ) - writeLines(lines, meta_file) result <- pecotmr:::regionalLdMeta( meta_file, GenomicRanges::GRanges("chr1:1000-1500") ) - expect_true(length(result$intersections$LD_file_paths) >= 2) + expect_identical( + result$intersections$paths, + file.path(geno_test_data_dir, .ldr_blockFiles) + ) }) # =========================================================================== @@ -599,7 +579,7 @@ test_that("ldPruneByCorrelation keeps all columns when uncorrelated", { expect_equal(colnames(result$X.new), colnames(X)) }) -test_that("ldPruneByCorrelation preserves colnames for single remaining column", { +test_that("ldPruneByCorrelation keeps the name of a lone remaining column", { set.seed(42) n <- 50 X <- matrix(rnorm(n * 3), nrow = n) @@ -622,7 +602,7 @@ test_that("ldPruneByCorrelation keeps a single column, with nothing to prune", { expect_identical(res$filter.id, 1L) }) -test_that("ldPruneByCorrelation strict threshold removes at least as many as lenient", { +test_that("ldPruneByCorrelation: a strict cutoff removes at least as many", { set.seed(42) n <- 100 p <- 5 @@ -666,7 +646,7 @@ test_that("dropCollinearColumns removes single problematic column", { expect_false("chr1:300:A:G" %in% colnames(result)) }) -test_that("dropCollinearColumns variance strategy removes lowest variance column", { +test_that("dropCollinearColumns(variance) drops the lowest-variance column", { set.seed(42) n <- 50 X <- matrix(rnorm(n * 3), nrow = n, ncol = 3) @@ -718,7 +698,7 @@ test_that("dropCollinearColumns correlation drops the highest-sum candidate", { expect_identical(result, X[, -2L]) }) -test_that("dropCollinearColumns responseCorrelation strategy removes lowest |cor| with response", { +test_that("dropCollinearColumns drops the column least correlated with y", { set.seed(42) n <- 50 X <- matrix(rnorm(n * 3), nrow = n, ncol = 3) @@ -734,7 +714,7 @@ test_that("dropCollinearColumns responseCorrelation strategy removes lowest |cor expect_true("chr1:100:A:G" %in% colnames(result)) }) -test_that("dropCollinearColumns errors on responseCorrelation without response", { +test_that("dropCollinearColumns: responseCorrelation needs a response", { X <- matrix(rnorm(60), 20, 3) colnames(X) <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") expect_error( @@ -760,7 +740,7 @@ test_that("dropCollinearColumns errors on invalid strategy", { ) }) -test_that("dropCollinearColumns preserves column name when single column remains", { +test_that("dropCollinearColumns keeps the name of a lone remaining column", { set.seed(42) X <- matrix(rnorm(40), nrow = 20, ncol = 2) colnames(X) <- c("keeper", "removed") @@ -787,7 +767,7 @@ test_that("dropCollinearColumns is silent by default", { # enforceDesignFullRank (unexported) # =========================================================================== -test_that("enforceDesignFullRank handles rank-deficient design via correlation fallback", { +test_that("enforceDesignFullRank's correlation fallback fixes deficient rank", { set.seed(42) n <- 50 X <- matrix(rnorm(n * 4), nrow = n, ncol = 4) @@ -884,7 +864,7 @@ test_that("findValidFilePath errors when both paths are invalid", { ) }) -test_that("findValidFilePath returns reference when target is invalid but reference exists", { +test_that("findValidFilePath falls back to an existing reference", { result <- pecotmr:::.findValidFilePath( referenceFilePath = .ldBed, targetFilePath = "/totally/bogus/path.txt" @@ -1064,7 +1044,8 @@ test_that("computeLd gcta agrees with sample method on complete data", { R_sample <- computeLd(X, method = "sample") R_gcta <- computeLd(X, method = "gcta") - # With no missing data, GCTA and sample should be close (differ by N vs N-1 denom) + # With no missing data, GCTA and sample should be close (differ by N vs N-1 + # denom) expect_true(max(abs(R_sample - R_gcta)) < 0.05) }) @@ -1170,52 +1151,43 @@ test_that("findIntersectionRows errors when region falls in a coverage gap", { }) test_that("regionalLdMeta handles whole-chromosome 0:0 sentinel rows", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_wholechrom_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste( - "1", - "0", - "0", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ), - "\n", - file = meta_file, - append = TRUE + meta_file <- .ldr_ldMeta( + "ld_meta_wholechrom_tmp.tsv", + list(start = 0L, end = 0L, path = .ldr_blockFiles[[1L]]) ) result <- pecotmr:::regionalLdMeta( meta_file, GenomicRanges::GRanges("chr1:1000-1190") ) - expect_true(length(result$intersections$LD_file_paths) >= 1) - expect_true(all(file.exists(result$intersections$LD_file_paths))) + expect_identical( + result$intersections$paths, + file.path(geno_test_data_dir, .ldr_blockFiles[[1L]]) + ) # 0:0 sentinel row should have had its end set to Inf internally expect_true(is.infinite(max(result$ldMetaData$end))) }) test_that("regionalLdMeta validates complete coverage when required", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_complete_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - lines <- c( - paste("chrom", "start", "end", "path", sep = "\t"), - paste( - "1", - "1000", - "1200", - "LD_block_1.chr1_1000_1200.float16.txt.xz,LD_block_1.chr1_1000_1200.float16.bim", - sep = "\t" - ) + meta_file <- .ldr_ldMeta( + "ld_meta_complete_tmp.tsv", + list(start = 1000L, end = 1200L, path = .ldr_blockFiles[[1L]]) ) - writeLines(lines, meta_file) # Region fully inside block 1 -> validateSelectedRegion passes result <- pecotmr:::regionalLdMeta( meta_file, GenomicRanges::GRanges("chr1:1050-1150"), completeCoverageRequired = TRUE ) - expect_true(length(result$intersections$LD_file_paths) >= 1) + expect_length(result$intersections$paths, 1L) + # One reaching past the block's end is not covered. + expect_error( + pecotmr:::regionalLdMeta( + meta_file, + GenomicRanges::GRanges("chr1:1050-1300"), + completeCoverageRequired = TRUE + ), + "not fully covered" + ) }) # ============================================================================= @@ -1294,7 +1266,8 @@ test_that(".ldFromRef still errors on a variant absent after reconciling", { format = "plink2" ) pid <- as.character(snpInfo(h)$SNP) - # request the prefix-stripped form (forces reconciliation) plus one truly-absent variant + # request the prefix-stripped form (forces reconciliation) plus one + # truly-absent variant req <- c(sub("^chr", "", pid[1]), "21_99999999_A_G") expect_error( pecotmr:::.ldFromRef(h, req), @@ -1336,47 +1309,22 @@ test_that(".ldFromRef rejects an ldReference that is not a genotype panel", { # @noRd .lds_mockExtractor <- function(seed = 7, nSamples = 30L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) nSnp <- nrow(snpInfo(handle)) panel <- matrix( rbinom(nSamples * nSnp, 2, 0.3), nrow = nSamples, - ncol = nSnp, - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - rr <- GenomicRanges::GRanges( - seqnames = str_c("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - dosage <- t(panel[, snpIdx, drop = FALSE]) - dimnames(dosage) <- list( - snpInfo(handle)$SNP[snpIdx], - sampleIds(handle) - ) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) + ncol = nSnp ) + panel[, snpIdx, drop = FALSE] } } test_that(".ldFromRef returns a symmetric unit-diagonal LD matrix", { h <- .lds_makeHandle() local_mocked_bindings( - extractBlockGenotypes = .lds_mockExtractor(), + .handleDosage = .lds_mockExtractor(), .package = "pecotmr" ) ids <- c("chr1:200:A:G", "chr1:400:A:G", "chr1:500:A:G") @@ -1395,7 +1343,7 @@ test_that(".ldFromRef negates LD for a variant the panel spells flipped", { # against a caller whose alleles were oriented the other way. h <- .lds_makeHandle() local_mocked_bindings( - extractBlockGenotypes = .lds_mockExtractor(), + .handleDosage = .lds_mockExtractor(), .package = "pecotmr" ) same <- c("chr1:200:A:G", "chr1:400:A:G", "chr1:500:A:G") @@ -1415,15 +1363,18 @@ test_that(".ldFromRef negates LD for a variant the panel spells flipped", { test_that(".ldFromRef leaves LD untouched when every allele agrees", { h <- .lds_makeHandle() local_mocked_bindings( - extractBlockGenotypes = .lds_mockExtractor(), + .handleDosage = .lds_mockExtractor(), .package = "pecotmr" ) ids <- c("chr1:200:A:G", "chr1:400:A:G") # The sample correlation of the very dosages the panel serves for those # variants: with no allele to flip, no sign may change. served <- .lds_mockExtractor()(h, c(2L, 4L)) - direct <- cor(t(SummarizedExperiment::assay(served, "dosage"))) - expect_equal(pecotmr:::.ldFromRef(h, ids), direct, tolerance = 1e-12) + expect_equal( + unname(pecotmr:::.ldFromRef(h, ids)), + cor(served), + tolerance = 1e-12 + ) }) test_that(".ldFromRef errors on a variant the panel does not carry", { @@ -1745,7 +1696,7 @@ test_that("dropCollinearColumns prints verbose messages for each strategy", { # Additional coverage: enforceDesignFullRank verbose / fallback branches # ============================================================================= -test_that("enforceDesignFullRank verbose: batch-removal success + iterative path", { +test_that("enforceDesignFullRank verbose: batch removal and iterative path", { set.seed(11) X <- matrix(rnorm(80 * 4), 80, 4) X[, 4] <- X[, 1] + X[, 2] # rank deficient, fixable by removing one column @@ -1764,11 +1715,12 @@ test_that("enforceDesignFullRank verbose: batch-removal success + iterative path expect_equal(qr(full_design)$rank, ncol(full_design)) }) -test_that("enforceDesignFullRank verbose: constant covariate triggers fallback", { +test_that("enforceDesignFullRank verbose: a constant covariate falls back", { set.seed(12) X <- matrix(rnorm(60 * 3), 60, 3) # X itself is full rank colnames(X) <- c("a", "b", "c") - C <- matrix(1, 60, 1) # constant -> collinear with intercept, not fixable via X + # constant -> collinear with intercept, not fixable via X + C <- matrix(1, 60, 1) # Iterative path finds no removable X column (break), then the correlation # fallback runs over each threshold; design stays rank-deficient throughout. expect_message( @@ -1790,7 +1742,8 @@ test_that("enforceDesignFullRank verbose: batch removal insufficient path", { colnames(X) <- c("a", "b", "c", "d") C <- matrix(1, 60, 1) # constant covariate keeps design deficient # Removing the QR-flagged X column cannot restore full rank (C is constant), - # so the batch-removal "insufficient" branch fires and skips iterative pruning. + # so the batch-removal "insufficient" branch fires and skips iterative + # pruning. expect_message( result <- enforceDesignFullRank( X, @@ -1817,7 +1770,7 @@ test_that("ldClumpByScore prints verbose message for single-variant input", { ) }) -test_that("ldClumpByScore accepts a pre-built FBM and reports retained count (verbose)", { +test_that("ldClumpByScore takes a pre-built FBM, reports what it keeps", { skip_if_not_installed("bigsnpr") skip_if_not_installed("bigstatsr") set.seed(1) @@ -1918,7 +1871,7 @@ test_that("the genotype-code backends refuse dosages rather than round them", { ) }) -test_that("computeLd errors when a non-internal backend is paired with non-sample method", { +test_that("computeLd errors on an external backend with a non-sample method", { set.seed(1) X <- matrix(rbinom(100 * 3, 2, 0.3), 100, 3) colnames(X) <- paste0("rs", 1:3) @@ -1946,7 +1899,8 @@ test_that("computeLd errors when a non-internal backend is paired with non-sampl set.seed(11) nS <- 100L af <- c(rep(0.35, 5L), rep(0.004, 5L)) - d <- exec(cbind, !!!map(af, function(f) rbinom(nS, 2L, f))) + dosageCols <- map(af, function(f) rbinom(nS, 2L, f)) + d <- exec(cbind, !!!dosageCols) colnames(d) <- sprintf("chr1:%d:A:G", 1000L * seq_along(af)) d[1:80, 2] <- NA d @@ -2303,18 +2257,40 @@ test_that("panel identity uses the allele-repaired ids for comparison", { dna <- c("chr1:100:A:G") expect_equal(pecotmr:::.repairVariantIds(dna, A2 = "C", A1 = "T"), dna) - # And an rsID panel passes through unchanged -- `.ldFromRefMatch()` - # falls back to exact id matching for those, so rewriting them would - # break the match rather than fix it. + # An rsID panel is keyed by the ids rendered from its ranges and + # alleles, which harmonized ids meet; its labels key a query of labels. panel <- readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) expect_equal( pecotmr:::.ldRefMatchIds(panel), + pecotmr:::.grVariantIds(SummarizedExperiment::rowRanges(panel)) + ) + expect_equal( + pecotmr:::.ldRefKeysFor(panel, rownames(panel)[1:3]), pecotmr:::.ldRefVariantIds(panel) ) }) +test_that("an rsID panel is matched by position and alleles", { + # Keyed by its labels, it matched no harmonized id, so every LD lookup + # against it came back empty. + panel <- readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + )[1:20, ] + ids <- pecotmr:::.grVariantIds(SummarizedExperiment::rowRanges(panel)) + m <- pecotmr:::.ldFromRefMatch(panel, ids[c(3L, 1L)], "lookup", "error") + expect_equal(m$idx, c(3L, 1L)) + # A query of its labels still meets them. + m <- pecotmr:::.ldFromRefMatch( + panel, + rownames(panel)[c(3L, 1L)], + "lookup", + "error" + ) + expect_equal(m$idx, c(3L, 1L)) +}) + # =========================================================================== # Sketch accessors and per-variant panel statistics # =========================================================================== @@ -2757,6 +2733,27 @@ test_that("a PLINK1 panel cut to a few variants keeps only those", { expect_equal(.dose(readRDS(saved)), .dose(cut)) }) +test_that("a panel that is already a subset is cut over its seed too", { + # Positions, not names, say which seed rows a panel holds, so a row or + # column subset is cut over the seed's own rows. + skip_if_not_installed("PlinkMatrix") + panel <- readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + ) + seedRows <- function(x) dim(pecotmr:::.panelSeed(x))[[1L]] + rows <- pecotmr:::.panelSubsetRows(panel[1:100, ], c(2L, 5L, 9L)) + expect_equal(seedRows(rows), 3L) + expect_equal(.dose(rows), .dose(panel[c(2L, 5L, 9L), ])) + cols <- pecotmr:::.panelSubsetRows(panel[, 1:20], 4:6) + expect_equal(dim(cols), c(3L, 20L)) + expect_equal(seedRows(cols), 3L) + expect_equal(.dose(cols), .dose(panel[4:6, 1:20])) + # A panel that reorders its seed's rows is cut from its assay instead. + reversed <- pecotmr:::.panelSubsetRows(panel[10:1, ], 1:3) + expect_equal(seedRows(reversed), nrow(panel)) + expect_equal(.dose(reversed), .dose(panel[10:8, ])) +}) + test_that("ldReference cross-checks are no-ops when a side has no variants", { # A zero-variant panel -- what an emptied object carries -- contradicts # nothing, so there is nothing to compare and the check returns quietly. @@ -3114,11 +3111,11 @@ test_that("the same-reference check compares LdMatrix objects by their LD", { test_that("the LD's eigenvalues come from its factor's thin SVD", { set.seed(4) X <- matrix(rbinom(30 * 50, 2, 0.3), 30, 50) - F <- pecotmr:::.ldFactorFromDosage(X) - R <- crossprod(F) / (nrow(F) - 1) - dec <- pecotmr:::.ldFactorEigen(F) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) + dec <- pecotmr:::.ldFactorEigen(ldFactor) # The SVD lists min(m, p) directions; the rest of R's are exactly zero. - expect_equal(dec$nNull, 50L - nrow(F)) + expect_equal(dec$nNull, 50L - nrow(ldFactor)) expect_equal(length(dec$values) + dec$nNull, 50L) expect_equal(dec$values[1:25], eigen(R, symmetric = TRUE)$values[1:25]) expect_equal(dec$vectors %*% (dec$values * t(dec$vectors)), R) @@ -3127,22 +3124,107 @@ test_that("the LD's eigenvalues come from its factor's thin SVD", { test_that("R o R products read the same from a matrix, factor or eigenpairs", { set.seed(5) X <- matrix(rbinom(40 * 600, 2, 0.4), 40, 600) - F <- pecotmr:::.ldFactorFromDosage(X) - R <- crossprod(F) / (nrow(F) - 1) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) e <- eigen(R, symmetric = TRUE) eig <- list(vectors = e$vectors, values = e$values) A <- cbind(1, runif(600), rbinom(600, 1, 0.3)) want <- (R^2) %*% A # 600 variants are read in three stripes, the last one partial. - expect_equal(pecotmr:::.ldSquaredProduct(list(F = F), A), want) + expect_equal( + pecotmr:::.ldSquaredProduct(list(ldFactor = ldFactor), A), + want + ) expect_equal(pecotmr:::.ldSquaredProduct(list(R = R), A), want) expect_equal(pecotmr:::.ldSquaredProduct(eig, A), want) - expect_equal(pecotmr:::.ldSourceRows(list(F = F), 3:5), R[3:5, ]) + expect_equal( + pecotmr:::.ldSourceRows(list(ldFactor = ldFactor), 3:5), + R[3:5, ] + ) expect_equal(pecotmr:::.ldSourceRows(eig, 3:5), R[3:5, ]) - expect_equal(pecotmr:::.ldSourceSize(list(F = F)), 600L) + expect_equal(pecotmr:::.ldSourceSize(list(ldFactor = ldFactor)), 600L) expect_equal(pecotmr:::.ldSourceSize(eig), 600L) }) +test_that("the shrink intensity reads the same from a matrix or a factor", { + set.seed(5) + X <- matrix(rbinom(40 * 600, 2, 0.4), 40, 600) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) + off <- R[upper.tri(R)] + want <- min(1, sum((1 - off^2)^2) / 39 / sum(off^2)) + # 600 variants are read in three stripes, the last one partial. + expect_equal(pecotmr:::.ldShrinkIntensity(list(R = R), 40L), want) + expect_equal( + pecotmr:::.ldShrinkIntensity(list(ldFactor = ldFactor), 40L), + want + ) + # A larger reference is shrunk less; one variant has nothing to shrink. + expect_lt(pecotmr:::.ldShrinkIntensity(list(R = R), 400L), want) + expect_equal(pecotmr:::.ldShrinkIntensity(list(R = matrix(1)), 40L), 1) +}) + +test_that("draws from N(0, R) come through a factor or a matrix", { + set.seed(6) + X <- matrix(rbinom(30 * 50, 2, 0.4), 30, 50) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) + # A factor's draws are F' e / sqrt(m - 1), exactly. + set.seed(1) + draws <- pecotmr:::.ldSourceDraws(list(ldFactor = ldFactor), 3L) + set.seed(1) + e <- matrix(rnorm(nrow(ldFactor) * 3L), nrow(ldFactor), 3L) + expect_equal(draws, crossprod(ldFactor, e) / sqrt(nrow(ldFactor) - 1)) + # A matrix's come through its eigendecomposition, which takes the zero + # eigenvalues of a 30-sample LD over 50 variants: their covariance is R. + many <- pecotmr:::.ldSourceDraws(list(R = R), 20000L) + expect_equal(dim(many), c(50L, 20000L)) + expect_lt(max(abs(tcrossprod(many) / 20000 - R)), 0.06) +}) + +test_that("an LD source's eigendecomposition comes from any of its forms", { + set.seed(6) + ldFactor <- pecotmr:::.ldFactorFromDosage(matrix( + rbinom(30 * 50, 2, 0.4), + 30, + 50 + )) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) + whole <- eigen(R, symmetric = TRUE) + expect_identical(pecotmr:::.ldSourceEigen(list(R = R)), whole) + # A factor's comes from its thin SVD: R's non-zero spectrum, in fewer + # directions than variants, and R itself. + thin <- pecotmr:::.ldSourceEigen(list(ldFactor = ldFactor)) + expect_lt(length(thin$values), 50L) + expect_equal( + thin$values[thin$values > 1e-8], + whole$values[whole$values > 1e-8], + tolerance = 1e-10 + ) + expect_equal( + tcrossprod(sweep(thin$vectors, 2L, thin$values, "*"), thin$vectors), + R, + tolerance = 1e-10 + ) + # A decomposition is its own; one a source carries is read as it is, + # and its draws are the matrix's. + expect_identical( + pecotmr:::.ldSourceEigen(list( + vectors = thin$vectors, + values = thin$values + )), + list(values = thin$values, vectors = thin$vectors) + ) + expect_identical(pecotmr:::.ldSourceEigen(list(R = R, eigen = thin)), thin) + set.seed(1) + drawn <- pecotmr:::.ldSourceDraws(list(R = R), 3L) + set.seed(1) + expect_identical( + pecotmr:::.ldSourceDraws(list(R = R, eigen = whole), 3L), + drawn + ) +}) + test_that("a sketch's .afreq sidecar is read beside a file of any format", { # The sidecar is named after the file's stem, whatever the format; a # stochastic one (U_MIN / U_MAX, OBS_CT) records the real sample count @@ -3264,9 +3346,9 @@ test_that(".ldRefDict stores each distinct reference once and keys every row", { b <- .ldr_ldm(rho = 0.5) # An equal copy built separately is the same reference, not a second one. dict <- pecotmr:::.ldRefDict(list(a, NULL, b, a, .ldr_ldm())) - expect_identical(dict$refs, list(ld1 = a, ld2 = b)) + expect_identical(dict$entries, list(ld1 = a, ld2 = b)) expect_identical(dict$keys, c("ld1", NA, "ld2", "ld1", "ld1")) - expect_identical(pecotmr:::.ldRefDict(list(NULL))$refs, list()) + expect_identical(pecotmr:::.ldRefDict(list(NULL))$entries, list()) }) test_that("a collection keeps each row on its own reference, stored once", { @@ -3505,3 +3587,124 @@ test_that("filterVariantsByLdReference filters via a PLINK metadata file", { # Fake variants should be filtered out expect_true(length(result$data) <= length(variant_ids)) }) + +# ---- packed LD sources ------------------------------------------------------- + +test_that("an LD source answers the same in every form", { + set.seed(3) + ldFactor <- pecotmr:::.ldFactorFromDosage(matrix(rnorm(60 * 6), 60, 6)) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) + dec <- eigen(R, symmetric = TRUE) + packed <- Matrix::pack(Matrix::forceSymmetric(R, uplo = "U")) + forms <- list( + R = list(R = R), + P = list(P = packed, sign = rep(1, 6L)), + ldFactor = list(ldFactor = ldFactor), + eigen = list(vectors = dec$vectors, values = dec$values) + ) + B <- matrix(rnorm(12), 6, 2) + for (nm in names(forms)) { + ld <- forms[[nm]] + expect_equal( + unname(pecotmr:::.ldSourceMatrix(ld)), + unname(R), + tolerance = 1e-10, + label = nm + ) + expect_equal( + unname(pecotmr:::.ldSourceTimes(ld, B)), + unname(R %*% B), + tolerance = 1e-10, + label = nm + ) + expect_equal( + pecotmr:::.ldQuadForms(ld, B), + colSums(B * (R %*% B)), + tolerance = 1e-10, + label = nm + ) + expect_equal( + unname(pecotmr:::.ldSourceRows(ld, c(5L, 2L))), + unname(R[c(5, 2), ]), + tolerance = 1e-10, + label = nm + ) + expect_equal(pecotmr:::.ldSourceSize(ld), 6L, label = nm) + } + idx <- c(4L, 1L, 6L) + for (nm in c("R", "P", "ldFactor")) { + cut <- pecotmr:::.ldSourceSubset(forms[[nm]], idx) + expect_equal( + unname(pecotmr:::.ldSourceMatrix(cut)), + unname(R[idx, idx]), + tolerance = 1e-10, + label = nm + ) + } + # A packed source reads each variant with its allele sign. + sign <- c(1, -1, 1, 1, -1, 1) + signed <- list(P = packed, sign = sign) + flipped <- R * outer(sign, sign) + expect_equal(unname(pecotmr:::.ldSourceMatrix(signed)), unname(flipped)) + expect_equal( + unname(pecotmr:::.ldSourceRows(signed, c(2L, 5L))), + unname(flipped[c(2, 5), ]) + ) + expect_equal( + unname(pecotmr:::.ldSourceTimes(signed, B)), + unname(flipped %*% B) + ) + expect_equal( + unname(pecotmr:::.ldSourceMatrix( + pecotmr:::.ldSourceSubset(signed, idx) + )), + unname(flipped[idx, idx]) + ) + # Held-out draws decompose the same matrix either way. + set.seed(1) + whole <- pecotmr:::.ldSourceDraws(forms$R, 3L) + set.seed(1) + expect_identical(pecotmr:::.ldSourceDraws(forms$P, 3L), whole) +}) + +test_that("a sign flip negates the flipped variants' rows and columns", { + R <- matrix(c(1, 0.5, 0.2, 0.5, 1, -0.3, 0.2, -0.3, 1), 3L) + flip <- c(1, -1, 1) + expect_equal(pecotmr:::.ldSignFlipped(R, flip), R * outer(flip, flip)) + expect_identical(pecotmr:::.ldSignFlipped(R, rep(1, 3L)), R) +}) + +test_that(".ldPackedFromRef reads an LdMatrix's block as .ldFromRef does", { + data(eqtlRegionExample, envir = environment()) + X <- eqtlRegionExample$X[, 1:8] + ldm <- LdMatrix(cor(X), nSamples = 10) + ids <- colnames(X)[c(6L, 2L, 4L)] + # An id given with its alleles swapped reads its rows and columns + # negated, as .ldFromRef() reads them. + parts <- str_split_fixed(ids[[2L]], ":", 4L) + ids[[2L]] <- str_c( + parts[, 1L], + parts[, 2L], + parts[, 4L], + parts[, 3L], + sep = ":" + ) + src <- pecotmr:::.ldPackedFromRef(ldm, ids, "test") + expect_s4_class(src$P, "dspMatrix") + expect_equal(nrow(src$P), 3L) + expect_equal( + pecotmr:::.ldSourceMatrix(src), + unname(pecotmr:::.ldFromRef(ldm, ids, "test")) + ) + absent <- "chr22:1:A:G" + kept <- pecotmr:::.ldPackedFromRef( + ldm, + c(ids, absent), + "test", + onMissing = "drop" + ) + expect_identical(attr(kept, "keptVariantIds"), ids) + expect_null( + pecotmr:::.ldPackedFromRef(ldm, absent, "test", onMissing = "drop") + ) +}) diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index 9bbfcf940..2e1da4fe7 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -366,7 +366,8 @@ test_that("loadGwasSumStatsFromManifest reads per-variant N_CASE/N_CONTROL", { expect_s4_class(obj, "GwasSumStats") mc <- S4Vectors::mcols(obj[[1L]]) expect_true(all(c("N_CASE", "N_CONTROL") %in% colnames(mc))) - expect_false("N" %in% colnames(mc)) # effective N is derived later by summaryStatsQc + # effective N is derived later by summaryStatsQc + expect_false("N" %in% colnames(mc)) expect_equal(as.integer(mc$N_CASE), rep(1000L, 5)) }) @@ -387,7 +388,8 @@ test_that(".resolveSumstatCols derives the Wald z from beta/se", { df$z <- NULL # no z column out <- pecotmr:::.resolveSumstatCols(df, NULL, "lbl") expect_equal(out$Z, .toyGwasDf(4)$z) # Z == beta/se - expect_true(all(c("BETA", "SE") %in% colnames(out))) # beta/se still attached + # beta/se still attached + expect_true(all(c("BETA", "SE") %in% colnames(out))) }) test_that("an af: key is directional AF; a maf: key is directionless", { @@ -479,7 +481,8 @@ test_that(".resolveSumstatCols allows no N when allowNoN = TRUE", { df$n_sample <- NULL # no per-variant N, no counts out <- pecotmr:::.resolveSumstatCols(df, NULL, "lbl", allowNoN = TRUE) expect_false("N" %in% colnames(out)) # built without N ... - expect_true(all(c("SNP", "A1", "A2", "Z") %in% colnames(out))) # ... core kept + # ... core kept + expect_true(all(c("SNP", "A1", "A2", "Z") %in% colnames(out))) }) test_that("loadGwasSumStatsFromManifest builds from a study nSample scalar", { @@ -1515,10 +1518,11 @@ test_that("GWAS-VCF without SS, or without ES/SE, errors", { # Each case drops fields the reader needs; the error names them. cases <- list(SS = list(dropSs = TRUE), `ES and SE` = list(dropEs = TRUE)) for (field in names(cases)) { + caseArgs <- cases[[field]] vcf <- exec( .writeGwasVcf, tempfile(tmpdir = tmp, fileext = ".vcf"), - !!!cases[[field]] + !!!caseArgs ) manifest <- data.frame( study = "study1", diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index b5897921d..02088af2e 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -274,7 +274,7 @@ test_that("makePairwiseContrastCol preserves template names", { expect_equal(names(out), c("x", "y", "z")) }) -test_that("makePairwiseContrastCol overwrites pre-existing values in template", { +test_that("makePairwiseContrastCol overwrites values already in the template", { tmpl <- setNames(c(5, -3, 7), c("a", "b", "c")) out <- makePairwiseContrastCol(c("a", "c"), tmpl) expect_equal(out[["a"]], 1) # was 5, now 1 @@ -332,7 +332,7 @@ test_that("sliceMashData restricts data$snp to intersection of snps argument", { # metaAnalysisPerCondition # --------------------------------------------------------------------------- -test_that("metaAnalysisPerCondition returns single-effect p-value when only one feature passes filter", { +test_that("metaAnalysisPerCondition: one passing feature gives its own p", { feat <- "var1" cols <- c("mean_contrast_brain_vs_blood") es <- matrix(0.5, nrow = 1, ncol = 1, dimnames = list(feat, cols)) @@ -359,7 +359,7 @@ test_that("metaAnalysisPerCondition returns single-effect p-value when only one expect_true(all(is.na(out$I2))) }) -test_that("metaAnalysisPerCondition returns NA pvalue when SE cutoff drops everything", { +test_that("metaAnalysisPerCondition: NA p when the SE cutoff drops all", { feat <- c("chr1:100:A:G", "chr1:200:A:G") cols <- "mean_contrast_brain_vs_blood" es <- matrix(c(0.1, 0.2), nrow = 2, ncol = 1, dimnames = list(feat, cols)) @@ -370,7 +370,7 @@ test_that("metaAnalysisPerCondition returns NA pvalue when SE cutoff drops every expect_true(all(is.na(out$meta_effect))) }) -test_that("metaAnalysisPerCondition runs DerSimonian-Laird when >=2 effects survive", { +test_that("metaAnalysisPerCondition runs DerSimonian-Laird on 2+ effects", { feat <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") cols <- "mean_contrast_brain_vs_blood" es <- matrix( @@ -387,7 +387,8 @@ test_that("metaAnalysisPerCondition runs DerSimonian-Laird when >=2 effects surv ) out <- metaAnalysisPerCondition(es, se) expect_equal(nrow(out), 2L) - # All three effects survive (SE = 0.1 > 0): meta_effect and meta_se populated + # All three effects survive (SE = 0.1 > 0): meta_effect and meta_se + # populated expect_false(any(is.na(out$meta_effect))) expect_false(any(is.na(out$meta_se))) expect_false(any(is.na(out$tau2))) @@ -396,7 +397,7 @@ test_that("metaAnalysisPerCondition runs DerSimonian-Laird when >=2 effects surv expect_true(all(out$I2 >= 0 & out$I2 <= 1)) }) -test_that("metaAnalysisPerCondition unique-condition extraction handles >2 conditions", { +test_that("metaAnalysisPerCondition extracts conditions when there are 3+", { feat <- "chr1:100:A:G" cols <- c( "mean_contrast_brain_vs_blood", @@ -415,7 +416,7 @@ test_that("metaAnalysisPerCondition unique-condition extraction handles >2 condi # updateMashModelCov — works on a hand-built mock fitted_g (no mashr dep) # --------------------------------------------------------------------------- -test_that("updateMashModelCov drops dropped conditions + resizes remaining cov matrices", { +test_that("updateMashModelCov drops conditions, resizes the rest's matrices", { R <- 3L samples <- c("brain", "blood", "muscle") U <- list( @@ -476,7 +477,7 @@ test_that("fitMashContrast returns NULL when fewer than 2 tested conditions", { expect_null(fitMashContrast(1L, origMean, pm, pv)) }) -test_that("fitMashContrast: 2-tested-conditions fast path yields one pairwise contrast", { +test_that("fitMashContrast: 2 tested conditions give one pairwise contrast", { origMean <- matrix( c(0.5, 0.3, 0), nrow = 1, @@ -506,7 +507,7 @@ test_that("fitMashContrast: 2-tested-conditions fast path yields one pairwise co expect_equal(out[["mean_contrast_a_vs_b"]], 0.5 - 0.3) }) -test_that("fitMashContrast: 3-tested-conditions yields deviation + pairwise contrasts", { +test_that("fitMashContrast: 3 tested conditions give deviation + pairwise", { origMean <- matrix( c(0.5, 0.3, -0.2), nrow = 1, @@ -576,13 +577,15 @@ test_that("fitMashContrast applies deviation + pairwise group adjustments", { pv <- array(0, dim = c(4, 4, 1), dimnames = list(conds, conds, NULL)) pv[,, 1] <- diag(4) * 0.1 # a,b share group 1 (replicates); c is its own group 2; d ungrouped (0). - # Non-NULL grouping triggers `grouping <- grouping[tested]`, the >2-condition - # deviation re-weighting loop, and the pairwise group-adjustment loop. + # Non-NULL grouping triggers `grouping <- grouping[tested]`, the + # >2-condition deviation re-weighting loop, and the pairwise + # group-adjustment loop. grouping <- setNames(c(1L, 1L, 2L, 0L), conds) out <- fitMashContrast(1L, origMean, pm, pv, grouping = grouping) expect_s3_class(out, "data.frame") expect_equal(nrow(out), 1L) - # feature_id + 4 deviation + choose(4,2)=6 pairwise = 10 contrasts -> 31 cols. + # feature_id + 4 deviation + choose(4,2)=6 pairwise = 10 contrasts -> 31 + # cols. expect_equal(ncol(out), 31L) contrastSuffix <- sub("^(mean|se|p)_contrast_", "", names(out)) expect_true(any(grepl("_deviation$", contrastSuffix))) @@ -596,7 +599,7 @@ test_that("fitMashContrast applies deviation + pairwise group adjustments", { # else branch, distinct from the no-dimnames positional-slice branch) # --------------------------------------------------------------------------- -test_that("updateMashModelCov slices named data-driven cov matrices by sample", { +test_that("updateMashModelCov slices named data-driven matrices by sample", { allSamples <- c("brain", "blood", "muscle") ddMat <- matrix(seq_len(9), 3, 3, dimnames = list(allSamples, allSamples)) U <- list(identity = diag(1, 3), dataDriven = ddMat) @@ -607,7 +610,8 @@ test_that("updateMashModelCov slices named data-driven cov matrices by sample", allSamples = allSamples, samples = c("brain", "muscle") ) - # The named data-driven matrix is sliced by name: cov[[d]][samples, samples]. + # The named data-driven matrix is sliced by name: cov[[d]][samples, + # samples]. expect_equal(dim(m2$fitted_g$Ulist$dataDriven), c(2L, 2L)) expect_equal( m2$fitted_g$Ulist$dataDriven, @@ -622,7 +626,7 @@ test_that("updateMashModelCov slices named data-driven cov matrices by sample", # metaAnalysisPerCondition — conditions matching no contrast column are skipped # --------------------------------------------------------------------------- -test_that("metaAnalysisPerCondition skips conditions whose name matches no column", { +test_that("metaAnalysisPerCondition skips conditions matching no column", { # The condition "x$y" is a derived condition name; used as a grep() pattern # the embedded `$` anchor matches nothing, exercising the # `if (length(idx) == 0) next` skip branch. @@ -741,7 +745,7 @@ test_that("mashPipeline rejects priorCovariances with wrong dimensions", { ) }) -test_that("mashPipeline passes supplied residualCorrelation + priorCovariances through", { +test_that("mashPipeline passes residualCorrelation, priorCovariances on", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") ss <- .mpSs @@ -878,7 +882,7 @@ test_that("a supplied residualCorrelation wins over the method", { # mashResidualCorrelation — the Vhat estimator extracted from mashPipeline. # --------------------------------------------------------------------------- -test_that("mashResidualCorrelation(identity) is an identity of the right size", { +test_that("mashResidualCorrelation(identity) is a right-sized identity", { skip_if_not_installed("mashr") ss <- .mpSs v <- mashResidualCorrelation( @@ -901,7 +905,8 @@ test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { ) )) expect_equal(dim(v), c(3L, 3L)) - expect_equal(unname(diag(v)), rep(1, 3), tolerance = 1e-8) # a correlation matrix + # a correlation matrix + expect_equal(unname(diag(v)), rep(1, 3), tolerance = 1e-8) expect_true(isSymmetric(unname(v))) }) @@ -918,7 +923,7 @@ test_that("mashResidualCorrelation(simple) errors without a null entry", { ) }) -test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", { +test_that("mashResidualCorrelation(simpleSpecific) gives a null correlation", { skip_if_not_installed("mashr") ss <- .mpSs v <- suppressMessages(suppressWarnings( @@ -932,7 +937,7 @@ test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", expect_equal(unname(diag(v)), rep(1, 3), tolerance = 1e-6) }) -test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", { +test_that("mashResidualCorrelation(corshrink) gives a 3x3 correlation", { skip_if_not_installed("mashr") skip_if_not_installed("CorShrink") ss <- .mpSs @@ -1236,7 +1241,7 @@ test_that("mashCovarianceComponents default builds all non-udr components", { expect_gt(length(.mpDefaultComps), length(one)) }) -test_that("mashCovarianceComponents feeds mashPriorCovariances (same components)", { +test_that("mashCovarianceComponents feeds mashPriorCovariances", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") ss <- .mpSs @@ -1281,7 +1286,7 @@ test_that("mashCovarianceComponents rejects unknown components", { ) }) -test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode)", { +test_that("mashPriorCovariances refines supplied priorComponents", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") ss <- .mpSs @@ -1318,7 +1323,7 @@ test_that("mashPriorCovariances validates priorComponents", { ) }) -test_that("mashPipeline result == composing the two extracted building blocks", { +test_that("mashPipeline equals composing its two building blocks", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") ss <- .mpSs @@ -1363,7 +1368,7 @@ test_that(".mashAsUlist unwraps the wrapper and passes a bare Ulist through", { expect_null(pecotmr:::.mashAsUlist(NULL)) }) -test_that(".mashAsUlist does not mistake a covariance named U for the wrapper", { +test_that(".mashAsUlist doesn't mistake a covariance named U for a wrapper", { # A genuine Ulist entry named "U" is a matrix, not a list, which is what # keeps the two shapes distinguishable. ulist <- list(U = diag(3), identity = diag(3)) @@ -1388,7 +1393,7 @@ test_that("fitMashContrast consumes a mashPosterior result", { # metaAnalysisPerCondition # --------------------------------------------------------------------------- -test_that("metaAnalysisPerCondition: threads metaMethod (DL default unchanged)", { +test_that("metaAnalysisPerCondition passes metaMethod on (DL by default)", { es <- matrix( rnorm(12), 6, @@ -1432,7 +1437,7 @@ test_that("metaAnalysisPerCondition: threads metaMethod (DL default unchanged)", list(pm = pm, pv = pv, orig = orig) } -test_that("mashPosteriorContrast: deviation + pairwise columns, rownames preserved", { +test_that("mashPosteriorContrast: deviation + pairwise columns, rows named", { f <- .mpc_fixture() res <- mashPosteriorContrast(f$pm, f$pv, f$orig) expect_equal(nrow(res), 5L) @@ -1450,7 +1455,7 @@ test_that("mashPosteriorContrast: deviation + pairwise columns, rownames preserv expect_false(is.unsorted(match(kinds, c("mean", "se", "p")))) }) -test_that("mashPosteriorContrast: features with < 2 tested conditions are dropped", { +test_that("mashPosteriorContrast drops features tested in under 2 conditions", { f <- .mpc_fixture() f$orig[2, ] <- 0 # feature 2 has no tested condition f$orig[4, c(2, 3)] <- 0 # feature 4 has only 1 tested condition @@ -1480,7 +1485,7 @@ test_that("mashPosteriorContrast: grouping is forwarded to fitMashContrast", { mashPosteriorContrast(f$pm, f$pv, f$orig) } -test_that("calculateFeatureScores: one Z per condition from deviation contrasts", { +test_that("calculateFeatureScores: a Z per condition from deviations", { cr <- .fs_contrast() fs <- calculateFeatureScores(cr, metaMethod = "REML") expect_setequal(fs$condition, c("Ast", "Mic", "Oli")) @@ -1490,7 +1495,7 @@ test_that("calculateFeatureScores: one Z per condition from deviation contrasts" expect_equal(nrow(calculateFeatureScores(data.frame(x = 1))), 0L) }) -test_that("nSignificantScore: fraction of significant deviation contrasts in [0,1]", { +test_that("nSignificantScore: share of significant deviations, in [0,1]", { cr <- .fs_contrast() ns <- nSignificantScore(cr, pCutoff = 0.5) expect_setequal(ns$condition, c("Ast", "Mic", "Oli")) @@ -1541,7 +1546,7 @@ test_that("calculateFeatureScores: NA when a condition's se column is absent", { expect_true(is.na(out$zScore)) }) -test_that("calculateFeatureScores: NA when no finite (effect, se) pair remains", { +test_that("calculateFeatureScores: NA when no finite effect, se pair remains", { cr <- data.frame( mean_contrast_Ast_deviation = c(1, 2), se_contrast_Ast_deviation = c(0, -1) @@ -1549,13 +1554,13 @@ test_that("calculateFeatureScores: NA when no finite (effect, se) pair remains", expect_true(is.na(calculateFeatureScores(cr)$zScore)) }) -test_that("nSignificantScore: empty result when there are no deviation p-value columns", { +test_that("nSignificantScore is empty without deviation p-value columns", { out <- nSignificantScore(data.frame(foo = 1:3, bar = 4:6)) expect_equal(nrow(out), 0L) expect_named(out, c("condition", "ratio")) }) -test_that("scoreFromCs: falls back to the single pairwise contrast when no deviation column", { +test_that("scoreFromCs uses the lone pairwise contrast without deviations", { fm <- data.frame( cs_order = c(1, 1, 0), pip = c(0.9, 0.5, 0.1), @@ -1569,11 +1574,12 @@ test_that("scoreFromCs: falls back to the single pairwise contrast when no devia feature_id = c("chr1:100:A:G", "chr1:200:A:G"), stringsAsFactors = FALSE ) - # condition "Xyz" has no deviation column; exactly one pairwise contrast exists. + # condition "Xyz" has no deviation column; exactly one pairwise contrast + # exists. expect_true(is.finite(scoreFromCs(fm, cr, condition = "Xyz"))) }) -test_that("scoreFromCs: NA when neither a deviation nor a single pairwise column exists", { +test_that("scoreFromCs: NA with no deviation and no lone pairwise column", { fm <- data.frame( cs_order = c(1, 0), pip = c(0.9, 0.1), @@ -1975,7 +1981,7 @@ test_that("filterInvalidSummaryStat replaces NaN/Inf in sbhat", { expect_equal(unname(result$sbhat[3, "a"]), 1000) }) -test_that("filterInvalidSummaryStat filters by missing_rate when null.b present", { +test_that("filterInvalidSummaryStat filters by missing_rate given null.b", { dat <- list( bhat = data.frame(a = c(0, 0, 1, 2), b = c(0, 0, 0, 3)), sbhat = data.frame(a = c(1, 1, 1, 1), b = c(1, 1, 1, 1)), @@ -1990,7 +1996,7 @@ test_that("filterInvalidSummaryStat filters by missing_rate when null.b present" expect_equal(nrow(result$bhat), 2) # rows 3 and 4 survive }) -test_that("filterInvalidSummaryStat filters by missing_rate when random.b present", { +test_that("filterInvalidSummaryStat filters by missing_rate given random.b", { dat <- list( bhat = data.frame(a = c(0, 1, 2), b = c(0, 1, 3)), sbhat = data.frame(a = c(1, 1, 1), b = c(1, 1, 1)), @@ -2005,7 +2011,7 @@ test_that("filterInvalidSummaryStat filters by missing_rate when random.b presen expect_true(nrow(result$bhat) < 3) }) -test_that("filterInvalidSummaryStat btoz with .b and .s pattern creates condition.z", { +test_that("filterInvalidSummaryStat btoz: .b and .s columns make condition.z", { dat <- list( strong.b = data.frame(a = c(1, 2), b = c(3, 4)), strong.s = data.frame(a = c(0.1, 0.2), b = c(0.3, 0.4)) @@ -2028,7 +2034,7 @@ test_that("filterInvalidSummaryStat btoz with .b and .s pattern creates conditio ) }) -test_that("filterInvalidSummaryStat btoz when bhat/sbhat data is NULL creates NULL z", { +test_that("filterInvalidSummaryStat btoz: NULL bhat/sbhat makes a NULL z", { dat <- list( strong.b = NULL, strong.s = data.frame(a = c(0.1)) @@ -2044,7 +2050,7 @@ test_that("filterInvalidSummaryStat btoz when bhat/sbhat data is NULL creates NU expect_null(result$strong.z) }) -test_that("filterInvalidSummaryStat btoz without .b/.s pattern creates generic z", { +test_that("filterInvalidSummaryStat btoz without .b/.s makes a generic z", { dat <- list( bhat = data.frame(a = c(1, 2, 3)), sbhat = data.frame(a = c(0.5, 1, 0.5)) @@ -2059,7 +2065,7 @@ test_that("filterInvalidSummaryStat btoz without .b/.s pattern creates generic z expect_equal(as.numeric(result$z[, 1]), c(2, 2, 6)) }) -test_that("filterInvalidSummaryStat btoz creates NULL z when bhat is NULL (no .b suffix)", { +test_that("filterInvalidSummaryStat btoz: NULL z for NULL bhat (no .b)", { dat <- list( bhat = NULL, sbhat = data.frame(a = c(0.1)) @@ -2074,7 +2080,7 @@ test_that("filterInvalidSummaryStat btoz creates NULL z when bhat is NULL (no .b expect_null(result$z) }) -test_that("filterInvalidSummaryStat btoz filters strong.z by significance cutoff", { +test_that("filterInvalidSummaryStat btoz filters strong.z by significance", { dat <- list( strong.b = data.frame( a = c(1, 0.01, 0.02, 2), @@ -2112,7 +2118,7 @@ test_that("filterInvalidSummaryStat processes z directly with null component", { expect_true(all(!is.infinite(result$null$z))) }) -test_that("filterInvalidSummaryStat z path applies significance cutoff to strong.z", { +test_that("filterInvalidSummaryStat z path cuts strong.z by significance", { dat <- list( strong = list( z = data.frame(a = c(10, 0.1, 0.2), b = c(0.1, 0.1, 0.1)) @@ -2133,7 +2139,7 @@ test_that("filterInvalidSummaryStat z path with filterByMissingRate", { expect_equal(nrow(result$random$z), 2) }) -test_that("filterInvalidSummaryStat processes bhat/sbhat without filterByMissingRate when no null.b/random.b", { +test_that("filterInvalidSummaryStat skips missing rate without null/random.b", { dat <- list( bhat = data.frame(a = c(1, NaN, 3), b = c(Inf, 2, -Inf)), sbhat = data.frame(a = c(0.1, NA, 0.3), b = c(0.1, 0.2, NaN)) @@ -2149,7 +2155,7 @@ test_that("filterInvalidSummaryStat processes bhat/sbhat without filterByMissing expect_equal(unname(result$sbhat[3, "b"]), 1000) }) -test_that("filterInvalidSummaryStat with filterByMissingRate=NULL keeps all rows even with null.b", { +test_that("filterByMissingRate = NULL keeps every row even with null.b", { dat <- list( bhat = data.frame(a = c(0, 0, 1), b = c(0, 0, 1)), sbhat = data.frame(a = c(1, 1, 1), b = c(1, 1, 1)), @@ -2240,7 +2246,7 @@ test_that("filterMixtureComponents drops zero matrices, renormalizes weights", { expect_true(result$w["comp2"] > 0.3) }) -test_that("filterMixtureComponents subsets 3x3 matrices to 2x2 and removes filtered condition names", { +test_that("filterMixtureComponents cuts 3x3 to 2x2 and drops their names", { U <- list( comp1 = matrix( c(1, 0.1, 0, 0.1, 2, 0, 0, 0, 3), @@ -2428,7 +2434,7 @@ test_that("mashRandNullSample NULL input returns NULL", { expect_null(result) }) -test_that("mashRandNullSample warns when no null variants found (all abs_z > 2)", { +test_that("mashRandNullSample warns with no null variants (all abs_z > 2)", { dat <- list( z = data.frame( cond1 = c(5, 6, 7, 8, 9), @@ -2469,7 +2475,7 @@ test_that("mashRandNullSample warns when not enough null data", { expect_equal(length(result$null), 0) }) -test_that("mashRandNullSample errors when excludeCondition not found (z path)", { +test_that("mashRandNullSample errors on an unknown excludeCondition (z)", { dat <- list( z = data.frame(cond1 = 1:5, cond2 = 1:5) ) @@ -2496,7 +2502,7 @@ test_that("mashRandNullSample errors when excludeCondition not found (z path)", ) }) -test_that("mashRandNullSample errors when excludeCondition not found (bhat path)", { +test_that("mashRandNullSample errors on an unknown excludeCondition (bhat)", { dat <- list( bhat = data.frame(cond1 = 1:5, cond2 = 1:5), sbhat = data.frame(cond1 = rep(1, 5), cond2 = rep(1, 5)) @@ -2641,7 +2647,7 @@ test_that(".mashSumStatsToMatrices: auto falls back to Z when no BETA/SE", { expect_true(all(out$s == 1 | out$s == 1000)) }) -test_that(".mashSumStatsToMatrices: inputScale='beta' errors when BETA missing", { +test_that(".mashSumStatsToMatrices: inputScale 'beta' errors without BETA", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), @@ -2656,7 +2662,7 @@ test_that(".mashSumStatsToMatrices: inputScale='beta' errors when BETA missing", ) }) -test_that(".mashSumStatsToMatrices: inputScale='z' forces Z+1 even when BETA present", { +test_that(".mashSumStatsToMatrices: inputScale 'z' forces Z+1 despite BETA", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), @@ -2703,7 +2709,7 @@ test_that(".mashSumStatsToMatrices: inputScale='z' errors when Z missing", { ) }) -test_that(".mashObjectMatrices errors when marginal effects lack the required columns", { +test_that(".mashObjectMatrices errors when marginal effects lack a column", { res <- QtlFineMappingResult( studyName = "s", context = "brain", @@ -2738,7 +2744,7 @@ test_that(".mashObjectMatrices errors when marginal effects lack the required co ) }) -test_that(".mashObjectMatrices warns and pins the first method on a multi-method result", { +test_that(".mashObjectMatrices warns, pins the first of several methods", { res <- QtlFineMappingResult( studyName = c("s", "s"), context = c("brain", "liver"), @@ -2756,7 +2762,7 @@ test_that(".mashObjectMatrices warns and pins the first method on a multi-method ) }) -test_that(".mashObjectPartitions errors when < 2 conditions remain after excludeCondition", { +test_that(".mashObjectPartitions errors when under 2 conditions remain", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), @@ -2780,7 +2786,7 @@ test_that(".mashObjectPartitions errors when < 2 conditions remain after exclude ) }) -test_that(".mashObjectPartitions warns when no variants match the independent-variant list", { +test_that(".mashObjectPartitions warns when no independent variant matches", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(n)), @@ -2810,7 +2816,7 @@ test_that(".mashObjectPartitions warns when no variants match the independent-va ) }) -test_that(".mashSumStatsToMatrices on bundled multicontext fixture: shape and rowname format", { +test_that(".mashSumStatsToMatrices on the multicontext fixture: shape, names", { data(qtlSumStatsMulticontextExample) out <- pecotmr:::.mashSumStatsToMatrices( qtlSumStatsMulticontextExample, @@ -2828,7 +2834,7 @@ test_that(".mashSumStatsToMatrices on bundled multicontext fixture: shape and ro expect_true(all(out$s < 1)) }) -test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=1000", { +test_that(".mashSumStatsToMatrices pads missing variants, bhat 0, sbhat 1000", { set.seed(42L) gh <- new( "GenotypeHandle", @@ -2888,7 +2894,7 @@ test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=10 expect_true(all(out$s[, "ctx1"] < 1)) }) -test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) blocks", { +test_that(".mashSumStatsToMatrices disambiguates names across study, trait", { set.seed(7L) gh <- new( "GenotypeHandle", @@ -3183,7 +3189,7 @@ test_that("qtlSumStatsFromZMatrix: one row per context, Z preserved verbatim", { expect_equal(S4Vectors::mcols(liver)$Z, unname(z[, 2])) }) -test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when they don't parse", { +test_that("qtlSumStatsFromZMatrix reads chrom/pos from ids, else makes them", { z <- matrix( rnorm(2), ncol = 1, @@ -3232,7 +3238,7 @@ test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcOptions", { expect_null(mcols(qss)$qcAudit) }) -test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait pairs", { +test_that("qtlSumStatsFromZMatrix: columns map to traits or context x trait", { z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("geneA", "geneB"))) # columns as traits: constant context, one trait per column qss <- qtlSumStatsFromZMatrix( @@ -3256,7 +3262,7 @@ test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait expect_equal(as.character(qss2$trait), c("geneA", "geneA")) }) -test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors", { +test_that("qtlSumStatsFromZMatrix errors on a wrong-length condition label", { z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("a", "b"))) expect_error( qtlSumStatsFromZMatrix( @@ -3269,7 +3275,7 @@ test_that("qtlSumStatsFromZMatrix: a condition label of the wrong length errors" ) }) -test_that("qtlSumStatsFromZMatrix: rejects non-matrix input and unlabelled conditions", { +test_that("qtlSumStatsFromZMatrix refuses a non-matrix, unlabelled columns", { expect_error( qtlSumStatsFromZMatrix(1:5, studyName = "s1", ldReference = .qszm_gh()), "variants x conditions matrix" @@ -3282,7 +3288,7 @@ test_that("qtlSumStatsFromZMatrix: rejects non-matrix input and unlabelled condi ) }) -test_that("qtlSumStatsFromBetaMatrix: one entry per context, BETA/SE/Z mcols set", { +test_that("qtlSumStatsFromBetaMatrix: an entry per context with BETA, SE, Z", { d <- .qszmBeta() qss <- qtlSumStatsFromBetaMatrix( d$bhat, @@ -3303,7 +3309,7 @@ test_that("qtlSumStatsFromBetaMatrix: one entry per context, BETA/SE/Z mcols set expect_equal(mc$Z, unname(d$bhat[, 1] / d$shat[, 1])) }) -test_that("qtlSumStatsFromBetaMatrix: feeds .mashSumStatsToMatrices on both scales", { +test_that("qtlSumStatsFromBetaMatrix feeds mash matrices on both scales", { d <- .qszmBeta() qss <- qtlSumStatsFromBetaMatrix( d$bhat, @@ -3318,7 +3324,7 @@ test_that("qtlSumStatsFromBetaMatrix: feeds .mashSumStatsToMatrices on both scal expect_equal(unname(mz$b), unname(d$bhat / d$shat)) }) -test_that("qtlSumStatsFromBetaMatrix: validates matrices and matching dimensions", { +test_that("qtlSumStatsFromBetaMatrix checks matrices and their dimensions", { d <- .qszmBeta() expect_error( qtlSumStatsFromBetaMatrix(1:5, d$shat, "s1", .qszm_gh()), @@ -3334,7 +3340,7 @@ test_that("qtlSumStatsFromBetaMatrix: validates matrices and matching dimensions ) }) -test_that("qtlSumStatsFromBetaMatrix: NULL rownames -> synthetic ids; placeholders set", { +test_that("qtlSumStatsFromBetaMatrix: no rownames, so placeholder ids", { bhat <- matrix(rnorm(4), nrow = 2, dimnames = list(NULL, c("x", "y"))) shat <- matrix( abs(rnorm(4)) + 0.1, @@ -3447,7 +3453,7 @@ test_that("mashInput: a fine-mapping result with no credible set: no strong", { expect_equal(nrow(out$random.z), 3L) }) -test_that("mashInput: multiple regions accumulate rows and disambiguate names", { +test_that("mashInput: several regions add rows and disambiguate names", { fmr <- .mi_makeFmr() one <- mashInput( list(a = fmr), @@ -3505,7 +3511,7 @@ test_that("mashInput: rejects a non-SumStats/non-FineMapping element", { expect_error(mashInput(list()), "non-empty list") }) -test_that("mashInput: independentVariants restricts random/null pool (strong untouched)", { +test_that("mashInput: independentVariants limits the random/null pool only", { fmr <- .mi_makeFmr() # 6 variants chr1:100..600, 2 contexts vids <- paste0("chr1:", 100 * seq_len(6), ":A:G") indep <- vids[1:3] # only the first three are "independent" @@ -3517,7 +3523,8 @@ test_that("mashInput: independentVariants restricts random/null pool (strong unt sigPCutoff = 0.5, seed = 7 ) - # random / null variant ids (strip the "_g" region suffix) must lie in indep. + # random / null variant ids (strip the "_g" region suffix) must lie in + # indep. rn_ids <- sub("_g$", "", rownames(out$random.z)) expect_true(length(rn_ids) > 0L && all(rn_ids %in% indep)) if (!is.null(out$null.z)) { @@ -3527,10 +3534,11 @@ test_that("mashInput: independentVariants restricts random/null pool (strong unt expect_true(nrow(out$strong.z) >= 1L) }) -test_that("mashInput: independentVariants matches across allele flip + chr prefix", { +test_that("mashInput: independentVariants matches across flips, chr prefix", { fmr <- .mi_makeFmr() # same positions as the first three variants, but ref/alt swapped and the - # chr prefix dropped -- matchVariants must still match them (not a string cmp). + # chr prefix dropped -- matchVariants must still match them (not a string + # cmp). indep_flipped <- c("1:100:G:A", "1:200:G:A", "1:300:G:A") out <- mashInput( list(g = fmr), @@ -3618,7 +3626,7 @@ test_that(".mashPrefixRownames leaves an absent or empty matrix alone", { expect_identical(pecotmr:::.mashPrefixRownames(empty, "ctx"), empty) }) -test_that(".mashProcessZ skips the missing-rate filter when none is asked for", { +test_that(".mashProcessZ skips the missing-rate filter unless asked", { # A NULL filterByMissingRate means "clean the values, keep every row". z <- matrix(c(1, NA, 3, 4), nrow = 2, dimnames = list(c("v1", "v2"), NULL)) out <- pecotmr:::.mashProcessZ(z, NULL) diff --git a/tests/testthat/test_mashWrapper.R b/tests/testthat/test_mashWrapper.R index b83f0e1d5..86e22fc65 100644 --- a/tests/testthat/test_mashWrapper.R +++ b/tests/testthat/test_mashWrapper.R @@ -73,7 +73,7 @@ test_that("mashPosterior outputPosteriorCov = FALSE omits PosteriorCov", { expect_equal(ncol(post$PosteriorMean), 3L) }) -test_that("mashPosterior(excludeCondition) drops the condition from model + output", { +test_that("mashPosterior(excludeCondition) drops it from model and output", { skip_if_not_installed("mashr") ss <- .mwSs conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) @@ -118,7 +118,7 @@ test_that("mashModelFit: SimpleList input + default (NULL) vhat", { expect_s3_class(m, "mash") }) -test_that("mashPosterior: default (NULL) vhat and excludeCondition dropping every condition", { +test_that("mashPosterior: NULL vhat, and excluding every condition", { skip_if_not_installed("mashr") ss <- .mwSs model <- .mwModel @@ -307,7 +307,7 @@ test_that("mashPosterior forwards posteriorArgs", { expect_equal(seen$pi_thresh, 1e-8) }) -test_that("UdFitOptions checks unconstrained.update's value, not just its name", { +test_that("UdFitOptions checks unconstrained.update's value, not its name", { skip_if_not_installed("udr") # udr validates the NAME but not the value: compute_penalty() is two # `if (update.type == ...)` branches with no else, so an unrecognised diff --git a/tests/testthat/test_overlapTopLoci.R b/tests/testthat/test_overlapTopLoci.R index 381324703..15a122f56 100644 --- a/tests/testthat/test_overlapTopLoci.R +++ b/tests/testthat/test_overlapTopLoci.R @@ -32,7 +32,7 @@ context("overlapTopLoci") ) } -test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-flip", { +test_that("overlapTopLoci joins QTL x GWAS allele-aware, flipping signs", { # QTL: two contexts, variants v1 (chr1:100:A:G) and v2 (chr1:200:A:G). q1 <- .ot_entry(.ot_tl( c("chr1:100:A:G", "chr1:200:A:G"), @@ -77,7 +77,8 @@ test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-fli expect_true(all(c("variant_id", "chrom", "pos", "A1", "A2") %in% cols)) expect_true(any(grepl("^qtl_", cols)) && any(grepl("^gwas_", cols))) expect_false(any(grepl("^qtl_(chrom|pos|A1|A2)$", cols))) - # 2 shared variants x 2 QTL contexts x 1 GWAS study = 4 rows (wide cross-product) + # 2 shared variants x 2 QTL contexts x 1 GWAS study = 4 rows (wide + # cross-product) expect_equal(length(ov), 4L) expect_setequal(unique(ov$variant_id), c("chr1:100:A:G", "chr1:200:A:G")) # per-context QTL rows preserved @@ -154,7 +155,8 @@ test_that("overlapTopLoci returns an empty merge when a side has no signal", { method = "susie", entry = list(g) ) - # signalCutoff above every pip (0.9) -> both top-loci tables empty -> emptyMerge. + # signalCutoff above every pip (0.9) -> both top-loci tables empty -> + # emptyMerge. df <- overlapTopLoci(qtl, gwas, signalCutoff = 0.99) expect_equal(length(df), 0L) cols <- names(S4Vectors::mcols(df)) diff --git a/tests/testthat/test_pvalCombineWrappers.R b/tests/testthat/test_pvalCombineWrappers.R index 4a022ec14..75e007649 100644 --- a/tests/testthat/test_pvalCombineWrappers.R +++ b/tests/testthat/test_pvalCombineWrappers.R @@ -102,7 +102,7 @@ test_that("combinePValues: errors when pvals and zScores lengths disagree", { ) }) -test_that("combinePValues: derives p-values from z-scores when only z is given", { +test_that("combinePValues derives p-values from z-scores when only z given", { z <- c(-2.5, 1.0, 3.0) res <- combinePValues(zScores = z, methods = "acat") expected_p <- 2 * pnorm(-abs(z)) @@ -261,7 +261,7 @@ test_that("combinePValues dispatches HMP through the unified menu", { expect_lte(res$results$hmp$pval, 1) }) -test_that("combinePValues dispatches poolr methods (fisher/stouffer/invchisq)", { +test_that("combinePValues dispatches poolr's fisher, stouffer, invchisq", { skip_if_not_installed("poolr") res <- combinePValues( pvals = c(0.01, 0.05, 0.1), diff --git a/tests/testthat/test_qtlAssociationPostprocess.R b/tests/testthat/test_qtlAssociationPostprocess.R index 4cbebd1f6..8470b1294 100644 --- a/tests/testthat/test_qtlAssociationPostprocess.R +++ b/tests/testthat/test_qtlAssociationPostprocess.R @@ -43,7 +43,8 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { r$q_bonferroni_min_original <= 1 )) - # Filtered flavour present and uses the smaller test count (n_variants_filtered). + # Filtered flavour present and uses the smaller test count + # (n_variants_filtered). expect_true(all( c( "p_bonferroni_min_filtered", @@ -68,7 +69,7 @@ test_that("q-values come from qvalue::qvalue, not a hand-rolled fallback", { ) }) -test_that("permutation nominal threshold == stats::qbeta of the empirical cutoff", { +test_that("permutation nominal threshold is qbeta of the empirical cutoff", { x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, @@ -94,7 +95,8 @@ test_that("significantQtls (bonferroni) matches the derived threshold rule", { expect_s4_class(sig, "GRanges") expect_true("trait" %in% names(S4Vectors::mcols(sig))) - # Reproduce the rule: variants with P*n_variants <= max(p_bonf_min over FDR-sig genes). + # Reproduce the rule: variants with P*n_variants <= max(p_bonf_min over + # FDR-sig genes). fdr <- as.numeric(r$fdr_bonferroni_min_original) sigGenes <- which(fdr < 0.5) expect_gt(length(sigGenes), 0) @@ -147,7 +149,7 @@ test_that(".qapSafeQvalue retries both qvalue-native degenerate cases", { } }) -test_that(".qapSafeQvalue re-raises a non-native qvalue error (no hand-rolled q)", { +test_that(".qapSafeQvalue re-raises a non-native qvalue error", { skip_if_not_installed("qvalue") testthat::local_mocked_bindings( qvalue = function(p, ...) stop("some unrelated numerical failure"), @@ -159,9 +161,10 @@ test_that(".qapSafeQvalue re-raises a non-native qvalue error (no hand-rolled q) ) }) -test_that("permutation nominal threshold is NA for every gene when none pass FDR", { - # An impossibly small FDR threshold leaves no q_beta-significant gene, so the - # empirical p_beta bracketing is empty and every nominal threshold is NA. +test_that("permutation nominal threshold is NA when no gene passes FDR", { + # An impossibly small FDR threshold leaves no q_beta-significant gene, so + # the empirical p_beta bracketing is empty and every nominal threshold is + # NA. r <- qtlAssociationPostprocess( .qapDefaultFixture, fdrThreshold = 1e-300, @@ -211,7 +214,8 @@ test_that("significantQtls (permutation) skips genes with an NA threshold", { expect_true(any(!is.na(thr))) # ... alongside non-NA genes sig <- significantQtls(r, "permutation") expect_s4_class(sig, "GRanges") - # Gene 1 contributes nothing; total is the sum over the non-NA-threshold genes. + # Gene 1 contributes nothing; total is the sum over the non-NA-threshold + # genes. expN <- sum(map_int( seq_len(nrow(r)), function(i) { @@ -235,7 +239,8 @@ test_that("significantQtls (permutation) errors without a nominal threshold", { }) test_that("significantQtls (bonferroni) errors when its columns are absent", { - r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") # no bonferroni + # no bonferroni + r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") expect_error(significantQtls(r, "bonferroni_original"), "columns absent") }) @@ -248,7 +253,8 @@ test_that("significantQtls (qvalue) selects variants by their qvalue mcol", { ) sig <- significantQtls(r, "qvalue", threshold = 0.1) expect_s4_class(sig, "GRanges") - # Reproduce: within genes whose event q_beta < 0.1, variants with qvalue < 0.1. + # Reproduce: within genes whose event q_beta < 0.1, variants with qvalue < + # 0.1. qb <- as.numeric(r$q_beta) sigGenes <- which(qb < 0.1) expect_gt(length(sigGenes), 0) @@ -264,7 +270,8 @@ test_that("significantQtls (qvalue) selects variants by their qvalue mcol", { test_that("significantQtls (qvalue) errors when no event q column exists", { # Drop p_beta so permutation adds no q_beta, and skip bonferroni so there is - # no q_bonferroni_min_original either -- yet the object is still postprocessed. + # no q_bonferroni_min_original either -- yet the object is still + # postprocessed. r <- qtlAssociationPostprocess( .qapWithout("p_beta"), methods = "permutation" @@ -274,7 +281,7 @@ test_that("significantQtls (qvalue) errors when no event q column exists", { expect_error(significantQtls(r, "qvalue"), "event q-value column") }) -test_that("significantQtls returns an empty GRanges when nothing is significant", { +test_that("significantQtls: an empty GRanges when nothing is significant", { r <- qtlAssociationPostprocess( .qapDefaultFixture, mafCutoff = 0.01, @@ -285,7 +292,7 @@ test_that("significantQtls returns an empty GRanges when nothing is significant" expect_length(sig, 0) }) -# ---- qtlAssociationPostprocess: required-column + empty-entry guards ---------- +# ---- qtlAssociationPostprocess: required-column + empty-entry guards --------- test_that("qtlAssociationPostprocess requires n_variants for Bonferroni", { expect_error( @@ -297,7 +304,7 @@ test_that("qtlAssociationPostprocess requires n_variants for Bonferroni", { ) }) -test_that("qtlAssociationPostprocess requires n_variants_filtered when filtering", { +test_that("qtlAssociationPostprocess needs n_variants_filtered to filter", { expect_error( qtlAssociationPostprocess( .qapWithout("n_variants_filtered"), @@ -318,8 +325,9 @@ test_that("qtlAssociationPostprocess skips genes whose entry has no variants", { expect_true(all(!is.na(pmin1[-1]))) # every other gene is finite }) -test_that("FILTERED Bonferroni drops MAF/cis-failing variants + uses n_variants_filtered", { - # Fixture entries: af = (.30, .20, .005, .40), tss/tes_distance = (0, 500, 9e5, 2e6). +test_that("filtered Bonferroni: drops failing variants, n_variants_filtered", { + # Fixture entries: AF = (.30, .20, .005, .40), + # tss/tes_distance = (0, 500, 9e5, 2e6). # With mafCutoff 0.01 + cisWindow 1e6 the filtered set keeps only v1, v2 # (v3 fails MAF, v4 is outside the cis window); the filtered count is 30. x <- .qapDefaultFixture @@ -340,7 +348,30 @@ test_that("FILTERED Bonferroni drops MAF/cis-failing variants + uses n_variants_ )) }) -test_that("significantQtls(bonferroni_filtered) applies the derived rule on the filtered set", { +test_that("a requested filter refuses entries without its column", { + # afCol defaulted to "af" while a QtlSumStats stores AF, so the MAF filter + # found no column and silently kept every variant in the "filtered" set. + x <- .qapDefaultFixture + expect_error( + qtlAssociationPostprocess( + x, + mafCutoff = 0.01, + methods = "bonferroni", + afCol = "af" + ), + "needs the per-variant column\\(s\\) af" + ) + expect_error( + .qapRequireFilterCols(S4Vectors::DataFrame(AF = 0.3), 0, 1e6, "AF", 1L), + "tss_distance, tes_distance" + ) + # An entry with no variants has nothing to filter. + expect_null( + .qapRequireFilterCols(S4Vectors::DataFrame(), 0.01, 1e6, "AF", 0L) + ) +}) + +test_that("bonferroni_filtered significance applies to the filtered set", { x <- .qapDefaultFixture r <- qtlAssociationPostprocess( x, @@ -354,7 +385,8 @@ test_that("significantQtls(bonferroni_filtered) applies the derived rule on the sigGenes <- which(!is.na(fdr) & fdr < 0.5) expect_gt(length(sigGenes), 0) # signal genes pass varThr <- max(as.numeric(r$p_bonferroni_min_filtered)[sigGenes]) - # only MAF/cis-passing variants (v1,v2) with P*n_filtered <= threshold qualify + # only MAF/cis-passing variants (v1,v2) with P*n_filtered <= threshold + # qualify expN <- sum(map_int( seq_len(nrow(r)), function(i) { @@ -366,7 +398,7 @@ test_that("significantQtls(bonferroni_filtered) applies the derived rule on the expect_equal(length(sig), expN) # Every returned variant satisfies the filtered keep rule (MAF and the # cis window). - af <- S4Vectors::mcols(sig)$af + af <- S4Vectors::mcols(sig)$AF expect_true(all(pmin(af, 1 - af) > 0.01)) expect_true(all( S4Vectors::mcols(sig)$tss_distance >= -1e6 & diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index 7ce9434f3..7f1ac6c3e 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -335,7 +335,7 @@ test_that("qtlEnrichmentPipeline: ldReference mismatch errors", { # Per-study / per-context iteration via mocked qtlEnrichment # =========================================================================== -test_that("qtlEnrichmentPipeline: returns one row per (gwasStudy, qtlStudy, qtlContext) triple", { +test_that("enrichment returns a row per (gwasStudy, qtlStudy, qtlContext)", { gfmr <- .qep_makeGwasFmr() qfmr <- .qep_makeQtlFmr(contexts = c("c1", "c2")) local_mocked_bindings( @@ -354,7 +354,7 @@ test_that("qtlEnrichmentPipeline: returns one row per (gwasStudy, qtlStudy, qtlC expect_equal(out$enrichment, c(2.0, 2.0)) }) -test_that("qtlEnrichmentPipeline: distinguishes two QTL studies that share a context label", { +test_that("qtlEnrichmentPipeline tells apart QTL studies sharing a context", { # Build a QtlFineMappingResult with two studies (Q1, Q2) both # tagging the same context "shared_ctx". Per-study filtering must # keep them separate (a context-only filter would merge them and @@ -389,7 +389,7 @@ test_that("qtlEnrichmentPipeline: distinguishes two QTL studies that share a con expect_true(all(lengths(capturedRegions) == 1L)) }) -test_that("qtlEnrichmentPipeline: qtlEnrichment failure produces a warning + skip", { +test_that("qtlEnrichmentPipeline warns and skips when qtlEnrichment fails", { gfmr <- .qep_makeGwasFmr() qfmr <- .qep_makeQtlFmr() local_mocked_bindings( @@ -406,7 +406,7 @@ test_that("qtlEnrichmentPipeline: qtlEnrichment failure produces a warning + ski expect_equal(nrow(out), 0L) }) -test_that("qtlEnrichmentPipeline: empty input collections yield the empty schema", { +test_that("qtlEnrichmentPipeline: empty inputs give the empty schema", { # Build a GwasFineMappingResult whose entries have empty fits so the PIP # vector is empty. emptyEntry <- FineMappingRow( @@ -582,7 +582,7 @@ test_that("qtlEnrichmentPipeline: duplicatePips = 'error' refuses conflicts", { ) }) -test_that("qtlEnrichmentPipeline: 'blockEnd' keeps the block ending at the variant", { +test_that("qtlEnrichmentPipeline 'blockEnd' keeps the block ending there", { # The upstream block's window ends at chr1:200; the downstream one starts # there. pip <- .qep_capturedGwasPip( @@ -620,7 +620,7 @@ test_that("qtlEnrichmentPipeline: agreeing copies merge under every policy", { } }) -test_that(".enrBuildQtlRegionsList: returns per-entry fit shapes for a (study, context) hit", { +test_that(".enrBuildQtlRegionsList gives each entry's fit for a hit", { qfmr <- .qep_makeQtlFmr(contexts = c("c1", "c2")) out <- pecotmr:::.enrBuildQtlRegionsList(qfmr, .qep_qtlIdent("Q1", "c1")) expect_equal(length(out), 1L) @@ -628,7 +628,7 @@ test_that(".enrBuildQtlRegionsList: returns per-entry fit shapes for a (study, c expect_true(!is.null(out[[1L]]$pip)) }) -test_that(".enrBuildQtlRegionsList: returns empty list when the (study, context) tuple is absent", { +test_that(".enrBuildQtlRegionsList: an empty list for an absent tuple", { qfmr <- .qep_makeQtlFmr(contexts = c("c1", "c2")) # Correct context but wrong study -> no hit, even though context exists. expect_equal( @@ -692,7 +692,7 @@ test_that(".enrBuildQtlRegionsList: returns empty list when the (study, context) ) } -test_that("qtlEnrichment: real C++ kernel returns the expected keys (numGwas + piQtl supplied)", { +test_that("qtlEnrichment: the C++ kernel returns the expected keys", { fx <- .qep_makeRealKernelInputs() res <- qtlEnrichment( gwasPip = fx$gwasPip, @@ -746,7 +746,7 @@ test_that("qtlEnrichment: a single MI round is estimable, not NaN", { )))) }) -test_that("qtlEnrichment: numGwas omitted -> estimates piGwas from data + warns", { +test_that("qtlEnrichment without numGwas estimates piGwas and warns", { fx <- .qep_makeRealKernelInputs(nSnps = 30, causalIdx = c(5, 15)) expect_warning( res <- qtlEnrichment( @@ -762,7 +762,7 @@ test_that("qtlEnrichment: numGwas omitted -> estimates piGwas from data + warns" expect_type(res, "list") }) -test_that("qtlEnrichment: piQtl omitted -> estimates from susieQtlRegions + warns", { +test_that("qtlEnrichment without piQtl estimates it from the QTL fits, warns", { fx <- .qep_makeRealKernelInputs(nSnps = 30, causalIdx = c(5, 15)) expect_warning( res <- qtlEnrichment( @@ -1273,9 +1273,9 @@ test_that("qtlEnrichment: reports per-round diagnostics", { } # =========================================================================== -# qtlEnrichment(): fastenloc semantics -# Checked against the R transcription of fastenloc above. fastenloc's EM keeps the previous iteration's -# intercept at convergence, so only sd (intercept) is not compared. +# qtlEnrichment(): fastenloc semantics Checked against the R transcription of +# fastenloc above. fastenloc's EM keeps the previous iteration's intercept at +# convergence, so only sd (intercept) is not compared. # =========================================================================== # The one-hot regions plus r4, whose effects sit on a GWAS variant and on @@ -1398,7 +1398,7 @@ test_that("qtlEnrichment: estimates do not depend on variant or region order", { expect_equal(unlist(res[keys]), unlist(base[keys]), tolerance = 1e-10) }) -test_that("qtlEnrichment: the variant total is the GWAS and QTL-only variants", { +test_that("qtlEnrichment: the variant total is GWAS plus QTL-only variants", { regions <- .qep_qtlOnlyRegions() # 200 GWAS variants and 5 QTL-only ones. expect_warning( @@ -1422,7 +1422,7 @@ test_that("qtlEnrichment: the variant total is the GWAS and QTL-only variants", expect_equal(unlist(below[keys]), unlist(at205[keys])) }) -test_that("qtlEnrichment: piQtl defaults to the summed QTL PIPs over the total", { +test_that("qtlEnrichment: piQtl defaults to summed QTL PIPs over the total", { regions <- .qep_qtlOnlyRegions() expect_warning( estimated <- qtlEnrichment( @@ -1594,7 +1594,7 @@ test_that("qtlEnrichment: refuses gwasPip naming a variant twice", { # qtlEnrichment(): verbose messages # =========================================================================== -test_that("qtlEnrichment: verbose=TRUE emits 'Estimated piGwas'/'Estimated piQtl' messages", { +test_that("qtlEnrichment(verbose = TRUE) reports the estimated priors", { # numGwas = NULL and piQtl = NULL both trigger data-estimation paths; # with verbose = TRUE each emits a message. fx <- .qep_makeRealKernelInputs(nSnps = 30, causalIdx = c(5, 15)) @@ -1663,7 +1663,7 @@ test_that(".enrBuildGwasPipVector: unknown study yields numeric(0)", { ) }) -test_that(".enrBuildGwasPipVector: skips a block whose pip length disagrees with variantIds", { +test_that(".enrBuildGwasPipVector skips a block whose pips miscount ids", { # Unnamed pip of length 2 against 3 variant ids -> ids come from # variantIds and length(ids) != length(pip) -> the block is skipped, # leaving no pieces -> numeric(0). @@ -1720,7 +1720,7 @@ test_that(".enrBuildQtlRegionsList: skips an entry whose fit lacks alpha/pip", { ) }) -test_that(".enrBuildQtlRegionsList: names an unnamed pip from the entry's variant ids", { +test_that(".enrBuildQtlRegionsList names an unnamed pip by the entry's ids", { unnamedPipFit <- list( alpha = matrix(c(0.6, 0.4), nrow = 1), pip = c(0.6, 0.4), # unnamed -> names assigned from variantIds @@ -1755,7 +1755,7 @@ test_that(".enrBuildQtlRegionsList: names an unnamed pip from the entry's varian # and the per-tuple "no usable QTL regions" skip # =========================================================================== -test_that("qtlEnrichmentPipeline: empty QTL collection errors with the no-triples message", { +test_that("qtlEnrichmentPipeline errors on an empty QTL collection", { gfmr <- .qep_makeGwasFmr() qfmrEmpty <- QtlFineMappingResult( studyName = character(0), @@ -1774,7 +1774,7 @@ test_that("qtlEnrichmentPipeline: empty QTL collection errors with the no-triple ) }) -test_that("qtlEnrichmentPipeline: alignTuple cache is reused across GWAS studies", { +test_that("qtlEnrichmentPipeline reuses the alignTuple cache across studies", { # Two GWAS studies -> each QTL tuple's alignment is computed for the # first study (cache miss) and served from cache for the second # (alignTuple early-return branch). @@ -1805,7 +1805,7 @@ test_that("qtlEnrichmentPipeline: alignTuple cache is reused across GWAS studies expect_setequal(out$gwasStudy, c("G1", "G2")) }) -test_that("qtlEnrichmentPipeline: a tuple with no usable QTL regions warns and is skipped", { +test_that("qtlEnrichmentPipeline warns, skips a tuple without QTL regions", { gfmr <- .qep_makeGwasFmr() emptyQtlEntry <- FineMappingRow( variantIds = "chr1:100:A:G", @@ -2005,8 +2005,9 @@ test_that("enrichment names a narrowed row's PIPs by its fit's variants", { method = "susie", entry = list(row) ) + piece <- pecotmr:::.enrPipTablesAt(endoapply(gwas, utils::head, 2L), 1L) expect_equal( - pecotmr:::.enrRowPipVector(1L, endoapply(gwas, utils::head, 2L)), + set_names(piece$pip, pecotmr:::.variantTableIds(piece$table)), set_names(pip, vids) ) qtl <- QtlFineMappingResult( @@ -2016,9 +2017,9 @@ test_that("enrichment names a narrowed row's PIPs by its fit's variants", { method = "susie", entry = list(row) ) - region <- pecotmr:::.enrRowRegion(1L, endoapply(qtl, utils::head, 2L)) - expect_equal(region$pip, set_names(pip, vids)) - expect_equal(region$prior_variance, 1) + region <- pecotmr:::.enrRegionsAt(endoapply(qtl, utils::head, 2L), 1L) + expect_equal(region[[1L]]$pip, set_names(pip, vids)) + expect_equal(region[[1L]]$prior_variance, 1) # A narrowed row whose fit names none has nothing to name them by. unnamed <- QtlFineMappingResult( studyName = "q1", @@ -2032,7 +2033,7 @@ test_that("enrichment names a narrowed row's PIPs by its fit's variants", { )) ) expect_error( - pecotmr:::.enrRowRegion(1L, endoapply(unnamed, utils::head, 2L)), + pecotmr:::.enrRegionsAt(endoapply(unnamed, utils::head, 2L), 1L), "does not name its variables" ) }) @@ -2128,7 +2129,7 @@ test_that(".enrValidateFits names a fit whose alpha is not a numeric matrix", { ) }) -test_that(".enrReportDiagnostics warns of unconverged rounds, reports the rest", { +test_that(".enrReportDiagnostics warns of unconverged rounds, reports rest", { en <- list( `EM converged per MI round` = c(TRUE, FALSE), `Missing proportion per MI round` = c(0.1, 0.3), diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index 9a000b826..e2f696c78 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -11,7 +11,7 @@ test_that("QtlSumStats: minimal single-tuple object builds and validates", { expect_equal(nrow(obj), 1L) }) -test_that("QtlSumStats: multi-tuple object is keyed by (study, context, trait)", { +test_that("a multi-tuple QtlSumStats is keyed by (study, context, trait)", { obj <- QtlSumStats( studyName = c("s1", "s1", "s2"), context = c("c1", "c2", "c1"), @@ -63,7 +63,7 @@ test_that("QtlSumStats: errors when required args are missing", { expect_error(QtlSumStats(studyName = "s1", context = "c1"), "all required") }) -test_that("QtlSumStats: errors on length mismatch among study/context/trait/entry", { +test_that("QtlSumStats errors when its identity and entry lengths differ", { expect_error( QtlSumStats( studyName = c("s1", "s2"), @@ -165,7 +165,7 @@ test_that("QtlSumStats: errors when varY or nSample length is not 1 or n", { } }) -test_that("QtlSumStats: optional nSample column is absent by default, attached and recycled when supplied", { +test_that("QtlSumStats nSample: absent by default, recycled when supplied", { bare <- .qtlMakeOne() expect_false("nSample" %in% names(bare)) # schema unchanged by default obj <- QtlSumStats( @@ -264,7 +264,7 @@ test_that("contexts / traitNames return unique values across tuples", { expect_setequal(traitNames(obj), c("t1", "t2")) }) -test_that("accessors require (study, context, trait) when collection has >1 entry", { +test_that("accessors need the full tuple when the collection has 2+ entries", { obj <- QtlSumStats( studyName = c("s1", "s2"), context = c("c1", "c1"), @@ -478,9 +478,10 @@ test_that("constructor derives tss/tes distance from a point trait position", { expect_equal(mc$tss_distance, mc$tes_distance) }) -test_that("constructor derives distinct tss/tes distance for a multi-base trait", { +test_that("a multi-base trait gets distinct tss and tes distances", { gr <- .qtlMakeEntryGr(3, start_at = 100L, step = 100L) # 100,200,300 - tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(200L, 400L)) # TSS 200, TES 400 + # TSS 200, TES 400 + tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(200L, 400L)) x <- QtlSumStats( studyName = "s", context = "c", @@ -494,7 +495,7 @@ test_that("constructor derives distinct tss/tes distance for a multi-base trait" expect_equal(mc$tes_distance, c(100, 200, 300) - 400) }) -test_that("no traitPos -> no distance columns; existing distance is preserved", { +test_that("no traitPos, no distance columns; a given distance is kept", { z <- .qtlMakeOne(n = 3) expect_null(S4Vectors::mcols(sumStats(z))$tss_distance) diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index 9b4fe7b78..5414eddf7 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -76,7 +76,7 @@ test_that("computeW0 handles all-zero Bhat by returning uniform weights", { }) -test_that("computeW0 distributes weight based on nonzero rows when ncomps > 1", { +test_that("computeW0 weights by nonzero rows when ncomps > 1", { # 2 out of 4 rows have nonzero entries Bhat <- matrix(0, nrow = 4, ncol = 2) Bhat[1, 1] <- 1 @@ -210,7 +210,7 @@ test_that("MrmashPriorParam refuses a priorGrid that is not a vector", { }) -test_that("mrmashWrapper errors when no prior matrices and canonical_priorMatrices is FALSE", { +test_that("mrmashWrapper errors with no data-driven or canonical prior", { skip_if_not_installed("glmnet") skip_if_not_installed("mr.mashr") X <- matrix(rnorm(12), nrow = 3, ncol = 4) @@ -227,7 +227,7 @@ test_that("mrmashWrapper errors when no prior matrices and canonical_priorMatric }) -test_that("mrmashWrapper warns when Y has missing and B_init_method is glasso", { +test_that("mrmashWrapper warns on missing Y with glasso initialisation", { skip_if_not_installed("glmnet") skip_if_not_installed("mr.mashr") set.seed(42) @@ -418,8 +418,9 @@ test_that("computeCoefficientsUnivGlmnet handles NA in Y", { # test_fineMappingWrappers.R. # ============================================================================= -# (Shared .rrwXy / .rrwStatLd / .rrwMulti fixtures live in helper-rrwFixtures.R -# so test_fineMappingWrappers.R can reuse them for the SuSiE weight extractors.) +# (Shared .rrwXy / .rrwStatLd / .rrwMulti fixtures live in +# helper-rrwFixtures.R so test_fineMappingWrappers.R can reuse them for +# the SuSiE weight extractors.) # -------------------------------- individual -------------------------------- @@ -569,15 +570,16 @@ test_that("mrashWeights returns length-p weights and can retain the fit", { test_that("qgg Bayes-alphabet weights (N/L/A/C/R) return length-p weights", { skip_if_not_installed("qgg") f <- .rrwXy() - mc <- list(nit = 200, nburn = 20, nthin = 1) - wN <- exec(bayesNWeights, !!!c(list(f$X, f$y), mc)) + mc <- list(nIter = 200, nBurnin = 20, thin = 1) + fitArgs <- c(list(f$X, f$y), mc) + wN <- exec(bayesNWeights, !!!fitArgs) expect_length(wN, f$p) expect_true(is.numeric(wN)) expect_true(all(is.finite(wN))) - expect_length(exec(bayesLWeights, !!!c(list(f$X, f$y), mc)), f$p) - expect_length(exec(bayesAWeights, !!!c(list(f$X, f$y), mc)), f$p) - expect_length(exec(bayesCWeights, !!!c(list(f$X, f$y), mc)), f$p) - expect_length(exec(bayesRWeights, !!!c(list(f$X, f$y), mc)), f$p) + expect_length(exec(bayesLWeights, !!!fitArgs), f$p) + expect_length(exec(bayesAWeights, !!!fitArgs), f$p) + expect_length(exec(bayesCWeights, !!!fitArgs), f$p) + expect_length(exec(bayesRWeights, !!!fitArgs), f$p) }) test_that("buildMrmashPriorMatrices exposes expand_covs' zeromat", { @@ -612,7 +614,8 @@ test_that("buildMrmashPriorMatrices exposes expand_covs' zeromat", { test_that("bayesAlphabetWeights forwards every MCMC control to gbayes", { # `nthin` was declared and documented (default 5) but never put in # callArgs, so every fit silently ran at gbayes's own nthin = 1 while - # its siblings nit and nburn were forwarded. + # its siblings nit and nburn were forwarded. gbayes runs nit + nburn + # iterations, so the total nIter reaches it net of the burn-in. seen <- NULL local_mocked_bindings( gbayes = function(...) { @@ -626,11 +629,11 @@ test_that("bayesAlphabetWeights forwards every MCMC control to gbayes", { f$X, f$y, method = "bayesN", - nit = 300, - nburn = 30, - nthin = 7 + nIter = 300, + nBurnin = 30, + thin = 7 )) - expect_equal(seen$nit, 300) + expect_equal(seen$nit, 270) expect_equal(seen$nburn, 30) expect_equal(seen$nthin, 7) }) @@ -688,11 +691,15 @@ test_that("mrmashWeights fits from (X, Y) and returns p x K weights", { # --------------------------- RSS weight wrappers ---------------------------- -test_that("lassosumRssWeights returns length-p weights and records the selection", { +test_that("lassosumRssWeights returns p weights and records the selection", { f <- .rrwStatLd() + set.seed(1) w <- lassosumRssWeights(f$stat, f$ldReference) expect_length(w, f$p) - expect_equal(unname(attr(w, "lassosum_selection")["mode"]), "ldQuadratic") + expect_equal(unname(attr(w, "lassosum_selection")["mode"]), "heldOut") + # The held-out splits come from R's random number generator. + set.seed(1) + expect_identical(lassosumRssWeights(f$stat, f$ldReference), w) expect_length( lassosumRssWeights(f$stat, f$ldReference, selection = "minFbeta"), f$p @@ -748,8 +755,9 @@ test_that("PenalizedRssOptions refuses the settings its wrappers own", { "lambda2", "maxSwaps" )) { + ownedArg <- set_names(list(1), nm) expect_error( - exec(PenalizedRssOptions, !!!set_names(list(1), nm)), + exec(PenalizedRssOptions, !!!ownedArg), str_c(nm, " is supplied by pecotmr"), label = nm ) @@ -782,7 +790,11 @@ test_that("prsCsWeights and sdprWeights attach the sampler's estimates", { methodArgs = prsOpts ) prsFit <- attr(prsSlim, "fit") - expect_named(prsFit, c("betaEst", "psiEst", "sigmaEst", "phiEst")) + expect_named( + prsFit, + c("betaEst", "psiEst", "sigmaEst", "phiEst", "variantIds") + ) + expect_equal(prsFit$variantIds, f$stat$variantNames) expect_equal(as.numeric(prsSlim), as.numeric(prsNone)) expect_equal(prsFit$betaEst, as.numeric(prsNone)) expect_length(prsFit$psiEst, f$p) @@ -801,7 +813,8 @@ test_that("prsCsWeights and sdprWeights attach the sampler's estimates", { fitRetention = "full", methodArgs = sdprOpts ) - expect_named(attr(sdprFull, "fit"), c("betaEst", "h2")) + expect_named(attr(sdprFull, "fit"), c("betaEst", "h2", "variantIds")) + expect_equal(attr(sdprFull, "fit")$variantIds, f$stat$variantNames) expect_length(attr(sdprFull, "fit")$h2, 1L) expect_equal(as.numeric(sdprFull), as.numeric(sdprNone)) expect_error( @@ -813,15 +826,19 @@ test_that("prsCsWeights and sdprWeights attach the sampler's estimates", { test_that("lassosumRssWeights keeps its search: path at slim, beta at full", { f <- .rrwStatLd() s <- c(0.5, 1) + # One seed per call, so the three draw the same held-out splits. + set.seed(1) none <- lassosumRssWeights(f$stat, f$ldReference, s = s) expect_null(attr(none, "fit")) + set.seed(1) slim <- lassosumRssWeights( f$stat, f$ldReference, s = s, fitRetention = "slim" ) - expect_named(attr(slim, "fit"), "path") + expect_named(attr(slim, "fit"), c("path", "variantIds")) + expect_equal(attr(slim, "fit")$variantIds, f$stat$variantNames) path <- attr(slim, "fit")$path expect_named( path, @@ -835,6 +852,7 @@ test_that("lassosumRssWeights keeps its search: path at slim, beta at full", { sel <- attr(slim, "lassosum_selection") expect_equal(path$s[path$selected], as.numeric(sel[["s"]])) expect_equal(path$lambda[path$selected], as.numeric(sel[["lambda"]])) + set.seed(1) full <- lassosumRssWeights( f$stat, f$ldReference, @@ -875,8 +893,8 @@ test_that("the RSS solvers run on a factor of the LD as on the LD itself", { # pre-shrunk matrix would. set.seed(8) X <- matrix(rbinom(80 * 120, 2, 0.3), 80, 120) - F <- pecotmr:::.ldFactorFromDosage(X) - R <- crossprod(F) / (nrow(F) - 1) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) beta <- replace(numeric(120), c(5, 40, 90), c(0.3, -0.2, 0.25)) z <- as.vector(R %*% beta) + rnorm(120, sd = 0.05) lambda <- exp(seq(log(0.1), log(0.001), length.out = 8)) @@ -927,7 +945,7 @@ test_that("the RSS solvers run on a factor of the LD as on the LD itself", { label = label ) expect_equal( - exec(pecotmr:::penalizedRssFactorCpp, z, F, s, !!!args), + exec(pecotmr:::penalizedRssFactorCpp, z, ldFactor, s, !!!args), dense, tolerance = 1e-8, label = label @@ -939,7 +957,7 @@ test_that("the RSS solvers run on a factor of the LD as on the LD itself", { l0Fit <- function(lambda2) { pecotmr:::penalizedRssFactorCpp( z, - F, + ldFactor, 0.2, lambdaR = lambda, penaltyStr = "L0L2", @@ -964,9 +982,9 @@ test_that("SDPR on a factor of the LD draws as it does on the matrix", { # with arrays). set.seed(7) X <- matrix(rbinom(40 * 120, 2, 0.3), 40, 120) - F <- pecotmr:::.ldFactorFromDosage(X) - R <- crossprod(F) / (nrow(F) - 1) - p <- ncol(F) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) + p <- ncol(ldFactor) effects <- replace(numeric(p), c(5, 40, 90), c(0.3, -0.25, 0.2)) bhat <- as.vector(R %*% effects) + rnorm(p, sd = 0.02) sizes <- sample(c(400, 500, 600), p, replace = TRUE) @@ -986,10 +1004,11 @@ test_that("SDPR on a factor of the LD draws as it does on the matrix", { iter = 100L, burn = 25L, thin = 5L, - numThreads = 1L, optLlk = 1L, verbose = FALSE, - seed = 11L + seed = 11L, + raoBlackwell = FALSE, + track = FALSE ) cases <- list( llk1 = list(), @@ -1003,16 +1022,17 @@ test_that("SDPR on a factor of the LD draws as it does on the matrix", { ) ) for (nm in names(cases)) { - args <- list_modify(base, !!!cases[[nm]]) + caseSettings <- cases[[nm]] + args <- list_modify(base, !!!caseSettings) expect_equal( - exec(pecotmr:::sdprFactorCpp, factorR = F, !!!args), + exec(pecotmr:::sdprFactorCpp, factorR = ldFactor, !!!args), exec(pecotmr:::sdprCpp, LD = list(R), !!!args), tolerance = 1e-8, label = nm ) } expect_error( - exec(pecotmr:::sdprFactorCpp, factorR = F[, -1], !!!base), + exec(pecotmr:::sdprFactorCpp, factorR = ldFactor[, -1], !!!base), "The LD factor has 119 columns but there are 120 effects" ) }) @@ -1044,23 +1064,12 @@ test_that("prsCsWeights and sdprWeights hand the engine z / sqrt(n)", { # Statistics over the first p variants of the test genotype panel, with the # same LD as an LdMatrix: a weight method must read the panel's LD (through # its standardized genotypes) as it reads the matrix. -.rrwPanelStat <- function(p = 40) { - panel <- readGenotypes(test_path("test_data", "test_variants.bed")) - ids <- names(SummarizedExperiment::rowRanges(panel))[seq_len(p)] - R <- pecotmr:::.ldFromRef(panel, ids, "test") - set.seed(3) - effects <- replace(numeric(p), c(3, 20), c(4, -3)) - z <- as.vector(R %*% effects) + rnorm(p) - list( - panel = panel, - ldMatrix = LdMatrix(R, nSamples = ncol(panel)), - stat = list(z = z, n = rep(500, p), variantNames = ids) - ) -} - test_that("RSS weights read a genotype panel's LD as they read the matrix", { # The panel route gives the solvers the panel's factor and never forms - # the LD matrix; it must land on the matrix route's weights. + # the LD matrix; it must land on the matrix route's weights. Held-out + # selection draws its splits through the factor on one route and the + # matrix's eigenvectors on the other, so a deterministic selection + # compares the fits. d <- .rrwPanelStat() fns <- list( lassosum = lassosumRssWeights, @@ -1070,8 +1079,8 @@ test_that("RSS weights read a genotype panel's LD as they read the matrix", { ) for (nm in names(fns)) { expect_equal( - fns[[nm]](d$stat, d$panel), - fns[[nm]](d$stat, d$ldMatrix), + fns[[nm]](d$stat, d$panel, selection = "minFbeta"), + fns[[nm]](d$stat, d$ldMatrix, selection = "minFbeta"), tolerance = 1e-6, label = nm ) @@ -1087,7 +1096,9 @@ test_that("RSS weights read a genotype panel's LD as they read the matrix", { ) # SDPR runs its own sampler on the low-rank form of its matrices, so a # seeded chain lands on the matrix route's. A 50-component mixture - # rather than the default 1000 keeps the chains quick. + # rather than the default 1000 keeps the chains quick, and statistics + # consistent with the LD keep them from diverging. + d <- .rrwPanelStatLd() for (optLlk in 1:2) { opts <- SdprOptions( iter = 100, @@ -1234,6 +1245,21 @@ test_that(".lassosumClampCor scales values with |cor| >= 1 below 1", { test_that(".lassosumFirstMax returns the first index of the maximum", { expect_equal(pecotmr:::.lassosumFirstMax(c(1, 3, 3, 2)), 2L) expect_equal(pecotmr:::.lassosumFirstMax(c(5, 1, 2)), 1L) + # A tie to rounding is a tie; a real difference is not. + expect_equal(pecotmr:::.lassosumFirstMax(c(1, 3, 3 + 1e-14, 2)), 2L) + expect_equal(pecotmr:::.lassosumFirstMax(c(1, 3, 3 + 1e-6, 2)), 3L) + expect_equal(pecotmr:::.lassosumFirstMax(c(-Inf, -Inf)), 1L) +}) + +test_that("held-out selection breaks a tie in correlation by variance", { + pick <- pecotmr:::.rssHeldOutPick + # Candidates 2 to 4 tie on the correlation, to rounding; of them, 3 + # explains the most held-out variance. + expect_equal(pick(c(0.1, 0.5, 0.5 + 1e-15, 0.5), c(9, 0.2, 0.3, 0.1)), 3L) + # A real difference in correlation wins whatever the variance. + expect_equal(pick(c(0.1, 0.5, 0.6, 0.5), c(9, 0.2, 0.1, 0.3)), 3L) + # Tied on both, the first in the grid. + expect_equal(pick(c(0.4, 0.5, 0.5), c(1, 0.2, 0.2)), 2L) }) test_that(".lassosumSelectMinFbeta picks the minimum-fbeta candidate", { @@ -1248,14 +1274,107 @@ test_that(".lassosumSelectMinFbeta picks the minimum-fbeta candidate", { expect_equal(r$beta, cb[, 2]) }) -test_that(".lassosumSelectLdQuadratic scores candidates by c'b / sqrt(b'Rb)", { - f <- .rrwStatLd() +test_that(".lassosumSelectLdQuadratic shrinks c by its lfdr like lassosum", { + skip_if_not_installed("fdrtool") + # Five strong correlations among 300; candidate 1 fits those five, + # candidate 2 is the least-squares direction c itself (R = I), which + # the raw in-sample score always prefers. set.seed(8) - cb <- matrix(rnorm(f$p * 4), f$p, 4) - r <- pecotmr:::.lassosumSelectLdQuadratic(cb, f$stat$b, list(R = f$LD)) + p <- 300L + corInput <- c(rnorm(p - 5L, sd = 0.03), 0.3, -0.25, 0.2, 0.28, -0.3) + signal <- replace(numeric(p), (p - 4L):p, sign(corInput[(p - 4L):p])) + cb <- unname(cbind(signal, corInput)) + lfdr <- fdrtool::fdrtool( + corInput, + statistic = "correlation", + plot = FALSE, + verbose = FALSE + )$lfdr + score <- function(cVec) colSums(cVec * cb) / sqrt(colSums(cb^2)) + expect_equal(which.max(score(corInput)), 2L) + want <- which.max(score(corInput * (1 - lfdr))) + expect_equal(want, 1L) + r <- pecotmr:::.lassosumSelectLdQuadratic(cb, corInput, list(R = diag(p))) expect_equal(r$mode, "ldQuadratic") - expect_true(r$index %in% seq_len(4)) - expect_equal(r$beta, cb[, r$index]) + expect_equal(r$index, want) + expect_equal(r$beta, cb[, want]) +}) + +test_that(".rssShrunkLdScore scores c'b against LD shrunk toward I", { + R <- matrix(c(1, 0.5, 0.5, 1), 2, 2) + cb <- cbind(c(1, 1), c(1, -1), c(0, 0)) + corInput <- c(0.2, 0.1) + w <- 0.3 + want <- colSums(corInput * cb[, 1:2]) / + sqrt((1 - w) * colSums(cb[, 1:2] * (R %*% cb[, 1:2])) + w * 2) + expect_equal( + pecotmr:::.rssShrunkLdScore(cb, corInput, list(R = R), w), + c(want, -Inf) + ) +}) + +test_that("held-out selection needs the LD reference's sample size", { + f <- .rrwStatLd() + unsized <- LdMatrix(f$LD) + expect_error( + lassosumRssWeights(f$stat, unsized), + "lassosumRssWeights: selection = \"heldOut\" needs the LD reference's" + ) + expect_error( + mcpRssWeights(f$stat, unsized), + "mcpRssWeights: selection = \"heldOut\" needs the LD reference's" + ) + expect_length( + lassosumRssWeights(f$stat, unsized, selection = "minFbeta"), + f$p + ) +}) + +test_that("held-out selection draws its splits through a panel's factor", { + d <- .rrwPanelStat() + set.seed(2) + w <- lassosumRssWeights(d$stat, d$panel) + expect_equal(unname(attr(w, "lassosum_selection")["mode"]), "heldOut") + expect_length(w, length(d$stat$z)) + expect_true(all(is.finite(w))) +}) + +test_that("held-out selection avoids the fit a small reference cannot judge", { + # Real genotypes: statistics from 250 people, LD from 100 others, over + # 200 variants. The least-penalized fit loads on directions of the LD + # the 100-person reference cannot see, and lassosum's in-sample score + # keeps choosing it. Held-out selection, with the LD shrunk for the + # reference's size, must pick a sparser fit that predicts the remaining + # people better. + data(eqtlRegionExample, envir = environment()) + G <- eqtlRegionExample$X + af <- colMeans(G) / 2 + G <- G[, pmin(af, 1 - af) > 0.05][, 1001:1200] + Gs <- scale(G) + set.seed(11) + g <- as.numeric(Gs %*% replace(numeric(200), c(40, 150), c(1, -0.8))) + y <- g * sqrt(0.15 / var(g)) + rnorm(nrow(G), sd = sqrt(0.85)) + perm <- sample(nrow(G)) + study <- perm[1:250] + test <- perm[351:415] + R <- cor(G[perm[251:350], ]) + stat <- list( + cor = as.numeric(cor(G[study, ], y[study])), + n = rep(250, 200), + variantNames = colnames(G) + ) + w <- lassosumRssWeights( + stat, + LdMatrix(R, nSamples = 100L), + fitRetention = "full" + ) + fit <- attr(w, "fit") + loosest <- which( + fit$path$s == 0.2 & fit$path$lambda == min(fit$path$lambda) + ) + accuracy <- function(b) cor(as.numeric(Gs[test, ] %*% b), g[test]) + expect_lt(sum(w != 0), fit$path$nparams[loosest]) + expect_gt(accuracy(as.numeric(w)), accuracy(fit$beta[, loosest])) }) test_that("computeCovDiag returns a diagonal condition covariance", { @@ -1266,7 +1385,7 @@ test_that("computeCovDiag returns a diagonal condition covariance", { expect_equal(unname(diag(cv)), unname(apply(m$Y, 2, var))) }) -test_that("buildMrmashPriorMatrices builds an expanded S0 list and a prior grid", { +test_that("buildMrmashPriorMatrices builds an expanded S0 and a prior grid", { skip_if_not_installed("mr.mashr") set.seed(9) res <- buildMrmashPriorMatrices( @@ -1283,7 +1402,7 @@ test_that("buildMrmashPriorMatrices builds an expanded S0 list and a prior grid" ))) }) -test_that("buildMrmashPriorMatrices errors without canonical or data-driven priors", { +test_that("buildMrmashPriorMatrices needs a canonical or data-driven prior", { skip_if_not_installed("mr.mashr") expect_error( buildMrmashPriorMatrices( @@ -1339,12 +1458,12 @@ test_that("MCMC / optimiser control arguments are guarded", { "thin.*Must be >= 1" ) expect_error( - bayesBWeights(NULL, NULL, probIn = 2), - "probIn.*is not <= 1" + bayesBWeights(NULL, NULL, pi = 2), + "pi.*is not <= 1" ) expect_error( - bLassoWeights(NULL, NULL, burnIn = -1), - "burnIn.*Must be >= 0" + bayesLWeights(NULL, NULL, nBurnin = -1), + "nBurnin.*Must be >= 0" ) expect_error( dprGibbsWeights(NULL, NULL, sStep = 0), @@ -1445,6 +1564,43 @@ test_that("MrmashOptions takes mr.mash's own argument names", { expect_error(MrmashOptions(maxIter = 10), "unknown argument") }) +test_that("MrmashOptions and MrmashRssOptions refuse nthreads", { + skip_if_not_installed("mr.mashr") + expect_error(MrmashOptions(nthreads = 2L), "`nthreads` cannot be set") + expect_error(MrmashRssOptions(nthreads = 2L), "`nthreads` cannot be set") +}) + +test_that("mr.mash and mr.mash.rss fit on one thread", { + # mr.mash names its thread count only when it runs more than one, so its + # verbose header pins single-threading on both paths. The header prints + # only with verbose = TRUE, so it also shows that mrmashWeights() hands + # mr.mash's own options on to the engine (it once spliced them into + # mrmashWrapper's arguments, which have none of those names). + skip_if_not_installed("mr.mashr") + skip_if_not_installed("glmnet") + m <- .rrwMulti(n = 60, p = 6, K = 3) + individual <- capture.output(suppressWarnings(suppressMessages( + mrmashWeights( + X = m$X, + Y = m$Y, + methodArgs = MrmashOptions( + canonicalPriorMatrices = TRUE, + verbose = TRUE, + max_iter = 2 + ) + ) + ))) + rss <- capture.output(suppressWarnings(mrmashRssWeights( + m$stat, + m$ldReference, + methodArgs = MrmashRssOptions(verbose = TRUE, max_iter = 2) + ))) + for (out in list(individual, rss)) { + expect_match(out, "Fitting the optimization algorithm", all = FALSE) + expect_no_match(out, "RcppParallel threads") + } +}) + test_that("mrmashWrapper refuses to let methodArgs override derived values", { skip_if_not_installed("mr.mashr") skip_if_not_installed("glmnet") diff --git a/tests/testthat/test_relatednessQc.R b/tests/testthat/test_relatednessQc.R index 2b0e83b4a..44e7efc75 100644 --- a/tests/testthat/test_relatednessQc.R +++ b/tests/testthat/test_relatednessQc.R @@ -16,7 +16,7 @@ noRelatedPairsRemain <- function( all(kept[[value]] < threshold) } -test_that("maximizeUnrelated removes related individuals and leaves clean set", { +test_that("maximizeUnrelated drops related individuals, leaving a clean set", { skip_if_not_installed("igraph") skip_if_not_installed("plinkQC") @@ -189,7 +189,7 @@ test_that("maximizeCases errors without phenoData", { ) }) -test_that("maximizeCases excludes a control listed as IID1 paired with a kept case", { +test_that("maximizeCases drops a control listed as IID1 beside a kept case", { skip_if_not_installed("igraph") skip_if_not_installed("plinkQC") diff --git a/tests/testthat/test_resultReaders.R b/tests/testthat/test_resultReaders.R index 1177ca4c9..a91217777 100644 --- a/tests/testthat/test_resultReaders.R +++ b/tests/testthat/test_resultReaders.R @@ -203,16 +203,16 @@ test_that("TWAS weights round-trip through a published BED", { "fine-mapping-derived" ) back <- readTwasWeights(path) - # Fine-mapping-derived rows are skipped on export, so fewer rows come - # back than went out -- that is the writer's rule, not a reader loss. - expect_lt(nrow(back), nrow(twasWeightsExample)) - md <- S4Vectors::mcols(back) - for (i in seq_len(nrow(back))) { + # Fine-mapping-derived entries are skipped on export, so fewer come back + # than went out -- that is the writer's rule, not a reader loss. + cells <- .twasCells(back) + expect_lt(nrow(cells), nrow(.twasCells(twasWeightsExample))) + for (i in seq_len(nrow(cells))) { key <- list( - studyName = as.character(md$study[[i]]), - context = as.character(md$context[[i]]), - trait = as.character(md$trait[[i]]), - method = as.character(md$method[[i]]) + studyName = cells$study[[i]], + context = cells$context[[i]], + trait = cells$trait[[i]], + method = cells$method[[i]] ) was <- exec(resolveWeights, twasWeightsExample, !!!key) now <- exec(resolveWeights, back, !!!key) @@ -223,15 +223,8 @@ test_that("TWAS weights round-trip through a published BED", { tolerance = 1e-10 ) } - expect_equal( - genomicRegion(back), - genomicRegion(twasWeightsExample)[ - match( - as.character(md$method), - as.character(S4Vectors::mcols(twasWeightsExample)$method) - ) - ] - ) + # One gene: its window survives the round trip. + expect_equal(genomicRegion(back), genomicRegion(twasWeightsExample)) }) # ---- multi-row tables ----------------------------------------------------- diff --git a/tests/testthat/test_resultWriters.R b/tests/testthat/test_resultWriters.R index 72d0875e4..b2bfeb14a 100644 --- a/tests/testthat/test_resultWriters.R +++ b/tests/testthat/test_resultWriters.R @@ -80,6 +80,27 @@ makeTestFineMappingResult <- function(n = 5) { # Fine-mapping result to VCF # ============================================================================= +test_that("a weights export reads the joint columns a collection carries", { + ids <- sprintf("chr1:%d:A:G", 100L * (1:3)) + row <- TwasWeightsRow(ids, c(0.1, 0.2, 0.3)) + tw <- TwasWeights( + studyName = c("s1", "s1"), + context = c("c1", "c2"), + trait = c("g1", "g1"), + method = c("mrmash", "mrmash"), + entry = list(row, row), + jointContexts = c("c1;c2", "c1;c2") + ) + expect_identical( + pecotmr:::.twbColumnOr(tw, "jointContexts"), + c("c1;c2", "c1;c2") + ) + expect_identical( + pecotmr:::.twbColumnOr(tw, "jointTraits"), + rep(NA_character_, 2L) + ) +}) + test_that("writeGwasVcf(FineMapping): emits PIP + CS FORMAT fields", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -263,11 +284,12 @@ test_that("writeGwasVcf(FineMapping): each split flag emits one VCF per tag", { ) d <- withr::local_tempdir() for (case in names(cases)) { + caseFlags <- cases[[case]]$flags paths <- exec( writeGwasVcf, fmr, file.path(d, str_c(case, ".vcf")), - !!!cases[[case]]$flags + !!!caseFlags ) expect_equal(length(paths), 2L, info = case) expect_true( @@ -1079,14 +1101,12 @@ test_that("writeBed writes the published TWAS-weight schema", { # the posterior columns a weights table has nothing to say about are gone expect_false(any(c("PIP", "LBF", "CS95") %in% names(tbl))) # one row per (model, variant): 168 variants each - # 2 of the 11 rows are fine-mapping-derived and are skipped + # 2 of the 11 entries are fine-mapping-derived and are skipped expect_identical(nrow(tbl), 9L * 168L) + methods <- .twasCells(twasWeightsExample)$method expect_setequal( unique(tbl$method), - setdiff( - as.character(S4Vectors::mcols(twasWeightsExample)$method), - .TWB_FINE_MAPPING_METHODS - ) + methods[!.twbIsFineMappingMethod(methods)] ) expect_true(all(tbl$end == tbl$start + 1L)) expect_false(is.unsorted(tbl$start)) @@ -1251,17 +1271,17 @@ test_that("writeGwasVcf narrows TWAS models with the identity selectors", { expect_length(header[-seq_len(9L)], 1L) expect_error( writeGwasVcf(twasWeightsExample, out, method = "nope"), - "no rows match" + "no entries match" ) # Selecting a fine-mapping method leaves nothing exportable, which is a - # different refusal from "no rows match". + # different refusal from "no entries match". expect_error( suppressMessages(writeGwasVcf( twasWeightsExample, out, method = "susie" )), - "every selected row is fine-mapping-derived" + "every selected entry is fine-mapping-derived" ) }) @@ -1712,17 +1732,16 @@ test_that("every weight row being fine-mapping-derived is an error", { # Those weights are the fine-mapping posterior re-expressed, so there is # nothing left to write once they are skipped. data(twasWeightsExample, envir = environment()) - fm <- twasWeightsExample[ - is_in( - as.character(twasWeightsExample$method), - .TWB_FINE_MAPPING_METHODS - ) - ] - expect_gt(nrow(fm), 0L) + methods <- methodNames(twasWeightsExample) + fm <- .twasKeepMethods( + twasWeightsExample, + methods[.twbIsFineMappingMethod(methods)] + ) + expect_gt(nrow(.twasCells(fm)), 0L) out <- withr::local_tempfile(fileext = ".bed") expect_error( suppressMessages(writeBed(fm, out)), - "every row is fine-mapping-derived" + "every entry is fine-mapping-derived" ) }) @@ -1757,10 +1776,7 @@ test_that("both formats skip fine-mapping-derived weight rows alike", { # fine-mapping result says strictly more. skip_if_not_installed("VariantAnnotation") data(twasWeightsExample, envir = environment()) - derived <- is_in( - as.character(twasWeightsExample$method), - .TWB_FINE_MAPPING_METHODS - ) + derived <- .twbIsFineMappingMethod(.twasCells(twasWeightsExample)$method) expect_gt(sum(derived), 0L) out <- withr::local_tempfile(fileext = ".vcf") expect_message( @@ -1771,12 +1787,31 @@ test_that("both formats skip fine-mapping-derived weight rows alike", { samples <- str_split(header, "\t")[[1L]][-seq_len(9L)] expect_length(samples, sum(!derived)) # None of the samples names a fine-mapping method. - expect_false(any(str_detect( - samples, - str_c("\\|", .TWB_FINE_MAPPING_METHODS, "$", collapse = "|") + expect_false(any(.twbIsFineMappingMethod( + stringr::str_extract(samples, "[^|]+$") ))) }) +test_that("fine-mapping rows are skipped under either spelling of the method", { + # A pipeline labels a row by token (susieInf), learnTwasWeights() by snake + # key (susie_inf). The skip list held only the snake keys, so a pipeline's + # SuSiE-inf and SuSiE-ash rows were exported as weights. + expect_equal( + .twbIsFineMappingMethod(c( + "susieInf", + "susie_inf", + "susieAsh", + "susie_ash", + "susie", + "mvsusie", + "fsusie", + "lasso", + "ensemble" + )), + c(rep(TRUE, 7L), FALSE, FALSE) + ) +}) + test_that("a weights export reads AF off the collection's LD panel", { # A TwasWeights element records only alleles and a weight, so the panel is # the only place a frequency can come from. The bundled sketch panel @@ -1786,16 +1821,14 @@ test_that("a weights export reads AF off the collection's LD panel", { data(ctwasWeightsExample, twasWeightsExample, envir = environment()) panel <- ldReference(ctwasWeightsExample)[[1L]] expect_false(is.null(panel)) - lasso <- twasWeightsExample[ - as.character(twasWeightsExample$method) == "lasso" - ] + lasso <- .twasKeepMethods(twasWeightsExample, "lasso") expect_equal(nrow(lasso), 1L) exported <- function(ref) { withPanel <- TwasWeights( studyName = as.character(lasso$study), context = as.character(lasso$context), trait = as.character(lasso$trait), - method = as.character(lasso$method), + method = "lasso", entry = list(.twrRowParts(lasso, 1L)), ldReference = ref ) @@ -1807,7 +1840,7 @@ test_that("a weights export reads AF off the collection's LD panel", { rr <- SummarizedExperiment::rowRanges(panel) expect_equal(tbl$AF, rr$AF[match(tbl$ID, .grVariantIds(rr))]) expect_false(anyNA(tbl$AF)) - keep <- c("SNP", "A1", "A2") + keep <- setdiff(colnames(SummarizedExperiment::rowData(panel)), "AF") noAf <- SummarizedExperiment::`rowData<-`( panel, value = SummarizedExperiment::rowData(panel)[, keep] @@ -1847,7 +1880,7 @@ test_that("a sumstats collection with no Z publishes no EZ", { # --------------------------------------------------------------------------- # A multi-trait weight matrix on a panel that records allele frequency: the -# two shapes the single-trait fixtures never exercise. `mr_mash` because the +# two shapes the single-trait fixtures never exercise. `mrmash` because the # matrix-weight fixture is a susie fit, which both exporters refuse as # fine-mapping-derived -- a joint TWAS fit is the case that reaches the # matrix paths at all. @@ -1870,7 +1903,7 @@ test_that("a sumstats collection with no Z publishes no EZ", { studyName = "S1", context = "ctx", trait = "tA", - method = "mr_mash", + method = "mrmash", entry = list(TwasWeightsRow( variantIds = vids[seq_len(nVariant)], weights = w[seq_len(nVariant), , drop = FALSE] @@ -1899,8 +1932,8 @@ test_that("a joint fit's VCF samples carry the weight-column label", { chrom <- hdr[str_starts(hdr, "#CHROM")] # The label is appended to the row's identity, so two weight columns of # one row stay two distinguishable samples. - expect_match(chrom, "S1\\|ctx\\|tA\\|mr_mash\\|tA") - expect_match(chrom, "S1\\|ctx\\|tA\\|mr_mash\\|tB") + expect_match(chrom, "S1\\|ctx\\|tA\\|mrmash\\|tA") + expect_match(chrom, "S1\\|ctx\\|tA\\|mrmash\\|tB") }) test_that("a recorded data_source wins over the derived one", { @@ -1990,7 +2023,7 @@ test_that("a weight matrix with no columns publishes a header-only file", { weightStandardized = FALSE )) ) - expect_length(.twbWeightLabels(mcols(tw[[1L]])$weight), 0L) + expect_length(.twbWeightLabels(weights(.twrCellParts(tw, 1L, "lasso"))), 0L) expect_null(.twbWeightsTable(tw, NULL, NULL)) out <- withr::local_tempfile(fileext = ".bed") writeBed(tw, out) diff --git a/tests/testthat/test_rrBayesAlphabet.R b/tests/testthat/test_rrBayesAlphabet.R index d0abf62d4..345d33cca 100644 --- a/tests/testthat/test_rrBayesAlphabet.R +++ b/tests/testthat/test_rrBayesAlphabet.R @@ -1,5 +1,11 @@ context("regularized_regression - bayes_alphabet") +.baXy <- function(n = 50, p = 10) { + set.seed(42) + X <- matrix(rnorm(n * p), nrow = n) + list(X = X, y = X[, 1] * 0.5 + rnorm(n), p = p) +} + # ---- bayesAlphabetWeights ---- test_that("bayesAlphabetWeights errors on dimension mismatch", { skip_if_not_installed("qgg") @@ -11,78 +17,800 @@ test_that("bayesAlphabetWeights errors on dimension mismatch", { ) }) -test_that("bayesAlphabetWeights errors on covariate dimension mismatch", { +test_that("bayesAlphabetWeights runs each method on its default engine", { skip_if_not_installed("qgg") - X <- matrix(rnorm(100), nrow = 10) - y <- rnorm(10) - Z <- matrix(rnorm(15), nrow = 5) + d <- .baXy() + result <- bayesAlphabetWeights( + d$X, + d$y, + method = "bayesN", + nIter = 50, + nBurnin = 10 + ) + expect_equal(length(result), d$p) + expect_true(is.numeric(result)) +}) + +test_that("each alphabet wrapper offers its method's backends, default first", { + # The wrappers spell their choices in their signatures; the pipeline reads + # them from .alphabetBackends. The two must not drift apart. + wrappers <- c( + bayesA = "bayesAWeights", + bayesB = "bayesBWeights", + bayesC = "bayesCWeights", + bayesL = "bayesLWeights", + bayesN = "bayesNWeights", + bayesR = "bayesRWeights" + ) + for (m in names(wrappers)) { + expect_equal( + eval(formals(get(wrappers[[m]]))$backend), + names(pecotmr:::.alphabetBackends$individual[[m]]), + info = m + ) + } +}) + +test_that("bayesAlphabetWeights refuses settings the method or engine lacks", { + d <- .baXy() expect_error( - bayesAlphabetWeights(X, y, method = "bayesN", Z = Z), - "Z.*Must have exactly 10 rows" + bayesAlphabetWeights(d$X, d$y, "bayesA", backend = "bglr"), + "`backend` for bayesA must be one of qgg, hibayes" + ) + expect_error( + bayesAlphabetWeights(d$X, d$y, "bayesN", pi = 0.1), + "`pi` applies to bayesB and bayesC, not bayesN" + ) + # The options must come from the chosen engine's own constructor. + expect_error( + bayesBWeights(d$X, d$y, methodArgs = QggOptions()), + "built for engine 'qgg', but backend 'bglr' takes BglrOptions" + ) + expect_error( + bayesAWeights(d$X, d$y, methodArgs = list(nub = 4)), + "must be built with QggOptions" + ) + expect_error( + bayesAWeights(d$X, d$y, nIter = 100, nBurnin = 100), + "must exceed `nBurnin`" ) }) -test_that("bayesAlphabetWeights does not error on valid Z dimensions", { +test_that("pi reaches qgg once, from the wrapper", { skip_if_not_installed("qgg") - set.seed(42) - n <- 50 - p <- 10 - q <- 3 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - Z <- matrix(round(runif(n * q, 0, 0.8), 0), nrow = n) + d <- .baXy() + seen <- NULL + local_mocked_bindings( + gbayes = function(...) { + seen <<- list(...) + list(bm = rep(0, 10)) + }, + .package = "qgg" + ) + invisible(bayesCWeights(d$X, d$y, pi = 0.05, nIter = 20, nBurnin = 5)) + expect_equal(seen$pi, 0.05) + expect_equal(seen$method, "bayesC") + # Setting it in the engine's options too is the same option twice. + expect_error( + bayesCWeights(d$X, d$y, methodArgs = QggOptions(pi = 0.05)), + "given twice: pi" + ) +}) - result <- bayesAlphabetWeights( - X, - y, - method = "bayesN", - Z = Z, - nit = 50, - nburn = 10 +test_that("the hibayes backend runs ibrm with the shared settings", { + skip_if_not_installed("hibayes") + d <- .baXy() + seen <- NULL + local_mocked_bindings( + ibrm = function(...) { + seen <<- list(...) + list(alpha = rep(0.5, ncol(seen$M))) + }, + .package = "hibayes" + ) + w <- bayesCWeights( + d$X, + d$y, + backend = "hibayes", + nIter = 30, + nBurnin = 7, + thin = 3 + ) + expect_equal(w, rep(0.5, d$p)) + expect_equal(seen$method, "BayesCpi") + expect_equal(seen$Pi, c(0.9, 0.1)) + expect_equal(c(seen$niter, seen$nburn, seen$thin), c(30, 7, 3)) + expect_equal(seen$threads, 1L) + # ibrm() matches genotypes to phenotypes by the first column of `data`. + expect_equal(seen$M.id, seen$data[[1L]]) + expect_error( + bayesCWeights( + d$X, + d$y, + "hibayes", + methodArgs = HibayesOptions(seed = 1) + ), + "`seed` cannot be set here" ) - expect_equal(length(result), p) - expect_true(is.numeric(result)) }) -test_that("bayesAlphabetWeights with Z = NULL does not error on dimension check", { - skip_if_not_installed("qgg") - set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - result <- bayesAlphabetWeights( - X, - y, - method = "bayesN", - Z = NULL, - nit = 50, - nburn = 10 +test_that("a hibayes fit leaves the caller's random stream where it was", { + skip_if_not_installed("hibayes") + d <- .baXy(n = 40, p = 5) + set.seed(9) + w <- bayesNWeights( + d$X, + d$y, + backend = "hibayes", + nIter = 200, + nBurnin = 50 ) - expect_equal(length(result), p) - expect_true(is.numeric(result)) + after <- runif(1) + expect_length(w, 5) + expect_true(all(is.finite(w))) + # The seed hibayes gets is one draw from R's generator; ibrm()'s own + # set.seed() is undone afterwards. + set.seed(9) + invisible(sample.int(.Machine$integer.max, 1L)) + expect_equal(after, runif(1)) }) # ---- bayesAlphabetWeights zero-variance handling ---- -test_that("bayesAlphabetWeights warns and zero-pads when X has zero-variance columns", { +test_that("bayesAlphabetWeights warns, zero-pads X's zero-variance columns", { skip_if_not_installed("qgg") - set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) + d <- .baXy() + X <- d$X X[, 4] <- 2 - y <- X[, 1] * 0.5 + rnorm(n) expect_warning( result <- bayesAlphabetWeights( X, - y, + d$y, method = "bayesN", - nit = 50, - nburn = 10 + nIter = 50, + nBurnin = 10 ), "bayesAlphabetWeights: dropping 1 zero-variance column" ) - expect_equal(length(result), p) + expect_equal(length(result), d$p) expect_equal(result[4], 0) expect_true(all(is.finite(result))) }) + +# ---- bayesAlphabetRssWeights ---- + +test_that("bayesAlphabetWeights keeps the posterior or the engine's fit", { + skip_if_not_installed("qgg") + skip_if_not_installed("BGLR") + skip_if_not_installed("hibayes") + d <- .baXy() + X <- d$X + colnames(X) <- sprintf("chr1:%d:A:G", seq_len(d$p)) + runs <- list( + list(method = "bayesC", backend = "qgg"), + list(method = "bayesB", backend = "bglr"), + list(method = "bayesR", backend = "hibayes") + ) + fits <- list() + for (r in runs) { + set.seed(1) + slim <- bayesAlphabetWeights( + X, + d$y, + r$method, + backend = r$backend, + nIter = 200, + nBurnin = 50, + fitRetention = "slim" + ) + fit <- attr(slim, "fit") + expect_equal(fit$coef, as.numeric(slim)) + expect_equal(fit$variantIds, colnames(X)) + full <- bayesAlphabetWeights( + X, + d$y, + r$method, + backend = r$backend, + nIter = 200, + nBurnin = 50, + fitRetention = "full" + ) + fits[[r$backend]] <- attr(full, "fit") + expect_equal( + pecotmr:::.twasFitVariantIds(fits[[r$backend]]), + colnames(X) + ) + } + # qgg and BGLR report inclusion probabilities, and name the effects. + expect_length(attr(slim, "fit")$coef, d$p) + expect_true(is.numeric(fits$qgg$dm)) + expect_s3_class(fits$bglr, "BGLR") + expect_null(fits$bglr$variantIds) + # hibayes names none, so its fit takes them once. + expect_s3_class(fits$hibayes, "blrMod") + expect_equal(fits$hibayes$variantIds, colnames(X)) +}) + +test_that("a summary-statistics fit picks its engine by the LD reference", { + d <- .rrwPanelStat() + f <- pecotmr:::.rssBackend + # A genotype reference runs pecotmr's own sampler on its factor; an LD + # matrix runs qgg, or hibayes for bayesB and bayesL. + expect_equal(f("bayesA", NULL, d$panel), "pecotmr") + expect_equal(f("bayesA", NULL, d$ldMatrix), "qgg") + expect_equal(f("bayesB", NULL, d$ldMatrix), "hibayes") + expect_equal(f("bayesL", NULL, d$ldMatrix), "hibayes") + # The matrix engines also run on a genotype reference, through the + # matrix formed from it. + expect_equal(f("bayesA", "hibayes", d$panel), "hibayes") + expect_error( + f("bayesA", "pecotmr", d$ldMatrix), + "runs on a genotype reference's factor" + ) + expect_error( + f("bayesB", "qgg", d$ldMatrix), + "must be one of hibayes, pecotmr" + ) + # LDpred2 defaults as the alphabet does; the lasso's pecotmr engine reads + # either LD, so it is the default and is never refused. + expect_equal(f("ldpred2Auto", NULL, d$panel), "pecotmr") + expect_equal(f("ldpred2Grid", NULL, d$ldMatrix), "bigsnpr") + expect_error( + f("ldpred2Grid", "pecotmr", d$ldMatrix), + "runs on a genotype reference's factor" + ) + expect_equal(f("lasso", NULL, d$ldMatrix), "pecotmr") + expect_equal(f("lasso", "pecotmr", d$ldMatrix), "pecotmr") + expect_equal(f("lasso", "bigsnpr", d$panel), "bigsnpr") +}) + +test_that("pecotmr's sampler lands where the matrix engines do", { + skip_if_not_installed("qgg") + skip_if_not_installed("hibayes") + d <- .rrwPanelStatLd() + run <- function(method, backend) { + native <- identical(backend, "pecotmr") + set.seed(1) + suppressMessages(bayesAlphabetRssWeights( + d$stat, + if (native) d$panel else d$ldMatrix, + method, + backend = backend, + nIter = 3000, + nBurnin = 500, + # Without SDPR's projection, which the matrix engines lack. + methodArgs = if (native) { + BayesAlphabetRssOptions(ldProjection = NULL) + } + )) + } + # Each method's priors follow one engine's, on the same LD. This LD has + # rank 22 of 40, so the effects of variants in perfect LD are not + # identified and two runs of one engine split them differently; their + # fitted marginal effects R b are what the engines must agree on. + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + fitted <- function(b) as.vector(crossprod(ldFactor, ldFactor %*% b)) + agree <- function(method, other) { + cor(fitted(run(method, "pecotmr")), fitted(run(method, other))) + } + expect_gt(agree("bayesA", "qgg"), 0.99) + expect_gt(agree("bayesC", "qgg"), 0.99) + expect_gt(agree("bayesN", "qgg"), 0.99) + expect_gt(agree("bayesR", "qgg"), 0.99) + expect_gt(agree("bayesB", "hibayes"), 0.99) + expect_gt(agree("bayesL", "hibayes"), 0.99) +}) + +test_that("pecotmr's Legarra bayesL matches qgg's individual-level fit", { + # qgg fits the Bayesian LASSO in Legarra et al.'s form on individual + # data; its summary-statistics sampler uses a different update, so the + # individual fit is the one the form is checked against. + skip_if_not_installed("qgg") + set.seed(31) + n <- 600 + p <- 30 + X <- matrix(rbinom(n * p, 2, 0.3), n, p) + for (j in 2:p) { + X[, j] <- ifelse(runif(n) < 0.5, X[, j - 1], X[, j]) + } + effects <- replace(numeric(p), c(5, 18), c(0.25, -0.2)) + Xs <- scale(X) + y <- as.vector(Xs %*% effects + rnorm(n, sd = 0.95)) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + native <- pecotmr:::bayesAlphabetRss( + as.vector(cor(Xs, y)), + ldFactor, + n, + "bayesL", + nIter = 3000, + nBurnin = 500, + bayesLForm = "legarra", + ldProjection = NULL + )$betaEst + individual <- suppressMessages( + bayesLWeights(Xs, y, nIter = 3000, nBurnin = 500) + ) + expect_gt(cor(native, individual), 0.95) +}) + +test_that("pecotmr's sampler is seeded by R's generator", { + d <- .rrwPanelStatLd() + run <- function() { + bayesARssWeights(d$stat, d$panel, nIter = 400, nBurnin = 100) + } + set.seed(5) + a <- run() + set.seed(5) + expect_identical(run(), a) + expect_length(a, length(d$stat$z)) + expect_true(all(is.finite(a))) +}) + +test_that("pecotmr's sampler checks the options only it takes", { + d <- .rrwPanelStatLd() + expect_error( + bayesARssWeights( + d$stat, + d$panel, + methodArgs = BayesAlphabetRssOptions(bayesLForm = "legarra") + ), + "`bayesLForm` applies to bayesL, not bayesA" + ) + expect_error(BayesAlphabetRssOptions(pi = 0.1), "the wrapper's `pi`") + expect_error( + BayesAlphabetRssOptions(shrinkCorr = 0.9), + "the wrapper's `shrinkCorr`" + ) + # qgg's per-variant weights run in place of n for every variant. + w <- bayesNRssWeights( + d$stat, + d$panel, + nIter = 400, + nBurnin = 100, + fitRetention = "slim", + methodArgs = BayesAlphabetRssOptions(perVariantWeights = TRUE) + ) + expect_true(all(is.finite(w))) + expect_equal(attr(w, "fit")$backend, "pecotmr") + # bayesN has no inclusions to report. + expect_null(attr(w, "fit")$pip) + pip <- attr( + bayesCRssWeights( + d$stat, + d$panel, + nIter = 400, + nBurnin = 100, + fitRetention = "slim" + ), + "fit" + )$pip + expect_true(all(pip >= 0 & pip <= 1)) +}) + +test_that("an sbrm fit leaves the caller's random stream where it was", { + skip_if_not_installed("hibayes") + d <- .rrwPanelStatLd() + set.seed(9) + w <- bayesNRssWeights( + d$stat, + d$ldMatrix, + backend = "hibayes", + nIter = 300, + nBurnin = 100 + ) + after <- runif(1) + expect_true(all(is.finite(w))) + set.seed(9) + invisible(sample.int(.Machine$integer.max, 1L)) + expect_equal(after, runif(1)) +}) + +test_that("pecotmr's sampler stays finite on statistics unlike the LD", { + # .rrwPanelStat()'s noise ignores the LD, so y'y - 2b'X'y + b'X'Xb, the + # residual sum of squares, turns negative; qgg's own sampler goes NaN + # there, while pecotmr's keeps the last residual variance. On the LD + # unshrunk, the chain then diverges, and says so. + d <- .rrwPanelStat() + run <- function(fn, shrinkCorr, ldProjection = NULL) { + fn( + d$stat, + d$panel, + nIter = 400, + nBurnin = 100, + shrinkCorr = shrinkCorr, + methodArgs = BayesAlphabetRssOptions(ldProjection = ldProjection) + ) + } + diverged <- "bayesAlphabetRss: the posterior mean effects' squares" + w <- expect_warning(run(bayesNRssWeights, 1), diverged) + expect_true(all(is.finite(w))) + # hibayes' forms fall back on half the genetic variance, as hibayes does. + w <- expect_warning(run(bayesBRssWeights, 1), diverged) + expect_true(all(is.finite(w))) + # Shrinkage keeps the chain from diverging; so does SDPR's projection, + # the default, which drops the statistics' part the LD cannot explain. + expect_silent(run(bayesNRssWeights, 0.8)) + expect_silent(run(bayesNRssWeights, 1, ldProjection = 0.1)) + expect_silent(run(bayesBRssWeights, 1, ldProjection = 0.1)) +}) + +test_that("SDPR's projection reads R (R + aI)^-1 R and R (R + aI)^-1 bhat", { + d <- .rrwPanelStatLd() + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + R <- unname(crossprod(ldFactor) / (nrow(ldFactor) - 1)) + bhat <- d$stat$z / sqrt(500) + toSpan <- R %*% solve(R + 0.1 * diag(nrow(R))) + projected <- pecotmr:::.alphabetProjected(bhat, ldFactor, 0.1) + ldOf <- function(x) crossprod(x$ldFactor) / (nrow(x$ldFactor) - 1) + expect_equal(ldOf(projected), toSpan %*% R, tolerance = 1e-8) + expect_equal(projected$bhat, as.vector(toSpan %*% bhat), tolerance = 1e-8) + # At a = 0 it keeps R, and the statistics' part in R's span. + hard <- pecotmr:::.alphabetProjected(bhat, ldFactor, 0) + expect_equal(ldOf(hard), R, tolerance = 1e-8) + expect_equal( + hard$bhat, + as.vector(R %*% MASS::ginv(R) %*% bhat), + tolerance = 1e-8 + ) + expect_identical( + pecotmr:::.alphabetProjected(bhat, ldFactor, NULL), + list(bhat = bhat, ldFactor = ldFactor) + ) +}) + +test_that("BayesAlphabetRssOptions sets SDPR's projection or turns it off", { + d <- .rrwPanelStatLd() + run <- function(methodArgs = NULL) { + set.seed(7) + bayesNRssWeights( + d$stat, + d$panel, + nIter = 300, + nBurnin = 50, + methodArgs = methodArgs + ) + } + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + direct <- function(ldProjection) { + set.seed(7) + pecotmr:::bayesAlphabetRss( + d$stat$z / sqrt(500), + ldFactor, + 500, + "bayesN", + nIter = 300, + nBurnin = 50, + shrinkCorr = 0.95, + ldProjection = ldProjection + )$betaEst + } + # On by default at SDPR's a = 0.1. + expect_equal(run(), direct(0.1)) + expect_equal( + run(BayesAlphabetRssOptions(ldProjection = NULL)), + direct(NULL) + ) + # A record whose last setting is NULL, which rlang's splice would drop, + # reaches the sampler too. + expect_equal( + run(BayesAlphabetRssOptions(h2 = 0.5, ldProjection = NULL)), + direct(NULL) + ) + expect_equal(run(BayesAlphabetRssOptions(ldProjection = 1)), direct(1)) + expect_false(isTRUE(all.equal(direct(0.1), direct(NULL)))) + expect_error( + run(BayesAlphabetRssOptions(ldProjection = -1)), + "ldProjection.*>= 0" + ) +}) + +test_that("pecotmr's sampler reports progress and refuses bad input", { + d <- .rrwPanelStatLd() + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + bhat <- d$stat$z / sqrt(500) + out <- capture.output( + fit <- pecotmr:::bayesAlphabetRss( + bhat, + ldFactor, + 500, + "bayesN", + nIter = 100, + nBurnin = 10, + verbose = TRUE + ) + ) + expect_match(out, "Iteration +100 of 100", all = FALSE) + expect_error( + pecotmr:::bayesAlphabetRss( + bhat, + ldFactor, + 500, + "bayesN", + perVariantWeights = TRUE, + nPerVariant = 1:3 + ), + "one sample size per variant" + ) + # The entry point checks what the R side already does, for a direct call. + w <- rep(500, ncol(ldFactor)) + expect_error( + pecotmr:::bayesAlphabetFactorCpp( + bhat, + ldFactor, + w, + 500L, + "bayesX", + FALSE, + 0, + 0.5, + 100L, + 10L, + 1L, + FALSE, + 1L, + 1, + TRUE, + FALSE, + FALSE + ), + "Unknown Bayesian alphabet method 'bayesX'" + ) + expect_error( + pecotmr:::bayesAlphabetFactorCpp( + bhat[-1], + ldFactor, + w, + 500L, + "bayesN", + FALSE, + 0, + 0.5, + 100L, + 10L, + 1L, + FALSE, + 1L, + 1, + TRUE, + FALSE, + FALSE + ), + "The LD factor has" + ) +}) + +# ---- pecotmr's sampler: the shared options ---- + +# The factor of c R + (1 - c) I for R = F'F / (k - 1): F's rows scaled by +# sqrt(c) stacked on the identity's scaled by sqrt(1 - c), all rescaled for +# the k + p - 1 that the sampler divides by. +.baShrunkFactor <- function(ldFactor, c) { + k <- nrow(ldFactor) + p <- ncol(ldFactor) + sqrt(k + p - 1) * rbind(sqrt(c / (k - 1)) * ldFactor, sqrt(1 - c) * diag(p)) +} + +# One run of pecotmr's sampler on the factor `ldFactor`. +.baFactorRun <- function( + bhat, + ldFactor, + method = "bayesA", + pi = 0, + shrinkCorr = 1, + allowJumpSign = TRUE, + raoBlackwell = FALSE, + seed = 3L +) { + pecotmr:::bayesAlphabetFactorCpp( + bhat, + ldFactor, + rep(500, ncol(ldFactor)), + 500L, + method, + FALSE, + pi, + 0.5, + 300L, + 50L, + 1L, + FALSE, + seed, + shrinkCorr, + allowJumpSign, + raoBlackwell, + FALSE + ) +} + +test_that("pecotmr's sampler reads the shrunk LD", { + # The sampler reads the LD only through its products, so shrinkCorr = c + # on F runs as the unshrunk sampler on a factor of c R + (1 - c) I, draw + # for draw up to rounding. + d <- .rrwPanelStatLd() + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + bhat <- d$stat$z / sqrt(500) + expect_equal( + .baFactorRun(bhat, ldFactor, shrinkCorr = 0.9), + .baFactorRun(bhat, .baShrunkFactor(ldFactor, 0.9)), + tolerance = 1e-8 + ) +}) + +test_that("pecotmr's sampler refuses a sign jump only when asked", { + # A lone variant with a strong statistic never draws the other sign, so + # refusing jumps changes nothing there; a null one's draws do jump. + set.seed(16) + ldFactor <- matrix(rnorm(50), 50, 1) + expect_identical( + .baFactorRun(0.5, ldFactor, allowJumpSign = FALSE), + .baFactorRun(0.5, ldFactor) + ) + expect_false(identical( + .baFactorRun(0, ldFactor, allowJumpSign = FALSE)$betaEst, + .baFactorRun(0, ldFactor)$betaEst + )) +}) + +test_that("pecotmr's Rao-Blackwellized sampler runs the same chain", { + d <- .rrwPanelStatLd() + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + bhat <- d$stat$z / sqrt(500) + draws <- .baFactorRun(bhat, ldFactor, "bayesC", pi = 0.1) + means <- .baFactorRun( + bhat, + ldFactor, + "bayesC", + pi = 0.1, + raoBlackwell = TRUE + ) + chain <- c("pip", "pi", "residualVariance") + expect_identical(means[chain], draws[chain]) + expect_false(identical(means$betaEst, draws$betaEst)) + expect_gt(cor(means$betaEst, draws$betaEst), 0.95) +}) + +test_that("pecotmr's sampler averages several chains over the kept ones", { + d <- .rrwPanelStatLd() + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + bhat <- d$stat$z / sqrt(500) + set.seed(8) + fit <- pecotmr:::bayesAlphabetRss( + bhat, + ldFactor, + 500, + "bayesA", + nIter = 300, + nBurnin = 50, + thin = 1, + shrinkCorr = 1, + # Against the kernel run on the statistics as given. + ldProjection = NULL, + nChains = 2 + ) + # Each chain's seed is drawn from R's generator. + set.seed(8) + seeds <- sample.int(.Machine$integer.max, 2L) + expect_equal(fit$chains$seed, as.numeric(seeds)) + expect_false(any(fit$chains$diverged)) + kept <- fit$chains$kept + singles <- map(seeds[kept], function(seed) { + .baFactorRun(bhat, ldFactor, seed = seed) + }) + expect_equal( + fit$betaEst, + reduce(map(singles, "betaEst"), `+`) / sum(kept) + ) +}) + +test_that("every engine reads the wrapper's shrunk LD", { + d <- .rrwPanelStatLd() + R <- pecotmr:::.ldFromRef(d$panel, d$stat$variantNames, "test") + shrunk <- LdMatrix(0.9 * R + 0.1 * diag(nrow(R)), nSamples = ncol(d$panel)) + # pecotmr's sampler takes the shrinkage itself, on the factor. + ld <- pecotmr:::.rssLdSource(d$stat, d$panel, "test") + bhat <- pecotmr:::.rssMarginalCor(d$stat, n = 500, p = ncol(ld$ldFactor)) + set.seed(4) + want <- pecotmr:::bayesAlphabetRss( + bhat, + ld$ldFactor, + 500, + "bayesA", + nIter = 300, + nBurnin = 50, + nPerVariant = d$stat$n, + shrinkCorr = 0.9 + )$betaEst + set.seed(4) + expect_equal( + bayesARssWeights( + d$stat, + d$panel, + nIter = 300, + nBurnin = 50, + shrinkCorr = 0.9 + ), + want + ) + # qgg and hibayes are given the shrunk matrix. + run <- function(fn, backend, ldReference, shrinkCorr) { + set.seed(5) + suppressMessages(fn( + d$stat, + ldReference, + backend = backend, + nIter = 300, + nBurnin = 50, + shrinkCorr = shrinkCorr + )) + } + skip_if_not_installed("hibayes") + expect_equal( + run(bayesBRssWeights, "hibayes", d$ldMatrix, 0.9), + run(bayesBRssWeights, "hibayes", shrunk, 1) + ) + skip_if_not_installed("qgg") + expect_equal( + run(bayesCRssWeights, "qgg", d$ldMatrix, 0.9), + run(bayesCRssWeights, "qgg", shrunk, 1) + ) +}) + +test_that("the alphabet wrapper records and checks its LD shrinkage", { + d <- .rrwPanelStatLd() + set.seed(6) + w <- bayesARssWeights( + d$stat, + d$panel, + nIter = 300, + nBurnin = 50, + shrinkCorr = 0.7, + fitRetention = "slim" + ) + expect_equal(attr(w, "fit")$shrinkCorr, 0.7) + expect_error( + bayesARssWeights(d$stat, d$panel, shrinkCorr = "heldOut"), + "shrinkCorr" + ) + expect_error( + bayesARssWeights(d$stat, d$panel, shrinkCorr = 0), + "`shrinkCorr` must be above 0" + ) +}) + +test_that("pecotmr's sampler errors when every one of its chains diverges", { + # Statistics of 1e-6 leave the draws near the prior's, far past twice + # the statistics' sum of squares. + set.seed(17) + ldFactor <- matrix(rnorm(50 * 3), 50, 3) + run <- function(n) { + pecotmr:::bayesAlphabetRss( + rep(1e-6, 3), + ldFactor, + n, + "bayesA", + nIter = 60, + nBurnin = 10, + nChains = 2 + ) + } + expect_error(run(100), "bayesAlphabetRss: every chain diverged") + # The samplers divide by n - 1 and the standard errors by n - 2. + expect_error(run(2), "bayesAlphabetRss: the sample size must exceed 2") + stat <- list(z = rep(1, 3), n = rep(2, 3), variantNames = .rrwIds(3)) + expect_error( + bayesARssWeights(stat, .rrwLdMatrix(diag(3), nSamples = 50L)), + "bayesAlphabetRssWeights: the sample size must exceed 2" + ) +}) + +test_that("hibayes' form sends a refused jump to the null class", { + # Effects of variants in LD trade signs between sweeps; in bayesB a + # refused jump zeroes the effect and drops it from the slab, which + # changes the chain. + d <- .rrwPanelStatLd() + ldFactor <- pecotmr:::.ldFactorFromRef(d$panel, d$stat$variantNames, "test") + bhat <- d$stat$z / sqrt(500) + expect_false(identical( + .baFactorRun(bhat, ldFactor, "bayesB", pi = 0.2, allowJumpSign = FALSE), + .baFactorRun(bhat, ldFactor, "bayesB", pi = 0.2) + )) +}) diff --git a/tests/testthat/test_rrBglr.R b/tests/testthat/test_rrBglr.R index 3a19d84f7..3f83a9dce 100644 --- a/tests/testthat/test_rrBglr.R +++ b/tests/testthat/test_rrBglr.R @@ -1,6 +1,6 @@ context("regularized_regression - bglr") -# ---- bglrWeights / bayesBWeights / bLassoWeights ---- +# ---- bglrWeights, and the alphabet methods it backs ---- test_that("bglrWeights computes weights with BayesB model", { skip_if_not_installed("BGLR") set.seed(42) @@ -22,21 +22,31 @@ test_that("bglrWeights computes weights with BayesB model", { expect_true(all(is.finite(result))) }) -test_that("bayesBWeights / bLassoWeights compute finite length-p weights", { +test_that("BGLR's BayesB and Bayesian LASSO compute finite length-p weights", { skip_if_not_installed("BGLR") set.seed(42) n <- 50 p <- 10 X <- matrix(rnorm(n * p), nrow = n) y <- X[, 1] * 0.5 + rnorm(n) - for (fn in c("bayesBWeights", "bLassoWeights")) { - result <- exec(fn, X, y, nIter = 100, burnIn = 20, thin = 2) - expect_equal(length(result), p, info = fn) - expect_true(all(is.finite(result)), info = fn) + fits <- list( + bayesB = bayesBWeights(X, y, nIter = 100, nBurnin = 20, thin = 2), + bayesL = bayesLWeights( + X, + y, + backend = "bglr", + nIter = 100, + nBurnin = 20, + thin = 2 + ) + ) + for (nm in names(fits)) { + expect_equal(length(fits[[nm]]), p, info = nm) + expect_true(all(is.finite(fits[[nm]])), info = nm) } }) -test_that("bayesBWeights passes probIn through to BGLR ETA", { +test_that("bayesBWeights passes pi to BGLR's ETA as probIn", { skip_if_not_installed("BGLR") set.seed(42) n <- 50 @@ -57,9 +67,9 @@ test_that("bayesBWeights passes probIn through to BGLR ETA", { X, y, nIter = 100, - burnIn = 20, + nBurnin = 20, thin = 2, - probIn = 0.42 + pi = 0.42 ) expect_equal(length(result), p) expect_equal(captured$eta[[1]]$model, "BayesB") @@ -68,7 +78,7 @@ test_that("bayesBWeights passes probIn through to BGLR ETA", { expect_named(captured$eta[[1]], c("X", "model", "probIn")) }) -test_that("bglrWeights warns and zero-pads when X has zero-variance columns", { +test_that("bayesBWeights warns and zero-pads zero-variance columns of X", { skip_if_not_installed("BGLR") set.seed(42) n <- 50 @@ -76,9 +86,10 @@ test_that("bglrWeights warns and zero-pads when X has zero-variance columns", { X <- matrix(rnorm(n * p), nrow = n) X[, 7] <- 9 y <- X[, 1] * 0.5 + rnorm(n) + # The dispatcher drops them before any engine sees X. expect_warning( - result <- bayesBWeights(X, y, nIter = 100, burnIn = 20, thin = 2), - "bglrWeights: dropping 1 zero-variance column" + result <- bayesBWeights(X, y, nIter = 100, nBurnin = 20, thin = 2), + "bayesAlphabetWeights: dropping 1 zero-variance column" ) expect_equal(length(result), p) expect_equal(result[7], 0) @@ -92,7 +103,29 @@ test_that("bglrWeights cleans up its tempdir on exit", { X <- matrix(rnorm(n * p), nrow = n) y <- X[, 1] * 0.5 + rnorm(n) before <- list.files(tempdir(), pattern = "^bglr_") - bayesBWeights(X, y, nIter = 100, burnIn = 20, thin = 2) + bayesBWeights(X, y, nIter = 100, nBurnin = 20, thin = 2) after <- list.files(tempdir(), pattern = "^bglr_") expect_setequal(before, after) }) + +test_that("bglrWeights keeps BGLR's fitted object, naming its variants", { + skip_if_not_installed("BGLR") + set.seed(42) + X <- matrix(rnorm(500), nrow = 50) + colnames(X) <- sprintf("chr1:%d:A:G", seq_len(10)) + y <- X[, 1] * 0.5 + rnorm(50) + w <- bglrWeights( + X, + y, + model = "BayesB", + nIter = 100, + burnIn = 20, + thin = 5, + fitRetention = "slim" + ) + fit <- attr(w, "fit") + expect_s3_class(fit, "BGLR") + expect_equal(as.numeric(w), as.numeric(fit$ETA[[1L]]$b)) + expect_null(fit$variantIds) + expect_equal(pecotmr:::.twasFitVariantIds(fit), colnames(X)) +}) diff --git a/tests/testthat/test_rrDispatch.R b/tests/testthat/test_rrDispatch.R index b03af42b4..da80c1f7b 100644 --- a/tests/testthat/test_rrDispatch.R +++ b/tests/testthat/test_rrDispatch.R @@ -14,8 +14,8 @@ test_that("prsCsWeights hands the PRS-CS sampler the right arguments", { bhat <- rnorm(p, sd = 0.1) R <- diag(p) # Heterogeneous n with median != mean: this lets the test catch a regression - # that swapped median(stat$n) for mean(stat$n) or sum(stat$n). - # sorted: 10, 20, 30, 40, 50, 60, 70, 80, 90, 1000 -> median = 55, mean = 145. + # that swapped median(stat$n) for mean(stat$n) or sum(stat$n). sorted: 10, + # 20, 30, 40, 50, 60, 70, 80, 90, 1000 -> median = 55, mean = 145. stat <- list( b = bhat, n = c(10, 20, 30, 40, 50, 60, 70, 80, 90, 1000), @@ -136,13 +136,17 @@ test_that("lassosumRssWeights defaults to LD-quadratic selection", { lambda = c(0.05, 0.01), fbeta = c(5, 1) ) - } + }, + # fdrtool cannot estimate a null from four correlations; at lfdr 0 + # the score is c'b / sqrt(b'Rb) itself. + .lassosumLfdr = function(corInput) rep(0, length(corInput)) ) result <- lassosumRssWeights( stat = stat, ldReference = .rrwLdMatrix(R), - s = 0.5 + s = 0.5, + selection = "ldQuadratic" ) expect_equal(c(result), expected) expect_equal( @@ -151,7 +155,7 @@ test_that("lassosumRssWeights defaults to LD-quadratic selection", { ) }) -test_that("lassosumRssWeights uses first-max tie behavior for LD-quadratic selection", { +test_that("lassosumRssWeights breaks LD-quadratic ties at the first maximum", { p <- 3 stat <- list( cor = c(0.3, 0.3, 0), @@ -167,13 +171,15 @@ test_that("lassosumRssWeights uses first-max tie behavior for LD-quadratic selec lambda = c(0.05, 0.01), fbeta = c(2, 1) ) - } + }, + .lassosumLfdr = function(corInput) rep(0, length(corInput)) ) result <- lassosumRssWeights( stat = stat, ldReference = .rrwLdMatrix(R), - s = 0.5 + s = 0.5, + selection = "ldQuadratic" ) expect_equal(c(result), c(1, 0, 0)) expect_equal( @@ -215,7 +221,7 @@ test_that("lassosumRssWeights still supports explicit min(fbeta)", { ) }) -test_that("bayes_{n,l,a,c,r}_weights each dispatch to bayesAlphabetWeights with correct method", { +test_that("each bayes*Weights hands bayesAlphabetWeights its method", { set.seed(42) X <- matrix(rnorm(50), nrow = 10) y <- rnorm(10) @@ -223,6 +229,7 @@ test_that("bayes_{n,l,a,c,r}_weights each dispatch to bayesAlphabetWeights with list(fn = bayesNWeights, expected = "bayesN"), list(fn = bayesLWeights, expected = "bayesL"), list(fn = bayesAWeights, expected = "bayesA"), + list(fn = bayesBWeights, expected = "bayesB"), list(fn = bayesCWeights, expected = "bayesC"), list(fn = bayesRWeights, expected = "bayesR") ) @@ -289,3 +296,25 @@ test_that("mrashWeights leaves the prior grid to mr.ash unless one is given", { }) gc() + +test_that("each bayes*RssWeights hands bayesAlphabetRssWeights its method", { + wrappers <- list( + bayesA = bayesARssWeights, + bayesB = bayesBRssWeights, + bayesC = bayesCRssWeights, + bayesL = bayesLRssWeights, + bayesN = bayesNRssWeights, + bayesR = bayesRRssWeights + ) + for (m in names(wrappers)) { + captured <- NULL + local_mocked_bindings( + bayesAlphabetRssWeights = function(stat, ldReference, method, ...) { + captured <<- method + 0 + } + ) + wrappers[[m]](list(), NULL) + expect_equal(captured, m, label = m) + } +}) diff --git a/tests/testthat/test_rrDpr.R b/tests/testthat/test_rrDpr.R index 5a56fc2f7..5edf770ab 100644 --- a/tests/testthat/test_rrDpr.R +++ b/tests/testthat/test_rrDpr.R @@ -29,3 +29,23 @@ test_that("dprWeights warns and zero-pads when X has zero-variance columns", { expect_equal(length(result), p) expect_equal(result[8], 0) }) + +test_that("dprWeights' slim fit drops the copy of the genotypes", { + skip_if_not_installed("RcppDPR") + set.seed(42) + X <- matrix(rnorm(500), nrow = 50) + colnames(X) <- sprintf("chr1:%d:A:G", seq_len(10)) + y <- X[, 1] * 0.5 + rnorm(50) + slim <- attr( + dprWeights(X, y, fittingMethod = "VB", fitRetention = "slim"), + "fit" + ) + expect_null(slim$x) + expect_equal(slim$variantIds, colnames(X)) + full <- attr( + dprWeights(X, y, fittingMethod = "VB", fitRetention = "full"), + "fit" + ) + expect_true(is.matrix(full$x)) + expect_equal(pecotmr:::.twasFitVariantIds(full), colnames(X)) +}) diff --git a/tests/testthat/test_rrE2eSolvers.R b/tests/testthat/test_rrE2eSolvers.R index 1e60d4bd2..9ef13ea49 100644 --- a/tests/testthat/test_rrE2eSolvers.R +++ b/tests/testthat/test_rrE2eSolvers.R @@ -83,7 +83,7 @@ test_that("l0learnWeights forwards penalty to L0Learn::L0Learn.cvfit", { expect_equal(captured$nFolds, 8) }) -test_that("bLassoWeights forwards model = 'BL' all the way to BGLR::BGLR", { +test_that("bayesLWeights on BGLR forwards model = 'BL' to BGLR::BGLR", { skip_if_not_installed("BGLR") set.seed(42) X <- matrix(rnorm(50), nrow = 10) @@ -99,19 +99,18 @@ test_that("bLassoWeights forwards model = 'BL' all the way to BGLR::BGLR", { }, .package = "BGLR" ) - bLassoWeights(X, y, nIter = 77, burnIn = 11, thin = 3) + bayesLWeights(X, y, backend = "bglr", nIter = 77, nBurnin = 11, thin = 3) expect_equal(captured$model, "BL") expect_equal(captured$nIter, 77) expect_equal(captured$burnIn, 11) expect_equal(captured$thin, 3) }) -test_that("bayesAlphabetWeights forwards method to qgg::gbayes for all alphabet variants", { +test_that("bayesAlphabetWeights passes every alphabet method to qgg::gbayes", { skip_if_not_installed("qgg") set.seed(42) X <- matrix(rnorm(50), nrow = 10) y <- rnorm(10) - Z <- matrix(rnorm(20), nrow = 10) captured <- new.env(parent = emptyenv()) local_mocked_bindings( gbayes = function(y, W, X = NULL, method, nit, nburn, ...) { @@ -119,22 +118,30 @@ test_that("bayesAlphabetWeights forwards method to qgg::gbayes for all alphabet captured$nit <- nit captured$nburn <- nburn captured$X <- X + captured$dots <- list(...) list(bm = rep(0, ncol(W))) }, .package = "qgg" ) for (m in c("bayesN", "bayesL", "bayesA", "bayesC", "bayesR")) { - bayesAlphabetWeights(X, y, method = m, Z = Z, nit = 17, nburn = 4) + bayesAlphabetWeights(X, y, method = m, nIter = 17, nBurnin = 4) expect_equal(captured$method, m, info = paste("method =", m)) - expect_equal(captured$nit, 17) + # gbayes runs nit + nburn iterations: 13 after the 4 of burn-in. + expect_equal(captured$nit, 13) expect_equal(captured$nburn, 4) - # Z is forwarded to qgg::gbayes via the X argument. - expect_equal( - captured$X, - Z, - info = paste("Z forwarding for method =", m) - ) + # Covariates are regressed out beforehand, so qgg gets none. + expect_null(captured$X, info = m) } + # A record whose last setting is NULL reaches the engine whole: rlang's + # splice of the record itself would drop that NULL. + bayesNWeights( + X, + y, + nIter = 17, + nBurnin = 4, + methodArgs = QggOptions(nug = 4, vg = NULL) + ) + expect_equal(captured$dots[c("nug", "vg")], list(nug = 4, vg = NULL)) }) test_that("dprWeights forwards fitting_method to RcppDPR::fit_model", { diff --git a/tests/testthat/test_rrGlmnet.R b/tests/testthat/test_rrGlmnet.R index 4b90324ef..d7b0c71ea 100644 --- a/tests/testthat/test_rrGlmnet.R +++ b/tests/testthat/test_rrGlmnet.R @@ -108,3 +108,34 @@ test_that("glmnetWeights produces non-zero weights for correlated data", { expect_length(w, p) expect_true(any(w != 0)) }) + +test_that("glmnetWeights keeps the selected fit or the whole path", { + skip_if_not_installed("glmnet") + set.seed(42) + X <- matrix(rnorm(500), nrow = 50) + colnames(X) <- sprintf("chr1:%d:A:G", seq_len(10)) + X[, 4] <- 1 + y <- X[, 1] * 0.5 + rnorm(50) + fitted <- colnames(X)[-4] + set.seed(1) + none <- suppressWarnings(glmnetWeights(X, y, alpha = 1)) + expect_null(attr(none, "fit")) + set.seed(1) + slim <- suppressWarnings(lassoWeights(X, y, fitRetention = "slim")) + expect_equal(as.numeric(slim), as.numeric(none)) + fit <- attr(slim, "fit") + expect_named( + fit, + c("coef", "intercept", "lambda", "cvm", "cvsd", "variantIds") + ) + expect_equal(fit$coef, as.numeric(slim)[-4]) + expect_equal(fit$variantIds, fitted) + full <- attr( + suppressWarnings(ridgeWeights(X, y, fitRetention = "full")), + "fit" + ) + expect_s3_class(full, "cv.glmnet") + # The path names its variants, so no second copy is added. + expect_null(full$variantIds) + expect_equal(pecotmr:::.twasFitVariantIds(full), fitted) +}) diff --git a/tests/testthat/test_rrL0learn.R b/tests/testthat/test_rrL0learn.R index f138b0618..81f5dfdda 100644 --- a/tests/testthat/test_rrL0learn.R +++ b/tests/testthat/test_rrL0learn.R @@ -1,7 +1,7 @@ context("regularized_regression - l0learn") # ---- l0learnWeights ---- -test_that("l0learnWeights warns and zero-pads when X has zero-variance columns", { +test_that("l0learnWeights warns, zero-pads X's zero-variance columns", { skip_if_not_installed("L0Learn") set.seed(42) n <- 50 @@ -46,3 +46,34 @@ test_that("l0learnWeights passes nGamma through to L0Learn.cvfit", { expect_equal(captured$args$nGamma, 3) expect_equal(captured$args$penalty, "L0L2") }) + +test_that("l0learnWeights keeps the selected fit or the whole search", { + skip_if_not_installed("L0Learn") + set.seed(42) + X <- matrix(rnorm(500), nrow = 50) + colnames(X) <- sprintf("chr1:%d:A:G", seq_len(10)) + y <- X[, 1] * 0.5 + rnorm(50) + set.seed(1) + none <- l0learnWeights(X, y) + set.seed(1) + slim <- l0learnWeights(X, y, fitRetention = "slim") + expect_equal(as.numeric(slim), as.numeric(none)) + fit <- attr(slim, "fit") + expect_named( + fit, + c( + "coef", + "intercept", + "gamma", + "lambda", + "cvMean", + "cvSd", + "variantIds" + ) + ) + expect_equal(fit$coef, as.numeric(slim)) + full <- attr(l0learnWeights(X, y, fitRetention = "full"), "fit") + expect_s3_class(full, "L0LearnCV") + # L0Learn names none of its variants, so the fit takes them once. + expect_equal(full$variantIds, colnames(X)) +}) diff --git a/tests/testthat/test_rrLassosum.R b/tests/testthat/test_rrLassosum.R index ce1304812..a4e254a0c 100644 --- a/tests/testthat/test_rrLassosum.R +++ b/tests/testthat/test_rrLassosum.R @@ -74,9 +74,10 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { ) } ) + # The all-zero candidate scores -Inf on every held-out split. result <- lassosumRssWeights( stat = stat, - ldReference = .rrwLdMatrix(R), + ldReference = .rrwLdMatrix(R, nSamples = n), s = 0.5 ) expect_equal(length(result), p) @@ -84,7 +85,7 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { expect_equal(c(result), expected) expect_equal( unname(attr(result, "lassosum_selection")["mode"]), - "ldQuadratic" + "heldOut" ) }) @@ -119,3 +120,126 @@ test_that("lassosumRssWeights clamps correlation input before scaling", { # Sign-preserving rescale expect_true(all(sign(scaled_cor) == sign(bhat))) }) + +# ---- lassosum on bigsnpr's lassosum2 ---------------------------------------- +# snp_lassosum2() times each grid point with system.time(), which runs a full +# garbage collection of the session first, so these tests keep their grids +# to a point or two: held-out selection runs lassosum2 five times (the fit +# and 4 refits). + +test_that("lassosum2 fits lassosum's objective at s = delta / (1 + delta)", { + skip_if_not_installed("bigsnpr") + d <- .rrwPanelStatLd() + R <- pecotmr:::.ldFromRef(d$panel, d$stat$variantNames, "test") + bhat <- d$stat$z / sqrt(500) + inp <- list(ld = list(R = R), bhat = bhat, n = rep(500, length(bhat))) + engine <- pecotmr:::.bigsnprEngine(inp) + on.exit(pecotmr:::.bigsnprRelease(engine)) + fits <- pecotmr:::.lassosum2Run( + inp, + engine, + list( + delta = c(0.01, 1), + options = list(nlambda = 2, tol = 1e-10, maxiter = 1e5) + ) + ) + # At the same lambda, lassosum's fit is lassosum2's times 1 + delta. + for (j in seq_len(ncol(fits$beta))) { + ours <- pecotmr:::.penalizedRssPath( + bhat * sqrt(500), + list(R = R, shrink = fits$path$s[[j]]), + 500, + pecotmr:::.rssPenalty("lasso"), + lambda = fits$path$lambda[[j]], + thr = 1e-12, + maxiter = 1e6 + )$beta[, 1] + expect_equal(ours, fits$beta[, j], tolerance = 1e-6) + } +}) + +test_that("lassosumRssWeights runs lassosum2 in lassosum's s", { + skip_if_not_installed("bigsnpr") + d <- .rrwPanelStatLd() + # Without `s`, lassosum2's own delta grid. + expect_equal(pecotmr:::.lassosum2Delta(NULL), c(0.001, 0.01, 0.1, 1)) + set.seed(1) + w <- lassosumRssWeights( + d$stat, + d$ldMatrix, + backend = "bigsnpr", + s = c(0.1, 0.5), + methodArgs = BigsnprOptions(nlambda = 1), + fitRetention = "full" + ) + path <- attr(w, "fit")$path + expect_named( + path, + c("s", "lambda", "iterations", "nparams", "selected") + ) + # delta = s / (1 - s), so the path reports the s it was given. + expect_equal(path$s, c(0.1, 0.5)) + sel <- attr(w, "lassosum_selection") + expect_equal(unname(sel[["mode"]]), "heldOut") + expect_equal(as.numeric(w), attr(w, "fit")$beta[, path$selected]) + # A genotype reference runs on the matrix formed from it. + set.seed(1) + expect_length( + lassosumRssWeights( + d$stat, + d$panel, + backend = "bigsnpr", + s = 0.5, + methodArgs = BigsnprOptions(nlambda = 1) + ), + 40L + ) +}) + +test_that("lassosum2 takes lassosum's own pseudovalidation", { + skip_if_not_installed("bigsnpr") + skip_if_not_installed("fdrtool") + d <- .rrwPanelStatLd() + # fdrtool warns that 40 statistics are too few for reliable FDRs. + w <- suppressWarnings(lassosumRssWeights( + d$stat, + d$ldMatrix, + backend = "bigsnpr", + s = c(0.1, 0.5), + selection = "ldQuadratic", + methodArgs = BigsnprOptions(nlambda = 1) + )) + expect_equal( + unname(attr(w, "lassosum_selection")[["mode"]]), + "ldQuadratic" + ) +}) + +test_that("lassosumRssWeights on bigsnpr refuses what lassosum2 cannot do", { + skip_if_not_installed("bigsnpr") + d <- .rrwPanelStatLd() + expect_error( + lassosumRssWeights( + d$stat, + d$ldMatrix, + backend = "bigsnpr", + selection = "minFbeta" + ), + "lassosum2 reports no objective" + ) + expect_error( + lassosumRssWeights(d$stat, d$ldMatrix, backend = "bigsnpr", s = 1), + "strictly between 0 and 1" + ) + expect_error( + lassosumRssWeights( + d$stat, + d$ldMatrix, + backend = "bigsnpr", + methodArgs = LassosumOptions() + ), + "backend 'bigsnpr' takes BigsnprOptions" + ) + expect_error(BigsnprOptions(delta = 1), "lassosumRssWeights\\(\\)'s `s`") + expect_error(BigsnprOptions(ncores = 2), "BiocParallel") +}) diff --git a/tests/testthat/test_rrLdpred2.R b/tests/testthat/test_rrLdpred2.R new file mode 100644 index 000000000..4b5d9ce47 --- /dev/null +++ b/tests/testthat/test_rrLdpred2.R @@ -0,0 +1,291 @@ +context("regularized_regression - LDpred2") + +# ---- pecotmr's sampler against bigsnpr's ----------------------------------- + +# The panel's factor for pecotmr, the matrix it gives for bigsnpr. Effects in +# tight LD are not identified from the panel's 100 samples, so the fits are +# compared by their fitted correlations R b, averaged over seeds. +.ld2FittedMean <- function(fit, R, seeds) { + fitted <- map(seeds, function(sd) { + set.seed(sd) + as.vector(R %*% fit()) + }) + reduce(fitted, `+`) / length(seeds) +} + +test_that("pecotmr's LDpred2-grid sampler agrees with bigsnpr's", { + skip_if_not_installed("bigsnpr") + d <- .rrwPanelStatLd() + R <- pecotmr:::.ldFromRef(d$panel, d$stat$variantNames, "test") + point <- function(ld, backend) { + function() { + ldpred2GridWeights( + d$stat, + ld, + backend = backend, + p = 0.1, + h2 = 0.15, + sparse = FALSE + ) + } + } + ours <- .ld2FittedMean(point(d$panel, "pecotmr"), R, 1:6) + theirs <- .ld2FittedMean(point(d$ldMatrix, "bigsnpr"), R, 1:6) + expect_gt(cor(ours, theirs), 0.99) +}) + +test_that("pecotmr's LDpred2-auto sampler agrees with bigsnpr's", { + skip_if_not_installed("bigsnpr") + d <- .rrwPanelStatLd() + R <- pecotmr:::.ldFromRef(d$panel, d$stat$variantNames, "test") + run <- function(ld, backend) { + ldpred2AutoWeights( + d$stat, + ld, + backend = backend, + h2Init = 0.1, + pInit = c(0.05, 0.1), + fitRetention = "slim" + ) + } + set.seed(1) + ours <- run(d$panel, "pecotmr") + set.seed(1) + theirs <- run(d$ldMatrix, "bigsnpr") + expect_gt(cor(as.vector(R %*% ours), as.vector(R %*% theirs)), 0.99) + expect_equal(attr(ours, "fit")$h2, attr(theirs, "fit")$h2, tolerance = 0.2) +}) + +# ---- the sampler ------------------------------------------------------------ + +test_that("an LDpred2 chain stops once its effects outgrow the statistics", { + # Statistics of 1e-6 on one sample each leave the prior's draws, of + # variance near 1, far above twice the statistics' sum of squares. + set.seed(6) + ldFactor <- scale(matrix(rnorm(40 * 5), 40, 5)) + run <- pecotmr:::ldpred2FactorCpp( + rep(1e-6, 5), + ldFactor, + rep(1, 5), + FALSE, + 1, + 1, + FALSE, + 1, + TRUE, + 1e-5, + 1, + 1, + 100L, + 50L, + FALSE, + 1L + ) + expect_true(run$diverged) + stat <- list(z = rep(1e-6, 5), n = rep(1, 5), variantNames = .rrwIds(5)) + ld <- .rrwLdMatrix(crossprod(ldFactor) / 39, nSamples = 40L) + skip_if_not_installed("bigsnpr") + expect_error( + ldpred2GridWeights(stat, ld, p = 1, h2 = 1, sparse = FALSE), + "every grid point diverged" + ) + expect_error( + ldpred2AutoWeights(stat, ld, h2Init = 1, pInit = 1), + "every chain diverged" + ) +}) + +test_that("pecotmr's LDpred2 sampler checks its input and reports progress", { + set.seed(7) + ldFactor <- scale(matrix(rnorm(40 * 5), 40, 5)) + run <- function(n, verbose) { + pecotmr:::ldpred2FactorCpp( + rep(0.3, 5), + ldFactor, + n, + FALSE, + 0.5, + 0.2, + FALSE, + 1, + TRUE, + 1e-5, + 1, + 1, + 100L, + 50L, + verbose, + 1L + ) + } + expect_error( + run(rep(100, 4), FALSE), + "There are 4 sample sizes but 5 effects" + ) + expect_match( + capture.output(run(rep(100, 5), TRUE)), + "Iteration +100 of 100", + all = FALSE + ) +}) + +test_that("LDpred2-auto keeps the chains the LDpred2 vignette keeps", { + chain <- function(span, diverged = FALSE) { + list(corrEst = c(0, span), diverged = diverged) + } + chains <- list(chain(1), chain(0.99), chain(0.5), chain(NA, TRUE)) + # The threshold is 0.95 times the spans' 95th percentile, about 0.95. + expect_equal( + pecotmr:::.mcmcKeptChains(chains, "test"), + c(TRUE, TRUE, FALSE, FALSE) + ) + expect_error( + pecotmr:::.mcmcKeptChains(list(chain(NA, TRUE)), "test"), + "test: every chain diverged" + ) +}) + +# ---- the weight functions -------------------------------------------------- + +test_that("ldpred2AutoWeights reports its chains at each retention", { + d <- .rrwPanelStatLd() + set.seed(2) + w <- ldpred2AutoWeights( + d$stat, + d$panel, + h2Init = 0.1, + pInit = c(0.01, 0.1, 0.2), + fitRetention = "full" + ) + fit <- attr(w, "fit") + expect_length(w, 40L) + expect_named(fit$chains, c("pInit", "p", "h2", "diverged", "kept")) + expect_equal(fit$chains$pInit, c(0.01, 0.1, 0.2)) + expect_length(fit$postp, 40L) + expect_equal(dim(fit$beta), c(40L, 3L)) + expect_equal( + as.numeric(w), + rowMeans(fit$beta[, fit$chains$kept, drop = FALSE]) + ) + set.seed(2) + expect_null(attr( + ldpred2AutoWeights(d$stat, d$panel, h2Init = 0.1, pInit = 0.1), + "fit" + )) +}) + +test_that("ldpred2GridWeights records its pick and its grid", { + d <- .rrwPanelStatLd() + set.seed(3) + w <- ldpred2GridWeights( + d$stat, + d$panel, + p = c(0.01, 0.1, 1), + h2 = c(0.1, 0.2), + fitRetention = "full" + ) + sel <- attr(w, "ldpred2_selection") + expect_equal(unname(sel[["mode"]]), "heldOut") + path <- attr(w, "fit")$path + expect_named(path, c("p", "h2", "sparse", "diverged", "selected")) + expect_equal(nrow(path), 12L) + # bigsnpr's order: large p first. + expect_equal(path$p[[1L]], 1) + expect_equal(sum(path$selected), 1L) + expect_equal(as.numeric(sel[["p"]]), path$p[path$selected]) + expect_equal(as.numeric(w), attr(w, "fit")$beta[, path$selected]) + skip_if_not_installed("fdrtool") + q <- suppressWarnings(ldpred2GridWeights( + d$stat, + d$panel, + p = c(0.1, 1), + h2 = 0.2, + selection = "ldQuadratic" + )) + expect_equal(unname(attr(q, "ldpred2_selection")[["mode"]]), "ldQuadratic") +}) + +test_that("LDpred2's heritability defaults to the window's LAVA estimate", { + d <- .rrwPanelStatLd() + gridH2 <- function() { + set.seed(4) + w <- ldpred2GridWeights(d$stat, d$panel, p = 0.1, fitRetention = "slim") + sort(unique(attr(w, "fit")$path$h2)) + } + local_mocked_bindings(.cisH2Lava = function(...) list(h2 = 0.2)) + expect_equal(gridH2(), 0.2 * c(0.3, 0.7, 1, 1.4)) + # Where LAVA gives no estimate, or a negative one, the grid scales + # bigsnpr's floor. + for (h2 in c(NA_real_, -0.05)) { + local_mocked_bindings(.cisH2Lava = function(...) list(h2 = h2)) + expect_equal(gridH2(), 1e-3 * c(0.3, 0.7, 1, 1.4)) + } + # LAVA reads the reference's sample size. + unsized <- LdMatrix( + pecotmr:::.ldFromRef(d$panel, d$stat$variantNames, "test") + ) + expect_error( + ldpred2AutoWeights(d$stat, unsized), + "estimating the heritability by LAVA needs the LD reference's" + ) +}) + +test_that("the LDpred2 weights check their engine and settings", { + d <- .rrwPanelStatLd() + expect_error( + ldpred2AutoWeights(d$stat, d$ldMatrix, backend = "pecotmr"), + "runs on a genotype reference's factor" + ) + expect_error( + ldpred2GridWeights( + d$stat, + d$panel, + backend = "bigsnpr", + allowJumpSign = FALSE + ), + "always allows a drawn effect to change sign" + ) + expect_error( + ldpred2AutoWeights(d$stat, d$panel, h2Init = 0.1, pInit = c(0, 0.1)), + "`pInit` must be above 0" + ) + expect_error( + ldpred2AutoWeights(d$stat, d$panel, h2Init = 0.1, shrinkCorr = 0), + "`shrinkCorr` must be above 0" + ) + expect_error( + ldpred2GridWeights(d$stat, d$panel, h2 = 0.1, nIter = 50), + "must exceed `nBurnin`" + ) +}) + +test_that("bigsnpr's grid sampler reads the LD shrunk to shrinkCorr", { + # bigsnpr's grid has no shrinkage of its own, so the matrix written for it + # is shrunk; LDpred2-auto's is left to bigsnpr's own shrink_corr. + skip_if_not_installed("bigsnpr") + d <- .rrwPanelStatLd() + inp <- pecotmr:::.rssPerVariantInput(d$stat, d$ldMatrix, "test") + written <- NULL + local_mocked_bindings( + as_SFBM = function(spmat, ...) { + written <<- as.matrix(spmat) + NULL + }, + .package = "bigsnpr" + ) + R <- unname(inp$ld$R) + pecotmr:::.ldpred2Engine(inp, "bigsnpr", 0.9) + expect_equal(unname(written), 0.9 * R + 0.1 * diag(nrow(R))) + pecotmr:::.ldpred2Engine(inp, "bigsnpr") + expect_equal(unname(written), R) + expect_equal(formals(ldpred2GridWeights)$shrinkCorr, 0.95) +}) + +test_that("bigsnpr's LD file lives only as long as the call", { + skip_if_not_installed("bigsnpr") + d <- .rrwPanelStatLd() + before <- list.files(tempdir(), pattern = "[.]sbk$") + set.seed(5) + ldpred2GridWeights(d$stat, d$ldMatrix, p = c(0.1, 1), h2 = 0.2) + expect_setequal(list.files(tempdir(), pattern = "[.]sbk$"), before) +}) diff --git a/tests/testthat/test_rrMrash.R b/tests/testthat/test_rrMrash.R index 538b4cc8e..a0075d115 100644 --- a/tests/testthat/test_rrMrash.R +++ b/tests/testthat/test_rrMrash.R @@ -1,7 +1,7 @@ context("regularized_regression - mrash") # ---- mrashWeights ---- -test_that("mrashWeights subsets a user-supplied beta.init of length ncol(X) by keep", { +test_that("mrashWeights subsets a full-length beta.init by keep", { skip_if_not_installed("glmnet") set.seed(42) n <- 50 @@ -42,3 +42,22 @@ test_that("mrashWeights warns and zero-pads when X has zero-variance columns", { }) gc() + +test_that("mrashWeights' slim fit drops the copy of the data", { + set.seed(42) + X <- matrix(rnorm(500), nrow = 50) + colnames(X) <- sprintf("chr1:%d:A:G", seq_len(10)) + y <- X[, 1] * 0.5 + rnorm(50) + set.seed(1) + slim <- attr(mrashWeights(X, y, fitRetention = "slim"), "fit") + expect_s3_class(slim, "mr.ash") + expect_false(any(is_in(c("data", "update.order"), names(slim)))) + # estimateSparsity() reads the mixture weights it keeps. + expect_true(is.numeric(slim$pi)) + expect_equal(slim$variantIds, colnames(X)) + set.seed(1) + full <- attr(mrashWeights(X, y, fitRetention = "full"), "fit") + expect_true(is.list(full$data)) + expect_null(full$variantIds) + expect_equal(pecotmr:::.twasFitVariantIds(full), colnames(X)) +}) diff --git a/tests/testthat/test_rrNcvreg.R b/tests/testthat/test_rrNcvreg.R index 49131c493..9b3a6f42f 100644 --- a/tests/testthat/test_rrNcvreg.R +++ b/tests/testthat/test_rrNcvreg.R @@ -14,7 +14,7 @@ test_that("ncvregWeights computes weights with SCAD penalty", { expect_true(all(is.finite(result))) }) -test_that("ncvregWeights warns and zero-pads when X has zero-variance columns", { +test_that("ncvregWeights warns, zero-pads X's zero-variance columns", { skip_if_not_installed("ncvreg") set.seed(42) n <- 50 @@ -42,3 +42,28 @@ test_that("mcpWeights computes weights and dispatches to ncvregWeights", { expect_equal(ncol(result), 1) expect_true(all(is.finite(result))) }) + +test_that("ncvregWeights keeps the selected fit or the path without X", { + skip_if_not_installed("ncvreg") + set.seed(42) + X <- matrix(rnorm(500), nrow = 50) + colnames(X) <- sprintf("chr1:%d:A:G", seq_len(10)) + y <- X[, 1] * 0.5 + rnorm(50) + set.seed(1) + none <- scadWeights(X, y) + set.seed(1) + slim <- scadWeights(X, y, fitRetention = "slim") + expect_equal(as.numeric(slim), as.numeric(none)) + fit <- attr(slim, "fit") + expect_named( + fit, + c("coef", "intercept", "lambda", "cve", "cvse", "variantIds") + ) + expect_equal(fit$variantIds, colnames(X)) + full <- attr(mcpWeights(X, y, fitRetention = "full"), "fit") + expect_s3_class(full, "cv.ncvreg") + # Its standardized copy of the genotypes is not kept. + expect_null(full$fit$X) + expect_null(full$variantIds) + expect_equal(pecotmr:::.twasFitVariantIds(full), colnames(X)) +}) diff --git a/tests/testthat/test_rrPenalizedRss.R b/tests/testthat/test_rrPenalizedRss.R index 45c1b3432..78ccfaab4 100644 --- a/tests/testthat/test_rrPenalizedRss.R +++ b/tests/testthat/test_rrPenalizedRss.R @@ -131,7 +131,7 @@ test_that("mcpRssWeights / scadRssWeights recover the signal direction", { for (pen in names(fns)) { w <- fns[[pen]]( stat = stat, - ldReference = .rrwLdMatrix(R), + ldReference = .rrwLdMatrix(R, nSamples = n), s = c(0.5, 0.9) ) expect_equal(length(w), p, info = pen) @@ -153,7 +153,7 @@ test_that("penalizedRss L0 recovers signal direction", { stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) w <- l0learnRssWeights( stat = stat, - ldReference = .rrwLdMatrix(R), + ldReference = .rrwLdMatrix(R, nSamples = n), penalty = "L0", s = c(0.5, 0.9), lambda0 = exp(seq(log(0.001), log(0.5), length.out = 5)) @@ -174,7 +174,11 @@ test_that("scadRssWeights / mcpRssWeights return p weights with attributes", { stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) fns <- list(SCAD = scadRssWeights, MCP = mcpRssWeights) for (pen in names(fns)) { - w <- fns[[pen]](stat = stat, ldReference = .rrwLdMatrix(R), s = 0.5) + w <- fns[[pen]]( + stat = stat, + ldReference = .rrwLdMatrix(R, nSamples = n), + s = 0.5 + ) expect_equal(length(w), p, info = pen) expect_true(is.numeric(w), info = pen) sel <- attr(w, "penalized_rss_selection") @@ -192,7 +196,7 @@ test_that("l0learnRssWeights returns correct-length vector with attributes", { stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) w <- l0learnRssWeights( stat = stat, - ldReference = .rrwLdMatrix(R), + ldReference = .rrwLdMatrix(R, nSamples = n), penalty = "L0", s = 0.5, lambda0 = c(0.01, 0.1) @@ -433,6 +437,88 @@ test_that("lassosumRss is penalizedRss's lasso at alpha = 1, bit for bit", { expect_identical(lassosum$fbeta, lasso$fbeta) }) +# The ridge's minimizer at shrinkage s and penalty l, from its normal +# equations ((1 - s) R + (s + l) I) beta = z. +.prs_ridgeExact <- function(l, R, z, s) { + solve((1 - s) * R + (s + l) * diag(nrow(R)), z) +} + +# A 30-sample reference over 50 variants: an LD of rank below its size, as +# a small reference gives it, so a factor's thin SVD spans only part of the +# variants. +.prs_lowRankLd <- function() { + set.seed(5) + ldFactor <- pecotmr:::.ldFactorFromDosage(matrix( + rbinom(30 * 50, 2, 0.4), + 30, + 50 + )) + list(ldFactor = ldFactor, R = crossprod(ldFactor) / (nrow(ldFactor) - 1)) +} + +test_that("a ridge is solved in closed form, on the matrix or a factor", { + d <- .prs_lowRankLd() + z <- as.numeric(d$R %*% rnorm(50, sd = 0.05)) + rnorm(50, sd = 0.02) + lambda <- c(2, 0.5, 0.1) + for (s in c(0, 0.3)) { + exactBetas <- map(lambda, .prs_ridgeExact, R = d$R, z = z, s = s) + exact <- exec(cbind, !!!exactBetas) + for (ld in list( + list(R = d$R, shrink = s), + list(ldFactor = d$ldFactor, shrink = s) + )) { + fit <- pecotmr:::.rssRidgeSolve(z, lambda, ld) + expect_equal(fit$beta, exact, tolerance = 1e-10) + expect_identical(fit$conv, rep(1L, 3L)) + bb <- colSums(fit$beta^2) + loss <- (1 - s) * + colSums(fit$beta * (d$R %*% fit$beta)) + + s * bb - + 2 * colSums(z * fit$beta) + expect_equal(fit$loss, loss, tolerance = 1e-10) + expect_equal(fit$fbeta, loss + lambda * bb, tolerance = 1e-10) + } + } + # penalizedRss() at alpha = 0 takes it: the minimum coordinate descent + # converges to. + descent <- pecotmr:::penalizedRssCpp( + z, + list(d$R), + 0, + lambda, + "lasso", + 0, + 0, + 0, + 0, + 1e-13, + 100000L, + 0L + ) + expect_equal( + penalizedRss(z * 10, d$R, 100, alpha = 0, lambda = lambda)$beta, + descent$beta, + tolerance = 1e-8 + ) +}) + +test_that("a ridge that nothing makes invertible is the minimum-norm fit", { + d <- .prs_lowRankLd() + z <- as.numeric(d$R %*% rnorm(50)) + ev <- eigen(d$R, symmetric = TRUE) + kept <- ev$values > 1e-8 + minNorm <- ev$vectors[, kept] %*% + (crossprod(ev$vectors[, kept], z) / ev$values[kept]) + # At s = lambda = 0 the LD's null space is unpenalized. + for (ld in list(list(R = d$R), list(ldFactor = d$ldFactor))) { + expect_equal( + pecotmr:::.rssRidgeSolve(z, 0, ld)$beta, + minNorm, + tolerance = 1e-8 + ) + } +}) + # ---- enetRssWeights / ridgeRssWeights ---------------------------------------- # Twelve variants, two of them causal, as summary statistics with their LD. @@ -448,7 +534,7 @@ test_that("lassosumRss is penalizedRss's lasso at alpha = 1, bit for bit", { n = rep(n, p), variantNames = .rrwIds(p) ), - ld = .rrwLdMatrix(cor(X)) + ld = .rrwLdMatrix(cor(X), nSamples = n) ) } @@ -463,8 +549,12 @@ test_that("enetRssWeights mixes at alpha and is lassosum at alpha = 1", { unname(attr(other, "penalized_rss_selection")["alpha"]), "0.2" ) + # One seed per call, so both draw the same held-out splits. + set.seed(3) + atOne <- enetRssWeights(f$stat, f$ld, alpha = 1) + set.seed(3) expect_equal( - as.numeric(enetRssWeights(f$stat, f$ld, alpha = 1)), + as.numeric(atOne), as.numeric(lassosumRssWeights(f$stat, f$ld)) ) expect_error(enetRssWeights(f$stat, f$ld, alpha = 2), "alpha.*<= 1") @@ -490,6 +580,59 @@ test_that("ridgeRssWeights fits the alpha = 0 mixing over the ridge path", { ) }) +test_that("a ridge's fits at s = 1, alike but for scale, are told apart", { + # At s = 1 each fit is c / (1 + lambda), so all tie on the selection's + # correlation. Held-out selection lets the variance each explains set + # the scale, so its pick does not depend on the grid's order; lassosum's + # pseudovalidation takes the grid's first. + f <- .prs_weightsInput() + lambda <- c(0.1, 0.3, 1, 3, 10) + picked <- function(lambda, selection = "heldOut") { + set.seed(4) + w <- ridgeRssWeights( + f$stat, + f$ld, + s = 1, + selection = selection, + methodArgs = PenalizedRssOptions(lambda = lambda) + ) + as.numeric(attr(w, "penalized_rss_selection")[["lambda"]]) + } + expect_equal(picked(lambda), picked(rev(lambda))) + skip_if_not_installed("fdrtool") + # fdrtool warns that 12 statistics are few to fit its null on. + expect_equal(suppressWarnings(picked(lambda, "ldQuadratic")), 0.1) + expect_equal(suppressWarnings(picked(rev(lambda), "ldQuadratic")), 10) +}) + +test_that("a ridge's whole search shares one decomposition of the LD", { + f <- .prs_weightsInput() + source <- pecotmr:::.rssLdSource(f$stat, f$ld, "test") + carried <- pecotmr:::.rssSolverSource( + source, + pecotmr:::.rssPenalty("lasso", alpha = 0) + ) + expect_identical(carried$eigen, eigen(source$R, symmetric = TRUE)) + # Any other penalty reads the source as it is. + expect_identical( + pecotmr:::.rssSolverSource( + source, + pecotmr:::.rssPenalty("lasso", alpha = 0.5) + ), + source + ) + # Four shrinkage levels, each refit on four held-out splits, and the + # splits' draws: one decomposition. + computed <- 0L + decompose <- pecotmr:::.ldSourceEigen + local_mocked_bindings(.ldSourceEigen = function(ld) { + computed <<- computed + is.null(ld$eigen) + decompose(ld) + }) + ridgeRssWeights(f$stat, f$ld) + expect_identical(computed, 1L) +}) + test_that("scadRssWeights and mcpRssWeights refuse alpha = 0 before fitting", { f <- .prs_weightsInput() cnd <- tryCatch(scadRssWeights(f$stat, f$ld, alpha = 0), error = identity) @@ -512,6 +655,18 @@ test_that("l0learnRssWeights takes its lambda path only as its own argument", { ) }) +test_that("l0learnRssWeights' L1 grid is the caller's or the penalty's", { + lambdaFor <- pecotmr:::.l0learnRssLambda + # L0L1 sweeps ten values on a log scale; the others have no L1 term. + expect_equal( + lambdaFor(NULL, "L0L1"), + exp(seq(log(0.0001), log(0.1), length.out = 10)) + ) + expect_equal(lambdaFor(NULL, "L0"), 0) + expect_equal(lambdaFor(NULL, "L0L2"), 0) + expect_equal(lambdaFor(c(0.01, 0.02), "L0L1"), c(0.01, 0.02)) +}) + test_that(".rssPenalty checks a penalty once and fills MCP / SCAD's gamma", { pen <- pecotmr:::.rssPenalty expect_equal(pen("SCAD")$gamma, 3.7) diff --git a/tests/testthat/test_rrPrsCs.R b/tests/testthat/test_rrPrsCs.R index e6fcb2556..d1e7f99e1 100644 --- a/tests/testthat/test_rrPrsCs.R +++ b/tests/testthat/test_rrPrsCs.R @@ -29,6 +29,36 @@ test_that("prsCs errors on mismatched bhat and R dimensions", { ) }) +test_that("prsCs averages exactly the draws its schedule keeps", { + # Iterations 5 and 10 are kept, two draws, though (12 - 3) / 5 rounds to + # one. A fixed phi is the same in every draw, so its mean is phi. + result <- prsCs( + bhat = rep(0.05, 5), + R = diag(5), + n = 100, + phi = 0.01, + nIter = 12, + nBurnin = 3, + thin = 5, + seed = 1L + ) + expect_equal(result$phiEst, 0.01) + expect_error( + prsCs(bhat = rep(0.05, 5), R = diag(5), n = 100, thin = 0), + "thinning interval positive" + ) + expect_error( + prsCs( + bhat = rep(0.05, 5), + R = diag(5), + n = 100, + nIter = 10, + nBurnin = 10 + ), + "keeps no draws" + ) +}) + test_that("prsCs runs with valid input and estimates phi when none is given", { set.seed(42) p <- 10 @@ -168,8 +198,8 @@ test_that("PRS-CS draws beta from the same posterior off a factor of the LD", { # N(A^-1 bhat, A^-1 / n) with A = R + I. set.seed(12) X <- matrix(rbinom(30 * 40, 2, 0.3), 30, 40) - F <- pecotmr:::.ldFactorFromDosage(X) - R <- crossprod(F) / (nrow(F) - 1) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) effects <- replace(numeric(40), c(4, 20), c(0.2, -0.15)) bhat <- as.vector(R %*% effects) + rnorm(40, sd = 0.03) n <- 200L @@ -187,12 +217,15 @@ test_that("PRS-CS draws beta from the same posterior off a factor of the LD", { bhat, NULL, n, - F, + ldFactor, 1L, 0L, 1L, FALSE, - s + s, + 1, + FALSE, + FALSE )$betaEst }, numeric(40) @@ -204,10 +237,215 @@ test_that("PRS-CS draws beta from the same posterior off a factor of the LD", { # sigma, steady across seeds, must agree too; their beta means agree to # Monte Carlo error. chain <- function(fn, ld, seed) { - fn(1, 0.5, 1e-3, bhat, NULL, n, ld, 4000L, 500L, 5L, FALSE, seed) + fn( + 1, + 0.5, + 1e-3, + bhat, + NULL, + n, + ld, + 4000L, + 500L, + 5L, + FALSE, + seed, + 1, + FALSE, + FALSE + ) } dense <- chain(pecotmr:::prsCsCpp, list(R), 1L) - factor <- chain(pecotmr:::prsCsFactorCpp, F, 2L) + factor <- chain(pecotmr:::prsCsFactorCpp, ldFactor, 2L) expect_equal(factor$sigmaEst, dense$sigmaEst, tolerance = 0.01) expect_gt(cor(dense$betaEst, factor$betaEst), 0.9) }) + +test_that("prsCs skips an empty LD block", { + R <- diag(5) + R[abs(row(R) - col(R)) == 1] <- 0.3 + run <- function(blocks) { + pecotmr:::prsCsCpp( + 1, + 0.5, + NULL, + rep(0.05, 5), + NULL, + 100L, + blocks, + 60L, + 10L, + 5L, + FALSE, + 7L, + 1, + FALSE, + FALSE + ) + } + expect_identical(run(list(matrix(numeric(0), 0, 0), R)), run(list(R))) +}) + +test_that("prsCs runs with the local shape a below and at 0.5", { + # a - 1/2 is the order of the generalized inverse Gaussian psi is drawn + # from: negative below a = 0.5, which the generator handles by drawing + # the reciprocal, and zero at it, which takes its own branch. + set.seed(6) + R <- diag(10) + R[abs(row(R) - col(R)) == 1] <- 0.3 + bhat <- rnorm(10, sd = 0.1) + for (a in c(0.3, 0.5)) { + fit <- prsCs( + bhat, + R, + 200, + a = a, + nIter = 60, + nBurnin = 10, + thin = 5, + seed = 1L + ) + expect_true(all(is.finite(fit$betaEst)), info = a) + } +}) + +# ---- the shared sampler options ---- + +# A factor F of 30 samples' LD R over 20 variants, and statistics with one +# causal variant. +.prsCsShrinkFixture <- function() { + set.seed(13) + X <- matrix(rbinom(30 * 20, 2, 0.3), 30, 20) + ldFactor <- pecotmr:::.ldFactorFromDosage(X) + R <- crossprod(ldFactor) / (nrow(ldFactor) - 1) + bhat <- as.vector(R %*% replace(numeric(20), 5, 0.2)) + + rnorm(20, sd = 0.03) + list(ldFactor = ldFactor, R = R, bhat = bhat) +} + +# One PRS-CS iteration on `ld`, from psi = 1 and sigma = 1. +.prsCsOneSweep <- function( + fn, + ld, + bhat, + shrinkCorr, + raoBlackwell, + track = FALSE +) { + fn( + 1, + 0.5, + 1e-3, + bhat, + NULL, + 200L, + ld, + 1L, + 0L, + 1L, + FALSE, + 9L, + shrinkCorr, + raoBlackwell, + track + ) +} + +test_that("PRS-CS reads the shrunk LD and reports conditional means", { + # Rao-Blackwellized, one iteration reports its draw's conditional mean, + # (c R + (1 - c) I + I)^-1 bhat, on the dense route and the factor's. + f <- .prsCsShrinkFixture() + want <- solve(0.8 * f$R + 0.2 * diag(20) + diag(20), f$bhat) + dense <- .prsCsOneSweep(pecotmr:::prsCsCpp, list(f$R), f$bhat, 0.8, TRUE) + factor <- .prsCsOneSweep( + pecotmr:::prsCsFactorCpp, + f$ldFactor, + f$bhat, + 0.8, + TRUE + ) + expect_equal(dense$betaEst, want, tolerance = 1e-10) + expect_equal(factor$betaEst, want, tolerance = 1e-10) + # Without, the iteration reports its draw: the mean plus noise. + draw <- .prsCsOneSweep(pecotmr:::prsCsCpp, list(f$R), f$bhat, 0.8, FALSE) + expect_false(isTRUE(all.equal(draw$betaEst, want))) +}) + +test_that("a tracked PRS-CS chain fits correlations through the shrunk LD", { + # With one kept draw, the mean fitted correlations are c R + (1 - c) I + # times that draw, on both routes. + f <- .prsCsShrinkFixture() + shrunk <- 0.8 * f$R + 0.2 * diag(20) + for (route in list( + list(pecotmr:::prsCsCpp, list(f$R)), + list(pecotmr:::prsCsFactorCpp, f$ldFactor) + )) { + fit <- .prsCsOneSweep(route[[1]], route[[2]], f$bhat, 0.8, FALSE, TRUE) + expect_false(fit$diverged) + expect_equal( + fit$corrEst, + as.vector(shrunk %*% fit$betaEst), + tolerance = 1e-10 + ) + } +}) + +# PRS-CS on a ten-variant window with one causal variant. +.prsCsOptionFit <- function(seed, raoBlackwell = FALSE, nChains = 1) { + set.seed(14) + R <- diag(10) + R[abs(row(R) - col(R)) == 1] <- 0.4 + bhat <- as.vector(R %*% replace(numeric(10), 3, 0.3)) + + rnorm(10, sd = 0.05) + prsCs( + bhat, + R, + 300, + nIter = 200, + nBurnin = 50, + thin = 5, + seed = seed, + raoBlackwell = raoBlackwell, + nChains = nChains + ) +} + +test_that("Rao-Blackwellized PRS-CS runs the same chain", { + draws <- .prsCsOptionFit(2L) + means <- .prsCsOptionFit(2L, raoBlackwell = TRUE) + chain <- c("psiEst", "sigmaEst", "phiEst") + expect_identical(means[chain], draws[chain]) + expect_false(identical(means$betaEst, draws$betaEst)) + expect_gt(cor(means$betaEst, draws$betaEst), 0.95) +}) + +test_that("prsCs averages several chains over the kept ones", { + fit <- .prsCsOptionFit(4L, nChains = 3) + expect_named(fit$chains, c("seed", "diverged", "kept")) + expect_equal(fit$chains$seed, c(4, 5, 6)) + expect_false(any(fit$chains$diverged)) + # A tracked chain draws as the untracked one of its seed does. + kept <- fit$chains$kept + singles <- map(4:6, .prsCsOptionFit)[kept] + expect_equal(fit$betaEst, reduce(map(singles, "betaEst"), `+`) / sum(kept)) + expect_null(.prsCsOptionFit(4L)$chains) +}) + +test_that("a diverged PRS-CS chain warns, and chains that all diverge error", { + # Statistics of 1e-6 on one sample leave the draws near the prior's, far + # past twice the statistics' sum of squares. + run <- function(nChains) { + prsCs( + rep(1e-6, 5), + diag(5), + 1, + nIter = 30, + nBurnin = 10, + thin = 5, + seed = 3L, + nChains = nChains + ) + } + expect_warning(run(1), "prsCs: the posterior mean effects' squares") + expect_error(run(2), "prsCs: every chain diverged") +}) diff --git a/tests/testthat/test_rrSdpr.R b/tests/testthat/test_rrSdpr.R index 3b55ca233..95471a626 100644 --- a/tests/testthat/test_rrSdpr.R +++ b/tests/testthat/test_rrSdpr.R @@ -78,12 +78,13 @@ test_that("sdpr runs with a per-variant sample size or an array vector", { array = list(array = rep(1, p)) ) for (nm in names(extras)) { + extraArgs <- extras[[nm]] result <- exec( sdpr, bhat = bhat, R = R, n = 100, - !!!extras[[nm]], + !!!extraArgs, iter = 50, burn = 10, thin = 2, @@ -123,6 +124,119 @@ test_that("sdpr recovers signal direction on simulated genotype data", { expect_gt(cor(result$betaEst, beta_true), 0.3) }) +# SDPR on 20 variants (n = 500), two of them causal. +.sdprTwoCausalFit <- function(seed, raoBlackwell = FALSE, nChains = 1) { + set.seed(2025) + n <- 500 + p <- 20 + X <- matrix(rbinom(n * p, 2, 0.3), nrow = n) + y <- X[, c(3, 10)] %*% c(0.4, -0.3) + rnorm(n) + sdpr( + bhat = as.vector(cor(y, X)), + R = cor(X), + n = n, + iter = 200, + burn = 50, + thin = 5, + verbose = FALSE, + seed = seed, + raoBlackwell = raoBlackwell, + nChains = nChains + ) +} + +test_that("Rao-Blackwellized SDPR runs the same chain", { + draws <- .sdprTwoCausalFit(42L) + means <- .sdprTwoCausalFit(42L, raoBlackwell = TRUE) + expect_identical(means$h2, draws$h2) + expect_false(identical(means$betaEst, draws$betaEst)) + expect_gt(cor(means$betaEst, draws$betaEst), 0.95) +}) + +test_that("sdpr errors when every one of several chains diverges", { + # Statistics of 1e-6 on one sample leave the draws near the prior's, far + # past twice the statistics' sum of squares. + expect_error( + sdpr( + rep(1e-6, 5), + diag(5), + 1, + iter = 30, + burn = 10, + thin = 5, + verbose = FALSE, + seed = 3L, + nChains = 2 + ), + "sdpr: every chain diverged" + ) +}) + +test_that("sdpr averages several chains over the kept ones", { + # SDPR's first sweeps draw far past the divergence test's bound before + # settling, which the test, past the burn-in, leaves alone. + many <- .sdprTwoCausalFit(4L, nChains = 3) + expect_equal(many$chains$seed, c(4, 5, 6)) + expect_false(any(many$chains$diverged)) + kept <- many$chains$kept + singles <- map(4:6, .sdprTwoCausalFit)[kept] + expect_equal( + many$betaEst, + reduce(map(singles, "betaEst"), `+`) / sum(kept) + ) + expect_equal(many$h2, reduce(map(singles, "h2"), `+`) / sum(kept)) +}) + +# A window of 30 variants in LD (n = 600) whose 15th variant alone has a +# standardized effect explaining `h2` of the trait, fitted by SDPR. +.sdprLoneCausalFit <- function(seed, h2) { + set.seed(seed) + n <- 600 + p <- 30 + X <- matrix(rbinom(n * p, 2, 0.3), n, p) + for (j in 2:p) { + X[, j] <- ifelse(runif(n) < 0.6, X[, j - 1], X[, j]) + } + X <- scale(X) + y <- X[, 15] * sqrt(h2) + rnorm(n, sd = sqrt(1 - h2)) + sdpr( + bhat = as.vector(cor(X, y)), + R = cor(X), + n = n, + M = 20, + iter = 600, + burn = 100, + thin = 5, + verbose = FALSE, + seed = 1L + ) +} + +test_that("sdpr recovers a lone causal variant's effect and h2", { + # A lone causal variant is drawn as several are, so eta's update reads + # N beta'A'bhat. The original's closed-form draw took eta times that, + # which centred eta near eta^2: on such a window the effect and h2 ran + # away (h2 in the tens of thousands here). The truth is an effect of + # sqrt(0.1) and h2 = 0.1. + result <- .sdprLoneCausalFit(1001, 0.1) + expect_gt(result$h2, 0.03) + expect_lt(result$h2, 0.3) + expect_gt(result$betaEst[15], 0.15) + expect_lt(result$betaEst[15], 0.6) +}) + +test_that("sdpr finds a weak lone causal variant rather than staying null", { + # Every chain starts with no causal variant, and while a sweep includes + # none, eta is drawn from its prior alone. The original's flat prior, in + # effect N(0, 1e6), put |eta| in the hundreds, which made every + # inclusion unlikely, so the chain stayed null. On this window (causal + # z = 4.8, h2 = 0.03) all of 500 seeds found the variant under the + # N(1, 1) prior and 4 of 100 under the original's. + result <- .sdprLoneCausalFit(2003, 0.03) + expect_gt(result$h2, 0.01) + expect_lt(result$h2, 0.2) +}) + # ---- sdpr verbose output ---- test_that("sdpr with verbose = TRUE produces output", { set.seed(42) @@ -200,3 +314,30 @@ test_that("sdprWeights calls sdpr and returns beta_est", { expect_equal(length(result), p) expect_true(is.numeric(result)) }) + +test_that("sdpr runs on a factor that carries no LD at all", { + # Every variant monomorphic: the factor has rank 0, so B and A vanish and + # nothing is heritable. + fit <- pecotmr:::sdprFactorCpp( + bhatR = rep(0.01, 5), + factorR = matrix(0, 10, 5), + n = 100L, + perVariantSampleSize = NULL, + array = NULL, + a = 0.1, + c = 1, + M = 20L, + a0k = 0.5, + b0k = 0.5, + iter = 50L, + burn = 10L, + thin = 1L, + optLlk = 1L, + verbose = FALSE, + seed = 1L, + raoBlackwell = FALSE, + track = FALSE + ) + expect_equal(fit$h2, 0) + expect_true(all(is.finite(fit$betaEst))) +}) diff --git a/tests/testthat/test_rrSignalRecovery.R b/tests/testthat/test_rrSignalRecovery.R index 7271ad5f6..534a4fb6d 100644 --- a/tests/testthat/test_rrSignalRecovery.R +++ b/tests/testthat/test_rrSignalRecovery.R @@ -93,7 +93,7 @@ test_that("lassosumRssWeights recovers signal direction on simulated data", { ) w <- lassosumRssWeights( stat = stat, - ldReference = .rrwLdMatrix(R), + ldReference = .rrwLdMatrix(R, nSamples = n), s = c(0.2, 0.5, 0.9) ) expect_equal(length(w), p) diff --git a/tests/testthat/test_sldscPostprocessingPipeline.R b/tests/testthat/test_sldscPostprocessingPipeline.R index 15b6c150d..092fa2fde 100644 --- a/tests/testthat/test_sldscPostprocessingPipeline.R +++ b/tests/testthat/test_sldscPostprocessingPipeline.R @@ -159,7 +159,8 @@ test_that("pipeline skips targets beyond a trait's single runs", { ) traits <- list( traitX = list( - single = list(.sldscMkRun(c("annot_A_0", "baselineLD_0"))), # only 1 run + # only 1 run + single = list(.sldscMkRun(c("annot_A_0", "baselineLD_0"))), joint = .sldscMkRun(c("annot_A_0", "annot_B_0", "baselineLD_0")) ) ) diff --git a/tests/testthat/test_sldscWrapper.R b/tests/testthat/test_sldscWrapper.R index 2bc036449..4cd35bfef 100644 --- a/tests/testthat/test_sldscWrapper.R +++ b/tests/testthat/test_sldscWrapper.R @@ -6,8 +6,9 @@ # # The reader functions (readSldscTrait/readSldscAnnot/readSldscFrq) do file I/O # and are tested against real fixture files. The compute functions -# (computeSldscMRef/computeSldscAnnotSd/isBinarySldscAnnot/standardizeSldscTrait) -# operate on an in-memory SldscData and are tested with in-memory fixtures. +# (computeSldscMRef, computeSldscAnnotSd, isBinarySldscAnnot, +# standardizeSldscTrait) operate on an in-memory SldscData and are tested with +# in-memory fixtures. # ============================================================================= # File-based fixtures for the readers @@ -250,7 +251,7 @@ test_that("readSldscFrq stacks per-chromosome .frq into one table", { expect_equal(nrow(df), 100L) }) -test_that("readSldscFrq falls back to a generic .frq glob when the prefix misses", { +test_that("readSldscFrq falls back to a .frq glob when the prefix misses", { dir <- withr::local_tempdir() for (chr in 1:2) { .make_frq(dir, chr, plinkName = "other_chr") @@ -393,7 +394,7 @@ test_that("computeSldscMRef applies the MAF cutoff", { expect_equal(M, 2L) # rs1, rs3 }) -test_that("computeSldscMRef falls back to annot row count when frq absent and mafCutoff = 0", { +test_that("computeSldscMRef counts annot rows without frq at mafCutoff 0", { expect_equal( computeSldscMRef(.sldscMkData(withFrq = FALSE), mafCutoff = 0), 6L @@ -717,7 +718,7 @@ test_that("metaSldscRandom meta-analyzes tauStar, enrichment and enrichstat", { ) } -test_that("sldscSubsetMeta metas a chosen trait/category subset with the four blocks", { +test_that("sldscSubsetMeta metas chosen traits and categories, four blocks", { res <- list( per_trait = list( t1 = .sms_makeWideTrait(), @@ -732,11 +733,12 @@ test_that("sldscSubsetMeta metas a chosen trait/category subset with the four bl c("tau_star_single", "tau_star_joint", "enrichment", "enrichstat") ) expect_equal(names(out$tau_star_single), "A_0") # only the chosen category - expect_equal(out$tau_star_single[["A_0"]]$nTraits, 2L) # only the chosen traits + # only the chosen traits + expect_equal(out$tau_star_single[["A_0"]]$nTraits, 2L) expect_true(is.finite(out$tau_star_joint[["A_0"]]$mean)) }) -test_that("sldscSubsetMeta defaults categories from params and validates traits", { +test_that("sldscSubsetMeta takes default categories, validates traits", { res <- list( per_trait = list(t1 = .sms_makeWideTrait(), t2 = .sms_makeWideTrait()), params = list(target_categories = c("A_0", "B_0")) @@ -796,7 +798,7 @@ test_that("metaSldscRandom skips NULL entries and NULL summaries", { expect_equal(result$nTraits, 2L) }) -test_that("metaSldscRandom skips a trait whose summary lacks the quantity columns", { +test_that("metaSldscRandom skips a trait whose summary lacks quantities", { valid <- .makePerTraitMeta( nTraits = 2, means = c(1e-5, 2e-5), diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 738655586..78df0e7a7 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -632,6 +632,40 @@ test_that("Merge operation is correct for mergeRaissDf", { expect_true(all(c("chr21", "chr22") %in% merged_df$chrom)) }) +test_that("mergeRaissDf keeps observed beta / se and blanks the imputed", { + # Only z is imputed, so an imputed variant has no beta or se of its own. + # The mask was inverted: the observed variants (Var == -1) lost theirs. + imputed <- data.frame( + chrom = "chr22", + pos = 200, + variant_id = "chr22:200:A:T", + A1 = "A", + A2 = "T", + z = 1.1, + Var = 0.3, + raissLdScore = 12, + raissR2 = 0.7 + ) + known <- data.frame( + chrom = "chr22", + pos = c(100, 300), + variant_id = c("chr22:100:A:T", "chr22:300:A:T"), + A1 = "A", + A2 = "T", + z = c(2, -3), + beta = c(0.2, -0.3), + se = c(0.1, 0.1) + ) + merged <- mergeRaissDf(imputed, known) + expect_equal( + merged$variant_id, + c(known$variant_id[1], imputed$variant_id, known$variant_id[2]) + ) + expect_equal(merged$beta, c(0.2, NA, -0.3)) + expect_equal(merged$se, c(0.1, NA, 0.1)) + expect_equal(merged$Var, c(-1, 0.3, -1)) +}) + generateFroTestData <- function(seed = 1) { set.seed(seed) return(data.frame( @@ -1791,7 +1825,8 @@ test_that("CS with diffuse signal contains many variants", { result <- slalom(zScore = z, R = R) - # Uniform PIPs => need at least ceiling(0.95 * n) = 10 variants for 95% coverage + # Uniform PIPs => need at least ceiling(0.95 * n) = 10 variants for 95% + # coverage expect_equal(length(result$summary$cs95), n) }) @@ -2290,39 +2325,14 @@ context("summaryStatsQc") } .ssQ_mockExtractor <- function(seed = 13, n_samples = 60L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -2345,7 +2355,7 @@ test_that("mafCutoff > 0 with no frequency skips the filter, not the run", { # mocked variant sits near MAF 0.3, so nothing is dropped there. ss <- .ssQ_makeGwasSumStats() local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .package = "pecotmr" ) expect_warning( @@ -2375,7 +2385,8 @@ test_that("summaryStatsQc: PIP screen runs AFTER allele harmonization", { # harmonization drops it. With the screen running *after* harmonization it # never sees the strong off-panel signal, so the remaining weak variants # fail the PIP screen and the region is skipped (empty). (Pre-harmonization - # screening would have kept the region on the strength of the off-panel hit.) + # screening would have kept the region on the strength of the off-panel + # hit.) gr <- .ssQ_makeEntryGr( c("rs1", "rs2", "rs3", "rsX"), positions = c(100L, 200L, 300L, 9999L) @@ -2402,7 +2413,8 @@ test_that("summaryStatsQc: PIP screen runs AFTER allele harmonization", { test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { # Same harmonized variants, screen disabled (no metric set): the three - # panel-matched variants survive (behavior-invariance for the screen-off path). + # panel-matched variants survive (behavior-invariance for the screen-off + # path). gr <- .ssQ_makeEntryGr( c("rs1", "rs2", "rs3", "rsX"), positions = c(100L, 200L, 300L, 9999L) @@ -2436,7 +2448,8 @@ test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { ranges = IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) ) S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = c("chr1:100:G:A", "chr1:200:A:G", "chr1:300:G:A"), # pos200 input-orientation + # pos200 input-orientation + SNP = c("chr1:100:G:A", "chr1:200:A:G", "chr1:300:G:A"), A1 = c("A", "G", "A"), # pos200 swapped relative to panel (A1=A) A2 = c("G", "A", "G"), Z = c(1.0, 2.0, 1.5), @@ -2446,9 +2459,10 @@ test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { } test_that("summaryStatsQc: harmonization re-keys SNP and sign-flips Z", { - # pos200 is allele-swapped vs the panel, so harmonization sign-flips its Z and - # the SNP must be re-keyed to the panel-orientation id (chr1:200:G:A), not - # left at the input-orientation chr1:200:A:G. Exact matches are unchanged. + # pos200 is allele-swapped vs the panel, so harmonization sign-flips its Z + # and the SNP must be re-keyed to the panel-orientation id (chr1:200:G:A), + # not left at the input-orientation chr1:200:A:G. Exact matches are + # unchanged. ss <- GwasSumStats( studyName = "g1", entry = list(.ssQ_makeFlipEntryGr()), @@ -2579,16 +2593,8 @@ test_that("summaryStatsQc: slalom z-mismatch resolves sign-flipped variants", { ldReference = .ssQ_makeHandleVid() ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), - ldMismatchQc = function( - zScore, - R = NULL, - X = NULL, - nSample = NULL, - method = c("slalom", "dentist"), - ldMethod = "sample", - ... - ) { + .handleDosage = .ssQ_mockExtractor(), + .ldMismatchQcOn = function(zScore, ld, nSample, method) { data.frame( original_z = zScore, outlier = rep(FALSE, length(zScore)), @@ -2624,16 +2630,8 @@ test_that("summaryStatsQc: ldMismatchQc reconciles a chr-prefix difference", { ldReference = h ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), - ldMismatchQc = function( - zScore, - R = NULL, - X = NULL, - nSample = NULL, - method = c("slalom", "dentist"), - ldMethod = "sample", - ... - ) { + .handleDosage = .ssQ_mockExtractor(), + .ldMismatchQcOn = function(zScore, ld, nSample, method) { data.frame( original_z = zScore, outlier = rep(FALSE, length(zScore)), @@ -2924,7 +2922,8 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts -> raw total", { }) test_that("summaryStatsQc(effectiveN=TRUE): study scalars fill all variants", { - # Entry has an N column but NO per-variant N_CASE/N_CONTROL; the scalars win. + # Entry has an N column but NO per-variant N_CASE/N_CONTROL; the scalars + # win. gr <- .ssQ_makeEntryGr() ss <- GwasSumStats( studyName = "g1", @@ -2941,7 +2940,8 @@ test_that("summaryStatsQc(effectiveN=TRUE): study scalars fill all variants", { }) test_that("summaryStatsQc: study nSample is the level-4 fallback", { - # Entry with NO per-variant N and NO case/control; only a study nSample scalar. + # Entry with NO per-variant N and NO case/control; only a study nSample + # scalar. gr <- .ssQ_makeEntryGr() mc <- S4Vectors::mcols(gr) mc$N <- NULL # remove per-variant N @@ -2998,7 +2998,8 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { res1 <- summaryStatsQc(ss1) expect_equal(.ssQ_entryNByPos(res1[[1L]]), c(360, 640, 510, 750)) expect_identical(res1$qcAudit[[1L]]$nSource, "effective") - # per-variant N column present alongside nSample (no counts) -> N wins (column). + # per-variant N column present alongside nSample (no counts) -> N wins + # (column). ss2 <- GwasSumStats( studyName = "g1", entry = list(.ssQ_makeEntryGr()), @@ -3041,8 +3042,9 @@ test_that("summaryStatsQc: quantitative QtlSumStats: no effective N", { # =========================================================================== test_that("summaryStatsQc: ldMismatchQcMethod 'dentist' walks the LD branch", { - # Panel ids follow the chr:pos:A2:A1 convention (as real LD sketches do) so the - # post-harmonization re-keyed SNP resolves against the panel for z-mismatch QC. + # Panel ids follow the chr:pos:A2:A1 convention (as real LD sketches do) so + # the post-harmonization re-keyed SNP resolves against the panel for + # z-mismatch QC. ss <- GwasSumStats( studyName = "g1", entry = list(.ssQ_makeEntryGr( @@ -3053,7 +3055,7 @@ test_that("summaryStatsQc: ldMismatchQcMethod 'dentist' walks the LD branch", { ldReference = .ssQ_makeHandleVid(snp_n = 8L) ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .package = "pecotmr" ) res <- suppressWarnings(summaryStatsQc(ss, ldMismatchQcMethod = "dentist")) @@ -3082,17 +3084,17 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .raissGenotypePath = function( refPanel, knownZscores, genotypeMatrix, p ) { - # Pretend RAISS imputed two of the missing panel variants (rs5, rs6) - # with synthetic z-scores. + # Pretend RAISS imputed two of the missing panel variants (pos 500, + # 600: rs5, rs6) with synthetic z-scores. added <- refPanel[ - refPanel$variant_id %in% c("rs5", "rs6"), + refPanel$pos %in% c(500L, 600L), , drop = FALSE ] @@ -3117,9 +3119,9 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { test_that("summaryStatsQc: impute scopes panel/dosage to the region", { # Sketch spans rs1..rs8 (pos 100..800); the entry observes only rs1..rs4 # (100..400). With the default flank the impute window is [100, 400], so the - # dosage must be materialized for just those 4 panel variants -- NOT the whole - # 8-variant sketch (the bug that makes --impute unusable on a per-chromosome - # sketch: it built dosage for seq_len(nrow(sketchSnpInfo))). + # dosage must be materialized for just those 4 panel variants -- NOT the + # whole 8-variant sketch (the bug that makes --impute unusable on a + # per-chromosome sketch: it built dosage for seq_len(nrow(sketchSnpInfo))). # # Observed at extractBlockGenotypes: the single reader every dosage path # funnels through, including the DelayedArray seed behind assay(). The @@ -3138,9 +3140,9 @@ test_that("summaryStatsQc: impute scopes panel/dosage to the region", { ) inner <- .ssQ_mockExtractor(n_samples = 60L) local_mocked_bindings( - extractBlockGenotypes = function(handle, snpIdx, meanImpute = TRUE) { + .handleDosage = function(handle, snpIdx) { cap$idx <- c(cap$idx, list(snpIdx)) - inner(handle, snpIdx, meanImpute) + inner(handle, snpIdx) }, raiss = function(...) NULL, .package = "pecotmr" @@ -3170,7 +3172,7 @@ test_that("summaryStatsQc: impute with a NULL raiss records 0 imputed", { ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), raiss = function(...) NULL, .package = "pecotmr" ) @@ -3186,7 +3188,7 @@ test_that("summaryStatsQc: impute with a NULL raiss records 0 imputed", { test_that("summaryStatsQc: QC track emits per-step messages and a rollup", { ss <- .ssQ_makeGwasSumStats() local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .package = "pecotmr" ) msgs <- capture_messages(summaryStatsQc(ss)) @@ -3205,7 +3207,7 @@ test_that("summaryStatsQc: QC track emits per-step messages and a rollup", { test_that("summaryStatsQc: skipped steps are omitted from the rollup", { ss <- .ssQ_makeGwasSumStats() local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .package = "pecotmr" ) msgs <- capture_messages( @@ -3236,7 +3238,7 @@ test_that("summaryStatsQc: QtlSumStats log lines carry the tuple label", { ldReference = .ssQ_makeHandle() ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .package = "pecotmr" ) msgs <- capture_messages(summaryStatsQc(qss)) @@ -3297,39 +3299,14 @@ context("sumstatsQc internal helpers") } .ssh_mockExtractor <- function(seed = 42, n_samples = 30L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -3371,6 +3348,12 @@ test_that(".dfToEntryGranges: rebuilds the GRanges with canonical mcols", { colnames(S4Vectors::mcols(gr)), c("SNP", "A1", "A2", "Z", "N") ) + # Alleles enter in upper case, as the chromosomes enter in UCSC style. + lower <- pecotmr:::.dfToEntryGranges( + mutate(df, A1 = c("a", "t"), A2 = c("g", "c")) + ) + expect_identical(lower$A1, c("A", "T")) + expect_identical(lower$A2, c("G", "C")) }) test_that(".dfToEntryGranges: derives SNP from variant_id when SNP is absent", { @@ -3407,7 +3390,9 @@ test_that(".refVariantsFromLdRef: extracts chr/pos/alleles from snpInfo", { rv <- pecotmr:::.refVariantsFromLdRef(h) expect_equal(rv$chrom, rep("chr1", 6)) expect_equal(rv$pos, c(100L, 200L, 300L, 400L, 500L, 600L)) - expect_equal(rv$variant_id, paste0("rs", 1:6)) + # Rendered from the panel's position and alleles (A2 the reference), not + # its rsID labels, which name no position a harmonized id could meet. + expect_equal(rv$variant_id, sprintf("chr1:%d:G:A", rv$pos)) expect_equal(rv$A1, rep("A", 6)) expect_equal(rv$A2, rep("G", 6)) }) @@ -3707,7 +3692,7 @@ test_that(".applyLdMismatchQcToEntry: drops variants absent from the sketch", { # leaves the drop to .ldFromRef's onMissing, so the z-mismatch lookup # drops it (recording the count) instead of aborting the run. local_mocked_bindings( - extractBlockGenotypes = .ssh_mockExtractor(), + .handleDosage = .ssh_mockExtractor(), .package = "pecotmr" ) df <- data.frame( @@ -3730,7 +3715,7 @@ test_that(".qcKrigingFlip: drops a panel-unsupported variant, no abort", { # Same contract at the kriging prefilter: the orphan (no sketch entry) is # dropped and counted, and the run continues on the panel-supported subset. local_mocked_bindings( - extractBlockGenotypes = .ssh_mockExtractor(), + .handleDosage = .ssh_mockExtractor(), .package = "pecotmr" ) df <- data.frame( @@ -3754,7 +3739,7 @@ test_that(".qcKrigingFlip: no-orphan entry is unchanged (drop is a no-op)", { # When every variant has a sketch entry, nothing is dropped and the result # matches the pre-change behaviour (panelUnsupportedDropped == 0). local_mocked_bindings( - extractBlockGenotypes = .ssh_mockExtractor(), + .handleDosage = .ssh_mockExtractor(), .package = "pecotmr" ) df <- data.frame( @@ -3778,7 +3763,7 @@ test_that("the kriging and mismatch checks read an entry's panel once", { # Both run on the same panel-supported variants, so the reference is read # once for the two, and the panel's drop is recorded once. local_mocked_bindings( - extractBlockGenotypes = .ssh_mockExtractor(), + .handleDosage = .ssh_mockExtractor(), .package = "pecotmr" ) reads <- 0L @@ -3910,7 +3895,7 @@ test_that("kriging and LD-mismatch QC accept every harmonized variant", { handle <- .ssTwin_makeHandle() opts <- .ssTwin_opts() local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(n_samples = 60L), + .handleDosage = .ssQ_mockExtractor(n_samples = 60L), .package = "pecotmr" ) harm <- suppressMessages( @@ -3927,7 +3912,7 @@ test_that("kriging and LD-mismatch QC accept every harmonized variant", { test_that("the fine-mapping LD build accepts every harmonized variant", { handle <- .ssTwin_makeHandle() local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(n_samples = 60L), + .handleDosage = .ssQ_mockExtractor(n_samples = 60L), .package = "pecotmr" ) harm <- suppressMessages(pecotmr:::.qcHarmonizeEntry( @@ -3959,21 +3944,13 @@ test_that(".applyLdMismatchQcToEntry: NA slalom outlier flags are kept", { N = rep(1000L, length(vids)), stringsAsFactors = FALSE ) - # Also mock extractBlockGenotypes: the entry-side helper extracts - # dosages from the LD sketch before delegating to ldMismatchQc, and the - # fixture handle points at a fake /tmp/sketch.gds path with no real - # GDS file behind it. + # Also mock the dosage reader: the entry-side helper reads dosages from + # the LD sketch before delegating to .ldMismatchQcOn, and the fixture + # handle points at a fake /tmp/sketch.gds path with no real GDS file + # behind it. local_mocked_bindings( - extractBlockGenotypes = .ssh_mockExtractor(), - ldMismatchQc = function( - zScore, - R = NULL, - X = NULL, - nSample = NULL, - method = c("slalom", "dentist"), - ldMethod = "sample", - ... - ) { + .handleDosage = .ssh_mockExtractor(), + .ldMismatchQcOn = function(zScore, ld, nSample, method) { data.frame( original_z = zScore, outlier = c(FALSE, TRUE, NA, NA), @@ -4004,7 +3981,8 @@ test_that(".asScreen canonicalizes screen specs", { expect_equal(pecotmr:::.asScreen(0.9), list(metric = "pip", cutoff = 0.9)) sc <- list(metric = "logBf", cutoff = 3) expect_identical(pecotmr:::.asScreen(sc), sc) - expect_null(pecotmr:::.asScreen(list(metric = "bf", cutoff = 0))) # explicit off + # explicit off + expect_null(pecotmr:::.asScreen(list(metric = "bf", cutoff = 0))) }) test_that(".applyEntryScreen: absZ skips / retains on max|Z|, no fit", { @@ -4299,20 +4277,25 @@ test_that("dentist from genotypes matches DENTIST on their LD per window", { expect_equal(viaX, viaR, tolerance = 1e-8) }) -test_that("the duplicate scan reads a factor as it reads the LD", { +test_that("the duplicate scan reads a factor and a packed LD as the LD", { d <- .dentistFactorData() f <- pecotmr:::.ldFactorFromDosage(d$X) - viaR <- pecotmr:::.findDuplicateVariants(d$z, d$R, 0.995) - viaF <- pecotmr:::.findDuplicateVariantsFactor(d$z, f, 0.995) + viaR <- pecotmr:::.findDuplicateVariants(d$z, list(R = d$R), 0.995) expect_gt(sum(viaR$dupBearer != -1), 0L) - for (k in c("filteredZ", "dupBearer", "corABS", "sign", "minValue")) { - expect_equal(viaF[[k]], viaR[[k]], tolerance = 1e-10) + packed <- list( + P = Matrix::pack(Matrix::forceSymmetric(d$R, uplo = "U")), + sign = rep(1, nrow(d$R)) + ) + for (ld in list(list(ldFactor = f), packed)) { + other <- pecotmr:::.findDuplicateVariants(d$z, ld, 0.995) + for (k in c("filteredZ", "dupBearer", "corABS", "sign", "minValue")) { + expect_equal(other[[k]], viaR[[k]], tolerance = 1e-10) + } + expect_equal( + unname(pecotmr:::.ldSourceMatrix(other$filteredLd)), + unname(viaR$filteredLd$R) + ) } - kept <- viaF$filteredFactor - expect_equal( - unname(crossprod(kept) / (nrow(kept) - 1)), - unname(viaR$filteredLD) - ) }) # =========================================================================== @@ -4339,13 +4322,14 @@ test_that("dentistSingleWindow returns one row per z-score under each option", { "outlier" ) for (nm in names(options)) { + windowOptions <- options[[nm]] expect_warning( res <- exec( dentistSingleWindow, data$z_scores, R = data$ldMat, nSample = data$nSample, - !!!options[[nm]] + !!!windowOptions ), "below 2000", info = nm @@ -4916,8 +4900,8 @@ test_that("mergeVariantInfo (data.frame): all = TRUE returns the union", { out <- mergeVariantInfo(v1, v2, all = TRUE) expect_s3_class(out, "data.frame") expect_setequal(colnames(out), c("chrom", "pos", "alt", "ref")) - # The flipped row2 collapses onto v1's orientation, so only the genuinely new - # variant (chrom 3) is added to the 3 from v1. + # The flipped row2 collapses onto v1's orientation, so only the genuinely + # new variant (chrom 3) is added to the 3 from v1. expect_equal(nrow(out), 4L) flipped <- out[out$chrom == "1" & out$pos == 200, ] expect_equal(flipped$alt, "C") @@ -5306,7 +5290,8 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { N = c(1000L, 1000L, 1000L) ) if (withAf) { - # A post-harmonization (directional) AF -- what the merge must re-attach. + # A post-harmonization (directional) AF -- what the merge must + # re-attach. df$AF <- c(0.10, 0.25, 0.40) } impDf <- data.frame( @@ -5384,7 +5369,8 @@ test_that("raissModel flags an inversion the rcond cutoff truncated", { test_that(".safeSvd stops when all singular values fall below tolerance", { set.seed(1) mat <- matrix(rnorm(20), nrow = 5, ncol = 4) - # tol >= 1 forces even the largest (ratio == 1) singular value below threshold. + # tol >= 1 forces even the largest (ratio == 1) singular value below + # threshold. expect_error( pecotmr:::.safeSvd(mat, tol = 2), "below the tolerance threshold" @@ -5493,7 +5479,8 @@ test_that("summaryStatsQc: emit() drops the label for an empty study id", { test_that("summaryStatsQc: the N filter emits its message and rollup", { gr <- .ssQ_makeEntryGr() - S4Vectors::mcols(gr)$N <- c(1000L, 1010L, 1005L, 100000L) # last is an N outlier + # last is an N outlier + S4Vectors::mcols(gr)$N <- c(1000L, 1010L, 1005L, 100000L) ss <- GwasSumStats( studyName = "g1", entry = list(gr), @@ -5590,7 +5577,7 @@ test_that("summaryStatsQc: kriging QC records its audit and rollup", { ldReference = .ssQ_makeHandleVid(snp_n = 8L) ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .package = "pecotmr" ) msgs <- capture_messages( @@ -5637,7 +5624,7 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { ldReference = .ssQ_makeHandle(snp_n = 8L, n_samples = 60L) ) local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .raissGenotypePath = function( refPanel, knownZscores, @@ -5645,7 +5632,7 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { p ) { added <- refPanel[ - refPanel$variant_id %in% c("rs5", "rs6"), + refPanel$pos %in% c(500L, 600L), , drop = FALSE ] @@ -5657,7 +5644,8 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { }, .package = "pecotmr" ) - # rs5/rs6 (pos 500/600) are beyond the observed range; widen the impute window. + # rs5/rs6 (pos 500/600) are beyond the observed range; widen the impute + # window. res <- summaryStatsQc( ss, impute = TRUE, @@ -5793,7 +5781,7 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { # needs a dosage source; the mock puts every variant near MAF 0.3, well # clear of the 0.01 cutoff, leaving the audited drop counts study-side. local_mocked_bindings( - extractBlockGenotypes = .ssQ_mockExtractor(), + .handleDosage = .ssQ_mockExtractor(), .package = "pecotmr" ) msgs <- capture_messages( @@ -5877,9 +5865,11 @@ test_that("dentistSingleWindow summarizes the cpp11 rsqExceed field", { duprThreshold = 1.0 ) ) - expect_true(any(grepl("rsq values exceeded 1", seen))) # summary from the data + # summary from the data + expect_true(any(grepl("rsq values exceeded 1", seen))) expect_true(any(grepl("Max reported: 1.1", seen))) # max(rsqExceed) - # The post-warning code (renames, outlier stat, z_diff drop) ran successfully. + # The post-warning code (renames, outlier stat, z_diff drop) ran + # successfully. expect_equal(nrow(res), m) expect_equal(res$original_z, z) expect_true(all( @@ -5917,44 +5907,19 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { "installed susieR has no kriging_rss" ) # All eight genotype columns load on one common factor (pairwise rho ~0.7), - # so LD predicts a shared sign. rs4's z has the opposite sign to its strongly - # correlated neighbours -- a genuine allele switch. krigingOutlierQc flags it, - # so the QC step sign-flips its Z in place (the nKr > 0 branch) and RETAINS - # the row. - corrExtractor <- function(handle, snpIdx, meanImpute = TRUE) { + # so LD predicts a shared sign. rs4's z has the opposite sign to its + # strongly correlated neighbours -- a genuine allele switch. + # krigingOutlierQc flags it, so the QC step sign-flips its Z in place (the + # nKr > 0 branch) and RETAINS the row. + corrExtractor <- function(handle, snpIdx) { set.seed(42) n <- length(sampleIds(handle)) k <- length(snpIdx) f <- rnorm(n) # shared latent factor - M <- exec( - cbind, - !!!map(seq_len(k), function(j) { - sqrt(0.7) * f + sqrt(0.3) * rnorm(n) - }) - ) - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - dosage <- t(M) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - ) + factorCols <- map(seq_len(k), function(j) { + sqrt(0.7) * f + sqrt(0.3) * rnorm(n) + }) + exec(cbind, !!!factorCols) } gr <- .ssQ_makeEntryGr( snp_ids = paste0("rs", 1:8), @@ -5973,7 +5938,7 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { ldReference = .ssQ_makeHandleVid(snp_n = 8L, n_samples = 300L) ) local_mocked_bindings( - extractBlockGenotypes = corrExtractor, + .handleDosage = corrExtractor, .package = "pecotmr" ) res <- suppressWarnings( @@ -6042,6 +6007,37 @@ test_that(".subsetLdRefToIds keeps exactly the entries' variants", { ) }) +test_that("QC keeps the variants of an rsID-labelled panel it matched", { + # The panel was keyed by its labels, which a harmonized id never equals, + # so QC kept every variant and emptied the panel. + panel <- readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + )[1:50, ] + rr <- SummarizedExperiment::rowRanges(panel) + set.seed(1) + gr <- GenomicRanges::GRanges( + GenomicRanges::seqnames(rr), + IRanges::IRanges(GenomicRanges::start(rr), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = pecotmr:::.grVariantIds(rr), + A1 = rr$A1, + A2 = rr$A2, + Z = rnorm(50L), + N = 5000L, + MAF = runif(50L, 0.05, 0.5) + ) + gs <- GwasSumStats( + studyName = "G", + entry = list(gr), + ldReference = panel, + genome = "hg19" + ) + qc <- suppressMessages(summaryStatsQc(gs)) + expect_gt(length(unlist(qc)), 0L) + expect_equal(nrow(ldReference(qc)[[1L]]), length(unlist(qc))) +}) + test_that(".subsetLdRefToRange / .subsetLdRefToIds are NULL-safe", { expect_null(pecotmr:::.subsetLdRefToRange(NULL, list())) expect_null(pecotmr:::.subsetLdRefToIds(NULL, list())) @@ -6131,7 +6127,6 @@ test_that(".ssqcPrunePanel prunes the RSE sketch's seed handle, not the view", { # the seed -- the real-flow shape the bare-handle tests do not exercise. h <- .ssqcPanelHandle() maf <- .ssqcPanelMaf(h) - ids <- as.character(snpInfo(h)$SNP) cutoff <- stats::median(maf, na.rm = TRUE) rse <- pecotmr:::.genotypeExperiment(h) expect_s4_class(rse, "RangedSummarizedExperiment") @@ -6140,10 +6135,12 @@ test_that(".ssqcPrunePanel prunes the RSE sketch's seed handle, not the view", { list(mafCutoff = cutoff, macCutoff = 0, imissCutoff = 1), "test" )) + # The seed's handle keeps each variant's file position, which is its row + # in the whole file's handle. seed <- pecotmr:::.ldRefHandle(pruned) expect_setequal( - as.character(snpInfo(seed)$SNP), - ids[!is.na(maf) & maf >= cutoff] + snpInfo(seed)$fileIdx, + which(!is.na(maf) & maf >= cutoff) ) }) @@ -6166,10 +6163,7 @@ test_that("summaryStatsQc: mafCutoff drops panel-rare observed variants", { # ... and the panel carried on the result -- the seed handle every LD # read keys off, not just the row view -- holds no sub-cutoff variant. seed <- pecotmr:::.ldRefHandle(ldReference(out)[[1L]]) - keptMaf <- maf[match( - as.character(snpInfo(seed)$SNP), - as.character(snpInfo(h)$SNP) - )] + keptMaf <- maf[snpInfo(seed)$fileIdx] expect_true(all(keptMaf >= cutoff)) }) @@ -6255,7 +6249,8 @@ test_that("summaryStatsQc validates the panel cutoffs before any panel read", { set.seed(1) nS <- 100L af <- c(runif(20L, 0.2, 0.4), runif(20L, 0.002, 0.01)) - dosage <- exec(cbind, !!!map(af, function(f) rbinom(nS, 2L, f))) + dosageCols <- map(af, function(f) rbinom(nS, 2L, f)) + dosage <- exec(cbind, !!!dosageCols) ids <- sprintf("chr1:%d:A:G", 1000L * seq_along(af)) colnames(dosage) <- ids dosage[1:60, 3] <- NA @@ -7328,3 +7323,63 @@ test_that(".entryToSumstatDf: require = c('Z', 'N') errors when missing", { "no N mcol" ) }) + +test_that("mismatch QC reads a packed LD as it reads the matrix", { + d <- .dentistFactorData() + packed <- list( + P = Matrix::pack(Matrix::forceSymmetric(d$R, uplo = "U")), + sign = rep(1, nrow(d$R)) + ) + lead <- 3L + expect_identical( + pecotmr:::.slalomLeadColumn(list(R = d$R), lead), + d$R[, lead] + ) + expect_equal( + pecotmr:::.slalomLeadColumn(packed, lead), + unname(d$R[, lead]) + ) + viaF <- pecotmr:::.slalomLeadColumn( + list(ldFactor = pecotmr:::.ldFactorFromDosage(d$X)), + lead + ) + expect_identical(viaF[[lead]], 1) + expect_equal(unname(viaF), unname(d$R[, lead]), tolerance = 1e-10) + for (method in list("slalom", SlalomParam(r2Threshold = 0.3))) { + expect_equal( + pecotmr:::.ldMismatchQcOn(d$z, packed, NULL, method), + ldMismatchQc(zScore = d$z, R = d$R, method = method) + ) + } + dentist <- DentistParam(nIter = 2) + expect_equal( + suppressWarnings(pecotmr:::.ldMismatchQcOn(d$z, packed, d$n, dentist)), + suppressWarnings(ldMismatchQc( + zScore = d$z, + R = d$R, + nSample = d$n, + method = dentist + )) + ) +}) + +test_that("the QC panel keeps an LdMatrix's LD packed", { + data(eqtlRegionExample, envir = environment()) + X <- eqtlRegionExample$X[, 1:8] + ldm <- LdMatrix(cor(X), nSamples = 100) + ids <- colnames(X) + df <- data.frame( + SNP = c(ids[[2L]], "chr22:1:A:G", ids[[5L]]), + Z = c(1, 2, 3) + ) + panel <- pecotmr:::.qcPanelSupportedLd(df, ldm, "test") + expect_equal(panel$dropped, 1L) + expect_s4_class(panel$ld$P, "dspMatrix") + expect_equal(nrow(panel$ld$P), 2L) + expect_null(panel$ld$R) + # Kriging, which takes nothing but the matrix, gets it whole. + expect_equal( + pecotmr:::.qcPanelLdMatrix(panel), + unname(pecotmr:::.ldFromRef(ldm, ids[c(2L, 5L)], "test")) + ) +}) diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 55b5b51cf..fd9b42e49 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -14,10 +14,8 @@ setClass("TsTestCollection", contains = "RangedTupleList") rep(list(GenomicRanges::GRanges()), n) ) if (length(cols) > 0L) { - S4Vectors::mcols(grl) <- exec( - S4Vectors::DataFrame, - !!!c(cols, list(check.names = FALSE)) - ) + dataFrameArgs <- c(cols, list(check.names = FALSE)) + S4Vectors::mcols(grl) <- exec(S4Vectors::DataFrame, !!!dataFrameArgs) } methods::new("TsTestCollection", grl) } @@ -31,7 +29,7 @@ test_that(".matchTupleRows: empty keys returns every row index", { expect_equal(pecotmr:::.matchTupleRows(df, list()), c(1L, 2L)) }) -test_that(".matchTupleRows: AND-matches across multiple (column, value) pairs", { +test_that(".matchTupleRows AND-matches several (column, value) pairs", { df <- .ts_coll( study = c("s1", "s1", "s2"), context = c("c1", "c2", "c1"), @@ -73,7 +71,7 @@ test_that(".tupleSelectRow: zero-row input errors with the class label", { ) }) -test_that(".tupleSelectRow: single-row collection returns 1L without selectors", { +test_that(".tupleSelectRow returns 1L for a one-row collection", { one <- .ts_coll( study = "s1", context = "c1", @@ -84,7 +82,7 @@ test_that(".tupleSelectRow: single-row collection returns 1L without selectors", expect_equal(pecotmr:::.tupleSelectRow(one), 1L) }) -test_that(".tupleSelectRow: multi-row + missing selectors errors with row count", { +test_that(".tupleSelectRow: several rows, no selectors: errors with count", { multi <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), @@ -138,7 +136,7 @@ test_that(".tupleSelectRow: matching tuple returns first row index", { ) }) -test_that(".tupleSelectRow: missing tuple errors with the 4-tuple in the message", { +test_that(".tupleSelectRow names the missing 4-tuple in its error", { multi <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), @@ -343,7 +341,7 @@ test_that(".fmrRowsMatching: a vector selector matches any listed value", { # .fmrRowMetadata (stable 8-column identity frame) # =========================================================================== -test_that(".fmrRowMetadata: emits all eight identity columns, NA-filling absent ones", { +test_that(".fmrRowMetadata gives all eight identity columns, NA if absent", { qtl <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), @@ -424,7 +422,7 @@ test_that(".rbindAligned: identical columns rbind and preserve type", { expect_equal(out$b, c("x", "y")) }) -test_that(".rbindAligned: differing columns align on the union, NA-filling gaps", { +test_that(".rbindAligned aligns differing columns on the union, NA in gaps", { p1 <- data.frame(a = 1L, b = "x", stringsAsFactors = FALSE) p2 <- data.frame(a = 2L, c = "z", stringsAsFactors = FALSE) out <- pecotmr:::.rbindAligned(list(p1, p2)) @@ -437,7 +435,7 @@ test_that(".rbindAligned: differing columns align on the union, NA-filling gaps" # =========================================================================== # Coverage: region-column + rbind helpers # =========================================================================== -test_that(".naLikeColumn: a non-character/non-GRanges exemplar pads with logical NA", { +test_that(".naLikeColumn pads any other exemplar with logical NA", { expect_identical(pecotmr:::.naLikeColumn(TRUE, 3L), rep(NA, 3L)) }) @@ -483,7 +481,7 @@ test_that(".appendTraitPosCol: traitPos must be a GRanges of matching length", { ) }) -test_that(".validateTraitPosColumn: reports non-GRanges and wrong-length traitPos", { +test_that(".validateTraitPosColumn: non-GRanges, wrong-length traitPos", { expect_equal( pecotmr:::.validateTraitPosColumn(.ts_coll(traitPos = c("x", "y"))), str_c( @@ -564,6 +562,37 @@ test_that("chromosome paths union when they agree and abort when they clash", { }) +test_that(".singleWeightColumn takes a one-column matrix as its column", { + expect_identical(pecotmr:::.singleWeightColumn(c(1, 2)), c(1, 2)) + one <- matrix(c(1, 2), ncol = 1L, dimnames = list(NULL, "susie")) + expect_identical(pecotmr:::.singleWeightColumn(one), c(1, 2)) + expect_null(pecotmr:::.singleWeightColumn(cbind(c(1, 2), c(3, 4)))) +}) + +test_that("a collection saved without a key column or a fits slot reads", { + data(qtlSumStatsExample, qtlFineMappingExample) + noKeys <- qtlSumStatsExample + md <- attr(noKeys, "elementMetadata") + md$ldReference <- NULL + attr(noKeys, "elementMetadata") <- md + expect_identical( + pecotmr:::.ldRefKeys(noKeys), + rep(NA_character_, length(noKeys)) + ) + noFits <- qtlFineMappingExample + attr(noFits, "fits") <- NULL + expect_identical(pecotmr:::.fitDict(noFits), list()) +}) + +test_that("bare handles, as LD references were saved, union as panels", { + skip_if_not_installed("pgenlibr") + stem <- test_path("test_data", "test_variants") + h <- readGenotypeHandle(stem, format = "plink2") + out <- pecotmr:::.unionPanelRefs(list(h, h), "combineX") + expect_s4_class(out, "RangedSummarizedExperiment") + expect_identical(dim(out), c(nrow(snpInfo(h)), length(sampleIds(h)))) +}) + test_that("panels read through no handle union their rows", { # A PLINK1, VCF or GDS panel has no handle whose snpInfo could be # widened, so the parts' assays are bound: each variant once, in genomic @@ -578,8 +607,9 @@ test_that("panels read through no handle union their rows", { pecotmr:::.ldRefDict(list(a, b)), "combineX" ) + expect_identical(names(merged), c("entries", "keys")) expect_identical(merged$keys, c("ld1", "ld1")) - out <- merged$refs$ld1 + out <- merged$entries$ld1 expect_identical(rownames(out), rownames(panel)[1:8]) expect_equal( as.matrix(SummarizedExperiment::assay(out, "dosage")), @@ -590,12 +620,12 @@ test_that("panels read through no handle union their rows", { pecotmr:::.ldRefSource(panel)$path ) # The same panel twice is that panel. - expect_identical(pecotmr:::.ssUnionPanels(list(a, a), character(0)), a) + expect_identical(pecotmr:::.unionPanelRefs(list(a, a), "combineX"), a) apart <- pecotmr:::.ldRefMergeViews( pecotmr:::.ldRefDict(list(a, readGenotypes(plink2Prefix = stem))), "combineX" ) - expect_length(apart$refs, 2L) + expect_length(apart$entries, 2L) }) @@ -621,9 +651,13 @@ test_that("an empty collection coerces to itself, not to a row", { pecotmr:::.asFmRowPayload(qtlFineMappingExample), "FineMappingRow" ) - expect_s4_class( + # A TWAS collection holding a single (gene, method) does too; one with + # more methods names none to read. + lasso <- pecotmr:::.twasKeepMethods(twasWeightsExample, "lasso") + expect_s4_class(pecotmr:::.asTwRowPayload(lasso), "TwasWeightsRow") + expect_error( pecotmr:::.asTwRowPayload(twasWeightsExample), - "TwasWeightsRow" + "holds 11 methods; name the one to read" ) # Anything that is not a collection passes straight through. expect_equal(pecotmr:::.asFmRowPayload(42), 42) @@ -792,7 +826,7 @@ test_that("LdMatrix views are stored as the one covering them, in any order", { pecotmr:::.ldRefDict(list(ld[1:2], ld[2:3])), "combine" ) - expect_length(apart$refs, 2L) + expect_length(apart$entries, 2L) # With the matrix covering both among them, both are stored as it, # wherever it comes. orders <- list( @@ -805,7 +839,7 @@ test_that("LdMatrix views are stored as the one covering them, in any order", { pecotmr:::.ldRefDict(parts), "combine" ) - expect_identical(merged$refs, list(ld1 = ld)) + expect_identical(merged$entries, list(ld1 = ld)) expect_identical(merged$keys, rep("ld1", 3L)) } }) @@ -819,7 +853,7 @@ test_that("binding stores an LdMatrix another part's covers as that one", { pecotmr:::.ldRefDict(list(wide, narrow, wide)), "probe" ) - expect_identical(merged$refs, list(ld1 = wide)) + expect_identical(merged$entries, list(ld1 = wide)) expect_identical(merged$keys, c("ld1", "ld1", "ld1")) # Matrices that do not nest are different references, and stay apart. other <- LdMatrix( @@ -829,14 +863,14 @@ test_that("binding stores an LdMatrix another part's covers as that one", { pecotmr:::.ldRefDict(list(wide, other)), "probe" ) - expect_length(apart$refs, 2L) + expect_length(apart$entries, 2L) # A panel and a matrix are never views of one source. panel <- readGenotypes(test_path("test_data", "test_variants.bed")) kinds <- pecotmr:::.ldRefMergeViews( pecotmr:::.ldRefDict(list(wide, panel)), "probe" ) - expect_length(kinds$refs, 2L) + expect_length(kinds$entries, 2L) }) test_that("binding stores a mixture another part's covers as that one", { @@ -848,7 +882,7 @@ test_that("binding stores a mixture another part's covers as that one", { pecotmr:::.ldRefDict(list(mix[1:200], mix, mix[100:349])), "probe" ) - expect_identical(merged$refs, list(ld1 = mix)) + expect_identical(merged$entries, list(ld1 = mix)) expect_identical(merged$keys, c("ld1", "ld1", "ld1")) # The same panels weighted differently are another mixture. reweighted <- GenotypeMixture(halves, mixtureWeights = c(0.4, 0.6)) @@ -856,7 +890,7 @@ test_that("binding stores a mixture another part's covers as that one", { pecotmr:::.ldRefDict(list(mix, reweighted[1:200])), "probe" ) - expect_length(apart$refs, 2L) + expect_length(apart$entries, 2L) }) # =========================================================================== @@ -1166,18 +1200,6 @@ test_that(".fitColumnOf finds each held variant's column in the fit", { expect_equal(f(c("chr1:200:T:C", "chr1:900:A:G"), .ts_fitted), c(2L, NA)) }) -test_that(".mdFitVariants reads a group's first row, nothing for old rows", { - md <- S4Vectors::DataFrame( - fitVariants = IRanges::CharacterList(list(c("a", "b"), c("a", "b"))) - ) - # Rows split from one entry repeat its fit and its variants alike. - expect_equal(pecotmr:::.mdFitVariants(md, c(1L, 2L)), c("a", "b")) - expect_equal( - pecotmr:::.mdFitVariants(S4Vectors::DataFrame(x = 1:2), 1L), - character(0) - ) -}) - test_that(".partsFitIds: the row's own ids, else the fit's names", { # A row holding all of its fit is its fit's variables, read by position. full <- .ts_fitRow() @@ -1227,13 +1249,20 @@ test_that(".fitWidth counts the fit's variables, never the null column", { test_that("a TWAS row records fit variants only when it carries a fit", { w <- c(0.1, 0.2, 0.3) - withCv <- TwasWeightsRow(.ts_fitted, w, cvResult = list(r2 = 0.5)) - expect_equal(pecotmr:::.twRowFitVariants(withCv), .ts_fitted) - # Weights alone are no fit payload. + # A weights row reads them off its fit. + withFit <- TwasWeightsRow( + .ts_fitted, + w, + methodFits = list(variantIds = .ts_fitted) + ) + expect_equal(pecotmr:::.twRowFitVariants(withFit), .ts_fitted) + # Weights alone, or with only their cross-validation, are no fit. expect_equal( pecotmr:::.twRowFitVariants(TwasWeightsRow(.ts_fitted, w)), character(0) ) + withCv <- TwasWeightsRow(.ts_fitted, w, cvResult = list(r2 = 0.5)) + expect_equal(pecotmr:::.twRowFitVariants(withCv), character(0)) }) test_that(".fitCoverageChecked warns about a narrowed row and returns it", { @@ -1270,7 +1299,7 @@ test_that(".fitCoverageCheckedRows is silent without a fit or rows", { x <- .ts_narrowedCollection(1L) expect_no_warning(pecotmr:::.fitCoverageCheckedRows(x[0], "f()")) fitless <- x - fitless$susieFit <- S4Vectors::SimpleList(list(NULL)) + fitless$susieFit <- NA_character_ expect_no_warning(pecotmr:::.fitCoverageCheckedRows(fitless, "f()")) # An optional input left out is nothing to check. expect_no_warning(pecotmr:::.fitCoverageCheckedRows(NULL, "f()")) @@ -1284,7 +1313,12 @@ test_that(".fitCoverageCheckedRows is silent without a fit or rows", { trait = "g1", method = "lasso", entry = list( - TwasWeightsRow(.ts_fitted, c(0.1, 0.2, 0.3), cvResult = list()) + TwasWeightsRow( + .ts_fitted, + c(0.1, 0.2, 0.3), + methodFits = list(variantIds = .ts_fitted), + cvResult = list() + ) ) ) endoapply(tw, `[`, keep) @@ -1295,9 +1329,10 @@ test_that(".narrowedRowLabels labels the narrowed rows and no others", { expect_length(labels, 2L) expect_match(labels, "^s[12]\\|c1\\|g1\\|susie") expect_identical(pecotmr:::.narrowedRowLabels(.ts_weights()), character(0)) + # A TWAS collection's cells are labelled (study, context, trait, method). expect_identical( pecotmr:::.narrowedRowLabels(.ts_weights(1:2)), - pecotmr:::.pubRowLabels(.ts_weights(1:2), 1L) + "w1|c1|g1|lasso" ) }) @@ -1673,3 +1708,59 @@ test_that(".ssCombineGenome is NA when no part records a build", { NA_character_ ) }) + +test_that("a row dictionary keeps each shared value once and keys every row", { + # The facility the LD references use, for any value rows share: equal + # values -- the same object or an equal copy -- are one entry. + a <- list(w = 1:3) + b <- list(w = 4:6) + d <- pecotmr:::.dictBuild(list(a, NULL, b, a, list(w = 1:3)), "fit") + expect_identical(d$entries, list(fit1 = a, fit2 = b)) + expect_identical(d$keys, c("fit1", NA, "fit2", "fit1", "fit1")) + expect_identical(pecotmr:::.dictBuild(list(NULL), "fit")$entries, list()) + # What a subset reports: only the entries its rows name. + expect_identical( + pecotmr:::.dictUsed(d$entries, c("fit2", NA)), + list(fit2 = b) + ) + expect_identical(pecotmr:::.dictUsed(d$entries, NA_character_), list()) + expect_null(pecotmr:::.dictEntryFor(NA_character_, d$entries)) + expect_identical(pecotmr:::.dictEntryFor("fit2", d$entries), b) + # Validity: every key resolves, and entries are uniquely named. + expect_null(pecotmr:::.dictProblems(d$entries, d$keys, "fits", "fit(s)")) + expect_match( + pecotmr:::.dictProblems(d$entries, "fit9", "fits", "fit(s)"), + "rows name fit\\(s\\) not in fits: fit9" + ) + expect_match( + pecotmr:::.dictProblems(unname(d$entries), d$keys, "fits", "fit(s)"), + "fits entries must have unique, non-empty names" + ) +}) + +test_that(".twrRowResolveWeights aligns weights to the variant ids", { + ids <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") + wr <- .twrRowResolveWeights(TwasWeightsRow(ids, c(0.1, -0.2, 0.05))) + expect_equal(wr$variantIds, ids) + expect_equal(wr$weights, c(0.1, -0.2, 0.05)) + # A weight matrix keeps its columns, one row per variant; it used to + # flatten to a length no variant set has, and so resolve to nothing. + w <- matrix(c(0.1, 0, 0.3, 0.4, 0.5, 0.6), 3L, 2L) + colnames(w) <- c("f1", "f2") + wr <- .twrRowResolveWeights(TwasWeightsRow(ids, w)) + expect_equal(wr$variantIds, ids) + expect_equal(wr$weights, w) + # A weight vector that does not match the variants (defensive) -> empty. + bad <- TwasWeightsRow(ids[1:2], c(0.1, -0.2)) + bad@weights <- c(0.1, -0.2, 0.3) + expect_length(.twrRowResolveWeights(bad)$variantIds, 0L) + # So does a weight matrix whose rows do not match them, which weights() + # hands back as it is. + badMatrix <- TwasWeightsRow(ids[1:2], matrix(c(0.1, -0.2), 2L, 1L)) + badMatrix@weights <- matrix(c(0.1, -0.2, 0.3), 3L, 1L) + expect_length(.twrRowResolveWeights(badMatrix)$variantIds, 0L) + expect_identical(weights(badMatrix), badMatrix@weights) + # A weight matrix of missing values resolves to nothing. + allNa <- TwasWeightsRow(ids, matrix(NA_real_, 3L, 2L)) + expect_length(.twrRowResolveWeights(allNa)$variantIds, 0L) +}) diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index 0c11cbd61..6762535af 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -72,22 +72,21 @@ mockSusie <- function(...) { # learnTwasWeights matrix); promote those back to a 1-column matrix here # so test assertions on nrow/ncol/rownames keep working. .weightsByMethod <- function(tw, method) { - shortName <- sub("_?[Ww]eights$", "", method) - idx <- which(as.character(tw$method) == shortName) + shortName <- pecotmr:::.twasMethodToken(sub("_?[Ww]eights$", "", method)) + cells <- pecotmr:::.twasCells(tw) + idx <- which(cells$method == shortName) if (length(idx) == 0L) { return(NULL) } - # The entry is a derived view now: ask the collection for it rather than - # reaching into a stored `entry` column that no longer exists. - entry <- twasWeights( - tw, - studyName = as.character(tw$study)[[idx[[1L]]]], - context = as.character(tw$context)[[idx[[1L]]]], - trait = as.character(tw$trait)[[idx[[1L]]]], + # One (gene, method) cell, read through the collection's accessors. + sel <- list( + studyName = cells$study[[idx[[1L]]]], + context = cells$context[[idx[[1L]]]], + trait = cells$trait[[idx[[1L]]]], method = shortName ) - w <- weights(entry) - vids <- variantIds(entry) + w <- exec(weights, tw, !!!sel) + vids <- exec(variantIds, tw, !!!sel) if (is.numeric(w) && is.null(dim(w))) { nm <- names(w) if (is.null(nm) && length(vids) == length(w)) { @@ -240,7 +239,7 @@ test_that("twasPredict: names without _weights suffix are kept unchanged", { expect_equal(names(res), "custom_method") }) -test_that("twasPredict: multi-column weights produce multi-column predictions", { +test_that("twasPredict: multi-column weights give multi-column predictions", { set.seed(42) n <- 15 p <- 5 @@ -451,7 +450,7 @@ test_that("twasWeightsCv: character weightMethods are accepted", { # CV with real lassoWeights (integration test) # --------------------------------------------------------------------------- -test_that("twasWeightsCv: basic CV with lassoWeights produces correct metrics structure", { +test_that("twasWeightsCv with lassoWeights gives the metrics' structure", { skip_if_not_installed("glmnet") d <- makeData(n = 50, p = 10) @@ -601,11 +600,13 @@ test_that("learnTwasWeights runs susie + susieInf from supplied fits", { ) ) ) - expect_equal(methodNames(result), c("susie", "susie_inf")) + # One spelling per method: learnTwasWeights' snake_case label becomes + # the camelCase token. + expect_equal(methodNames(result), c("susie", "susieInf")) }) -test_that("twasWeightsCv: NA values in Y trigger NA-removal branch in metrics", { +test_that("twasWeightsCv: NA in Y drops those samples from the metrics", { set.seed(42) n <- 30 p <- 5 @@ -617,7 +618,8 @@ test_that("twasWeightsCv: NA values in Y trigger NA-removal branch in metrics", colnames(Y) <- "outcome" Y[c(3, 11, 17), 1] <- NA # introduce NAs - # Mock to return non-zero (so prediction has nonzero variance and lm_fit runs) + # Mock to return non-zero (so prediction has nonzero variance and lm_fit + # runs) local_mocked_bindings( lassoWeights = function(X, y, ...) { w <- rep(0, ncol(X)) @@ -671,7 +673,8 @@ test_that("twasWeightsCv: dataDrivenPriorMatricesCv is plumbed through", { ) # mrmashWeights mock should have been called and received the per-fold prior # matrix under the camelCase name that actually binds mrmashWrapper's - # `dataDrivenPriorMatrices` argument (the snake_case form was a latent no-op). + # `dataDrivenPriorMatrices` argument (the snake_case form was a latent + # no-op). expect_true(length(captured_args) >= 1) expect_true(any(map_lgl( captured_args, @@ -829,7 +832,7 @@ test_that("twasPredict with single variant", { # === Tests migrated from test_s4Constructors.R (TwasWeights) === -test_that("TwasWeights: builds a collection keyed by 4-tuple", { +test_that("TwasWeights: builds one row per gene, its methods an axis", { e1 <- .sc_makeTwasWeightsRow() e2 <- .sc_makeTwasWeightsRow() tw <- TwasWeights( @@ -840,7 +843,8 @@ test_that("TwasWeights: builds a collection keyed by 4-tuple", { entry = list(e1, e2) ) expect_s4_class(tw, "TwasWeights") - expect_equal(nrow(tw), 2L) + # One row per gene, its methods an axis. + expect_equal(nrow(tw), 1L) expect_setequal(methodNames(tw), c("lasso", "enet")) }) @@ -861,7 +865,7 @@ test_that("TwasWeights: studyName / contexts / traitNames / methodNames", { }) -test_that("TwasWeights: rejects duplicate 4-tuples", { +test_that("TwasWeights: rejects two weights for one gene's method", { e <- .sc_makeTwasWeightsRow() expect_error( TwasWeights( @@ -871,7 +875,24 @@ test_that("TwasWeights: rejects duplicate 4-tuples", { method = c("lasso", "lasso"), entry = list(e, e) ), - "uniqueness violated" + "more than one set of weights for one method" + ) +}) + +test_that("TwasWeights: rejects a gene whose methods span chromosomes", { + # A gene's row is one element; its methods are one cis fit. + expect_error( + TwasWeights( + studyName = c("s1", "s1"), + context = c("c1", "c1"), + trait = c("t1", "t1"), + method = c("lasso", "enet"), + entry = list( + TwasWeightsRow("chr1:100:A:G", 0.1), + TwasWeightsRow("chr2:100:A:G", 0.2) + ) + ), + "more than one chromosome" ) }) @@ -924,7 +945,7 @@ test_that("TwasWeights: twasWeights extracts the entry for a tuple", { ) expect_s4_class(picked, "TwasWeights") expect_equal(nrow(picked), 1L) - expect_equal(as.character(picked$method), "enet") + expect_equal(methodNames(picked), "enet") expect_identical(variantIds(picked), .twrPartsVariantIds(e2)) expect_equal(unname(weights(picked)), unname(weights(e2))) }) @@ -982,7 +1003,8 @@ test_that("show.TwasWeights prints entry/study/context/trait/method counts", { entry = list(e, e) ) out <- capture.output(show(tw)) - expect_true(any(grepl("TwasWeights: 2 entries", out))) + # Two contexts are two genes, each with one method's weights. + expect_true(any(grepl("TwasWeights: 2 genes, 2 entries", out))) expect_true(any(grepl("1 studies.*2 contexts.*1 traits.*2 methods", out))) }) @@ -1007,7 +1029,7 @@ test_that("show.TwasWeights reports ldReference when present", { # # =========================================================================== -test_that(".normalizeCvFolds: list cvFolds + samplePartition are mutually exclusive", { +test_that(".normalizeCvFolds: a cvFolds list excludes samplePartition", { expect_error( pecotmr:::.normalizeCvFolds( cvFolds = list(c("s1", "s2"), c("s3", "s4")), @@ -1017,7 +1039,7 @@ test_that(".normalizeCvFolds: list cvFolds + samplePartition are mutually exclus ) }) -test_that(".normalizeCvFolds: samplePartition must have Sample and Fold columns", { +test_that(".normalizeCvFolds: samplePartition needs Sample and Fold", { expect_error( pecotmr:::.normalizeCvFolds(samplePartition = data.frame(a = 1, b = 2)), "must have columns" @@ -1123,7 +1145,7 @@ test_that(".normalizeCvFolds: character fold-id vectors are used as-is", { expect_equal(nrow(res$samplePartition), 4L) }) -test_that(".normalizeCvFolds: integer cvFolds returns NULL partition + nFolds = k", { +test_that(".normalizeCvFolds: integer cvFolds gives no partition, nFolds k", { res <- pecotmr:::.normalizeCvFolds(cvFolds = 5) expect_null(res$samplePartition) expect_equal(res$nFolds, 5L) @@ -1171,7 +1193,7 @@ test_that("TwasWeights: joint* column length must match study", { ) }) -test_that("TwasWeights: weightStandardized/weightsDataType/variantIds delegate to the entry", { +test_that("TwasWeights row accessors delegate to the entry", { e1 <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rnorm(4), @@ -1257,7 +1279,7 @@ test_that("TwasWeights: per-tuple weights/cvResult/methodFits/ldReference", { trait = "t1", method = "lasso" ), - w1 + set_names(w1, sprintf("chr1:%d:A:G", 100L * (1:4))) ) expect_equal( cvResult( @@ -1318,7 +1340,7 @@ test_that("TwasWeights: validity does not recurse on key subset (#546)", { # # =========================================================================== -test_that(".resolveMethodFunction: unresolvable key falls back to the key itself", { +test_that(".resolveMethodFunction returns an unresolvable key as it is", { expect_equal( pecotmr:::.resolveMethodFunction("no_such_fn_xyz"), "no_such_fn_xyz" @@ -1331,16 +1353,21 @@ test_that(".resolveMethodFunction: unresolvable key falls back to the key itself # # =========================================================================== -test_that(".prepareSusieWeightMethods writes supplied fits onto the method args", { +test_that(".prepareSusieWeightMethods puts supplied fits in the method args", { infFit <- makeFakeSusieFit(p = 8, maxNumSingleEffects = 3, inf = TRUE) susieFit <- makeFakeSusieFit(p = 8, maxNumSingleEffects = 5) wm <- pecotmr:::.prepareSusieWeightMethods( weightMethods = list( susie_weights = list(), - susie_inf_weights = list() + susie_inf_weights = list(), + mvsusie_weights = list() ), - fittedModels = list(susie = susieFit, susieInf = infFit) + fittedModels = list( + susie = susieFit, + susieInf = infFit, + mvsusie = list(coef = matrix(0, 8L, 2L)) + ) ) # Each supplied fit is class-tagged and lands on its own method's args. @@ -1349,6 +1376,9 @@ test_that(".prepareSusieWeightMethods writes supplied fits onto the method args" expect_true("susieInf" %in% class(wm$susie_inf_weights$susieInfFit)) expect_true("susie" %in% class(wm$susie_weights$susieFit)) expect_null(wm$susie_weights$model_init) + # Every token with an adapter is resolved, not susie / susieInf alone: + # the gate accepted an mvsusie fit in fittedModels that never arrived. + expect_true("mvsusie" %in% class(wm$mvsusie_weights$mvsusieFit)) }) # =========================================================================== @@ -1371,53 +1401,38 @@ test_that("twasWeightsCv: warns when no random seed has been set", { ) }) -test_that("twasWeightsCv: mvsusie per-fold reweighted prior is plumbed (verbose=2)", { +test_that("twasWeightsCv scores a fine-mapping method with its fold weights", { + # A SuSiE-family method never fine-maps, so each fold is scored with the + # weights its own fine-mapping fit gave rather than by refitting. set.seed(42) n <- 24 p <- 4 X <- matrix(rnorm(n * p), nrow = n) colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) rownames(X) <- paste0("s", seq_len(n)) - Y <- matrix(rnorm(n * 2), nrow = n) - colnames(Y) <- c("y1", "y2") - rownames(Y) <- rownames(X) - - captured <- list() - local_mocked_bindings( - mvsusieWeights = function(X, Y, ...) { - captured[[length(captured) + 1]] <<- list(...) - matrix( - 0, - nrow = ncol(X), - ncol = ncol(Y), - dimnames = list(colnames(X), colnames(Y)) - ) - } - ) - prior_cv <- list(matrix(1, 2, 2), matrix(2, 2, 2)) - set.seed(1) - # A SuSiE-family token needs that fold's own fit; the fitter is mocked - # here, so a stub per fold is enough to reach the per-fold prior path. + Y <- matrix(rnorm(n), nrow = n, dimnames = list(rownames(X), "y1")) sp <- suppressMessages(twasWeightsCv(X, Y, fold = 2))$samplePartition - foldFits <- list(fold_1 = "FIT1", fold_2 = "FIT2") - attr(foldFits, "partitionKey") <- pecotmr:::.cvPartitionKey(sp) - result <- suppressMessages(twasWeightsCv( + fw <- matrix( + c(1, 0, 0, 0, 0, 1, 0, 0), + p, + 2L, + dimnames = list(colnames(X), c("fold_1", "fold_2")) + ) + attr(fw, "partitionKey") <- pecotmr:::.cvPartitionKey(sp) + local_mocked_bindings(susieWeights = function(...) abort("refit")) + out <- suppressMessages(twasWeightsCv( X, Y, samplePartitions = sp, - weightMethods = list(mvsusieWeights = list()), - reweightedMixturePriorCv = prior_cv, - fittedModelsCv = list(mvsusie = foldFits), - verbose = 2 + weightMethods = list(susie_weights = list()), + foldWeights = list(susie = fw), + verbose = 0 )) - expect_true("prediction" %in% names(result)) - # the per-fold prior_variance was forwarded to the multivariate fitter - expect_true(any(map_lgl( - captured, - function(a) { - "prior_variance" %in% names(a) - } - ))) + pred <- out$prediction[["susie_predicted"]] + held1 <- sp$Sample[sp$Fold == 1L] + held2 <- sp$Sample[sp$Fold == 2L] + expect_equal(unname(pred[held1, 1L]), unname(X[held1, 1L])) + expect_equal(unname(pred[held2, 1L]), unname(X[held2, 2L])) }) test_that("twasWeightsCv forwards fitRetention to a fitter that takes it", { @@ -1459,7 +1474,7 @@ test_that("twasWeightsCv forwards fitRetention to a fitter that takes it", { ))) }) -test_that("twasWeightsCv: univariate fitter runs under verbose=2 (no quiet wrapper)", { +test_that("twasWeightsCv runs a univariate fitter unquieted at verbose = 2", { d <- makeData(n = 30, p = 6) local_mocked_bindings( lassoWeights = function(X, y, ...) { @@ -1520,25 +1535,30 @@ test_that("learnTwasWeights: multivariate fitter, fitRetention + verbose=2", { expect_equal(captured[[1]]$fitRetention, "slim") }) -test_that("a method that takes no fitRetention is left alone", { - # Retention is passed only to a weight function that declares it; one - # that does not keeps nothing, and must not be handed the argument. +test_that("a run keeping fits hands its retention to every method", { + # Every weight method takes fitRetention, so a run that keeps fits passes + # its level on; one that keeps none leaves the method's own default. d <- makeData(n = 30, p = 6) - seen <- NULL - local_mocked_bindings( - bayesRWeights = function(X, y, ...) { - seen <<- names(list(...)) - rep(0, ncol(X)) - } - ) - result <- suppressMessages(learnTwasWeights( - d$X, - d$Y, - weightMethods = list(bayesRWeights = list()), - fitRetention = "slim" - )) - expect_true(is(result, "TwasWeights")) - expect_false("fitRetention" %in% seen) + run <- function(keep) { + seen <- NULL + local_mocked_bindings( + bayesRWeights = function(X, y, ...) { + seen <<- list(...)$fitRetention %||% "unset" + rep(0, ncol(X)) + }, + .env = environment() + ) + result <- suppressMessages(learnTwasWeights( + d$X, + d$Y, + weightMethods = list(bayesRWeights = list()), + fitRetention = keep + )) + expect_true(is(result, "TwasWeights")) + seen + } + expect_equal(run("slim"), "slim") + expect_equal(run("none"), "unset") }) test_that("learnTwasWeights: univariate fitter runs under verbose=2", { @@ -1615,10 +1635,10 @@ test_that("twasPredict: accepts a TwasWeights S4 collection", { test_that("validity names the missing key and payload columns", { data(twasWeightsExample) bad <- twasWeightsExample - S4Vectors::mcols(bad)$method <- NULL + S4Vectors::mcols(bad)$study <- NULL expect_error( methods::validObject(bad), - "missing elements \\{'method'\\}" + "missing elements \\{'study'\\}" ) expect_true(methods::validObject(twasWeightsExample)) bad2 <- twasWeightsExample @@ -1712,46 +1732,44 @@ test_that(".twasMethodRows keeps a per-outcome context vector", { test_that("twasWeightsCv: argument guards fire", { d <- generateXY(seed = 1) base <- list(X = d$X, Y = d$Y, fold = 2, weightMethods = list()) + badPartitions <- list_modify(base, samplePartitions = 1L) expect_error( - exec( - twasWeightsCv, - !!!list_modify(base, !!!list(samplePartitions = 1L)) - ), + exec(twasWeightsCv, !!!badPartitions), "samplePartitions.*Must be of type 'data.frame'" ) + zeroVariants <- list_modify(base, maxNumVariants = 0) expect_error( - exec(twasWeightsCv, !!!list_modify(base, !!!list(maxNumVariants = 0))), + exec(twasWeightsCv, !!!zeroVariants), "maxNumVariants.*is not >= 1" ) + badBpparam <- list_modify(base, BPPARAM = 2) expect_error( - exec(twasWeightsCv, !!!list_modify(base, !!!list(BPPARAM = 2))), + exec(twasWeightsCv, !!!badBpparam), "must be a BiocParallelParam" ) + badRetention <- list_modify(base, fitRetention = "sometimes") expect_error( - exec( - twasWeightsCv, - !!!list_modify(base, !!!list(fitRetention = "sometimes")) - ), + exec(twasWeightsCv, !!!badRetention), "must be one of" ) + badSeed <- list_modify(base, seed = "x") expect_error( - exec(twasWeightsCv, !!!list_modify(base, !!!list(seed = "x"))), + exec(twasWeightsCv, !!!badSeed), "seed.*Must be of type 'single integerish value'" ) # Inf is the documented "no cap" sentinel and must still be accepted. + infVariants <- list_modify(base, maxNumVariants = Inf) expect_no_error( - exec(twasWeightsCv, !!!list_modify(base, !!!list(maxNumVariants = Inf))) + exec(twasWeightsCv, !!!infVariants) ) }) test_that("learnTwasWeights: argument guards fire", { d <- generateXY(seed = 1) base <- list(X = d$X, Y = d$Y, weightMethods = list()) + badStudyName <- list_modify(base, studyName = 1L) expect_error( - exec( - learnTwasWeights, - !!!list_modify(base, !!!list(studyName = 1L)) - ), + exec(learnTwasWeights, !!!badStudyName), "studyName.*Must be of type 'string'" ) # Called directly, not via modifyList(): modifyList() DROPS an element @@ -1765,18 +1783,14 @@ test_that("learnTwasWeights: argument guards fire", { ), "weightStandardized.*Must be of type 'logical flag'" ) + badDataType <- list_modify(base, weightsDataType = 1L) expect_error( - exec( - learnTwasWeights, - !!!list_modify(base, !!!list(weightsDataType = 1L)) - ), + exec(learnTwasWeights, !!!badDataType), "weightsDataType.*Must be of type 'string'" ) + badMethods <- list_modify(base, weightMethods = 1L) expect_error( - exec( - learnTwasWeights, - !!!list_modify(base, !!!list(weightMethods = 1L)) - ), + exec(learnTwasWeights, !!!badMethods), "weightMethods.*One of the following must apply" ) }) @@ -1794,35 +1808,70 @@ test_that("twasPredict: weightsList must be a list or TwasWeights", { # fineMappingPipeline's own CV retained each fold's fit. # --------------------------------------------------------------------------- -test_that("twasWeightsCv cross-validates susie from the retained fold fits", { +test_that("twasWeightsCv cross-validates susie from its fold weights", { f <- .twcvFixture out <- suppressMessages(twasWeightsCv( f$X, f$Y, samplePartitions = f$slice$samplePartition, weightMethods = list(susie_weights = list()), - fittedModelsCv = list(susie = f$slice$foldFits), + foldWeights = list(susie = f$foldWeights), verbose = 0 )) - expect_true(all(c("prediction", "performance") %in% names(out))) - expect_false(is.null(out$prediction)) + # Each fold scored with the weights its own fit gave reproduces the + # fine-mapping CV's out-of-fold predictions. + expect_false(anyNA(f$foldWeights)) + expect_equal( + out$prediction$susie_predicted, + f$cv$prediction$susie_predicted + ) + expect_null(out$foldWeights) }) -test_that(".twasFoldFit injects the fold's fit, else leaves the args alone", { - f <- pecotmr:::.twasFoldFit - ff <- list(susie = list(fold_1 = "FIT1", fold_2 = "FIT2")) - a <- f(list(), "susie_weights", 2L, ff) - expect_identical(a$susieFit, "FIT2") - args <- list(X = 1) - # No CV payload at all. - expect_identical(f(args, "susie_weights", 1L, NULL), args) - # A method with no fine-mapping adapter is untouched. - expect_identical(f(args, "lasso_weights", 1L, ff), args) - # The token is present but carries no folds, so there is nothing to add. - expect_identical(f(args, "susie", 1L, list(susie = list())), args) +test_that(".twasFoldWeightsW reads a fold's weights, aligned to its X", { + f <- pecotmr:::.twasFoldWeightsW + Xtr <- matrix(0, 3L, 2L, dimnames = list(NULL, c("a", "c"))) + Ytr <- matrix(0, 3L, 2L) + fw <- matrix( + 1:6, + 3L, + 2L, + dimnames = list(c("a", "b", "c"), c("fold_1", "fold_2")) + ) + # The fold's column, on the fold's variants, for every outcome. + expect_equal( + f("susie_weights", 2L, Xtr, Ytr, list(susie = fw)), + matrix(c(4, 6, 4, 6), 2L, 2L, dimnames = list(c("a", "c"), NULL)) + ) + # Not a fine-mapping method, no weights, or no such fold: none given. + expect_null(f("lasso_weights", 1L, Xtr, Ytr, list(susie = fw))) + expect_null(f("susie_weights", 1L, Xtr, Ytr, NULL)) + expect_null(f("susie_weights", 3L, Xtr, Ytr, list(susie = fw))) + # Weights naming no variants cannot be aligned. + expect_error( + f("susie_weights", 1L, Xtr, Ytr, list(susie = `rownames<-`(fw, NULL))), + "do not name their variants" + ) + # A method with weights of its own per outcome takes them from a third + # axis, matched to the columns of Y by name. + fw3 <- array( + 1:12, + c(3L, 2L, 2L), + dimnames = list(c("a", "b", "c"), c("fold_1", "fold_2"), c("y1", "y2")) + ) + Ytr2 <- matrix(0, 3L, 2L, dimnames = list(NULL, c("y2", "y1"))) + expect_equal( + f("mvsusie_weights", 1L, Xtr, Ytr2, list(mvsusie = fw3)), + matrix(c(7, 9, 1, 3), 2L, 2L, dimnames = list(c("a", "c"), NULL)) + ) + Ytr3 <- matrix(0, 3L, 1L, dimnames = list(NULL, "y3")) + expect_error( + f("mvsusie_weights", 1L, Xtr, Ytr3, list(mvsusie = fw3)), + "no outcome y3" + ) }) -test_that("twasWeightsCv refuses fold fits from a different partition", { +test_that("twasWeightsCv refuses fold weights from a different partition", { f <- .twcvFixture wm <- list(susie = list()) @@ -1834,13 +1883,13 @@ test_that("twasWeightsCv refuses fold fits from a different partition", { f$Y, weightMethods = wm, verbose = 0, - fittedModelsCv = list(susie = f$slice$foldFits) + foldWeights = list(susie = f$foldWeights) )), "needs the fold partition" ) - # (b) fits with no fingerprint cannot be shown to match. - unkeyed <- f$slice$foldFits + # (b) weights with no fingerprint cannot be shown to match. + unkeyed <- f$foldWeights attr(unkeyed, "partitionKey") <- NULL expect_error( suppressMessages(twasWeightsCv( @@ -1849,7 +1898,7 @@ test_that("twasWeightsCv refuses fold fits from a different partition", { weightMethods = wm, verbose = 0, samplePartitions = f$slice$samplePartition, - fittedModelsCv = list(susie = unkeyed) + foldWeights = list(susie = unkeyed) )), "no partition fingerprint" ) @@ -1865,7 +1914,7 @@ test_that("twasWeightsCv refuses fold fits from a different partition", { weightMethods = wm, verbose = 0, samplePartitions = other$samplePartition, - fittedModelsCv = list(susie = f$slice$foldFits) + foldWeights = list(susie = f$foldWeights) )), "trained on a different fold partition" ) @@ -1928,7 +1977,39 @@ test_that("learnTwasWeights refuses a susie token with no fit", { ))) }) -test_that("twasWeightsCv refuses a susie token with no per-fold fits", { +test_that("learnTwasWeights extracts mvSuSiE weights from a supplied fit", { + skip_if_not_installed("mvsusieR") + # Every multivariate method is called with X and Y. The real + # mvsusieWeights() refused them, which only mocks of it that took X and Y + # hid, so a joint mvSuSiE fit never reached TWAS. + set.seed(1) + ids <- sprintf("chr1:%d:A:G", 100L * (1:3)) + X <- matrix(rbinom(60L, 2L, 0.3), 20L, 3L, dimnames = list(NULL, ids)) + Y <- matrix(rnorm(40L), 20L, 2L, dimnames = list(NULL, c("c1", "c2"))) + coefs <- matrix( + c(0, 0.5, 0, 0, 0, 0, 0.2, 0), + nrow = 4L, + dimnames = list(c("(Intercept)", ids), colnames(Y)) + ) + local_mocked_bindings( + coef.mvsusie = function(...) coefs, + .package = "mvsusieR" + ) + fit <- structure( + list(pip = set_names(c(0.9, 0.1, 0.8), ids)), + class = "mvsusie" + ) + tw <- suppressMessages(learnTwasWeights( + X, + Y, + weightMethods = list(mvsusie_weights = list()), + fittedModels = list(mvsusie = fit), + verbose = 0 + )) + expect_equal(weights(tw), coefs[-1L, ]) +}) + +test_that("twasWeightsCv refuses a susie token with no per-fold weights", { f <- .twcvFixture expect_error( suppressMessages(twasWeightsCv( @@ -1938,7 +2019,7 @@ test_that("twasWeightsCv refuses a susie token with no per-fold fits", { weightMethods = list(susie_weights = list()), verbose = 0 )), - "never run fine-mapping themselves.*needs that fold's own fit" + "never run fine-mapping themselves.*own fit gave" ) }) @@ -2023,7 +2104,10 @@ test_that(".twasSusieTokensRequested matches both method spellings", { LD[abs(row(LD) - col(LD)) == 1] <- 0.3 ids <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) list( - ldReference = LdMatrix(`dimnames<-`(LD, list(ids, ids))), + ldReference = LdMatrix( + `dimnames<-`(LD, list(ids, ids)), + nSamples = 500L + ), stat = list( b = rnorm(p) * 0.1, seb = rep(0.05, p), @@ -2174,6 +2258,12 @@ test_that("per-class checking rejects a name only the other path accepts", { # The exported *Options constructor that method `token` resolves to on input # path `path`, by name: NA when the method does not run on that path, "?" # when what it resolves to is not an exported *Options constructor. +takesMethodArgs <- function(token, path) { + impl <- pecotmr:::.twasMethodImplFor(token, path) + fn <- get(impl, envir = asNamespace("pecotmr")) + is_in("methodArgs", names(formals(fn))) +} + optionsCtorName <- function(token, path) { ctor <- pecotmr:::.twasMethodCtorFor(token, path) if (is.null(ctor)) { @@ -2206,6 +2296,9 @@ test_that("the TWAS Options registry is derived from each implementation", { pecotmr:::.twasConfigurableMethods(), pecotmr:::.twasMethodsFor(path) ) + # An implementation without `methodArgs` takes every setting as its + # own argument (LDpred2), so it has no constructor to resolve. + toks <- toks[map_lgl(toks, takesMethodArgs, path = path)] ctorNames <- map_chr(toks, optionsCtorName, path = path) expect_equal( toks[is.na(ctorNames) | ctorNames == "?"], @@ -2230,6 +2323,14 @@ test_that("each method's Options constructor is resolved per input path", { # prsCs has no individual implementation; its one constructor is the # summary-statistics one. expect_equal(optionsCtorName("prsCs", "QtlSumStats"), "PrsCsOptions") + # The lasso's default engine on summary statistics is pecotmr's, and + # bigsnpr's takes its own constructor; LDpred2 takes none. + expect_equal( + pecotmr:::.twasImplCtorName("lassosumRssWeights", "bigsnpr"), + "BigsnprOptions" + ) + expect_null(pecotmr:::.twasMethodCtorFor("ldpred2Auto", "QtlSumStats")) + expect_true(is_in("ldpred2Grid", pecotmr:::.twasMethodsFor("QtlSumStats"))) # A method that does not run on a path has no constructor there. expect_null(pecotmr:::.twasMethodCtorFor("dprVb", "QtlSumStats")) expect_null(pecotmr:::.twasMethodCtorFor("prsCs", "QtlDataset")) @@ -2268,10 +2369,10 @@ test_that(".twasCanonicalShortName maps a function name back, else passes on", { expect_equal(f("unknownThing", map), "unknownThing") }) -test_that(".twasFoldFitsFor answers NULL when no spelling is present", { - f <- pecotmr:::.twasFoldFitsFor +test_that(".twasFoldWeightsFor answers NULL when no spelling is present", { + f <- pecotmr:::.twasFoldWeightsFor expect_null(f(NULL, "susie")) - # A CV payload keyed by something else is not this token's fits. + # A CV payload keyed by something else is not this token's weights. expect_null(f(list(somethingElse = list()), "susie")) }) @@ -2302,21 +2403,144 @@ test_that("TwasWeights() keeps the caller's metadata", { expect_equal(S4Vectors::metadata(tw), list(run = "r1")) }) -test_that("a weights row records its fit variants only with a fit payload", { +# A slim fit's shape: coefficients, and the variants they were fitted on. +.tw_fit <- list(coef = c(0.1, 0.2, 0.3), variantIds = .tw_ids) + +# Two LD references over .tw_ids that differ. +.tw_ldPair <- function() { + R <- diag(3) + dimnames(R) <- list(.tw_ids, .tw_ids) + list(LdMatrix(R), LdMatrix(R * 0.9 + 0.1)) +} + +# A gene's two methods, fitted with `...`. +.tw_twoMethods <- function(...) { + row <- TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)) + TwasWeights( + studyName = c("s1", "s1"), + context = c("c1", "c1"), + trait = c("g1", "g1"), + method = c("lasso", "enet"), + entry = list(row, row), + ... + ) +} + +.tw_dropFirst <- function(g) { + g[-1L] +} + +test_that("TwasWeights refuses per-cell ranges that are not one per cell", { + rows <- list(TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3))) + one <- function(traitPos) { + TwasWeights( + studyName = "s1", + context = "c1", + trait = "g1", + method = "lasso", + entry = rows, + traitPos = traitPos + ) + } + expect_error(one("chr1:100"), "must be a GRanges") + two <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(1L, 5L), width = 1L) + ) + expect_error(one(two), "same length as `study`") +}) + +test_that("a gene's methods must share their LD reference and window", { + ld <- .tw_ldPair() + expect_error( + .tw_twoMethods(ldReference = ld), + "different LD references" + ) + expect_error( + .tw_twoMethods( + traitPos = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100L, 900L), width = 1L) + ) + ), + "different `traitPos` values" + ) +}) + +test_that("an empty TwasWeights has no cell to select", { + tw <- .tw_collection(list(TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)))) + expect_error( + pecotmr:::.twrSelectCell(tw[0], "s1", "c1", "g1", "lasso"), + "has no rows" + ) +}) + +test_that("validity refuses a row holding a method twice", { + bad <- .tw_twoMethods() + md <- attr(bad, "elementMetadata") + md$methods <- IRanges::CharacterList(c("lasso", "lasso")) + attr(bad, "elementMetadata") <- md + expect_identical( + pecotmr:::.twasValidateMethods(bad), + "a row holds one set of weights per method" + ) +}) + +test_that("combining TwasWeights takes a given LD reference for every row", { + ld <- .tw_ldPair()[[1L]] + tw <- .tw_collection(list(TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)))) + out <- combineTwasWeights(tw, ldReference = ld) + expect_identical(ldReference(out), list(ld1 = ld)) +}) + +test_that("an element operation re-aligns a sparse method's weights", { + ids <- sprintf("chr1:%d:A:G", 100L * (1:6)) + w <- c(0, 0, 0.5, 0, 0, 0) + tw <- .tw_collection(list(TwasWeightsRow(ids, w))) + expect_false(is.null(S4Vectors::mcols(tw)$weightTensor[[1L]]$sparse)) + dropped <- endoapply(tw, .tw_dropFirst) + expect_identical( + unname(weights(pecotmr:::.twrCellParts(dropped, 1L, "lasso"))), + w[-1L] + ) +}) + +test_that("flattening handles no rows and a method without weights", { + tw <- .tw_collection(list(TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)))) + expect_length(flattenTupleRanges(tw[0]), 0L) + noWeights <- .tw_collection(list(TwasWeightsRow(.tw_ids, NULL))) + flat <- flattenTupleRanges(noWeights) + expect_true(all(is.na(S4Vectors::mcols(flat)$weight))) + back <- nestTupleRanges(flat, noWeights) + expect_null(weights(pecotmr:::.twrCellParts(back, 1L, "lasso"))) +}) + +test_that("a weights row reads the variants it was fitted on off its fit", { tw <- .tw_collection(list( - TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = list(r2 = 0.4)), - TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)) + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), methodFits = .tw_fit), + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = list(r2 = 0.4)) )) - expect_s4_class(tw$fitVariants, "CharacterList") - expect_equal(as.character(tw$fitVariants[[1L]]), .tw_ids) - expect_equal(as.character(tw$fitVariants[[2L]]), character(0)) + # The collection keeps no second copy of them. + expect_false(is_in("fitVariants", colnames(mcols(tw)))) + fitOf <- function(trait) { + methodFits( + tw, + studyName = "s1", + context = "c1", + trait = trait, + method = "lasso" + ) + } + expect_equal(pecotmr:::.twasFitVariantIds(fitOf("g1")), .tw_ids) + # A row kept without a fit has nothing to read them from. + expect_equal(pecotmr:::.twasFitVariantIds(fitOf("g2")), character(0)) + expect_length(pecotmr:::.twasNarrowedCellLabels(tw), 0L) }) test_that("cvResult() and methodFits() of a narrowed row warn", { - fits <- list(lasso = list(lambda = 0.1)) cv <- list(r2 = 0.4) tw <- .tw_collection(list( - TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), fits, cv) + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), .tw_fit, cv) )) narrowed <- endoapply(tw, utils::head, 2L) expect_warning( @@ -2328,35 +2552,68 @@ test_that("cvResult() and methodFits() of a narrowed row warn", { outFits <- methodFits(narrowed), "methodFits\\(\\): .* Refit on the variants kept" ) - expect_identical(outFits, fits) + expect_identical(outFits, .tw_fit) expect_no_warning(cvResult(tw)) expect_no_warning(methodFits(tw)) + # Kept without a fit, a narrowed row has nothing to compare with. + bare <- .tw_collection(list( + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = cv) + )) + expect_no_warning(cvResult(endoapply(bare, utils::head, 2L))) }) -test_that("updateObject() backfills a fitted row's held variants", { +test_that("updateObject() folds a saved per-method collection by gene", { tw <- .tw_collection(list( - TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = list(r2 = 0.4)), - TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)) + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), .tw_fit, list(r2 = 0.4)) )) - saved <- tw - saved$fitVariants <- NULL + saved <- .savedTwasPerMethod( + tw, + extra = list(fitVariants = IRanges::CharacterList(list(.tw_ids))) + ) up <- updateObject(saved) - expect_equal(as.character(up$fitVariants[[1L]]), .tw_ids) - expect_equal(as.character(up$fitVariants[[2L]]), character(0)) + expect_false(is_in("fitVariants", colnames(mcols(up)))) + expect_identical(up, tw) # A current collection is left as it is. - expect_identical(updateObject(tw)$fitVariants, tw$fitVariants) + expect_identical(updateObject(tw), tw) expect_message(updateObject(tw, verbose = TRUE), "TwasWeights") }) -test_that("updateObject() backfills held variants and keys LD rows at once", { +test_that("updateObject() drops the variant ids saved weights carry", { + # Rows stored every weight named by its variant id -- a third copy of + # every id, and most of the weight column's size. The accessors name them + # on the way out instead. + data(twasWeightsExample, envir = environment()) + saved <- .savedTwasPerMethod(twasWeightsExample, named = TRUE) + up <- updateObject(saved) + expect_identical(up, twasWeightsExample) + expect_lt( + length(serialize(up, NULL)), + length(serialize(saved, NULL)) + ) +}) + +test_that("updateObject() folds a saved collection held in its old slot", { + # Folding reads the LD references, so it runs once the saved `ldSketch` + # slot has been brought up to date. + tw <- .tw_collection(list(TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)))) + saved <- .savedWithLdSketch(.savedTwasPerMethod(tw, named = TRUE), NULL) + up <- updateObject(saved) + expect_true(validObject(up)) + expect_identical(up, tw) + expect_identical(updateObject(up), up) +}) + +test_that("updateObject() drops saved fit variants and keys LD rows at once", { tw <- .tw_collection(list( TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = list(r2 = 0.4)) )) - saved <- tw - saved$fitVariants <- NULL + saved <- .savedTwasPerMethod( + tw, + extra = list(fitVariants = IRanges::CharacterList(list(.tw_ids))) + ) up <- updateObject(.savedWithLdSketch(saved, NULL)) expect_true(validObject(up)) - expect_equal(as.character(up$fitVariants[[1L]]), .tw_ids) + expect_false(is_in("fitVariants", colnames(mcols(up)))) expect_identical(ldReference(up), list()) expect_true(is.na(up$ldReference)) expect_identical(updateObject(up), up) @@ -2375,7 +2632,7 @@ test_that("estimateSparsity: legacy list input reads attr(.,'fit')$pi", { expect_equal(estimateSparsity(weightResults), 1 - 0.6, tolerance = 1e-12) }) -test_that("estimateSparsity: TwasWeights collection input reads from the mrash entry", { +test_that("estimateSparsity reads a TwasWeights collection's mrash entry", { entry <- TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), weights = c(0.1, 0, 0.3), @@ -2407,7 +2664,7 @@ test_that("estimateSparsity: TwasWeights without mrash entry errors", { ) }) -test_that("estimateSparsity: TwasWeights with mrash entry but no fit$pi errors", { +test_that("estimateSparsity errors on an mrash entry without fit$pi", { entry <- TwasWeightsRow( variantIds = c("chr1:100:A:G"), weights = c(0.1), @@ -2462,3 +2719,246 @@ test_that("ser is reachable as a TWAS method", { "nothing to configure here" ) }) + +test_that("an alphabet method's chain is its default backend's", { + expect_equal( + pecotmr:::.twasMethodChainFor("bayesR", "QtlDataset"), + c( + "bayesRWeights", + "bayesAlphabetWeights", + ".alphabetQggFit", + "qgg::gbayes" + ) + ) + expect_equal( + pecotmr:::.twasMethodChainFor("bayesB", "QtlSumStats")[[3L]], + ".alphabetHibayesRssFit" + ) + # The names a plain list may set are every backend's: BGLR's R2 and + # hibayes' dfvg both reach bayesB, and the pipeline's own backend none. + skip_if_not_installed("BGLR") + skip_if_not_installed("hibayes") + accepted <- pecotmr:::.twasChainAccepted("bayesB", "QtlDataset") + expect_true(all(is_in(c("R2", "dfvg"), accepted))) + expect_false(is_in("backend", accepted)) +}) + +# ---- flat views ------------------------------------------------------------- + +# One gene with a two-column (fSuSiE-like) weight matrix and a weight vector +# on three of its four variants. +.tw_flatGene <- function() { + ids <- sprintf("chr1:%d:A:G", 100L * (1:4)) + w <- matrix( + c(0.1, 0, 0.3, 0.4, 0, 0.6, 0.7, 0), + 4L, + 2L, + dimnames = list(NULL, c("f1", "f2")) + ) + TwasWeights( + studyName = c("S", "S"), + context = c("c", "c"), + trait = c("t", "t"), + method = c("fsusie", "lasso"), + entry = list( + TwasWeightsRow(ids, w), + TwasWeightsRow(ids[1:3], c(0.5, 0, 0.2)) + ) + ) +} + +.tw_flatSel <- list(studyName = "S", context = "c", trait = "t") + +test_that("reordering a gene's variants keeps each method's own weights", { + # lasso holds three of the gene's four variants; reversed, they are no + # longer the first three of the row. + tw <- .tw_flatGene() + before <- weights(pecotmr:::.twrCellParts(tw, 1L, "lasso")) + reversed <- endoapply(tw, rev) + after <- weights(pecotmr:::.twrCellParts(reversed, 1L, "lasso")) + expect_identical(after[names(before)], before) +}) + + +test_that("a TwasWeights flattens to one range per variant and method", { + data(twasWeightsExample, envir = environment()) + x <- twasWeightsExample + flat <- flattenTupleRanges(x) + cells <- .twasCells(x) + expect_setequal(unique(flat$.method), cells$method) + expect_true(all(is.na(flat$.weightColumn))) + m <- cells$method[[1L]] + key <- list( + studyName = cells$study[[1L]], + context = cells$context[[1L]], + trait = cells$trait[[1L]], + method = m + ) + expect_equal( + flat$weight[flat$.method == m], + unname(exec(weights, x, !!!key)) + ) + expect_identical(nestTupleRanges(flat, x), x) +}) + +test_that("a weight matrix flattens to one block per column and back", { + tw <- .tw_flatGene() + flat <- flattenTupleRanges(tw) + expect_equal( + flat$.weightColumn[flat$.method == "fsusie"], + rep(c("f1", "f2"), each = 4L) + ) + expect_identical(nestTupleRanges(flat, tw), tw) +}) + +test_that("nesting keeps each method's surviving weights", { + tw <- .tw_flatGene() + flat <- flattenTupleRanges(tw) + kept <- nestTupleRanges(flat[flat$weight != 0], tw) + expect_equal( + exec(weights, kept, !!!.tw_flatSel, method = "lasso"), + c(`chr1:100:A:G` = 0.5, `chr1:300:A:G` = 0.2) + ) + # A matrix weight dropped from one column while its variant kept the + # other is 0, as a method's weight is wherever it has none. + fs <- exec(weights, kept, !!!.tw_flatSel, method = "fsusie") + expect_equal(nrow(fs), 4L) + expect_equal(fs["chr1:200:A:G", ], c(f1 = 0, f2 = 0.6)) +}) + +test_that("filter() and select() keep a TwasWeights' weights", { + skip_if_not_installed("plyranges") + tw <- .tw_flatGene() + lasso <- dplyr::filter(tw, .method == "lasso") + # The other method keeps its entry, with no variants. + expect_equal(nrow(.twasCells(lasso)), 2L) + expect_length( + exec(variantIds, lasso, !!!.tw_flatSel, method = "fsusie"), + 0L + ) + # A selection cannot drop the weights or the alleles naming a variant. + picked <- dplyr::select(tw, A1) + expect_identical( + exec(weights, picked, !!!.tw_flatSel, method = "lasso"), + exec(weights, tw, !!!.tw_flatSel, method = "lasso") + ) +}) + +# ---- fits dictionary -------------------------------------------------------- + +# A joint mr.mash fit's rows: one per context, every one holding the same fit +# and, with cross-validation, the same per-fold fits. +.tw_jointRows <- function(withFolds = FALSE) { + cv <- if (withFolds) { + list( + predictions = c(s1 = 0.1, s2 = 0.2), + metrics = c(rsq = 0.3), + foldFits = list(fold_1 = list(w0 = 0.5), fold_2 = list(w0 = 0.6)) + ) + } + row <- TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), .tw_fit, cv) + TwasWeights( + studyName = c("s1", "s1"), + context = c("c1", "c2"), + trait = c("g1", "g1"), + method = c("mrmash", "mrmash"), + entry = list(row, row), + jointContexts = c("c1;c2", "c1;c2") + ) +} + +test_that("a fit the rows of a joint fit share is stored once", { + tw <- .tw_jointRows() + expect_length(.fitDict(tw), 1L) + keys <- unlist(S4Vectors::mcols(tw)$fits) + expect_identical(keys[[1L]], keys[[2L]]) + for (ctx in c("c1", "c2")) { + expect_identical( + methodFits(tw, "s1", ctx, "g1", "mrmash"), + .tw_fit + ) + } +}) + +test_that("per-fold fits are stored once and read back in place", { + tw <- .tw_jointRows(withFolds = TRUE) + # One full-data fit and one set of per-fold fits. + expect_length(.fitDict(tw), 2L) + cv <- cvResult(tw, "s1", "c2", "g1", "mrmash") + expect_identical( + cv$foldFits, + list(fold_1 = list(w0 = 0.5), fold_2 = list(w0 = 0.6)) + ) + expect_identical(names(cv), c("predictions", "metrics", "foldFits")) +}) + +# `x` as saved one row per gene before rows shared their fits: each method's +# fit in its row's `fits` cell, the per-fold fits inside its cvResult, no +# `foldFits` column and no dictionary. +.tw_savedInlineFits <- function(x) { + md <- S4Vectors::mcols(x, use.names = FALSE) + cells <- .twasCells(x) + k <- list_c(map(lengths(md$methods), seq_len)) + md$fits <- .tw_byRow( + map2(cells$row, k, .tw_inlineFit, x = x, md = md), + cells$row, + md$methods + ) + md$cvResult <- .tw_byRow( + map2(cells$row, k, .tw_inlineCv, x = x, md = md), + cells$row, + md$methods + ) + md$foldFits <- NULL + saved <- x + attr(saved, "elementMetadata") <- md + attr(saved, "fits") <- NULL + saved +} + +# Per-cell values regrouped into per-row lists named by method. +.tw_byRow <- function(values, rows, methods) { + S4Vectors::SimpleList(map2( + unname(split(values, rows)), + as.list(methods), + set_names + )) +} + +.tw_inlineFit <- function(row, k, x, md) { + .fitEntry(md$fits[[row]][[k]], x) +} + +.tw_inlineCv <- function(row, k, x, md) { + stored <- md$cvResult[[row]][[k]] + folds <- .fitEntry(md$foldFits[[row]][[k]], x) + if (is.null(folds)) stored else purrr::list_assign(stored, foldFits = folds) +} + +test_that("updateObject() moves a gene's saved fits into the dictionary", { + tw <- .tw_jointRows(withFolds = TRUE) + saved <- .tw_savedInlineFits(tw) + expect_false(methods::.hasSlot(saved, "fits")) + up <- updateObject(saved) + expect_identical(up, tw) + expect_identical(updateObject(up), up) +}) + +test_that("combining keeps one copy of a fit the parts share", { + tw <- .tw_jointRows() + both <- combineTwasWeights(tw[1L], tw[2L]) + expect_length(.fitDict(both), 1L) + expect_identical(both, tw) +}) + +test_that("a subset keeps only the fits its rows name", { + other <- list(coef = c(0.4, 0.5, 0.6), variantIds = .tw_ids) + tw <- .tw_collection(list( + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), .tw_fit), + TwasWeightsRow(.tw_ids, c(0.4, 0.5, 0.6), other) + )) + expect_length(.fitDict(tw), 2L) + second <- tw[2L] + expect_length(.fitDict(second), 1L) + expect_identical(methodFits(second, "s1", "c1", "g2", "lasso"), other) +}) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 2c14181ff..9d1c94eeb 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -92,39 +92,14 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") } .tp_mockExtractor <- function(seed = 1, n_samples = 40L) { - function(handle, snpIdx, meanImpute = TRUE) { + function(handle, snpIdx) { set.seed(seed) panel <- matrix( rbinom(n_samples * nrow(snpInfo(handle)), 2, 0.3), nrow = n_samples, - ncol = nrow(snpInfo(handle)), - dimnames = list(sampleIds(handle), snpInfo(handle)$SNP) - ) - sub <- panel[, snpIdx, drop = FALSE] - rr <- GenomicRanges::GRanges( - seqnames = paste0("chr", snpInfo(handle)$CHR[snpIdx]), - ranges = IRanges::IRanges( - start = snpInfo(handle)$BP[snpIdx], - width = 1L - ) - ) - S4Vectors::mcols(rr) <- S4Vectors::DataFrame( - SNP = snpInfo(handle)$SNP[snpIdx], - A1 = snpInfo(handle)$A1[snpIdx], - A2 = snpInfo(handle)$A2[snpIdx] - ) - cd <- S4Vectors::DataFrame( - sampleId = sampleIds(handle), - row.names = sampleIds(handle) - ) - dosage <- t(sub) - rownames(dosage) <- snpInfo(handle)$SNP[snpIdx] - colnames(dosage) <- sampleIds(handle) - SummarizedExperiment::SummarizedExperiment( - assays = list(dosage = dosage), - rowRanges = rr, - colData = cd + ncol = nrow(snpInfo(handle)) ) + panel[, snpIdx, drop = FALSE] } } @@ -208,13 +183,14 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") # twasWeightsPipeline(QtlDataset) # =========================================================================== -test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers", { +test_that("twasWeightsPipeline(QtlDataset) runs end to end, mocked solvers", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = c("ENSG_A", "ENSG_B")) mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages( twasWeightsPipeline( qd, @@ -230,8 +206,9 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" ) ) expect_s4_class(res, "TwasWeights") - # 1 context x 2 traits x 2 methods = 4 rows. - expect_equal(nrow(res), 4L) + # 1 context x 2 traits = 2 genes, each with 2 methods. + expect_equal(nrow(res), 2L) + expect_equal(nrow(.twasCells(res)), 4L) expect_setequal(methodNames(res), c("lasso", "enet")) expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) # Provenance, aligned per row (.tp_makeSe: ENSG_A -> chr1:1000-1499, @@ -241,8 +218,8 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" tp <- traitPosition(res) expect_s4_class(reg, "GRanges") expect_s4_class(tp, "GRanges") - expect_equal(length(reg), 4L) - expect_equal(length(tp), 4L) + expect_equal(length(reg), 2L) + expect_equal(length(tp), 2L) # traitPos: the trait's own coordinates. expect_true(all(GenomicRanges::start(tp)[res$trait == "ENSG_A"] == 1000L)) expect_true(all(GenomicRanges::end(tp)[res$trait == "ENSG_A"] == 1499L)) @@ -256,16 +233,105 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" expect_true(all(GenomicRanges::end(reg)[res$trait == "ENSG_B"] <= 3499L)) }) -test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tighten the variant set", { +test_that("twasWeightsPipeline hands each method the backend it names", { + qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + seen <- list() + mocks <- list( + .handleDosage = .tp_mockExtractor(), + bayesRWeights = function(X, y, backend = c("qgg", "hibayes"), ...) { + seen$bayesR <<- backend + rep(0, ncol(X)) + }, + bayesCWeights = function(X, y, backend = c("qgg", "hibayes"), ...) { + seen$bayesC <<- backend + rep(0, ncol(X)) + } + ) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) + suppressMessages(twasWeightsPipeline( + qd, + methods = c("bayesR", "bayesC"), + backend = c(bayesR = "hibayes"), + cisWindow = 1000L, + estimatePi = FALSE, + verbose = 0, + crossValidationParam = CrossValidationParam(folds = 0) + )) + expect_equal(seen$bayesR, "hibayes") + # A method the vector leaves out stays on its own default. + expect_equal(seen$bayesC, c("qgg", "hibayes")) +}) + +test_that("twasWeightsPipeline refuses a backend it cannot honour", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") + local_mocked_bindings( + .handleDosage = .tp_mockExtractor(), + .package = "pecotmr" + ) + run <- function(...) { + twasWeightsPipeline( + qd, + ..., + cisWindow = 1000L, + verbose = 0, + crossValidationParam = CrossValidationParam(folds = 0) ) + } + expect_error( + run(methods = "bayesR", backend = "hibayes"), + "named character vector keyed by method" + ) + expect_error( + run(methods = "bayesR", backend = c(bayesC = "hibayes")), + "not being run: bayesC" + ) + expect_error( + run(methods = "lasso", backend = c(lasso = "glmnet")), + "lasso has one implementation" + ) + expect_error( + run(methods = "bayesR", backend = c(bayesR = "bglr")), + "`backend` for bayesR must be one of qgg, hibayes" + ) + # `backend` is pipeline plumbing, never a method option, so the + # methods' own name check refuses it and says where it goes. + expect_error( + run(methods = list(bayesR = list(backend = "hibayes"))), + str_c( + "unknown argument\\(s\\) backend for bayesR on QtlDataset\\. ", + "Choose it with twasWeightsPipeline\\(\\)'s own `backend` ", + "argument, keyed by method: ", + "backend = c\\(bayesR = \"hibayes\"\\)\\. ", + "bayesR on QtlDataset offers qgg, hibayes\\." + ) + ) + # A choice that is not one of the method's backends falls back to the + # first as the example. + expect_error( + run(methods = list(bayesR = list(backend = "bglr"))), + "backend = c\\(bayesR = \"qgg\"\\)" + ) + # Refused even though glmnet's `...` leaves lasso's other names + # unchecked. + expect_error( + run(methods = list(lasso = list(backend = "glmnet"))), + str_c( + "unknown argument\\(s\\) backend for lasso on QtlDataset\\. ", + "`backend` is twasWeightsPipeline\\(\\)'s own argument, and lasso ", + "has one implementation on QtlDataset" + ) + ) +}) + +test_that("mafCutoff and xvarCutoff overrides tighten the TWAS variant set", { + qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) call <- function(...) { suppressMessages(twasWeightsPipeline( qd, @@ -309,10 +375,11 @@ test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tight test_that("twasWeightsPipeline(QtlDataset): context narrows the context loop", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages( twasWeightsPipeline( qd, @@ -344,10 +411,11 @@ test_that("twasWeightsPipeline(QtlDataset): context narrows the context loop", { test_that("twasWeightsPipeline(QtlDataset): trait chosen per context", { mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(twasWeightsPipeline( .tp_twoContextStudy("A"), methods = list(lasso = list()), @@ -368,10 +436,11 @@ test_that("twasWeightsPipeline(QtlDataset): trait chosen per context", { test_that("twasWeightsPipeline(MultiStudy): list selections stay per study", { mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockIndividualWeights() ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) mt <- MultiStudyQtlDataset( qtlDatasets = list( A = .tp_twoContextStudy("A"), @@ -474,6 +543,134 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { ) } +test_that("twasWeightsPipeline(QtlSumStats) runs each row on its engine", { + ss <- .tp_makeQtlSumStats() + seen <- NULL + local_mocked_bindings( + .handleDosage = .tp_mockExtractor(), + bayesRRssWeights = function(stat, ldReference, backend = NULL, ...) { + seen <<- c(seen, backend) + rep(0, length(stat$variantNames)) + }, + .package = "pecotmr" + ) + # A genotype reference defaults to pecotmr's sampler, row by row. + suppressMessages(suppressWarnings( + twasWeightsPipeline(ss, methods = "bayesR", verbose = 0) + )) + expect_true(length(seen) > 0L && all(seen == "pecotmr")) + seen <- NULL + suppressMessages(suppressWarnings(twasWeightsPipeline( + ss, + methods = "bayesR", + backend = c(bayesR = "qgg"), + verbose = 0 + ))) + expect_true(length(seen) > 0L && all(seen == "qgg")) + seen <- NULL + suppressMessages(suppressWarnings(twasWeightsPipeline( + ss, + methods = "bayesR", + backend = c(bayesR = "pecotmr"), + verbose = 0 + ))) + expect_true(length(seen) > 0L && all(seen == "pecotmr")) + # pecotmr's sampler is refused up front when an LD reference is a matrix; + # the lasso's pecotmr engine, which reads either, is not. + local_mocked_bindings( + ldReference = function(x, ...) list(a = .rrwLdMatrix(diag(2))), + .package = "pecotmr" + ) + expect_error( + pecotmr:::.twasCheckPecotmrLd( + c(bayesR = "pecotmr", lasso = "pecotmr"), + ss + ), + "for bayesR reads a genotype reference's factor" + ) + expect_null(pecotmr:::.twasCheckPecotmrLd(c(lasso = "pecotmr"), ss)) +}) + +test_that("twasWeightsPipeline(QtlSumStats) runs LDpred2 and lasso", { + ss <- .tp_makeQtlSumStats() + seen <- list() + record <- function(method) { + function(stat, ldReference, backend = NULL, ...) { + seen[[method]] <<- c(seen[[method]], backend) + rep(0, length(stat$variantNames)) + } + } + local_mocked_bindings( + .handleDosage = .tp_mockExtractor(), + ldpred2AutoWeights = record("ldpred2Auto"), + lassosumRssWeights = record("lasso"), + .package = "pecotmr" + ) + run <- function(...) { + suppressMessages(suppressWarnings(twasWeightsPipeline( + ss, + methods = c("ldpred2Auto", "lasso"), + verbose = 0, + ... + ))) + } + # A genotype reference defaults both to pecotmr. + run() + expect_true( + length(seen$ldpred2Auto) > 0L && all(seen$ldpred2Auto == "pecotmr") + ) + expect_true(length(seen$lasso) > 0L && all(seen$lasso == "pecotmr")) + seen <- list() + run(backend = c(ldpred2Auto = "bigsnpr", lasso = "bigsnpr")) + expect_true(all(seen$ldpred2Auto == "bigsnpr")) + expect_true(all(seen$lasso == "bigsnpr")) +}) + +test_that("twasWeightsPipeline(QtlSumStats) fits LDpred2-grid weights", { + local_mocked_bindings( + .handleDosage = .tp_mockExtractor(), + .package = "pecotmr" + ) + set.seed(1) + res <- suppressMessages(suppressWarnings(twasWeightsPipeline( + .tp_makeQtlSumStats(), + methods = list(ldpred2Grid = list(p = c(0.1, 1), h2 = 0.1)), + verbose = 0 + ))) + expect_setequal(methodNames(res), "ldpred2Grid") + w <- weights( + res, + studyName = "s1", + context = "c1", + trait = "t1", + method = "ldpred2Grid" + ) + expect_true(all(is.finite(w))) +}) + +test_that("twasWeightsPipeline(QtlSumStats) checks backend too", { + ss <- .tp_makeQtlSumStats() + expect_error( + twasWeightsPipeline( + ss, + methods = "enet", + backend = c(enet = "bigsnpr"), + verbose = 0 + ), + "enet has one implementation" + ) + # On summary statistics the lasso runs on pecotmr or bigsnpr. + expect_error( + twasWeightsPipeline( + ss, + methods = "lasso", + backend = c(lasso = "glmnet"), + verbose = 0 + ), + "`backend` for lasso must be one of pecotmr, bigsnpr" + ) +}) + # Mock sumstat weight methods to return zero vectors of the LD dim. .tp_mockSumstatWeights <- function() { list( @@ -495,13 +692,14 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { ) } -test_that("twasWeightsPipeline(QtlSumStats): runs end-to-end with mocked solvers", { +test_that("twasWeightsPipeline(QtlSumStats) runs end to end, mocked solvers", { ss <- .tp_makeQtlSumStats() mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockSumstatWeights() ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) # Method tokens are the bare short names; the QtlSumStats dispatch # resolves them to the *Rss impl via the .twasMethodCapabilities table. # Fine-mapping methods (susie / susieInf / etc.) require a @@ -510,7 +708,7 @@ test_that("twasWeightsPipeline(QtlSumStats): runs end-to-end with mocked solvers twasWeightsPipeline(ss, methods = c("mrash", "lasso"), verbose = 0) )) expect_s4_class(res, "TwasWeights") - expect_equal(nrow(res), 2L) + expect_equal(nrow(res), 1L) expect_setequal(methodNames(res), c("mrash", "lasso")) }) @@ -530,7 +728,7 @@ test_that("twasWeightsPipeline(QtlSumStats): individual-only method rejected", { ) }) -test_that("twasWeightsPipeline(QtlSumStats): empty contexts/trait filter errors", { +test_that("twasWeightsPipeline(QtlSumStats) errors on an empty filter", { ss <- .tp_makeQtlSumStats() expect_error( twasWeightsPipeline(ss, methods = "lasso", traitId = "ghost"), @@ -543,17 +741,18 @@ test_that("twasWeightsPipeline(QtlSumStats): empty contexts/trait filter errors" ) }) -test_that("twasWeightsPipeline(QtlSumStats): per-method failure surfaces as warning + skip", { +test_that("sumstat TWAS: a method's failure warns and is skipped", { ss <- .tp_makeQtlSumStats() mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockSumstatWeights() ) # Override lassosumRssWeights with the failure-producing version. mocks$lassosumRssWeights <- function(stat, ldReference, ...) { stop("synthetic test failure") } - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) # All entries fail -> the per-method-warning fires *and* the pipeline # then errors out (no rows produced). Capture both. expect_error( @@ -641,7 +840,7 @@ test_that("gate: fsusie now has a TWAS-weight extractor (accepted with FMR)", { ) }) -test_that("gate: fsusie on QtlSumStats delegates to .fmCheckMethodCapabilities", { +test_that("gate: fsusie on QtlSumStats goes to .fmCheckMethodCapabilities", { ss <- .tp_makeQtlSumStats() fmr <- .tp_makeStubFineMappingResult( studyName = "s1", @@ -690,13 +889,14 @@ test_that("gate: QtlDataset + susie + fineMappingResult threads the susieFit", { ) sawFit <- FALSE mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), susieWeights = function(X = NULL, y = NULL, susieFit = NULL, ...) { sawFit <<- !is.null(susieFit) rep(0, ncol(X)) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -715,7 +915,7 @@ test_that("gate: QtlDataset + susie + fineMappingResult threads the susieFit", { expect_true(sawFit) }) -test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit", { +test_that("gate: susie with a fineMappingResult passes susieRssFit", { ss <- .tp_makeQtlSumStats() fmr <- .tp_makeStubFineMappingResult( studyName = "s1", @@ -725,7 +925,7 @@ test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit ) fitsSeen <- 0L mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), susieRssWeights = function( stat, ldReference, @@ -738,7 +938,8 @@ test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit rep(0, length(stat$variantNames)) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -753,7 +954,7 @@ test_that("gate: QtlSumStats + susie + fineMappingResult threads the susieRssFit expect_equal(fitsSeen, 1L) }) -test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAshRssFit", { +test_that("gate: susieAsh with a fineMappingResult passes susieAshRssFit", { ss <- .tp_makeQtlSumStats() fmr <- .tp_makeStubFineMappingResult( studyName = "s1", @@ -763,7 +964,7 @@ test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAsh ) sawFit <- FALSE mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), susieAshRssWeights = function( stat, ldReference, @@ -774,7 +975,8 @@ test_that("gate: QtlSumStats + susieAsh + fineMappingResult threads the susieAsh rep(0, length(stat$variantNames)) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -801,10 +1003,11 @@ test_that("gate: missing matching tuple in fineMappingResult warns and skips", { method = "susie" ) mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockSumstatWeights() ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) expect_error( suppressWarnings(suppressMessages( twasWeightsPipeline( @@ -836,7 +1039,7 @@ test_that("twasWeightsPipeline(QtlDataset): mvsusie gives a row per context", { ) mvCalls <- 0L mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), mvsusieWeights = function(X, Y, mvsusieFit = NULL, ...) { mvCalls <<- mvCalls + 1L # Verify the gate threaded the precomputed fit through. @@ -849,7 +1052,8 @@ test_that("twasWeightsPipeline(QtlDataset): mvsusie gives a row per context", { ) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -873,13 +1077,13 @@ test_that("twasWeightsPipeline(QtlDataset): mvsusie gives a row per context", { expect_equal(mvCalls, 1L) }) -test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 traits x 2 contexts", { +test_that("mr.mash multivariate TWAS with 2 traits x 2 contexts", { qd <- .tp_makeQtlDataset( contexts = c("brain", "liver"), traits = c("ENSG_A", "ENSG_B") ) mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), mrmashWeights = function(X, Y, ...) { matrix( 0, @@ -889,7 +1093,8 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 tra ) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -909,14 +1114,14 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 tra expect_setequal(methodNames(res), "mrmash") }) -test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the fits slot", { +test_that("mr.mash TWAS keeps its fit parts in the fits slot", { # The multivariate dispatch retains fits so the mr.mash fit # parts (the shared fit fineMappingPipeline consumes to build the mvSuSiE # prior) land on the entry's `fits` slot. qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") ddpm <- list(U = list(comp = diag(2))) mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), # The mock must carry the formals the production code reads off the # implementation: `methodArgs` (whose default names the per-path # Options constructor) and `dataDrivenPriorMatrices` (a wrapper-level @@ -950,7 +1155,8 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the w } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -1004,7 +1210,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the ) } -test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns one row per context", { +test_that("sumstat mvsusie TWAS returns one row per context", { ss <- .tp_makeMultiCtxQtlSumStats(contexts = c("c1", "c2")) fmr <- .tp_makeStubFineMappingResult( studyName = "s1", @@ -1014,7 +1220,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns o ) shapesSeen <- list() mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), mvsusieRssWeights = function( stat, ldReference, @@ -1035,7 +1241,8 @@ test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns o ) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -1058,15 +1265,16 @@ test_that("twasWeightsPipeline(QtlSumStats): mvsusie multivariate path returns o expect_true(shapesSeen[[1L]]$sawFit) }) -test_that("twasWeightsPipeline(QtlSumStats): mr.mash multivariate solver failure surfaces as warning + empty result", { +test_that("sumstat mr.mash TWAS: a solver failure warns, result empty", { ss <- .tp_makeMultiCtxQtlSumStats(contexts = c("c1", "c2")) mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), mrmashRssWeights = function(stat, ldReference, ...) { stop("synthetic multivariate failure") } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) # All multivariate fits fail -> no rows -> the pipeline errors out at the # end, surfacing the per-group warning along the way. expect_error( @@ -1092,7 +1300,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash multivariate solver failure ) } -test_that("twasWeightsPipeline(QtlDataset): full cache hit avoids all weight fitting", { +test_that("twasWeightsPipeline: a full cache hit fits no weights", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") cached <- TwasWeights( studyName = "study1", @@ -1103,13 +1311,14 @@ test_that("twasWeightsPipeline(QtlDataset): full cache hit avoids all weight fit ) fits <- 0L mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), list(lassoWeights = function(X, y, ...) { fits <<- fits + 1L rep(0, ncol(X)) }) ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages( twasWeightsPipeline( qd, @@ -1127,7 +1336,7 @@ test_that("twasWeightsPipeline(QtlDataset): full cache hit avoids all weight fit expect_equal(fits, 0L) # the cached entry short-circuited the fit }) -test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing methods", { +test_that("twasWeightsPipeline: a partial cache hit fits only the rest", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") # Cache covers `lasso` but `enet` is missing -> only enetWeights is called. cached <- TwasWeights( @@ -1140,7 +1349,7 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing enetCalls <- 0L lassoCalls <- 0L mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), list( lassoWeights = function(X, y, ...) { lassoCalls <<- lassoCalls + 1L @@ -1152,7 +1361,8 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing } ) ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages( twasWeightsPipeline( qd, @@ -1169,7 +1379,7 @@ test_that("twasWeightsPipeline(QtlDataset): partial cache hit fits only missing ) ) expect_setequal(methodNames(res), c("lasso", "enet")) - expect_equal(nrow(res), 2L) + expect_equal(nrow(.twasCells(res)), 2L) expect_equal(lassoCalls, 0L) # cache hit expect_equal(enetCalls, 1L) # cache miss -> fit }) @@ -1185,14 +1395,15 @@ test_that("twasWeightsPipeline(QtlSumStats): cache hit on a per-tuple basis", { ) rssCalls <- 0L mocks <- c( - list(extractBlockGenotypes = .tp_mockExtractor()), + list(.handleDosage = .tp_mockExtractor()), .tp_mockSumstatWeights() ) mocks$lassosumRssWeights <- function(stat, ldReference, ...) { rssCalls <<- rssCalls + 1L rep(0, length(stat$variantNames)) } - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -1275,7 +1486,7 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { ) } mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), mvsusieWeights = function(X, Y, mvsusieFit = NULL, ...) { mvCalls <<- mvCalls + 1L mkW(X, Y) @@ -1285,7 +1496,8 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { mkW(X, Y) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( qd, @@ -1305,8 +1517,10 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { expect_setequal(methodNames(res), c("mrmash", "mvsusie")) expect_setequal(contexts(res), c("brain", "liver")) expect_setequal(traitNames(res), "ENSG_A") - # 2 contexts x 1 trait x 2 methods, with no method overwriting the other. - expect_equal(nrow(res), 4L) + # 2 contexts x 1 trait, each holding both methods: no method overwrote + # the other. + expect_equal(nrow(res), 2L) + expect_equal(nrow(.twasCells(res)), 4L) }) context("ensembleWeights") @@ -1447,7 +1661,7 @@ test_that("ensembleWeights: multi-dataset with different methods errors", { # alternatives" below. # =========================================================================== -test_that("ensembleWeights: does not return ensemble_performance (in-sample R^2 omitted)", { +test_that("ensembleWeights omits ensemble_performance (in-sample R^2)", { cv <- makeCvResult(n = 300, K = 5, seed = 13) res <- ensembleWeights(cv, Y = cv$.y) @@ -1455,7 +1669,7 @@ test_that("ensembleWeights: does not return ensemble_performance (in-sample R^2 expect_false("ensemble_performance" %in% names(res)) }) -test_that("ensembleWeights: per-method R^2 values are sensible (between 0 and 1)", { +test_that("ensembleWeights: per-method R^2 values lie between 0 and 1", { cv <- makeCvResult(n = 200, K = 4, seed = 21) res <- ensembleWeights(cv, Y = cv$.y) @@ -1548,7 +1762,7 @@ test_that("ensembleWeights: all zero-variance methods errors", { # Weight combination (sum of zeta_k * w_k: see "Solver alternatives") # =========================================================================== -test_that("ensembleWeights: NULL twas_weight_list returns NULL ensembleTwasWeights", { +test_that("ensembleWeights: a NULL weight list gives NULL ensemble weights", { cv <- makeCvResult(n = 50, K = 3, seed = 1) res <- ensembleWeights(cv, Y = cv$.y, twasWeightList = NULL) expect_null(res$ensembleTwasWeights) @@ -1753,7 +1967,8 @@ test_that("ensembleWeights: solver='glmnet' respects alpha parameter", { expect_true(all(res_ridge$methodCoef >= 0)) expect_equal(sum(res_ridge$methodCoef), 1, tolerance = 1e-6) - # Lasso should be at least as sparse as ridge (fewer or equal non-zero coefs) + # Lasso should be at least as sparse as ridge (fewer or equal non-zero + # coefs) n_nonzero_lasso <- sum(res_lasso$methodCoef > 1e-8) n_nonzero_ridge <- sum(res_ridge$methodCoef > 1e-8) expect_true(n_nonzero_lasso <= n_nonzero_ridge) @@ -1843,7 +2058,7 @@ test_that(".twasCheckMethodCapabilities: empty token list is a no-op", { )) }) -test_that(".twasCheckMethodCapabilities: individual-only token + QtlDataset is fine", { +test_that("capability check: an individual-only token on QtlDataset is fine", { expect_silent(pecotmr:::.twasCheckMethodCapabilities( c("lasso", "enet"), "QtlDataset" @@ -1854,7 +2069,7 @@ test_that(".twasCheckMethodCapabilities: individual-only token + QtlDataset is f )) }) -test_that(".twasCheckMethodCapabilities: sumstat-only token + QtlDataset errors", { +test_that("capability check: a sumstat-only token on QtlDataset errors", { # prsCs has sumstatImpl only -- not legal for QtlDataset. expect_error( pecotmr:::.twasCheckMethodCapabilities("prsCs", "QtlDataset"), @@ -1862,7 +2077,7 @@ test_that(".twasCheckMethodCapabilities: sumstat-only token + QtlDataset errors" ) }) -test_that(".twasCheckMethodCapabilities: individual-only token + QtlSumStats errors", { +test_that("capability check: an individual-only token on QtlSumStats errors", { # dprVb has individualImpl only -- not legal for QtlSumStats. expect_error( pecotmr:::.twasCheckMethodCapabilities("dprVb", "QtlSumStats"), @@ -1870,7 +2085,7 @@ test_that(".twasCheckMethodCapabilities: individual-only token + QtlSumStats err ) }) -test_that(".twasCheckMethodCapabilities: unknown token errors with the full menu", { +test_that("capability check: an unknown token errors with the full menu", { expect_error( pecotmr:::.twasCheckMethodCapabilities("bogus", "QtlDataset"), "unknown method token" @@ -1905,7 +2120,7 @@ test_that(".twasCheckMultivariateY: mvsusie passes when traits >= 2", { )) }) -test_that(".twasCheckMultivariateY: mvsusie/mrmash error with single trait, single context", { +test_that(".twasCheckMultivariateY refuses mvsusie, mrmash on one condition", { expect_error( pecotmr:::.twasCheckMultivariateY( c("mvsusie", "mrmash"), @@ -2007,7 +2222,7 @@ test_that(".twasFineMappingFits: refuses a non-result input", { ) }) -test_that(".twasFineMappingFits: pulls matching (study,context,trait) susie fit", { +test_that(".twasFineMappingFits pulls the matching tuple's susie fit", { e_susie <- .tw_makeFmEntry("susie") e_susieInf <- .tw_makeFmEntry("susieInf") res <- QtlFineMappingResult( @@ -2062,8 +2277,8 @@ test_that(".twasFineMappingFits: ignores non-susie methods (e.g. lasso)", { context = "c1", trait = "t1" ) - # Only susie should be picked up; lasso is not in the susie/susieInf/susieAsh - # canonical menu. + # Only susie should be picked up; lasso is not in the + # susie/susieInf/susieAsh canonical menu. expect_equal(names(out), "susie") }) @@ -2090,7 +2305,7 @@ test_that(".twasRegionLabel / .twasFitsForRegion select per-region fits", { ) }) -test_that(".twasMergeRegionEntries stacks weights and builds a flat per-region CV df", { +test_that(".twasMergeRegionEntries stacks weights, builds a per-region CV", { mk <- function(vids, w, rsq) { TwasWeightsRow( variantIds = vids, @@ -2210,14 +2425,12 @@ test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { test_that("twasWeightsPipeline: per-region and joint fits span both regions", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) regions <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(c(50L, 1050L), c(1050L, 2050L)) @@ -2252,26 +2465,24 @@ test_that("twasWeightsPipeline: per-region and joint fits span both regions", { } }) -test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatenates per-region weights", { +test_that("mr.mash with jointRegions = FALSE joins per-region weights", { # One trait over two contexts is the multivariate group mr.mash fits. qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - mrmashWeights = function(X, Y, ...) { - matrix( - 0, - nrow = ncol(X), - ncol = ncol(Y), - dimnames = list(colnames(X), colnames(Y)) - ) - } - ), - list(.package = "pecotmr") - ) + mockArgs <- c( + list( + .handleDosage = .tp_mockExtractor(), + mrmashWeights = function(X, Y, ...) { + matrix( + 0, + nrow = ncol(X), + ncol = ncol(Y), + dimnames = list(colnames(X), colnames(Y)) + ) + } + ), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) regions <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(c(50L, 1050L), c(1050L, 2050L)) @@ -2307,7 +2518,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatena # handed-over methods. # =========================================================================== -test_that(".twasCvResultFor merges per-method cvResult across a tuple's entries", { +test_that(".twasCvResultFor merges each method's cvResult over a tuple", { tl <- data.frame( variant_id = "chr1:100:A:G", pip = 0.5, @@ -2376,7 +2587,7 @@ test_that(".twasCvResultFor returns NULL when no entry carries CV", { }) -test_that(".unpackMashPrior routes a MashPrior into the internal CV arguments", { +test_that(".unpackMashPrior routes a MashPrior into the CV arguments", { unpack <- pecotmr:::.unpackMashPrior U <- list(U1 = diag(2)) sp <- data.frame( @@ -2428,14 +2639,16 @@ test_that(".unpackMashPrior routes a MashPrior into the internal CV arguments", trait = "t1", method = "lasso", vid = "chr1:100:A:G", - w = 0.5 + w = 0.5, + jointContexts = NULL ) { TwasWeights( studyName = studyName, context = context, trait = trait, method = method, - entry = list(TwasWeightsRow(variantIds = vid, weights = w)) + entry = list(TwasWeightsRow(variantIds = vid, weights = w)), + jointContexts = jointContexts ) } @@ -2443,26 +2656,28 @@ test_that(".unpackMashPrior routes a MashPrior into the internal CV arguments", # .rbindTwasWeights # ----------------------------------------------------------------------------- -test_that(".rbindTwasWeights: concatenates two collections and rejects non-TwasWeights", { +test_that(".rbindTwasWeights joins two collections, refuses other classes", { out <- pecotmr:::.rbindTwasWeights( .tp_tw(method = "lasso"), .tp_tw(method = "enet") ) expect_s4_class(out, "TwasWeights") - expect_equal(nrow(out), 2L) - expect_setequal(as.character(out$method), c("lasso", "enet")) + # One gene: its two methods share a row. + expect_equal(nrow(out), 1L) + expect_setequal(methodNames(out), c("lasso", "enet")) expect_error( pecotmr:::.rbindTwasWeights(list(), .tp_tw()), "Must inherit from class 'TwasWeights'" ) }) -test_that("combineTwasWeights: variadic and list forms row-bind; guards empty/mixed", { +test_that("combineTwasWeights binds variadic and list forms; guards inputs", { tw1 <- .tp_tw(trait = "g1") tw2 <- .tp_tw(trait = "g2") tw3 <- .tp_tw(trait = "g3") expect_equal(nrow(combineTwasWeights(tw1, tw2)), 2L) # variadic - expect_equal(nrow(combineTwasWeights(list(tw1, tw2, tw3))), 3L) # single list + # single list + expect_equal(nrow(combineTwasWeights(list(tw1, tw2, tw3))), 3L) expect_equal(nrow(combineTwasWeights(tw1)), 1L) # single -> as-is expect_s4_class(combineTwasWeights(tw1, tw2), "TwasWeights") expect_error(combineTwasWeights(), "nothing to combine") @@ -2487,14 +2702,14 @@ test_that(".twasMergeRegionEntries: all-NULL entries -> NULL", { # .twasNormalizeMethods / .twasTokensFromMethodList / .twasIsMultivariateToken # ----------------------------------------------------------------------------- -test_that(".twasNormalizeMethods: a fine-mapping token without a learner gets a stub entry", { +test_that(".twasNormalizeMethods stubs a fine-mapping token with no learner", { norm <- pecotmr:::.twasNormalizeMethods(c("lasso", "fsusie")) expect_true("fsusie" %in% norm$tokens) expect_true("fsusie_weights" %in% names(norm$methodList)) expect_equal(norm$methodList$fsusie_weights, list()) }) -test_that(".twasTokensFromMethodList: unknown snake keys fall back to the bare name", { +test_that(".twasTokensFromMethodList: an unknown snake key stays bare", { toks <- pecotmr:::.twasTokensFromMethodList( list(susie_inf_weights = list(), totally_made_up_weights = list()) ) @@ -2502,7 +2717,7 @@ test_that(".twasTokensFromMethodList: unknown snake keys fall back to the bare n expect_true("totally_made_up" %in% toks) # unknown -> fallback }) -test_that(".twasIsMultivariateToken: TWAS table, FM table, and unknown tokens", { +test_that(".twasIsMultivariateToken: TWAS, FM and unknown tokens", { expect_true(pecotmr:::.twasIsMultivariateToken("mrmash")) # TWAS table expect_true(pecotmr:::.twasIsMultivariateToken("mvsusie")) # FM table expect_false(pecotmr:::.twasIsMultivariateToken("lasso")) @@ -2535,7 +2750,7 @@ test_that(".twasCvResultFor: NULL / non-FMR / no-match all return NULL", { expect_null(pecotmr:::.twasCvResultFor(fmr, "study1", "brain", "OTHER")) }) -test_that(".twasCvResultFor: a multi-region (per-region list) cvResult is unwrapped", { +test_that(".twasCvResultFor unwraps a per-region cvResult list", { sp <- data.frame( Sample = paste0("s", 1:4), Fold = rep(1:2, 2), @@ -2578,7 +2793,7 @@ test_that(".twasCvResultFor: a multi-region (per-region list) cvResult is unwrap # Ensemble stacking solver fallbacks (quadprog + lbfgsb: failure & all-zero) # ----------------------------------------------------------------------------- -test_that(".solveEnsembleQuadprog: solver failure and all-zero solution fall back to equal weights", { +test_that(".solveEnsembleQuadprog: failure or all-zero gives equal weights", { P <- matrix(rnorm(20), 10, 2) y <- rnorm(10) local_mocked_bindings( @@ -2598,7 +2813,7 @@ test_that(".solveEnsembleQuadprog: solver failure and all-zero solution fall bac expect_equal(z2, c(0.5, 0.5)) }) -test_that(".solveEnsembleLbfgsb: solver failure and all-zero solution fall back to equal weights", { +test_that(".solveEnsembleLbfgsb: failure or all-zero gives equal weights", { P <- matrix(rnorm(20), 10, 2) y <- rnorm(10) local_mocked_bindings( @@ -2680,7 +2895,7 @@ test_that("ensembleWeights: too few complete observations errors", { ) }) -test_that("ensembleWeights: only one method with signal -> it gets full weight", { +test_that("ensembleWeights: the one method with signal gets full weight", { samp <- paste0("s", 1:30) y <- rnorm(30) names(y) <- samp @@ -2701,7 +2916,7 @@ test_that("ensembleWeights: only one method with signal -> it gets full weight", expect_equal(unname(res$methodCoef[["b"]]), 0) }) -test_that("ensembleWeights: twasWeightList non-list and dimension-mismatch warnings", { +test_that("ensembleWeights warns on a non-list or mismatched twasWeightList", { samp <- paste0("s", 1:30) y <- rnorm(30) names(y) <- samp @@ -2729,20 +2944,10 @@ test_that("ensembleWeights: twasWeightList non-list and dimension-mismatch warni "empty or not a list" ) expect_null(r1$ensembleTwasWeights) - # Mismatched dims across method weight matrices -> warn + skip that method. + # Unnamed weights of another shape cannot be aligned: warn + skip. wl <- list( - a_weights = matrix( - 0.1, - 3, - 1, - dimnames = list(sprintf("chr1:%d:A:G", 100L * (1:3)), NULL) - ), - b_weights = matrix( - 0.1, - 2, - 1, - dimnames = list(sprintf("chr1:%d:A:G", 100L * (1:2)), NULL) - ) + a_weights = matrix(0.1, 3, 1), + b_weights = matrix(0.1, 2, 1) ) expect_warning( ensembleWeights( @@ -2752,6 +2957,63 @@ test_that("ensembleWeights: twasWeightList non-list and dimension-mismatch warni ), "inconsistent dimensions" ) + # Named weights on other variants are refused. + ids <- sprintf("chr1:%d:A:G", 100L * (1:3)) + named <- list( + a_weights = matrix(0.1, 3, 1, dimnames = list(ids, NULL)), + b_weights = matrix(0.1, 2, 1, dimnames = list(ids[1:2], NULL)) + ) + expect_error( + ensembleWeights( + cvResults = list(prediction = pb), + Y = y, + twasWeightList = named + ), + "on other variants" + ) +}) + +test_that("ensembleWeights adds methods' weights by variant, not position", { + samp <- paste0("s", 1:30) + set.seed(4) + y <- set_names(rnorm(30), samp) + pb <- list( + a_predicted = matrix( + y + rnorm(30, sd = .3), + 30, + 1, + dimnames = list(samp, NULL) + ), + b_predicted = matrix( + y + rnorm(30, sd = .5), + 30, + 1, + dimnames = list(samp, NULL) + ) + ) + ids <- sprintf("chr1:%d:A:G", 100L * (1:3)) + wa <- set_names(c(1, 2, 3), ids) + wb <- set_names(c(10, 20, 30), ids) + inOrder <- ensembleWeights( + cvResults = list(prediction = pb), + Y = y, + twasWeightList = list(a_weights = wa, b_weights = wb) + ) + reordered <- ensembleWeights( + cvResults = list(prediction = pb), + Y = y, + twasWeightList = list(a_weights = wa, b_weights = rev(wb)) + ) + expect_identical( + reordered$ensembleTwasWeights, + inOrder$ensembleTwasWeights + ) + expect_named(inOrder$ensembleTwasWeights, ids) + zeta <- inOrder$methodCoef + expect_equal( + unname(inOrder$ensembleTwasWeights), + unname(zeta[["a"]] * wa + zeta[["b"]] * wb) + ) }) # ----------------------------------------------------------------------------- @@ -2787,16 +3049,14 @@ test_that("QtlDataset: CrossValidationParam(fitFullData) reaches the engine", { expect_null(cfg$fitFullData) }) -test_that("twasWeightsPipeline(QtlDataset): mashPrior with no mrmash warns and is ignored", { +test_that("a mashPrior without mrmash warns and is ignored", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) expect_warning( suppressMessages(twasWeightsPipeline( qd, @@ -2812,12 +3072,12 @@ test_that("twasWeightsPipeline(QtlDataset): mashPrior with no mrmash warns and i ) }) -test_that("twasWeightsPipeline(QtlDataset): mashPrior full prior is threaded into mr.mash args", { +test_that("a full mashPrior reaches mr.mash's arguments", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") ddpm <- list(U = list(comp = diag(2))) captured <- NULL local_mocked_bindings( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), mrmashWeights = function(X, Y, ...) { dots <- list(...) captured <<- dots$dataDrivenPriorMatrices @@ -2843,25 +3103,24 @@ test_that("twasWeightsPipeline(QtlDataset): mashPrior full prior is threaded int expect_identical(captured, ddpm) }) -test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso both run", { +test_that("jointSpec mr.mash and univariate lasso both run", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") jointRes <- .tp_tw( studyName = "study1", context = "brain", trait = "ENSG_A", - method = "mrmash" + method = "mrmash", + jointContexts = "brain,liver" ) - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - .twasDispatchJointSpecsQtlDataset = function(...) jointRes - ), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list( + .handleDosage = .tp_mockExtractor(), + .twasDispatchJointSpecsQtlDataset = function(...) jointRes + ), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( qd, methods = c("mrmash", "lasso"), @@ -2873,20 +3132,19 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec mr.mash + univariate lasso ensembleParam = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") - expect_true("mrmash" %in% as.character(res$method)) # from jointResult - expect_true("lasso" %in% as.character(res$method)) # from per-tuple loop -}) - -test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", { - qd <- .tp_makeQtlDataset(contexts = "brain", traits = c("ENSG_A", "ENSG_B")) # @1000, @2000 - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) + expect_true("mrmash" %in% methodNames(res)) # from jointResult + expect_true("lasso" %in% methodNames(res)) # from per-tuple loop +}) + +test_that("twasWeightsPipeline's region selects overlapping traits", { + # @1000, @2000 + qd <- .tp_makeQtlDataset(contexts = "brain", traits = c("ENSG_A", "ENSG_B")) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(900, 1600)) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( qd, @@ -2904,25 +3162,23 @@ test_that("twasWeightsPipeline(QtlDataset): region selects overlapping traits", # twasWeightsPipeline(QtlSumStats): remaining branches # ----------------------------------------------------------------------------- -test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS preset", { +test_that("sumstat TWAS: NULL methods uses the default RSS preset", { ss <- .tp_makeQtlSumStats() - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - prsCsWeights = function(stat, ldReference, ...) { - rep(0, length(stat$variantNames)) - } - ), - # .tp_mockSumstatWeights() already mocks sdprWeights. Passing a - # binding to local_mocked_bindings() twice makes it record the - # first mock as the "original", so unwinding restores the mock - # instead of the real function and it leaks for the session. - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) - ) + mockArgs <- c( + list( + .handleDosage = .tp_mockExtractor(), + prsCsWeights = function(stat, ldReference, ...) { + rep(0, length(stat$variantNames)) + } + ), + # .tp_mockSumstatWeights() already mocks sdprWeights. Passing a + # binding to local_mocked_bindings() twice makes it record the + # first mock as the "original", so unwinding restores the mock + # instead of the real function and it leaks for the session. + .tp_mockSumstatWeights(), + list(.package = "pecotmr") + ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = NULL, verbose = 0) )) @@ -2930,16 +3186,14 @@ test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS p expect_setequal(methodNames(res), c("lasso", "prsCs", "dprGibbs")) }) -test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type", { +test_that("sumstat TWAS: named-list methods, and an invalid type", { ss <- .tp_makeQtlSumStats() - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline( ss, @@ -2967,39 +3221,35 @@ test_that("twasWeightsPipeline(QtlSumStats): trait selects matching rows", { ldReference = .tp_makeHandle(snp_n = 20L), qcOptions = list(step1 = "ok") ) - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = "lasso", traitId = "t2", verbose = 0) )) expect_equal(as.character(res$trait), "t2") expect_equal(as.character(res$context), "c1") - expect_equal(as.character(res$method), "lasso") + expect_equal(methodNames(res), "lasso") }) -test_that("twasWeightsPipeline(QtlSumStats): multivariate mr.mash returns a column per context", { +test_that("sumstat multivariate mr.mash returns a column per context", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # 2 contexts of (s1, t1) - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - mrmashRssWeights = function(stat, ldReference, ...) { - k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L - ids <- stat$variantNames - matrix(0, length(ids), k, dimnames = list(ids, NULL)) - } - ), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list( + .handleDosage = .tp_mockExtractor(), + mrmashRssWeights = function(stat, ldReference, ...) { + k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L + ids <- stat$variantNames + matrix(0, length(ids), k, dimnames = list(ids, NULL)) + } + ), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = "mrmash", verbose = 0) )) @@ -3007,7 +3257,7 @@ test_that("twasWeightsPipeline(QtlSumStats): multivariate mr.mash returns a colu expect_equal(nrow(res), 2L) # one row per context }) -test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fineMappingResult errors", { +test_that("sumstat TWAS errors on an FM method absent from the FM result", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # A fine-mapping result that does NOT contain an mvsusie fit (only susie). fmr <- .tp_makeStubFineMappingResult( @@ -3041,9 +3291,9 @@ test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fin MultiStudyQtlDataset(qtlDatasets = list(study1 = qd), sumStats = ss) } -test_that("twasWeightsPipeline(MultiStudyQtlDataset): per-study options are not dropped", { +test_that("multi-study TWAS keeps per-study options", { # residualization and fit retention were declared on the multi-study - # method and never reached .twasMsCfg's config, and the + # method and never reached the record its components run with, and the # QtlDataset-only options rode `...` into the embedded QtlSumStats call. cap <- new.env(parent = emptyenv()) local_mocked_bindings( @@ -3139,13 +3389,13 @@ test_that("MultiStudyQtlDataset takes every component argument", { expect_equal( setdiff( ms, - c(.cfgFieldNames(".twasMsCfg"), "jointSpecification") + c(.cfgFieldNames(".twasPipelineMultiStudy"), "jointSpecification") ), character(0) ) }) -test_that("twasWeightsPipeline(MultiStudyQtlDataset): a misspelled option errors", { +test_that("multi-study TWAS errors on a misspelled option", { # The method no longer takes `...`, so a typo cannot be swallowed. expect_error( twasWeightsPipeline( @@ -3158,15 +3408,13 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): a misspelled option errors }) test_that("twasWeightsPipeline(MSQD) rbinds both, lays cisWindow on sumstats", { - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( .tp_makeMultiStudy(), methods = "lasso", @@ -3199,7 +3447,7 @@ test_that("twasWeightsPipeline(MSQD) rbinds both, lays cisWindow on sumstats", { ) }) -test_that("twasWeightsPipeline(MultiStudyQtlDataset): region + cisWindow is rejected", { +test_that("multi-study TWAS refuses region with cisWindow", { mt <- .tp_makeMultiStudy() expect_error( twasWeightsPipeline( @@ -3215,15 +3463,13 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): region + cisWindow is reje test_that("twasWeightsPipeline(MultiStudy): trait selection skips a study", { # A trait vector applies to every component: one carrying none of the # traits sits out, and the run is refused only when none carries any. - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) mt <- .tp_makeMultiStudy() fit <- function(traitId) { suppressMessages(twasWeightsPipeline( @@ -3246,13 +3492,14 @@ test_that("twasWeightsPipeline(MultiStudy): trait selection skips a study", { ) }) -test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec-only mr.mash returns the joint result", { +test_that("multi-study jointSpec-only mr.mash returns the joint result", { mt <- .tp_makeMultiStudy() jointRes <- .tp_tw( studyName = "s1", context = "c1", trait = "t1", - method = "mrmash" + method = "mrmash", + jointContexts = "c1,c2" ) local_mocked_bindings( .twasDispatchJointSpecsMultiStudy = function(...) jointRes, @@ -3269,30 +3516,29 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec-only mr.mash ret verbose = 0 ))) expect_true(is(res, "TwasWeights"), info = info) - expect_equal(unique(as.character(res$method)), "mrmash", info = info) + expect_equal(methodNames(res), "mrmash", info = info) } }) -test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univariate lasso are combined", { +test_that("multi-study TWAS combines jointSpec mr.mash and univariate lasso", { mt <- .tp_makeMultiStudy() jointRes <- .tp_tw( studyName = "s1", context = "c1", trait = "t1", - method = "mrmash" + method = "mrmash", + jointContexts = "c1,c2" ) - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - .twasDispatchJointSpecsMultiStudy = function(...) jointRes - ), - .tp_mockIndividualWeights(), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list( + .handleDosage = .tp_mockExtractor(), + .twasDispatchJointSpecsMultiStudy = function(...) jointRes + ), + .tp_mockIndividualWeights(), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( mt, methods = c("mrmash", "lasso"), @@ -3304,8 +3550,8 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univar ensembleParam = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") - expect_true("mrmash" %in% as.character(res$method)) - expect_true("lasso" %in% as.character(res$method)) + expect_true("mrmash" %in% methodNames(res)) + expect_true("lasso" %in% methodNames(res)) }) # =========================================================================== @@ -3323,7 +3569,7 @@ test_that(".twasCheckFineMappingMethods: empty token list is a no-op", { )) }) -test_that(".twasCvResultFor: an entry whose nested CV carries no partition is skipped", { +test_that(".twasCvResultFor skips an entry whose CV has no partition", { nested <- list( region1 = list(prediction = list(susie_predicted = matrix(0, 1, 1))) ) @@ -3343,7 +3589,7 @@ test_that(".twasCvResultFor: an entry whose nested CV carries no partition is sk expect_null(pecotmr:::.twasCvResultFor(fmr, "S", "c1", "t1")) }) -test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash-only with no fits errors", { +test_that("sumstat jointSpec mr.mash-only with no fits errors", { ss <- .tp_makeQtlSumStats() local_mocked_bindings( .twasDispatchJointSpecsQtlSumStats = function(...) NULL, @@ -3359,33 +3605,32 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash-only with no fits ) }) -test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lasso combine", { +test_that("sumstat TWAS combines jointSpec mr.mash and univariate lasso", { ss <- .tp_makeQtlSumStats() jointRes <- .tp_tw( studyName = "s1", context = "c1", trait = "t1", - method = "mrmash" + method = "mrmash", + jointContexts = "c1,c2" ) - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - .twasDispatchJointSpecsQtlSumStats = function(...) jointRes - ), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list( + .handleDosage = .tp_mockExtractor(), + .twasDispatchJointSpecsQtlSumStats = function(...) jointRes + ), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( ss, methods = c("mrmash", "lasso"), jointSpecification = "context", verbose = 0 ))) - expect_true("mrmash" %in% as.character(res$method)) # from the joint result - expect_true("lasso" %in% as.character(res$method)) # from the per-tuple loop + expect_true("mrmash" %in% methodNames(res)) # from the joint result + expect_true("lasso" %in% methodNames(res)) # from the per-tuple loop }) test_that("twasWeightsPipeline(QtlSumStats): mr.mash skips 1-context traits", { @@ -3402,7 +3647,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash skips 1-context traits", { qcOptions = list(step1 = "ok") ) local_mocked_bindings( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), mrmashRssWeights = function(stat, ldReference, ...) { k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L ids <- stat$variantNames @@ -3416,7 +3661,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash skips 1-context traits", { expect_setequal(traitNames(res), "t1") # only t1 }) -test_that("twasWeightsPipeline(QtlSumStats): a mismatched SNP order in a multivariate group errors", { +test_that("sumstat TWAS errors on mismatched SNP order in a joint group", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # (s1, t1) x 2 ctx calls <- 0L local_mocked_bindings( @@ -3459,7 +3704,7 @@ test_that("ensembleWeights: partial sample overlap emits a message", { ) }) -test_that("ensembleWeights: contextIndex beyond Y matrix columns errors (named path)", { +test_that("ensembleWeights errors on a contextIndex past Y's columns", { samp <- paste0("s", 1:30) pb <- list( a_predicted = matrix(rnorm(30), 30, 1, dimnames = list(samp, NULL)), @@ -3476,7 +3721,7 @@ test_that("ensembleWeights: contextIndex beyond Y matrix columns errors (named p ) }) -test_that("ensembleWeights: vector (non-matrix) method weights are coerced to a column", { +test_that("ensembleWeights makes a method's weight vector a column", { samp <- paste0("s", 1:30) y <- rnorm(30) names(y) <- samp @@ -3507,7 +3752,7 @@ test_that("ensembleWeights: vector (non-matrix) method weights are coerced to a expect_length(res$ensembleTwasWeights, 3L) }) -test_that(".solveEnsembleNnls: solver failure and all-zero fall back to equal weights", { +test_that(".solveEnsembleNnls: failure or all-zero gives equal weights", { skip_if_not_installed("nnls") P <- matrix(rnorm(20), 10, 2) y <- rnorm(10) @@ -4103,11 +4348,18 @@ test_that("an entry must come from that method's constructor for that path", { TwasWeightsMethodsParam(qtlDatasetMethods = list(lasso = QggOptions())), "uses the 'glmnet' constructor" ) + # A method with several backends takes any of their constructors. expect_error( TwasWeightsMethodsParam( qtlDatasetMethods = list(bayesA = GlmnetOptions()) ), - "uses the 'qgg' constructor" + "uses the 'qgg' or 'hibayes' constructor" + ) + expect_s4_class( + TwasWeightsMethodsParam( + qtlDatasetMethods = list(bayesA = HibayesOptions()) + ), + "TwasWeightsMethodsParam" ) }) @@ -4146,29 +4398,45 @@ test_that("each path takes that path's own constructor", { ) }) -test_that("twasWeightsPipeline: fitRetention='full' says so when unhonourable", { - # Few methods distinguish the levels; for every other method "full" was - # silently indistinguishable from "slim". On individual-level data only - # mr.mash does. +test_that("a fine-mapping method's TWAS rows keep none of its fit", { + # Its weights are extracted from the fineMappingResult's fit; a row + # keeping it too held a second copy per (gene, context). + for (tk in c("susie", "susieInf", "susieAsh", "mvsusie", "fsusie")) { + expect_identical(pecotmr:::.twasRowRetention(tk, "full"), "none") + } + expect_identical(pecotmr:::.twasRowRetention("lasso", "full"), "full") + expect_identical(pecotmr:::.twasRowRetention(NULL, "slim"), "slim") + # The joint engine's floor (it keeps its fits) yields to the same rule. + cfg <- list(fitRetention = "none") + expect_identical(pecotmr:::.jointRetentionLevel(cfg, "mvsusie"), "none") + expect_identical(pecotmr:::.jointRetentionLevel(cfg, "mrmash"), "slim") +}) + +test_that("twasWeightsPipeline says when fitRetention = 'full' can't be kept", { + # Not every method distinguishes the levels; for the rest "full" would be + # silently indistinguishable from "slim". The SuSiE family keeps no fit + # on its rows either way: the fine-mapping result holds it. expect_error( twasWeightsPipeline( .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A"), - methods = "lasso", + methods = "susie", fitRetention = "full" ), - "honoured on QtlDataset input only by mrmash" + "honoured on QtlDataset input only by mrmash, lasso" ) - # A mixed run warns and proceeds -- mr.mash honours "full", lasso does - # not. Asserted on the rule itself: driving it through the pipeline would - # also need mr.mash mocked, which tests the mock rather than the rule. + # A mixed run warns and proceeds -- lasso honours "full", susie does not. + # Asserted on the rule itself: driving it through the pipeline would also + # need a fine-mapping result, which tests the fixture rather than the rule. warnFull <- pecotmr:::.twasWarnUnretainableDetail expect_warning( - warnFull("full", c("lasso", "mrmash"), "QtlDataset"), - "lasso retain their usual fit" + warnFull("full", c("susie", "lasso"), "QtlDataset"), + "susie retain their usual fit" + ) + expect_silent( + warnFull("full", c("lasso", "mrmash", "bayesR", "mrash"), "QtlDataset") ) - expect_silent(warnFull("full", "mrmash", "QtlDataset")) - expect_silent(warnFull("slim", "lasso", "QtlDataset")) - expect_silent(warnFull("none", "lasso", "QtlDataset")) + expect_silent(warnFull("slim", "susie", "QtlDataset")) + expect_silent(warnFull("none", "susie", "QtlDataset")) # On summary statistics the shrinkage-grid methods keep their candidate # coefficients at "full"; PRS-CS keeps the same fit either way. expect_silent(warnFull("full", c("lasso", "scad"), "QtlSumStats")) @@ -4191,7 +4459,7 @@ test_that("twasWeightsPipeline(QtlSumStats) hands its fitRetention down", { ss <- .tp_makeQtlSumStats() seen <- new.env(parent = emptyenv()) local_mocked_bindings( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), lassosumRssWeights = function( stat, ldReference, @@ -4283,14 +4551,12 @@ test_that("twasWeightsPipeline(QtlDataset): usePCA adds top-PC rows", { contexts = "brain", traits = c("ENSG_A", "ENSG_B") ) - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) withPc <- suppressMessages(suppressWarnings(twasWeightsPipeline( qd, methods = "lasso", @@ -4309,7 +4575,7 @@ test_that("twasWeightsPipeline(QtlDataset): usePCA adds top-PC rows", { expect_true(all(is_in(c("ENSG_A", "ENSG_B"), pcs))) }) -test_that("a multivariate method needs every MultiStudy component multivariate", { +test_that("a multivariate method needs every study to be multivariate", { # mvsusie / mr.mash / fsusie fit one model across a tuple's traits and # contexts, so each component they run on must supply a multivariate Y. uni <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") @@ -4388,22 +4654,20 @@ test_that("twasWeightsPipeline: multivariate resume is all-or-nothing", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # 2 contexts of (s1, t1) calls <- new.env(parent = emptyenv()) calls$n <- 0L - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - mrmashRssWeights = function(stat, ldReference, ...) { - calls$n <- calls$n + 1L - k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L - ids <- stat$variantNames - matrix(0, length(ids), k, dimnames = list(ids, NULL)) - } - ), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list( + .handleDosage = .tp_mockExtractor(), + mrmashRssWeights = function(stat, ldReference, ...) { + calls$n <- calls$n + 1L + k <- if (is.matrix(stat$z)) ncol(stat$z) else 1L + ids <- stat$variantNames + matrix(0, length(ids), k, dimnames = list(ids, NULL)) + } + ), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) # Cold run: one joint fit spans both contexts of the group. cold <- suppressMessages(suppressWarnings( @@ -4481,30 +4745,26 @@ test_that("a summary-statistics run records the standardized scale itself", { twasWeightsPipeline(ss, methods = "lasso", weightStandardized = FALSE), "unused argument" ) - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = "lasso", verbose = 0) )) - expect_true(all(as.logical(S4Vectors::mcols(res)$standardized))) + expect_true(all(map_lgl(.collectionEntries(res), weightStandardized))) }) test_that("twasWeightsPipeline(QtlDataset) records the accessor's scale", { qd <- .tp_makeQtlDataset(traits = "ENSG_A") - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) recorded <- function(...) { res <- suppressMessages(suppressWarnings(twasWeightsPipeline( qd, @@ -4515,7 +4775,7 @@ test_that("twasWeightsPipeline(QtlDataset) records the accessor's scale", { crossValidationParam = CrossValidationParam(folds = 0), residualizationParam = ResidualizationParam(...) ))) - unique(as.logical(S4Vectors::mcols(res)$standardized)) + unique(map_lgl(.collectionEntries(res), weightStandardized)) } # Derived, not declared: by default genotypes are standardized on the way # to every fitter, so there is nothing for a caller to say ... @@ -4684,14 +4944,12 @@ test_that("a multivariate TWAS group refuses contexts on two LD references", { }) test_that("twasWeightsPipeline(QtlSumStats) lays a cisWindow around traitPos", { - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) # The entry's variants sit every 100 bp from chr1:100 to chr1:800 and the # trait at chr1:400, so the fit keeps the variants within `cisWindow` of # it; with no window it keeps them all. @@ -4734,14 +4992,12 @@ test_that("twasWeightsPipeline(QtlSumStats) lays a cisWindow around traitPos", { }) test_that("twasWeightsPipeline(QtlSumStats) records traitPos and its window", { - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockSumstatWeights(), - list(.package = "pecotmr") - ) + mockArgs <- c( + list(.handleDosage = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") ) + exec(local_mocked_bindings, !!!mockArgs) # A per-tuple fit's row carries its input's trait position and the window # the cisWindow laid around it, as a joint fit's row does. ss <- .tp_makeQtlSumStats(traitPos = GenomicRanges::GRanges("chr1:400")) @@ -4790,13 +5046,14 @@ test_that("twasWeightsPipeline refuses a phenotype QC its fits cannot take", { # The stub fine-mapping result with its rows narrowed to two of their three # variants. A row is narrowed when it holds fewer variants than its fit has, -# so the stub fits carry the PIPs of all three. +# so the stub fits, which the rows key into the fits dictionary, carry the +# PIPs of all three. .tp_narrowedFineMapping <- function(...) { x <- .tp_makeStubFineMappingResult(...) - x$susieFit <- S4Vectors::SimpleList(map( - as.list(x$susieFit), + methods::slot(x, "fits") <- map( + x@fits, function(fit) c(fit, list(pip = c(0.9, 0.5, 0.1))) - )) + ) endoapply(x, utils::head, 2L) } @@ -4879,7 +5136,7 @@ test_that("enet and ridge are registered for both input kinds", { test_that("the enet mixing reaches the individual-level wrapper", { seen <- NULL mocks <- list( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), enetWeights = function( X, y, @@ -4890,7 +5147,8 @@ test_that("the enet mixing reaches the individual-level wrapper", { rep(0, ncol(X)) } ) - exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + mockArgs <- c(mocks, list(.package = "pecotmr")) + exec(local_mocked_bindings, !!!mockArgs) res <- suppressMessages(twasWeightsPipeline( .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A"), methods = list(enet = list(alpha = 0.3)), @@ -4906,12 +5164,18 @@ test_that("the enet mixing reaches the individual-level wrapper", { test_that("enet and ridge run on summary statistics, alpha set per method", { local_mocked_bindings( - extractBlockGenotypes = .tp_mockExtractor(), + .handleDosage = .tp_mockExtractor(), .package = "pecotmr" ) + # Each method draws its own held-out splits, so the lasso and the + # alpha = 1 elastic net are compared under a deterministic selection. res <- suppressMessages(suppressWarnings(twasWeightsPipeline( .tp_makeQtlSumStats(), - methods = list(lasso = list(), enet = list(alpha = 1), ridge = list()), + methods = list( + lasso = list(selection = "minFbeta"), + enet = list(alpha = 1, selection = "minFbeta"), + ridge = list() + ), verbose = 0 ))) expect_setequal(methodNames(res), c("lasso", "enet", "ridge")) @@ -4922,3 +5186,22 @@ test_that("enet and ridge run on summary statistics, alpha set per method", { expect_equal(as.numeric(rowOf("enet")), as.numeric(rowOf("lasso"))) expect_true(all(rowOf("ridge") != 0)) }) + +test_that("an alphabet method's plain options are built for its backend", { + # A method with several engines has no single constructor to read off its + # signature, so the leftover options take its backend's. + split <- pecotmr:::.splitMethodArgs( + "bayesRWeights", + list(nIter = 10, nub = 5) + ) + expect_equal(split$nIter, 10) + expect_equal(S4Vectors::metadata(split$methodArgs)$engine, "qgg") + skip_if_not_installed("hibayes") + split <- pecotmr:::.splitMethodArgs( + "bayesRWeights", + list(backend = "hibayes", dfvg = 5) + ) + expect_equal(split$backend, "hibayes") + expect_equal(S4Vectors::metadata(split$methodArgs)$engine, "hibayes") + expect_equal(split$methodArgs$dfvg, 5) +}) diff --git a/tests/testthat/test_twasWeightsRow.R b/tests/testthat/test_twasWeightsRow.R index 8c6e5741d..601ad6edc 100644 --- a/tests/testthat/test_twasWeightsRow.R +++ b/tests/testthat/test_twasWeightsRow.R @@ -26,33 +26,19 @@ test_that("TwasWeightsRow: constructor and accessors round-trip", { .twrPartsVariantIds(e), c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") ) - expect_equal(weights(e), c(0.1, -0.2, 0.05)) + # Named by the row's variants, whose ids the row holds once; the stored + # weights carry no copy of them. + expect_equal( + weights(e), + set_names(c(0.1, -0.2, 0.05), .twrPartsVariantIds(e)) + ) + expect_null(names(S4Vectors::mcols(e@variants)$weight)) expect_equal(methodFits(e), list(model = "lasso")) expect_equal(cvResult(e), list(rsq = 0.4)) expect_true(isTRUE(weightStandardized(e))) expect_equal(weightsDataType(e), "expression") }) -test_that("TwasWeightsRow: resolveWeights returns the aligned (variantIds, weights) pair", { - e <- TwasWeightsRow( - variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), - weights = c(0.1, -0.2, 0.05) - ) - wr <- .twrRowResolveWeights(e) - expect_equal( - wr$variantIds, - c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") - ) - expect_equal(wr$weights, c(0.1, -0.2, 0.05)) - # length mismatch (defensive) -> empty - e2 <- TwasWeightsRow( - variantIds = c("chr1:100:A:G", "chr1:200:A:G"), - weights = c(0.1, -0.2) - ) - e2@weights <- matrix(0, 2, 2) # flattens to length 4 != 2 ids - expect_length(.twrRowResolveWeights(e2)$variantIds, 0L) -}) - test_that("TwasWeightsRow: standardized is coerced via isTRUE() semantics", { # isTRUE() only returns TRUE for a length-1 logical TRUE. Non-TRUE @@ -161,3 +147,69 @@ test_that("an empty variant set is allowed", { expect_s4_class(e, "TwasWeightsRow") expect_equal(length(.twrPartsVariantIds(e)), 0L) }) + +# =========================================================================== +# The variants a stored fit was made on +# =========================================================================== + +.twr_ids <- c("chr1:100:A:G", "chr1:200:C:T") + +test_that("a fit's variants are read where its engine names them", { + f <- pecotmr:::.twasFitVariantIds + named <- set_names(c(0.1, 0.2), .twr_ids) + path <- matrix(0, 2L, 3L, dimnames = list(.twr_ids, NULL)) + geno <- matrix(0, 3L, 2L, dimnames = list(NULL, .twr_ids)) + expect_equal(f(list(coef = c(0.1, 0.2), variantIds = .twr_ids)), .twr_ids) + # glmnet's path, ncvreg's past its intercept, qgg's and BGLR's effects. + expect_equal(f(list(glmnet.fit = list(beta = path))), .twr_ids) + intercept <- matrix(0, 1L, 3L, dimnames = list("(Intercept)", NULL)) + expect_equal(f(list(fit = list(beta = rbind(intercept, path)))), .twr_ids) + expect_equal(f(list(bm = named)), .twr_ids) + expect_equal(f(list(ETA = list(list(b = named)))), .twr_ids) + # mr.ash's and DPR's copies of the genotypes, a SuSiE fit's names. + expect_equal(f(list(data = list(X = geno))), .twr_ids) + expect_equal(f(list(x = geno)), .twr_ids) + expect_equal(f(list(pip = named)), .twr_ids) + # A row joined from regions: each region's variants in turn. + regions <- list( + r1 = list(variantIds = .twr_ids[[1L]]), + r2 = list(variantIds = .twr_ids[[2L]]) + ) + expect_equal(f(regions), .twr_ids) + # Nothing names them, or there is no fit. + expect_equal(f(list(coef = c(0.1, 0.2))), character(0)) + expect_equal(f(NULL), character(0)) +}) + +test_that("a kept fit takes the variant ids only when it names none", { + g <- pecotmr:::.withFitVariantIds + expect_equal(g(list(coef = c(0.1, 0.2)), .twr_ids)$variantIds, .twr_ids) + # One that already names them keeps its own names alone. + named <- list(pip = set_names(c(0.1, 0.9), .twr_ids)) + expect_identical(g(named, rev(.twr_ids)), named) + expect_null(g(NULL, .twr_ids)) + expect_identical(g(list(coef = 1), NULL), list(coef = 1)) + # An engine's class survives the addition. + classed <- structure(list(coef = c(0.1, 0.2)), class = "someEngineFit") + expect_s3_class(g(classed, .twr_ids), "someEngineFit") + # On weights, only a fit they carry is touched. + w <- `attr<-`(c(0.1, 0.2), "fit", list(coef = c(0.1, 0.2))) + expect_equal( + attr(pecotmr:::.withWeightsFitIds(w, .twr_ids), "fit")$variantIds, + .twr_ids + ) + expect_identical( + pecotmr:::.withWeightsFitIds(c(0.1, 0.2), .twr_ids), + c(0.1, 0.2) + ) +}) + +test_that("updateObject() drops a row's saved fitVariants slot", { + row <- TwasWeightsRow(.twr_ids, c(0.1, 0.2)) + saved <- `attr<-`(row, "fitVariants", .twr_ids) + up <- updateObject(saved) + expect_null(attr(up, "fitVariants", exact = TRUE)) + expect_identical(up, row) + expect_identical(updateObject(row), row) + expect_message(updateObject(row, verbose = TRUE), "TwasWeightsRow") +}) diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index 0e8f6f057..95f8de917 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -72,7 +72,7 @@ test_that("parseVariantId: a chrom/pos/A2/A1 frame is read in UCSC style", { expect_equal(attr(res, "convention")$hasChr, TRUE) }) -test_that("parseVariantId: data.frame input with >=4 columns assigns positional names", { +test_that("parseVariantId names a 4+ column data frame's columns by position", { df <- data.frame( c1 = "1", c2 = "100", @@ -94,7 +94,7 @@ test_that("parseVariantId: data.frame input with >=4 columns assigns positional # .repairVariantIds # =========================================================================== -test_that(".repairVariantIds: rebuilds a tag-allele id from the allele columns", { +test_that(".repairVariantIds rebuilds a tag-allele id from allele columns", { ids <- c("chr21:13988152:INS:T", "chr21:13988153:DEL:T") expect_equal( pecotmr:::.repairVariantIds(ids, A2 = c("A", "GT"), A1 = c("AT", "G")), @@ -127,7 +127,7 @@ test_that(".repairVariantIds: preserves the ids' own naming convention", { ) }) -test_that(".repairVariantIds: keeps the id when the alleles cannot replace it", { +test_that(".repairVariantIds keeps an id the alleles cannot replace", { ids <- c("chr1:100:INS:T", "chr1:200:INS:T", "chr1:300:INS:T") expect_equal( pecotmr:::.repairVariantIds( @@ -469,7 +469,7 @@ test_that("matchVariants takes GRanges of variants", { ) }) -test_that("matchVariants matches non-autosomal variants (chrX, chr23 synonym)", { +test_that("matchVariants matches non-autosomal variants (chrX as chr23)", { m <- pecotmr:::matchVariants( c("chrX:100:A:G", "chr23:200:C:T"), c("X:100:A:G", "X:200:C:T") @@ -518,7 +518,7 @@ test_that("matchVariants accepts data.frame (chrom/pos/A2/A1) input", { expect_equal(m$sign, 1) }) -test_that("matchVariants allowFlip = FALSE matches exact alleles only (no swap)", { +test_that("matchVariants(allowFlip = FALSE) matches exact alleles only", { # chr-prefix / separator still reconcile ... m1 <- pecotmr:::matchVariants( "chr1:100:A:G", @@ -566,7 +566,7 @@ test_that("harmonizeAlleles warns and returns empty when nothing overlaps", { expect_equal(attr(res, "qcCounts")$considered, 0L) }) -test_that("harmonizeAlleles removeUnmatched = FALSE retains unmatched target variants", { +test_that("harmonizeAlleles(removeUnmatched = FALSE) keeps unmatched rows", { tgt <- .vid_df(c("1", "1"), c(100, 200), c("A", "A"), c("G", "G")) res <- pecotmr:::harmonizeAlleles( tgt, @@ -603,7 +603,7 @@ test_that("harmonizeAlleles complements colToComplement on an allele swap", { expect_equal(res$harmonizedData$z, -2) }) -test_that("harmonizeAlleles errors when colToFlip / colToComplement are absent", { +test_that("harmonizeAlleles errors without colToFlip or colToComplement", { tgt <- .vid_df("1", 100, "A", "G") expect_error( pecotmr:::harmonizeAlleles( @@ -637,7 +637,7 @@ test_that("harmonizeAlleles errors when too few variants clear matchMinProp", { ) }) -test_that("harmonizeAlleles errors on duplicate variant IDs when removeDups = FALSE", { +test_that("harmonizeAlleles errors on duplicate ids when removeDups = FALSE", { tgt <- .vid_df(c("1", "1"), c(100, 100), c("A", "A"), c("G", "G")) expect_error( pecotmr:::harmonizeAlleles( @@ -649,7 +649,7 @@ test_that("harmonizeAlleles errors on duplicate variant IDs when removeDups = FA ) }) -test_that("harmonizeAlleles removeDups = TRUE drops duplicates with a warning", { +test_that("harmonizeAlleles(removeDups = TRUE) drops duplicates, warning", { tgt <- .vid_df(c("1", "1"), c(100, 100), c("A", "A"), c("G", "G")) expect_warning( res <- pecotmr:::harmonizeAlleles( @@ -825,7 +825,8 @@ test_that("harmonizeAlleles: strips a conflicting variant_id from target", { matchMinProp = 0 ) expect_equal(nrow(res$harmonizedData), 2L) - # The input variant_id was stripped; the returned id is rebuilt from QC'd alleles. + # The input variant_id was stripped; the returned id is rebuilt from QC'd + # alleles. expect_false(any(c("old1", "old2") %in% res$harmonizedData$variant_id)) }) @@ -939,8 +940,8 @@ test_that(".ucscRanges merges two spellings of one chromosome", { expect_identical(unname(GenomeInfoDb::genome(out)), c("hg38", "hg38")) }) -test_that(".ucscEntries renames every element and keeps a NULL one", { - out <- pecotmr:::.ucscEntries(list( +test_that(".canonEntries renames every element and keeps a NULL one", { + out <- pecotmr:::.canonEntries(list( a = GenomicRanges::GRanges("22", IRanges::IRanges(1L, width = 1L)), b = NULL )) @@ -949,6 +950,39 @@ test_that(".ucscEntries renames every element and keeps a NULL one", { expect_null(out$b) }) +test_that("alleles enter in upper case; labels keep their spelling", { + # A lowercase allele column made a row's id disagree with its alleles once + # harmonization uppercased them, and failed exact joins on either. + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 1L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = "rs1a", + A1 = "g", + A2 = "a" + ) + out <- pecotmr:::.canonEntries(list(gr))[[1L]] + expect_identical(out$A1, "G") + expect_identical(out$A2, "A") + expect_identical(out$SNP, "rs1a") + # The id utilities agree: parsed and rendered alleles are upper case. + parsed <- parseVariantId(c("chr1:100:a:g", "rs1")) + expect_identical(parsed$A2, c("A", NA)) + expect_identical(parsed$A1, c("G", NA)) + expect_identical( + pecotmr:::formatVariantId("1", 100L, "a", "g"), + "chr1:100:A:G" + ) + expect_identical( + normalizeVariantId(c("1:100:a:g", "rs1")), + c("chr1:100:A:G", "rs1") + ) + df <- parseVariantId(data.frame(chrom = 1, pos = 100, A2 = "a", A1 = "g")) + expect_identical(c(df$A2, df$A1), c("A", "G")) + expect_identical( + pecotmr:::detectVariantConvention("chr1:100_a_g")$alleleSep, + "_" + ) +}) + test_that(".ucscExperiment renames an experiment's rowRanges only", { m <- matrix(1, 1L, 1L, dimnames = list("v", "s")) plain <- SummarizedExperiment::SummarizedExperiment(list(x = m)) @@ -966,6 +1000,35 @@ test_that(".ucscExperiment renames an experiment's rowRanges only", { expect_identical(pecotmr:::.ucscExperiment(out), out) }) +test_that(".canonExperiment also puts a panel's alleles in upper case", { + # A panel built outside pecotmr reaches every pipeline through .asLdRef(), + # and a QtlDataset's genotypes through its constructor; both land here. + m <- matrix(1, 1L, 1L, dimnames = list("v", "s")) + panel <- SummarizedExperiment::SummarizedExperiment( + list(x = m), + rowRanges = GenomicRanges::GRanges( + "22", + IRanges::IRanges(9L, width = 1L), + A1 = "g", + A2 = "a" + ) + ) + out <- pecotmr:::.asLdRef(panel) + mc <- S4Vectors::mcols(SummarizedExperiment::rowRanges(out)) + expect_identical(c(mc$A1, mc$A2), c("G", "A")) + expect_identical(GenomeInfoDb::seqlevels(out), "chr22") + expect_identical(SummarizedExperiment::assay(out), m) + # An experiment with no alleles, a phenotype's, is only renamed; one + # with no rowRanges at all (QtlDataset accepts it) passes through. + plain <- SummarizedExperiment::SummarizedExperiment( + list(x = m), + rowRanges = GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 1L)) + ) + expect_identical(pecotmr:::.canonExperiment(plain), plain) + bare <- SummarizedExperiment::SummarizedExperiment(list(x = m)) + expect_identical(pecotmr:::.canonExperiment(bare), bare) +}) + # =========================================================================== # matchVariants: data.frame input # =========================================================================== diff --git a/vignettes/coloc-pipeline.Rmd b/vignettes/coloc-pipeline.Rmd index f7c5cf68b..28224f61e 100644 --- a/vignettes/coloc-pipeline.Rmd +++ b/vignettes/coloc-pipeline.Rmd @@ -34,9 +34,10 @@ Inputs: - **GWAS input** — either a `GwasSumStats` (fine-mapping run internally) or a `GwasFineMappingResult` (used directly). -The output is a `ColocResult`: one element per tested -`(QTL credible set, GWAS credible set, block)` pair, holding that pair's -aligned variants. Pair-level posteriors (`PP.H0.abf` … `PP.H4.abf`) and the +The output is a `ColocResult`: one element per scored group (a QTL row +against a GWAS row in one block), holding the group's aligned variants once, +with one row per tested `(QTL credible set, GWAS credible set)` pair nested +in it. Pair-level posteriors (`PP.H0.abf` … `PP.H4.abf`) and each pair's per-variant `SNP.PP.H4` are both kept, and four accessors project the object to whichever granularity an analysis needs — see [Reading the result](#reading-the-result). diff --git a/vignettes/ctwas-pipeline.Rmd b/vignettes/ctwas-pipeline.Rmd index 8adb7071e..066d4cda7 100644 --- a/vignettes/ctwas-pipeline.Rmd +++ b/vignettes/ctwas-pipeline.Rmd @@ -218,14 +218,20 @@ has no real signal) and `cs` is `NA` because the gene falls in no credible set. `susieAlpha()` returns the per-single-effect alpha matrix behind those -PIPs, and the run's EM group priors sit in the `groupPriors` column, the -same on every region of the run: +PIPs. The group priors are the run's one genome-wide estimate: the EM step +fits them across every region, and each region is then fine-mapped under +them. `ctwasGroupPriors()` lists them once per run, one row per group with +its size, prior inclusion probability and prior effect variance: ```{r ctwas-param} -param <- res$groupPriors[[1]] -param$group_prior -param$group_prior_var -param$converged +ctwasGroupPriors(res) +``` + +The rest of the EM output, iteration traces and convergence flag included, +sits in the `groupPriors` column, the same on every region of the run: + +```{r ctwas-em} +res$groupPriors[[1]]$converged ``` By default the context-agnostic SNP background is dropped from the result, diff --git a/vignettes/heritability.Rmd b/vignettes/heritability.Rmd index ed79d7cfb..96fe9cb56 100644 --- a/vignettes/heritability.Rmd +++ b/vignettes/heritability.Rmd @@ -33,11 +33,17 @@ and what they need: | `"hdl"` | High-definition likelihood (Ning 2020) | `LdEigen` | Supplying `annotations` makes any of them stratified, adding a -per-annotation enrichment table. +per-annotation enrichment table. These estimators are genome-wide: each +gives one estimate per study. Given QTL summary statistics instead, +`estimateH2()` estimates each gene's heritability in its cis window. Either +way the result is an `H2Estimate`, a collection with one row per estimate: +its identity (`study`, `context`, `trait`, `method`) and values (`h2`, +`h2_se`, ...) are columns, and a cis estimate's element is the window it +covers. There is a second, separate track in the package: when stratified LDSC has already been run externally by [polyfun][pf], `sldscPostprocessingPipeline()` -postprocesses those outputs. Both are covered below. +postprocesses those outputs. Both tracks are covered below. [pf]: https://github.com/omerwe/polyfun @@ -395,6 +401,39 @@ alongside polyfun runs: names(h2EstimateToSldscTrait(strat)) ``` +## Per-gene cis heritability + +Given a `QtlSumStats`, `estimateH2()` estimates each trait's heritability +in its cis window: one estimate per (study, context, trait) row, from the +row's own statistics and LD reference, so it takes no `ldRef`. Each method +reports what its authors report, and `NA` where they report nothing: + +| `method` | Approach | Reports | +|---|---|---| +| `"lava"` | LAVA (Werme 2022): adjusted R^2 on LD components | h2, p | +| `"hdlL"` | HDL-L (Li 2025): likelihood with an intercept | h2, p, intercept | +| `"fastHer"` | FastHer (Svishcheva 2025): maximum likelihood | h2, SE, scale | + +```{r cis-h2} +data(qtlSumStatsExample) +cis <- estimateH2(qtlSumStatsExample) +cis +cis[[1]] +heritabilityIntercept(estimateH2(qtlSumStatsExample, method = "hdlL")) +``` + +Each row's element is the window its estimate covers: the row's `region`, +or with `cisWindow` the trait's position widened by that much on each side. +LAVA, the default, projects the statistics onto the LD components that hold +99% of the LD variance and corrects for the reference's size. LAVA itself +withholds its estimate where the components outnumber a tenth of the sample +size, which a cis window's usually do at QTL sample sizes; `estimateH2()` +reports it at any size. LAVA and HDL-L read the reference's sample size, so +an `LdMatrix` reference must record `nSamples`. FastHer's likelihood +assumes in-sample LD (HEELS maximizes the same one): where the reference's +rank or the statistics reach the study's sample size, as with an external +reference larger than the study, its estimate is `NA`, with a warning. + ## Next steps - [Molecular QTL enrichment](xqtl-enrichment.html) — the complementary diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index 29b38697a..bf772e9e1 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -35,7 +35,7 @@ by `(study, context, trait, method)`, one element per tuple). |---|---| | `QtlDataset` | Univariate: LASSO, elastic net, ridge, mr.ash, MCP, SCAD, L0Learn, Bayesian alphabet, DPR. Multivariate: mr.mash, mvsusie | | `MultiStudyQtlDataset` | Iterates over embedded studies; same methods as `QtlDataset` | -| `QtlSumStats` | RSS-only: LASSO, elastic net, ridge, mr.ash, MCP, SCAD, L0Learn, DPR, PRS-CS, P+T. Multivariate: mr.mash, mvsusie | +| `QtlSumStats` | RSS-only: LASSO, elastic net, ridge, mr.ash, MCP, SCAD, L0Learn, Bayesian alphabet, DPR, PRS-CS, LDpred2, P+T. Multivariate: mr.mash, mvsusie | ```{r load-packages} library(pecotmr) @@ -142,9 +142,10 @@ to the call for a single QtlDataset. ## Multiple weight methods at once Pass a character vector to fit several methods on the same fold split and -return them as separate `(method)` rows in the collection. Fine-mapping methods -(`susie`, `susieInf`, `susieAsh`, `mvsusie`) can only be included if their -results are present in the object passed to the `fineMappingResult` argument: +return them as the methods of each gene's row in the collection. Fine-mapping +methods (`susie`, `susieInf`, `susieAsh`, `mvsusie`) can only be included if +their results are present in the object passed to the `fineMappingResult` +argument: ```{r multimethod, eval=FALSE} # TWAS-regression only — no fineMappingResult needed. @@ -239,9 +240,10 @@ The families, and the `methods =` name each answers to: | Family | `methods =` | Function | |---|---|---| | Penalized regression | `lasso`, `enet`, `ridge`, `mcp`, `scad`, `l0learn` | `lassoWeights()`, `enetWeights()`, `ridgeWeights()`, … | -| Bayesian alphabet | `bayesA` … `bayesR`, `bLasso` | `bayesAWeights()`, `bLassoWeights()`, … | +| Bayesian alphabet | `bayesA` … `bayesR` | `bayesAWeights()`, `bayesARssWeights()`, … | | Dirichlet process regression | `dprVb`, `dprGibbs`, `dprAdaptiveGibbs` | `dprVbWeights()`, `dprGibbsWeights()`, … | | PRS-CS | `prsCs` (sumstats input only) | `prsCsWeights()` | +| LDpred2 | `ldpred2Auto`, `ldpred2Grid` (sumstats input only) | `ldpred2AutoWeights()`, `ldpred2GridWeights()` | | mr.mash / mr.ash | `mrmash`, `mrash` | `mrmashWeights()`, `mrashWeights()` | | SuSiE family | `susie`, `susieInf`, `susieAsh`, `mvsusie`, `fsusie` | `susieWeights()`, `mvsusieWeights()`, … | @@ -253,25 +255,74 @@ Most families have an RSS counterpart taking summary statistics and an LD reference instead of `X`/`y` — `lassosumRssWeights()` for `lasso`, `enetRssWeights()` and `ridgeRssWeights()` for `enet` and `ridge`, `mcpRssWeights()`, `sdprWeights()` (SDPR) for `dprGibbs`, `susieRssWeights()`, -and so on; the Bayesian alphabet, `dprVb` and `dprAdaptiveGibbs` have none. +`bayesARssWeights()` through `bayesRRssWeights()` for the Bayesian alphabet, +and so on; `dprVb` and `dprAdaptiveGibbs` have none. `enet` mixes the lasso and ridge penalties at `alpha = 0.5` on either input; `methods = list(enet = list(alpha = 0.3))` sets another mixing. Those are what `twasWeightsPipeline()` calls when the input is a `QtlSumStats`. The LD reference is the same `ldReference` the rest of the package takes: a genotype panel from `readGenotypes()`, a `GenotypeMixture` or an `LdMatrix`, matched to -the statistics by their `variantNames`. lassosum, the penalized methods, PRS-CS -and SDPR use a genotype reference through its standardized genotypes without -forming the LD matrix; the mr.ash and mr.mash engines take the matrix, which is +the statistics by their `variantNames`. lassosum, the penalized methods, +PRS-CS, SDPR and pecotmr's own Bayesian alphabet sampler use a genotype +reference through its standardized genotypes without forming the LD matrix; +the mr.ash and mr.mash engines, qgg and hibayes take the matrix, which is formed over the statistics' variants. +Each Bayesian alphabet method runs on several engines, chosen with `backend`. +On individual-level data, `bayesB` defaults to BGLR and the others to qgg, +with hibayes available for all. On summary statistics, a genotype reference +defaults to pecotmr's sampler, and an `LdMatrix` to qgg (`bayesA`, `bayesC`, +`bayesN`, `bayesR`) or hibayes (`bayesB`, `bayesL`). The pipeline takes the +choice per method: `twasWeightsPipeline(..., backend = c(bayesR = "hibayes"))`. +LDpred2 defaults the same way, to pecotmr's sampler on a genotype reference +and to bigsnpr on an `LdMatrix`. `lasso` also runs on bigsnpr's lassosum2 +(`backend = "bigsnpr"`), which takes its own settings in `BigsnprOptions()`. + +Every alphabet engine reads the LD shrunk toward the identity, +`shrinkCorr` R + (1 - `shrinkCorr`) I, with `shrinkCorr = 0.95` by default, +the LDpred2 vignette's: a reference with fewer people than the window has +variants lacks directions the statistics have, and without shrinkage the +alphabet's effects can grow without bound along them. A small or mismatched +reference does better with less, down to 0.4; the study's own genotypes as +the reference need none. pecotmr's sampler also reads the statistics through +SDPR's likelihood by default: the LD as R (R + aI)^-1^ R and the marginal +effects as R (R + aI)^-1^ b, with a = 0.1, which drops the part of the +effects the reference LD cannot explain, the part those effects grow along. +`BayesAlphabetRssOptions(ldProjection = NULL)` turns it off. + +PRS-CS, SDPR, pecotmr's Bayesian alphabet sampler and LDpred2 share +LDpred2's sampler options. `nChains` runs several chains and averages those +that LDpred2's own filter keeps; `raoBlackwell = TRUE` averages each +effect's conditional posterior mean rather than its draws; `shrinkCorr` +shrinks the LD toward the identity (PRS-CS, the alphabet and LDpred2); and +`allowJumpSign = FALSE` refuses a draw whose sign differs from the effect's +(the alphabet and LDpred2). Each method takes them in its options, as in +`prsCsWeights(stat, ldReference, methodArgs = PrsCsOptions(nChains = 4))`; +the alphabet takes `shrinkCorr` as an argument of its own, since it applies +to every engine. + Several of these engines estimate more than the weights, and `fitRetention = "slim"` keeps it as the `"fit"` attribute of the weights they return: SDPR's heritability estimate (`h2`), PRS-CS's posterior shrinkage -parameters (`psiEst`, `sigmaEst`, `phiEst`), and for lassosum and the -penalized methods the search itself --- `path` has one row per LD shrinkage -`s` and penalty `lambda`, with the objective (`fbeta`), `loss`, convergence -flag and number of non-zero weights, and marks the candidate returned. -`fitRetention = "full"` adds each candidate's coefficients. +parameters (`psiEst`, `sigmaEst`, `phiEst`), LDpred2-auto's chains (each +one's starting `p`, its estimates of `p` and `h2`, and whether it was kept) +with the inclusion probabilities, LDpred2-grid's grid of `p`, `h2` and +`sparse`, and for lassosum and the penalized methods the search itself --- +`path` has one row per LD shrinkage `s` and penalty `lambda`, with the +objective (`fbeta`), `loss`, convergence flag and number of non-zero +weights, and marks the candidate returned. `fitRetention = "full"` adds each +candidate's coefficients. + +These methods, and LDpred2-grid, pick the returned candidate on held-out +summary statistics: +the statistics are split into training and held-out parts, the path is refit +on each training part, and every candidate is scored on the held-out part. +The scoring shrinks the LD toward the identity by an amount set by the +reference's sample size, because a reference smaller than the number of +variants misses directions of the true LD, and the least-penalized fits put +weight exactly there. An `LdMatrix` therefore needs `nSamples`, and the +splits are random, so `set.seed()` makes the weights reproducible. +`selection = "ldQuadratic"` is lassosum's own pseudovalidation instead. ```{r rss-fit} # An LdMatrix is keyed by chrom:pos:A2:A1 variant ids. @@ -283,7 +334,12 @@ stat <- list( n = rep(n, p), variantNames = ids ) -w <- lassosumRssWeights(stat, LdMatrix(R), fitRetention = "slim") +set.seed(1) +w <- lassosumRssWeights( + stat, + LdMatrix(R, nSamples = n), + fitRetention = "slim" +) head(attr(w, "fit")$path) ``` @@ -362,32 +418,34 @@ twasWeightsPipeline( ## Reading the result -`TwasWeights` is a `GRangesList` subclass keyed by the 4-tuple -`(study, context, trait, method)` — one element per tuple, holding the -variants its weights are aligned to. The tuple and the per-tuple payloads are -`mcols()` columns, reached with `$`: +`TwasWeights` is a `GRangesList` subclass with one element per gene — its +`(study, context, trait)`, plus the group of a joint fit — holding the +variants its methods' weights are aligned to. A gene's methods are an axis of +its row, listed by `methodNames()`; the identity is in `mcols()` columns, +reached with `$`: ```{r tw-shape} tw colnames(tw) -tw$method +methodNames(tw) ``` -`as.data.frame()` gives the long per-variant view across every method at once, -which is usually what you want for inspection: +`as(tw, "GRanges")` gives the long per-variant view across every method at +once — one range per variant and method, carrying its `weight` and +`.method` — which is usually what you want for inspection: ```{r tw-table} -head(as.data.frame(tw), 3) +head(as.data.frame(as(tw, "GRanges")), 3) ``` -To pull one method's weights, pass the tuple to the accessor: +To pull one method's weights, pass the gene and the method to the accessor: ```{r tw-one-tuple} key <- list( studyName = tw$study[[1L]], context = tw$context[[1L]], trait = tw$trait[[1L]], - method = tw$method[[1L]] + method = methodNames(tw)[[1L]] ) w <- do.call(weights, c(list(tw), key)) length(w) @@ -432,9 +490,10 @@ writeBed(tw, "weights.bed.gz") ``` Both export the **full-data fit only**, and refuse an object that has none — -`crossValidationParam = CrossValidationParam(fitFullData = FALSE)` produces rows -holding nothing but cross-validation results, and those cannot be published: -they describe held-out folds, and fold membership is sample-level information. +`crossValidationParam = CrossValidationParam(fitFullData = FALSE)` produces +entries holding nothing but cross-validation results, and those cannot be +published: they describe held-out folds, and fold membership is sample-level +information. For the same reason neither exporter writes CV metrics. Those stay on the object: @@ -449,7 +508,7 @@ cv <- cvResult( cv$performance # per-method metric matrix: corr, rsq, adj_rsq, pval, RMSE, MAE ``` -Fine-mapping-derived rows (`susie`, `susie_inf`, `susie_ash`, `mvsusie`, +Fine-mapping-derived entries (`susie`, `susieInf`, `susieAsh`, `mvsusie`, `fsusie`) are skipped with a message by **both** exporters, because their "weights" are the fine-mapping posterior re-expressed — export the fine-mapping result instead, which carries the posterior, its standard error