purrr/0000755000176200001440000000000013552331245011427 5ustar liggesuserspurrr/NAMESPACE0000644000176200001440000001017713551363270012656 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(as_mapper,character) S3method(as_mapper,default) S3method(as_mapper,list) S3method(as_mapper,numeric) S3method(modify,character) S3method(modify,default) S3method(modify,double) S3method(modify,integer) S3method(modify,logical) S3method(modify,pairlist) S3method(modify2,character) S3method(modify2,default) S3method(modify2,double) S3method(modify2,integer) S3method(modify2,logical) S3method(modify_at,character) S3method(modify_at,default) S3method(modify_at,double) S3method(modify_at,integer) S3method(modify_at,logical) S3method(modify_depth,default) S3method(modify_if,character) S3method(modify_if,default) S3method(modify_if,double) S3method(modify_if,integer) S3method(modify_if,logical) S3method(print,purrr_function_compose) S3method(print,purrr_function_partial) S3method(print,purrr_rate_backoff) S3method(print,purrr_rate_delay) S3method(rate_sleep,purrr_rate_backoff) S3method(rate_sleep,purrr_rate_delay) export("%>%") export("%@%") export("%||%") export("pluck<-") export(accumulate) export(accumulate2) export(accumulate_right) export(array_branch) export(array_tree) export(as_function) export(as_mapper) export(as_vector) export(assign_in) export(at_depth) export(attr_getter) export(auto_browse) export(chuck) export(compact) export(compose) export(cross) export(cross2) export(cross3) export(cross_d) export(cross_df) export(cross_n) export(detect) export(detect_index) export(discard) export(done) export(every) export(exec) export(flatten) export(flatten_chr) export(flatten_dbl) export(flatten_df) export(flatten_dfc) export(flatten_dfr) export(flatten_int) export(flatten_lgl) export(flatten_raw) export(has_element) export(head_while) export(imap) export(imap_chr) export(imap_dbl) export(imap_dfc) export(imap_dfr) export(imap_int) export(imap_lgl) export(imap_raw) export(imodify) export(insistently) export(invoke) export(invoke_map) export(invoke_map_chr) export(invoke_map_dbl) export(invoke_map_df) export(invoke_map_dfc) export(invoke_map_dfr) export(invoke_map_int) export(invoke_map_lgl) export(invoke_map_raw) export(is_atomic) export(is_bare_atomic) export(is_bare_character) export(is_bare_double) export(is_bare_integer) export(is_bare_list) export(is_bare_logical) export(is_bare_numeric) export(is_bare_vector) export(is_character) export(is_double) export(is_empty) export(is_formula) export(is_function) export(is_integer) export(is_list) export(is_logical) export(is_null) export(is_numeric) export(is_rate) export(is_scalar_atomic) export(is_scalar_character) export(is_scalar_double) export(is_scalar_integer) export(is_scalar_list) export(is_scalar_logical) export(is_scalar_numeric) export(is_scalar_vector) export(is_vector) export(iwalk) export(keep) export(lift) export(lift_dl) export(lift_dv) export(lift_ld) export(lift_lv) export(lift_vd) export(lift_vl) export(list_along) export(list_merge) export(list_modify) export(lmap) export(lmap_at) export(lmap_if) export(map) export(map2) export(map2_chr) export(map2_dbl) export(map2_df) export(map2_dfc) export(map2_dfr) export(map2_int) export(map2_lgl) export(map2_raw) export(map_at) export(map_call) export(map_chr) export(map_dbl) export(map_depth) export(map_df) export(map_dfc) export(map_dfr) export(map_if) export(map_int) export(map_lgl) export(map_raw) export(modify) export(modify2) export(modify_at) export(modify_depth) export(modify_if) export(modify_in) export(negate) export(partial) export(pluck) export(pmap) export(pmap_chr) export(pmap_dbl) export(pmap_df) export(pmap_dfc) export(pmap_dfr) export(pmap_int) export(pmap_lgl) export(pmap_raw) export(possibly) export(prepend) export(pwalk) export(quietly) export(rate_backoff) export(rate_delay) export(rate_reset) export(rate_sleep) export(rbernoulli) export(rdunif) export(reduce) export(reduce2) export(reduce2_right) export(reduce_right) export(rep_along) export(rerun) export(safely) export(set_names) export(simplify) export(simplify_all) export(slowly) export(some) export(splice) export(tail_while) export(transpose) export(update_list) export(vec_depth) export(walk) export(walk2) export(when) export(zap) import(rlang) importFrom(magrittr,"%>%") useDynLib(purrr, .registration = TRUE) purrr/LICENSE0000644000176200001440000010451313403735151012437 0ustar liggesusers 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 . purrr/README.md0000644000176200001440000000555313552017616012721 0ustar liggesusers # purrr [![CRAN\_Status\_Badge](https://www.r-pkg.org/badges/version/purrr)](https://cran.r-project.org/package=purrr) [![Build Status](https://travis-ci.org/tidyverse/purrr.svg?branch=master)](https://travis-ci.org/tidyverse/purrr) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/tidyverse/purrr?branch=master&svg=true)](https://ci.appveyor.com/project/tidyverse/purrr) [![Coverage Status](https://img.shields.io/codecov/c/github/tidyverse/purrr/master.svg)](https://codecov.io/github/tidyverse/purrr?branch=master) ## Overview purrr enhances R’s functional programming (FP) toolkit by providing a complete and consistent set of tools for working with functions and vectors. If you’ve never heard of FP before, the best place to start is the family of `map()` functions which allow you to replace many for loops with code that is both more succinct and easier to read. The best place to learn about the `map()` functions is the [iteration chapter](http://r4ds.had.co.nz/iteration.html) in R for data science. ## Installation ``` r # The easiest way to get purrr is to install the whole tidyverse: install.packages("tidyverse") # Alternatively, install just purrr: install.packages("purrr") # Or the the development version from GitHub: # install.packages("devtools") devtools::install_github("tidyverse/purrr") ``` ## Cheatsheet ## Usage The following example uses purrr to solve a fairly realistic problem: split a data frame into pieces, fit a model to each piece, compute the summary, then extract the R2. ``` r library(purrr) mtcars %>% split(.$cyl) %>% # from base R map(~ lm(mpg ~ wt, data = .)) %>% map(summary) %>% map_dbl("r.squared") #> 4 6 8 #> 0.5086326 0.4645102 0.4229655 ``` This example illustrates some of the advantages of purrr functions over the equivalents in base R: - The first argument is always the data, so purrr works naturally with the pipe. - All purrr functions are type-stable. They always return the advertised output type (`map()` returns lists; `map_dbl()` returns double vectors), or they throw an error. - All `map()` functions either accept function, formulas (used for succinctly generating anonymous functions), a character vector (used to extract components by name), or a numeric vector (used to extract by position). ----- Please note that this project is released with a [Contributor Code of Conduct](https://purrr.tidyverse.org/CODE_OF_CONDUCT). By participating in this project you agree to abide by its terms. purrr/man/0000755000176200001440000000000013552020017012172 5ustar liggesuserspurrr/man/list_modify.Rd0000644000176200001440000000321513426303100015001 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/list-modify.R \name{list_modify} \alias{list_modify} \alias{list_merge} \alias{update_list} \title{Modify a list} \usage{ list_modify(.x, ...) list_merge(.x, ...) } \arguments{ \item{.x}{List to modify.} \item{...}{New values of a list. Use \code{zap()} to remove values. These values should be either all named or all unnamed. When inputs are all named, they are matched to \code{.x} by name. When they are all unnamed, they are matched positionally. These dots support \link[rlang:list2]{tidy dots} features. In particular, if your functions are stored in a list, you can splice that in with \code{!!!}.} } \description{ \code{list_modify()} and \code{list_merge()} recursively combine two lists, matching elements either by name or position. If a sub-element is present in both lists \code{list_modify()} takes the value from \code{y}, and \code{list_merge()} concatenates the values together. \code{update_list()} handles formulas and quosures that can refer to values existing within the input list. Note that this function might be deprecated in the future in favour of a \code{dplyr::mutate()} method for lists. } \examples{ x <- list(x = 1:10, y = 4, z = list(a = 1, b = 2)) str(x) # Update values str(list_modify(x, a = 1)) # Replace values str(list_modify(x, z = 5)) str(list_modify(x, z = list(a = 1:5))) # Remove values str(list_modify(x, z = zap())) # Combine values str(list_merge(x, x = 11, z = list(a = 2:5, c = 3))) # All these functions support tidy dots features. Use !!! to splice # a list of arguments: l <- list(new = 1, y = zap(), z = 5) str(list_modify(x, !!!l)) } purrr/man/array-coercion.Rd0000644000176200001440000000372713403735151015416 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/arrays.R \name{array-coercion} \alias{array-coercion} \alias{array_branch} \alias{array_tree} \title{Coerce array to list} \usage{ array_branch(array, margin = NULL) array_tree(array, margin = NULL) } \arguments{ \item{array}{An array to coerce into a list.} \item{margin}{A numeric vector indicating the positions of the indices to be to be enlisted. If \code{NULL}, a full margin is used. If \code{numeric(0)}, the array as a whole is wrapped in a list.} } \description{ \code{array_branch()} and \code{array_tree()} enable arrays to be used with purrr's functionals by turning them into lists. The details of the coercion are controlled by the \code{margin} argument. \code{array_tree()} creates an hierarchical list (a tree) that has as many levels as dimensions specified in \code{margin}, while \code{array_branch()} creates a flat list (by analogy, a branch) along all mentioned dimensions. } \details{ When no margin is specified, all dimensions are used by default. When \code{margin} is a numeric vector of length zero, the whole array is wrapped in a list. } \examples{ # We create an array with 3 dimensions x <- array(1:12, c(2, 2, 3)) # A full margin for such an array would be the vector 1:3. This is # the default if you don't specify a margin # Creating a branch along the full margin is equivalent to # as.list(array) and produces a list of size length(x): array_branch(x) \%>\% str() # A branch along the first dimension yields a list of length 2 # with each element containing a 2x3 array: array_branch(x, 1) \%>\% str() # A branch along the first and third dimensions yields a list of # length 2x3 whose elements contain a vector of length 2: array_branch(x, c(1, 3)) \%>\% str() # Creating a tree from the full margin creates a list of lists of # lists: array_tree(x) \%>\% str() # The ordering and the depth of the tree are controlled by the # margin argument: array_tree(x, c(3, 1)) \%>\% str() } purrr/man/zap.Rd0000644000176200001440000000051013426303100013244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-rlang.R \docType{import} \name{zap} \alias{zap} \title{Zap an element} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{rlang}{\code{\link[rlang]{zap}}} }} purrr/man/modify_in.Rd0000644000176200001440000000311213426303100014430 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/modify.R \name{modify_in} \alias{modify_in} \alias{assign_in} \title{Modify a pluck location} \usage{ modify_in(.x, .where, .f, ...) assign_in(x, where, value) } \arguments{ \item{.x}{A vector or environment} \item{.where, where}{A pluck location, as a numeric vector of positions, a character vector of names, or a list combining both. The location must exist in the data structure.} \item{.f}{A function to apply at the pluck location given by \code{.where}.} \item{...}{Arguments passed to \code{.f}.} \item{x}{A vector or environment} \item{value}{A value to replace in \code{.x} at the pluck location.} } \description{ \itemize{ \item \code{assign_in()} takes a data structure and a \link{pluck} location, assigns a value there, and returns the modified data structure. \item \code{modify_in()} applies a function to a pluck location, assigns the result back to that location with \code{\link[=assign_in]{assign_in()}}, and returns the modified data structure. } The pluck location must exist. } \examples{ # Recall that pluck() returns a component of a data structure that # might be arbitrarily deep x <- list(list(bar = 1, foo = 2)) pluck(x, 1, "foo") # Use assign_in() to modify the pluck location: assign_in(x, list(1, "foo"), 100) # modify_in() applies a function to that location and update the # element in place: modify_in(x, list(1, "foo"), ~ .x * 200) # Additional arguments are passed to the function in the ordinary way: modify_in(x, list(1, "foo"), `+`, 100) } \seealso{ \code{\link[=pluck]{pluck()}} } purrr/man/rate_sleep.Rd0000644000176200001440000000141113426303100014576 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rate.R \name{rate_sleep} \alias{rate_sleep} \alias{rate_reset} \title{Wait for a given time} \usage{ rate_sleep(rate, quiet = TRUE) rate_reset(rate) } \arguments{ \item{rate}{A \link[=rate_backoff]{rate} object determining the waiting time.} \item{quiet}{If \code{FALSE}, prints a message displaying how long until the next request.} } \description{ If the rate's internal counter exceeds the maximum number of times it is allowed to sleep, \code{rate_sleep()} throws an error of class \code{purrr_error_rate_excess}. } \details{ Call \code{rate_reset()} to reset the internal rate counter to 0. } \seealso{ \code{\link[=rate_backoff]{rate_backoff()}}, \code{\link[=insistently]{insistently()}} } purrr/man/reduce_right.Rd0000644000176200001440000000334413426303100015126 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reduce.R \name{reduce_right} \alias{reduce_right} \alias{reduce2_right} \alias{accumulate_right} \title{Reduce from the right (retired)} \usage{ reduce_right(.x, .f, ..., .init) reduce2_right(.x, .y, .f, ..., .init) accumulate_right(.x, .f, ..., .init) } \arguments{ \item{.x}{A list or atomic vector.} \item{.f}{For \code{reduce()}, and \code{accumulate()}, a 2-argument function. The function will be passed the accumulated value as the first argument and the "next" value as the second argument. For \code{reduce2()} and \code{accumulate2()}, a 3-argument function. The function will be passed the accumulated value as the first argument, the next value of \code{.x} as the second argument, and the next value of \code{.y} as the third argument. The reduction terminates early if \code{.f} returns a value wrapped in a \code{\link[=done]{done()}}.} \item{...}{Additional arguments passed on to the mapped function.} \item{.init}{If supplied, will be used as the first value to start the accumulation, rather than using \code{.x[[1]]}. This is useful if you want to ensure that \code{reduce} returns a correct value when \code{.x} is empty. If missing, and \code{.x} is empty, will throw an error.} \item{.y}{For \code{reduce2()} and \code{accumulate2()}, an additional argument that is passed to \code{.f}. If \code{init} is not set, \code{.y} should be 1 element shorter than \code{.x}.} } \description{ \Sexpr[results=rd, stage=render]{purrr:::lifecycle("soft-deprecated")} These functions are retired as of purrr 0.3.0. Please use the \code{.dir} argument of \code{\link[=reduce]{reduce()}} instead, or reverse your vectors and use a left reduction. } \keyword{internal} purrr/man/as_vector.Rd0000644000176200001440000000322213403735151014454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coercion.R \name{as_vector} \alias{as_vector} \alias{simplify} \alias{simplify_all} \title{Coerce a list to a vector} \usage{ as_vector(.x, .type = NULL) simplify(.x, .type = NULL) simplify_all(.x, .type = NULL) } \arguments{ \item{.x}{A list of vectors} \item{.type}{A vector mold or a string describing the type of the input vectors. The latter can be any of the types returned by \code{\link[=typeof]{typeof()}}, or "numeric" as a shorthand for either "double" or "integer".} } \description{ \code{as_vector()} collapses a list of vectors into one vector. It checks that the type of each vector is consistent with \code{.type}. If the list can not be simplified, it throws an error. \code{simplify} will simplify a vector if possible; \code{simplify_all} will apply \code{simplify} to every element of a list. } \details{ \code{.type} can be a vector mold specifying both the type and the length of the vectors to be concatenated, such as \code{numeric(1)} or \code{integer(4)}. Alternatively, it can be a string describing the type, one of: "logical", "integer", "double", "complex", "character" or "raw". } \examples{ # Supply the type either with a string: as.list(letters) \%>\% as_vector("character") # Or with a vector mold: as.list(letters) \%>\% as_vector(character(1)) # Vector molds are more flexible because they also specify the # length of the concatenated vectors: list(1:2, 3:4, 5:6) \%>\% as_vector(integer(2)) # Note that unlike vapply(), as_vector() never adds dimension # attributes. So when you specify a vector mold of size > 1, you # always get a vector and not a matrix } purrr/man/negate.Rd0000644000176200001440000000154213435517376013751 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/negate.R \name{negate} \alias{negate} \title{Negate a predicate function.} \usage{ negate(.p) } \arguments{ \item{.p}{A single predicate function, a formula describing such a predicate function, or a logical vector of the same length as \code{.x}. Alternatively, if the elements of \code{.x} are themselves lists of objects, a string indicating the name of a logical element in the inner lists. Only those elements where \code{.p} evaluates to \code{TRUE} will be modified.} } \value{ A new predicate function. } \description{ Negate a predicate function. } \examples{ negate("x") negate(is.null) negate(~ .x > 0) x <- transpose(list(x = 1:10, y = rbernoulli(10))) x \%>\% keep("y") \%>\% length() x \%>\% keep(negate("y")) \%>\% length() # Same as x \%>\% discard("y") \%>\% length() } purrr/man/invoke.Rd0000644000176200001440000001060113551365051013763 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/retired-invoke.R \name{invoke} \alias{invoke} \alias{invoke_map} \alias{invoke_map_lgl} \alias{invoke_map_int} \alias{invoke_map_dbl} \alias{invoke_map_chr} \alias{invoke_map_raw} \alias{invoke_map_dfr} \alias{invoke_map_dfc} \alias{invoke_map_df} \alias{map_call} \title{Invoke functions.} \usage{ invoke(.f, .x = NULL, ..., .env = NULL) invoke_map(.f, .x = list(NULL), ..., .env = NULL) invoke_map_lgl(.f, .x = list(NULL), ..., .env = NULL) invoke_map_int(.f, .x = list(NULL), ..., .env = NULL) invoke_map_dbl(.f, .x = list(NULL), ..., .env = NULL) invoke_map_chr(.f, .x = list(NULL), ..., .env = NULL) invoke_map_raw(.f, .x = list(NULL), ..., .env = NULL) invoke_map_dfr(.f, .x = list(NULL), ..., .env = NULL) invoke_map_dfc(.f, .x = list(NULL), ..., .env = NULL) } \arguments{ \item{.f}{For \code{invoke}, a function; for \code{invoke_map} a list of functions.} \item{.x}{For \code{invoke}, an argument-list; for \code{invoke_map} a list of argument-lists the same length as \code{.f} (or length 1). The default argument, \code{list(NULL)}, will be recycled to the same length as \code{.f}, and will call each function with no arguments (apart from any supplied in \code{...}.} \item{...}{Additional arguments passed to each function.} \item{.env}{Environment in which \code{\link[=do.call]{do.call()}} should evaluate a constructed expression. This only matters if you pass as \code{.f} the name of a function rather than its value, or as \code{.x} symbols of objects rather than their values.} } \description{ \Sexpr[results=rd, stage=render]{purrr:::lifecycle("retired")} This pair of functions make it easier to combine a function and list of parameters to get a result. \code{invoke} is a wrapper around \code{do.call} that makes it easy to use in a pipe. \code{invoke_map} makes it easier to call lists of functions with lists of parameters. } \section{Life cycle}{ These functions are retired in favour of \code{\link[=exec]{exec()}}. They are no longer under active development but we will maintain them in the package undefinitely. \itemize{ \item \code{invoke()} is retired in favour of the simpler \code{exec()} function reexported from rlang. \code{exec()} evaluates a function call built from its inputs and supports tidy dots:\preformatted{# Before: invoke(mean, list(na.rm = TRUE), x = 1:10) # After exec(mean, 1:10, !!!list(na.rm = TRUE)) } \item \code{invoke_map()} is is retired without replacement because it is more complex to understand than the corresponding code using \code{map()}, \code{map2()} and \code{exec()}:\preformatted{# Before: invoke_map(fns, list(args)) invoke_map(fns, list(args1, args2)) # After: map(fns, exec, !!!args) map2(fns, list(args1, args2), function(fn, args) exec(fn, !!!args)) } } } \examples{ # Invoke a function with a list of arguments invoke(runif, list(n = 10)) # Invoke a function with named arguments invoke(runif, n = 10) # Combine the two: invoke(paste, list("01a", "01b"), sep = "-") # That's more natural as part of a pipeline: list("01a", "01b") \%>\% invoke(paste, ., sep = "-") # Invoke a list of functions, each with different arguments invoke_map(list(runif, rnorm), list(list(n = 10), list(n = 5))) # Or with the same inputs: invoke_map(list(runif, rnorm), list(list(n = 5))) invoke_map(list(runif, rnorm), n = 5) # Or the same function with different inputs: invoke_map("runif", list(list(n = 5), list(n = 10))) # Or as a pipeline list(m1 = mean, m2 = median) \%>\% invoke_map(x = rcauchy(100)) list(m1 = mean, m2 = median) \%>\% invoke_map_dbl(x = rcauchy(100)) # Note that you can also match by position by explicitly omitting `.x`. # This can be useful when the argument names of the functions are not # identical list(m1 = mean, m2 = median) \%>\% invoke_map(, rcauchy(100)) # If you have pairs of function name and arguments, it's natural # to store them in a data frame. Here we use a tibble because # it has better support for list-columns if (rlang::is_installed("tibble")) { df <- tibble::tibble( f = c("runif", "rpois", "rnorm"), params = list( list(n = 10), list(n = 5, lambda = 10), list(n = 10, mean = -3, sd = 10) ) ) df invoke_map(df$f, df$params) } } \seealso{ Other map variants: \code{\link{imap}}, \code{\link{lmap}}, \code{\link{map2}}, \code{\link{map_if}}, \code{\link{map}}, \code{\link{modify}} } \concept{map variants} \keyword{internal} purrr/man/splice.Rd0000644000176200001440000000163513426303100013742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/splice.R \name{splice} \alias{splice} \title{Splice objects and lists of objects into a list} \usage{ splice(...) } \arguments{ \item{...}{Objects to concatenate.} } \value{ A list. } \description{ \Sexpr[results=rd, stage=render]{purrr:::lifecycle("questioning")} This splices all arguments into a list. Non-list objects and lists with a S3 class are encapsulated in a list before concatenation. } \section{Life cycle}{ \code{splice()} is in the questioning lifecycle stage as of purrr 0.3.0. We are now favouring the \code{!!!} syntax enabled by \code{\link[rlang:list2]{rlang::list2()}}. } \examples{ inputs <- list(arg1 = "a", arg2 = "b") # splice() concatenates the elements of inputs with arg3 splice(inputs, arg3 = c("c1", "c2")) \%>\% str() list(inputs, arg3 = c("c1", "c2")) \%>\% str() c(inputs, arg3 = c("c1", "c2")) \%>\% str() } purrr/man/purrr-package.Rd0000644000176200001440000000141313426303100015220 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/purrr.R \docType{package} \name{purrr-package} \alias{purrr} \alias{purrr-package} \title{purrr: Functional Programming Tools} \description{ \if{html}{\figure{logo.png}{options: align='right'}} A complete and consistent functional programming toolkit for R. } \seealso{ Useful links: \itemize{ \item \url{http://purrr.tidyverse.org} \item \url{https://github.com/tidyverse/purrr} \item Report bugs at \url{https://github.com/tidyverse/purrr/issues} } } \author{ \strong{Maintainer}: Lionel Henry \email{lionel@rstudio.com} Authors: \itemize{ \item Hadley Wickham \email{hadley@rstudio.com} } Other contributors: \itemize{ \item RStudio [copyright holder, funder] } } \keyword{internal} purrr/man/at_depth.Rd0000644000176200001440000000327313551365051014267 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/modify.R \name{at_depth} \alias{at_depth} \title{Map at depth} \usage{ at_depth(.x, .depth, .f, ...) } \arguments{ \item{.x}{A list or atomic vector.} \item{.depth}{Level of \code{.x} to map on. Use a negative value to count up from the lowest level of the list. \itemize{ \item \code{map_depth(x, 0, fun)} is equivalent to \code{fun(x)}. \item \code{map_depth(x, 1, fun)} is equivalent to \code{x <- map(x, fun)} \item \code{map_depth(x, 2, fun)} is equivalent to \code{x <- map(x, ~ map(., fun))} }} \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to the mapped function.} } \description{ This function is defunct and has been replaced by \code{\link[=map_depth]{map_depth()}}. See also \code{\link[=modify_depth]{modify_depth()}} for a version that preserves the types of the elements of the tree. } \keyword{internal} purrr/man/along.Rd0000644000176200001440000000112613426303100013556 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/along.R \name{along} \alias{along} \alias{list_along} \title{Helper to create vectors with matching length.} \usage{ list_along(x) } \arguments{ \item{x}{A vector.} \item{y}{Values to repeat.} } \value{ A vector of the same length as \code{x}. } \description{ These functions take the idea of \code{\link[=seq_along]{seq_along()}} and generalise it to creating lists (\code{list_along}) and repeating values (\code{rep_along}). } \examples{ x <- 1:5 rep_along(x, 1:2) rep_along(x, 1) list_along(x) } \keyword{internal} purrr/man/rdunif.Rd0000644000176200001440000000071013403735151013755 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{rdunif} \alias{rdunif} \title{Generate random sample from a discrete uniform distribution} \usage{ rdunif(n, b, a = 1) } \arguments{ \item{n}{Number of samples to draw.} \item{a, b}{Range of the distribution (inclusive).} } \description{ Generate random sample from a discrete uniform distribution } \examples{ table(rdunif(1e3, 10)) table(rdunif(1e3, 10, -5)) } purrr/man/map.Rd0000644000176200001440000001234513551365051013254 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/map.R \name{map} \alias{map} \alias{map_lgl} \alias{map_chr} \alias{map_int} \alias{map_dbl} \alias{map_raw} \alias{map_dfr} \alias{map_df} \alias{map_dfc} \alias{walk} \title{Apply a function to each element of a vector} \usage{ map(.x, .f, ...) map_lgl(.x, .f, ...) map_chr(.x, .f, ...) map_int(.x, .f, ...) map_dbl(.x, .f, ...) map_raw(.x, .f, ...) map_dfr(.x, .f, ..., .id = NULL) map_dfc(.x, .f, ...) walk(.x, .f, ...) } \arguments{ \item{.x}{A list or atomic vector.} \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to the mapped function.} \item{.id}{Either a string or \code{NULL}. If a string, the output will contain a variable with that name, storing either the name (if \code{.x} is named) or the index (if \code{.x} is unnamed) of the input. If \code{NULL}, the default, no variable will be created. Only applies to \code{_dfr} variant.} } \value{ \itemize{ \item \code{map()} Returns a list the same length as \code{.x}. \item \code{map_lgl()} returns a logical vector, \code{map_int()} an integer vector, \code{map_dbl()} a double vector, and \code{map_chr()} a character vector. \item \code{map_df()}, \code{map_dfc()}, \code{map_dfr()} all return a data frame. \item If \code{.x} has \code{names()}, the return value preserves those names. \item The output of \code{.f} will be automatically typed upwards, e.g. logical -> integer -> double -> character. } \itemize{ \item \code{walk()} returns the input \code{.x} (invisibly). This makes it easy to use in pipe. } } \description{ The map functions transform their input by applying a function to each element and returning a vector the same length as the input. \itemize{ \item \code{map()} always returns a list. See the \code{\link[=modify]{modify()}} family for versions that return an object of the same type as the input. \item \code{map_lgl()}, \code{map_int()}, \code{map_dbl()} and \code{map_chr()} return an atomic vector of the indicated type (or die trying). \item \code{map_dfr()} and \code{map_dfc()} return data frames created by row-binding and column-binding respectively. They require dplyr to be installed. \item The return value of \code{.f} must be of length one for each element of \code{.x}. If \code{.f} uses an extractor function shortcut, \code{.default} can be specified to handle values that are absent or empty. See \code{\link[=as_mapper]{as_mapper()}} for more on \code{.default}. } \itemize{ \item \code{walk()} calls \code{.f} for its side-effect and returns the input \code{.x}. } } \examples{ 1:10 \%>\% map(rnorm, n = 10) \%>\% map_dbl(mean) # Or use an anonymous function 1:10 \%>\% map(function(x) rnorm(10, x)) # Or a formula 1:10 \%>\% map(~ rnorm(10, .x)) # Using set_names() with character vectors is handy to keep track # of the original inputs: set_names(c("foo", "bar")) \%>\% map_chr(paste0, ":suffix") # Extract by name or position # .default specifies value for elements that are missing or NULL l1 <- list(list(a = 1L), list(a = NULL, b = 2L), list(b = 3L)) l1 \%>\% map("a", .default = "???") l1 \%>\% map_int("b", .default = NA) l1 \%>\% map_int(2, .default = NA) # Supply multiple values to index deeply into a list l2 <- list( list(num = 1:3, letters[1:3]), list(num = 101:103, letters[4:6]), list() ) l2 \%>\% map(c(2, 2)) # Use a list to build an extractor that mixes numeric indices and names, # and .default to provide a default value if the element does not exist l2 \%>\% map(list("num", 3)) l2 \%>\% map_int(list("num", 3), .default = NA) # A more realistic example: split a data frame into pieces, fit a # model to each piece, summarise and extract R^2 mtcars \%>\% split(.$cyl) \%>\% map(~ lm(mpg ~ wt, data = .x)) \%>\% map(summary) \%>\% map_dbl("r.squared") # Use map_lgl(), map_dbl(), etc to reduce output to a vector instead # of a list: mtcars \%>\% map_dbl(sum) # If each element of the output is a data frame, use # map_dfr to row-bind them together: mtcars \%>\% split(.$cyl) \%>\% map(~ lm(mpg ~ wt, data = .x)) \%>\% map_dfr(~ as.data.frame(t(as.matrix(coef(.))))) # (if you also want to preserve the variable names see # the broom package) } \seealso{ \code{\link[=map_if]{map_if()}} for applying a function to only those elements of \code{.x} that meet a specified condition. Other map variants: \code{\link{imap}}, \code{\link{invoke}}, \code{\link{lmap}}, \code{\link{map2}}, \code{\link{map_if}}, \code{\link{modify}} } \concept{map variants} purrr/man/every.Rd0000644000176200001440000000143413426303100013612 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/every-some.R \name{every} \alias{every} \alias{some} \title{Do every or some elements of a list satisfy a predicate?} \usage{ every(.x, .p, ...) some(.x, .p, ...) } \arguments{ \item{.x}{A list or atomic vector.} \item{.p}{A predicate function to apply on each element of \code{.x}. \code{some()} returns \code{TRUE} when \code{.p} is \code{TRUE} for at least one element. \code{every()} returns \code{TRUE} when \code{.p} is \code{TRUE} for all elements.} \item{...}{Additional arguments passed on to \code{.p}.} } \value{ A logical vector of length 1. } \description{ Do every or some elements of a list satisfy a predicate? } \examples{ y <- list(0:10, 5.5) y \%>\% every(is.numeric) y \%>\% every(is.integer) } purrr/man/transpose.Rd0000644000176200001440000000373513413636343014522 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/transpose.R \name{transpose} \alias{transpose} \title{Transpose a list.} \usage{ transpose(.l, .names = NULL) } \arguments{ \item{.l}{A list of vectors to transpose. The first element is used as the template; you'll get a warning if a subsequent element has a different length.} \item{.names}{For efficiency, \code{transpose()} bases the return structure on the first component of \code{.l} by default. Specify \code{.names} to override this.} } \value{ A list with indexing transposed compared to \code{.l}. } \description{ Transpose turns a list-of-lists "inside-out"; it turns a pair of lists into a list of pairs, or a list of pairs into pair of lists. For example, if you had a list of length n where each component had values \code{a} and \code{b}, \code{transpose()} would make a list with elements \code{a} and \code{b} that contained lists of length n. It's called transpose because \code{x[[1]][[2]]} is equivalent to \code{transpose(x)[[2]][[1]]}. } \details{ Note that \code{transpose()} is its own inverse, much like the transpose operation on a matrix. You can get back the original input by transposing it twice. } \examples{ x <- rerun(5, x = runif(1), y = runif(5)) x \%>\% str() x \%>\% transpose() \%>\% str() # Back to where we started x \%>\% transpose() \%>\% transpose() \%>\% str() # transpose() is useful in conjunction with safely() & quietly() x <- list("a", 1, 2) y <- x \%>\% map(safely(log)) y \%>\% str() y \%>\% transpose() \%>\% str() # Use simplify_all() to reduce to atomic vectors where possible x <- list(list(a = 1, b = 2), list(a = 3, b = 4), list(a = 5, b = 6)) x \%>\% transpose() x \%>\% transpose() \%>\% simplify_all() # Provide explicit component names to prevent loss of those that don't # appear in first component ll <- list( list(x = 1, y = "one"), list(z = "deux", x = 2) ) ll \%>\% transpose() nms <- ll \%>\% map(names) \%>\% reduce(union) ll \%>\% transpose(.names = nms) } purrr/man/rbernoulli.Rd0000644000176200001440000000070213403735151014644 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{rbernoulli} \alias{rbernoulli} \title{Generate random sample from a Bernoulli distribution} \usage{ rbernoulli(n, p = 0.5) } \arguments{ \item{n}{Number of samples} \item{p}{Probability of getting \code{TRUE}} } \value{ A logical vector } \description{ Generate random sample from a Bernoulli distribution } \examples{ rbernoulli(10) rbernoulli(100, 0.1) } purrr/man/when.Rd0000644000176200001440000000307413403735151013435 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/when.R \name{when} \alias{when} \title{Match/validate a set of conditions for an object and continue with the action associated with the first valid match.} \usage{ when(., ...) } \arguments{ \item{.}{the value to match against} \item{...}{formulas; each containing a condition as LHS and an action as RHS. named arguments will define additional values.} } \value{ The value resulting from the action of the first valid match/condition is returned. If no matches are found, and no default is given, NULL will be returned. Validity of the conditions are tested with \code{isTRUE}, or equivalently with \code{identical(condition, TRUE)}. In other words conditions resulting in more than one logical will never be valid. Note that the input value is always treated as a single object, as opposed to the \code{ifelse} function. } \description{ \code{when} is a flavour of pattern matching (or an if-else abstraction) in which a value is matched against a sequence of condition-action sets. When a valid match/condition is found the action is executed and the result of the action is returned. } \examples{ 1:10 \%>\% when( sum(.) <= 50 ~ sum(.), sum(.) <= 100 ~ sum(.)/2, ~ 0 ) 1:10 \%>\% when( sum(.) <= x ~ sum(.), sum(.) <= 2*x ~ sum(.)/2, ~ 0, x = 60 ) iris \%>\% subset(Sepal.Length > 10) \%>\% when( nrow(.) > 0 ~ ., ~ iris \%>\% head(10) ) iris \%>\% head \%>\% when(nrow(.) < 10 ~ ., ~ stop("Expected fewer than 10 rows.")) } \keyword{internal} purrr/man/get-attr.Rd0000644000176200001440000000111113426303100014177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{get-attr} \alias{get-attr} \alias{\%@\%} \title{Infix attribute accessor} \usage{ x \%@\% name } \arguments{ \item{x}{Object} \item{name}{Attribute name} } \description{ \Sexpr[results=rd, stage=render]{purrr:::lifecycle("soft-deprecated")} Please use the \code{\%@\%} operator exported in rlang. It has an interface more consistent with \code{@}: uses NSE, supports S4 fields, and has an assignment variant. } \examples{ factor(1:3) \%@\% "levels" mtcars \%@\% "class" } \keyword{internal} purrr/man/pluck.Rd0000644000176200001440000000770613426303100013606 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pluck.R \name{pluck} \alias{pluck} \alias{chuck} \alias{pluck<-} \title{Pluck or chuck a single element from a vector or environment} \usage{ pluck(.x, ..., .default = NULL) chuck(.x, ...) pluck(.x, ...) <- value } \arguments{ \item{.x, x}{A vector or environment} \item{...}{A list of accessors for indexing into the object. Can be an integer position, a string name, or an accessor function (except for the assignment variants which only support names and positions). If the object being indexed is an S4 object, accessing it by name will return the corresponding slot. These dots support \link[rlang:list2]{tidy dots} features. In particular, if your accessors are stored in a list, you can splice that in with \code{!!!}.} \item{.default}{Value to use if target is empty or absent.} \item{value}{A value to replace in \code{.x} at the pluck location.} } \description{ \code{pluck()} and \code{chuck()} implement a generalised form of \code{[[} that allow you to index deeply and flexibly into data structures. \code{pluck()} consistently returns \code{NULL} when an element does not exist, \code{chuck()} always throws an error in that case. } \details{ \itemize{ \item You can pluck or chuck with standard accessors like integer positions and string names, and also accepts arbitrary accessor functions, i.e. functions that take an object and return some internal piece. This is often more readable than a mix of operators and accessors because it reads linearly and is free of syntactic cruft. Compare: \code{accessor(x[[1]])$foo} to \code{pluck(x, 1, accessor, "foo")}. \item These accessors never partial-match. This is unlike \code{$} which will select the \code{disp} object if you write \code{mtcars$di}. } } \examples{ # Let's create a list of data structures: obj1 <- list("a", list(1, elt = "foo")) obj2 <- list("b", list(2, elt = "bar")) x <- list(obj1, obj2) # pluck() provides a way of retrieving objects from such data # structures using a combination of numeric positions, vector or # list names, and accessor functions. # Numeric positions index into the list by position, just like `[[`: pluck(x, 1) x[[1]] pluck(x, 1, 2) x[[1]][[2]] # Supply names to index into named vectors: pluck(x, 1, 2, "elt") x[[1]][[2]][["elt"]] # By default, pluck() consistently returns `NULL` when an element # does not exist: pluck(x, 10, .default = NA) try(x[[10]]) # You can also supply a default value for non-existing elements: pluck(x, 10, .default = NA) # If you prefer to consistently fail for non-existing elements, use # the opinionated variant chuck(): chuck(x, 1) try(chuck(x, 10)) try(chuck(x, 1, 10)) # The map() functions use pluck() by default to retrieve multiple # values from a list: map(x, 2) # Pass multiple indexes with a list: map(x, list(2, "elt")) # This is equivalent to: map(x, pluck, 2, "elt") # You can also supply a default: map(x, list(2, "elt", 10), .default = "superb default") # Or use the strict variant: try(map(x, chuck, 2, "elt", 10)) # You can also assign a value in a pluck location with pluck<-: pluck(x, 2, 2, "elt") <- "quuux" x # This is a shortcut for the prefix function assign_in(): y <- assign_in(x, list(2, 2, "elt"), value = "QUUUX") y # pluck() also supports accessor functions: my_element <- function(x) x[[2]]$elt # The accessor can then be passed to pluck: pluck(x, 1, my_element) pluck(x, 2, my_element) # Even for this simple data structure, this is more readable than # the alternative form because it requires you to read both from # right-to-left and from left-to-right in different parts of the # expression: my_element(x[[1]]) # If you have a list of accessors, you can splice those in with `!!!`: idx <- list(1, my_element) pluck(x, !!!idx) } \seealso{ \code{\link[=attr_getter]{attr_getter()}} for creating attribute getters suitable for use with \code{pluck()} and \code{chuck()}. \code{\link[=modify_in]{modify_in()}} for applying a function to a pluck location. } purrr/man/has_element.Rd0000644000176200001440000000063113426303100014742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/detect.R \name{has_element} \alias{has_element} \title{Does a list contain an object?} \usage{ has_element(.x, .y) } \arguments{ \item{.x}{A list or atomic vector.} \item{.y}{Object to test for} } \description{ Does a list contain an object? } \examples{ x <- list(1:10, 5, 9.9) x \%>\% has_element(1:10) x \%>\% has_element(3) } purrr/man/compose.Rd0000644000176200001440000000221713426303100014125 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compose.R \name{compose} \alias{compose} \title{Compose multiple functions} \usage{ compose(..., .dir = c("backward", "forward")) } \arguments{ \item{...}{Functions to apply in order (from right to left by default). Formulas are converted to functions in the usual way. These dots support \link[rlang:list2]{tidy dots} features. In particular, if your functions are stored in a list, you can splice that in with \code{!!!}.} \item{.dir}{If \code{"backward"} (the default), the functions are called in the reverse order, from right to left, as is conventional in mathematics. If \code{"forward"}, they are called from left to right.} } \value{ A function } \description{ Compose multiple functions } \examples{ not_null <- compose(`!`, is.null) not_null(4) not_null(NULL) add1 <- function(x) x + 1 compose(add1, add1)(8) # You can use the formula shortcut for functions: fn <- compose(~ paste(.x, "foo"), ~ paste(.x, "bar")) fn("input") # Lists of functions can be spliced with !!! fns <- list( function(x) paste(x, "foo"), ~ paste(.x, "bar") ) fn <- compose(!!!fns) fn("input") } purrr/man/lmap.Rd0000644000176200001440000001010313551365051013416 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lmap.R \name{lmap} \alias{lmap} \alias{lmap_if} \alias{lmap_at} \title{Apply a function to list-elements of a list} \usage{ lmap(.x, .f, ...) lmap_if(.x, .p, .f, ..., .else = NULL) lmap_at(.x, .at, .f, ...) } \arguments{ \item{.x}{A list or data frame.} \item{.f}{A function that takes and returns a list or data frame.} \item{...}{Additional arguments passed on to the mapped function.} \item{.p}{A single predicate function, a formula describing such a predicate function, or a logical vector of the same length as \code{.x}. Alternatively, if the elements of \code{.x} are themselves lists of objects, a string indicating the name of a logical element in the inner lists. Only those elements where \code{.p} evaluates to \code{TRUE} will be modified.} \item{.else}{A function applied to elements of \code{.x} for which \code{.p} returns \code{FALSE}.} \item{.at}{A character vector of names, positive numeric vector of positions to include, or a negative numeric vector of positions to exlude. Only those elements corresponding to \code{.at} will be modified. If the \code{tidyselect} package is installed, you can use \code{vars()} and the \code{tidyselect} helpers to select elements.} } \value{ If \code{.x} is a list, a list. If \code{.x} is a data frame, a data frame. } \description{ \code{lmap()}, \code{lmap_at()} and \code{lmap_if()} are similar to \code{map()}, \code{map_at()} and \code{map_if()}, with the difference that they operate exclusively on functions that take \emph{and} return a list (or data frame). Thus, instead of mapping the elements of a list (as in \code{.x[[i]]}), they apply a function \code{.f} to each subset of size 1 of that list (as in \code{.x[i]}). We call those elements \code{list-elements}). } \details{ Mapping the list-elements \code{.x[i]} has several advantages. It makes it possible to work with functions that exclusively take a list or data frame. It enables \code{.f} to access the attributes of the encapsulating list, like the name of the components it receives. It also enables \code{.f} to return a larger list than the list-element of size 1 it got as input. Conversely, \code{.f} can also return empty lists. In these cases, the output list is reshaped with a different size than the input list \code{.x}. } \examples{ # Let's write a function that returns a larger list or an empty list # depending on some condition. This function also uses the names # metadata available in the attributes of the list-element maybe_rep <- function(x) { n <- rpois(1, 2) out <- rep_len(x, n) if (length(out) > 0) { names(out) <- paste0(names(x), seq_len(n)) } out } # The output size varies each time we map f() x <- list(a = 1:4, b = letters[5:7], c = 8:9, d = letters[10]) x \%>\% lmap(maybe_rep) # We can apply f() on a selected subset of x x \%>\% lmap_at(c("a", "d"), maybe_rep) # Or only where a condition is satisfied x \%>\% lmap_if(is.character, maybe_rep) # A more realistic example would be a function that takes discrete # variables in a dataset and turns them into disjunctive tables, a # form that is amenable to fitting some types of models. # A disjunctive table contains only 0 and 1 but has as many columns # as unique values in the original variable. Ideally, we want to # combine the names of each level with the name of the discrete # variable in order to identify them. Given these requirements, it # makes sense to have a function that takes a data frame of size 1 # and returns a data frame of variable size. disjoin <- function(x, sep = "_") { name <- names(x) x <- as.factor(x[[1]]) out <- lapply(levels(x), function(level) { as.numeric(x == level) }) names(out) <- paste(name, levels(x), sep = sep) out } # Now, we are ready to map disjoin() on each categorical variable of a # data frame: iris \%>\% lmap_if(is.factor, disjoin) mtcars \%>\% lmap_at(c("cyl", "vs", "am"), disjoin) } \seealso{ Other map variants: \code{\link{imap}}, \code{\link{invoke}}, \code{\link{map2}}, \code{\link{map_if}}, \code{\link{map}}, \code{\link{modify}} } \concept{map variants} purrr/man/safely.Rd0000644000176200001440000000565413426303100013753 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/output.R \name{safely} \alias{safely} \alias{quietly} \alias{possibly} \alias{auto_browse} \title{Capture side effects.} \usage{ safely(.f, otherwise = NULL, quiet = TRUE) quietly(.f) possibly(.f, otherwise, quiet = TRUE) auto_browse(.f) } \arguments{ \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{otherwise}{Default value to use when an error occurs.} \item{quiet}{Hide errors (\code{TRUE}, the default), or display them as they occur?} } \value{ \code{safely}: wrapped function instead returns a list with components \code{result} and \code{error}. If an error occurred, \code{error} is an \code{error} object and \code{result} has a default value (\code{otherwise}). Else \code{error} is \code{NULL}. \code{quietly}: wrapped function instead returns a list with components \code{result}, \code{output}, \code{messages} and \code{warnings}. \code{possibly}: wrapped function uses a default value (\code{otherwise}) whenever an error occurs. } \description{ These functions wrap functions so that instead of generating side effects through printed output, messages, warnings, and errors, they return enhanced output. They are all adverbs because they modify the action of a verb (a function). } \examples{ safe_log <- safely(log) safe_log(10) safe_log("a") list("a", 10, 100) \%>\% map(safe_log) \%>\% transpose() # This is a bit easier to work with if you supply a default value # of the same type and use the simplify argument to transpose(): safe_log <- safely(log, otherwise = NA_real_) list("a", 10, 100) \%>\% map(safe_log) \%>\% transpose() \%>\% simplify_all() # To replace errors with a default value, use possibly(). list("a", 10, 100) \%>\% map_dbl(possibly(log, NA_real_)) # For interactive usage, auto_browse() is useful because it automatically # starts a browser() in the right place. f <- function(x) { y <- 20 if (x > 5) { stop("!") } else { x } } if (interactive()) { map(1:6, auto_browse(f)) } # It doesn't make sense to use auto_browse with primitive functions, # because they are implemented in C so there's no useful environment # for you to interact with. } purrr/man/map_if.Rd0000644000176200001440000001001413551365051013721 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/map.R \name{map_if} \alias{map_if} \alias{map_at} \alias{map_depth} \title{Apply a function to each element of a vector conditionally} \usage{ map_if(.x, .p, .f, ..., .else = NULL) map_at(.x, .at, .f, ...) map_depth(.x, .depth, .f, ..., .ragged = FALSE) } \arguments{ \item{.x}{A list or atomic vector.} \item{.p}{A single predicate function, a formula describing such a predicate function, or a logical vector of the same length as \code{.x}. Alternatively, if the elements of \code{.x} are themselves lists of objects, a string indicating the name of a logical element in the inner lists. Only those elements where \code{.p} evaluates to \code{TRUE} will be modified.} \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to the mapped function.} \item{.else}{A function applied to elements of \code{.x} for which \code{.p} returns \code{FALSE}.} \item{.at}{A character vector of names, positive numeric vector of positions to include, or a negative numeric vector of positions to exlude. Only those elements corresponding to \code{.at} will be modified. If the \code{tidyselect} package is installed, you can use \code{vars()} and the \code{tidyselect} helpers to select elements.} \item{.depth}{Level of \code{.x} to map on. Use a negative value to count up from the lowest level of the list. \itemize{ \item \code{map_depth(x, 0, fun)} is equivalent to \code{fun(x)}. \item \code{map_depth(x, 1, fun)} is equivalent to \code{x <- map(x, fun)} \item \code{map_depth(x, 2, fun)} is equivalent to \code{x <- map(x, ~ map(., fun))} }} \item{.ragged}{If \code{TRUE}, will apply to leaves, even if they're not at depth \code{.depth}. If \code{FALSE}, will throw an error if there are no elements at depth \code{.depth}.} } \description{ The functions \code{map_if()} and \code{map_at()} take \code{.x} as input, apply the function \code{.f} to some of the elements of \code{.x}, and return a list of the same length as the input. \itemize{ \item \code{map_if()} takes a predicate function \code{.p} as input to determine which elements of \code{.x} are transformed with \code{.f}. \item \code{map_at()} takes a vector of names or positions \code{.at} to specify which elements of \code{.x} are transformed with \code{.f}. } \itemize{ \item \code{map_depth()} allows to apply \code{.f} to a specific depth level of a nested vector. } } \examples{ # Use a predicate function to decide whether to map a function: map_if(iris, is.factor, as.character) # Specify an alternative with the `.else` argument: map_if(iris, is.factor, as.character, .else = as.integer) # Use numeric vector of positions select elements to change: iris \%>\% map_at(c(4, 5), is.numeric) # Use vector of names to specify which elements to change: iris \%>\% map_at("Species", toupper) # Use `map_depth()` to recursively traverse nested vectors and map # a function at a certain depth: x <- list(a = list(foo = 1:2, bar = 3:4), b = list(baz = 5:6)) str(x) map_depth(x, 2, paste, collapse = "/") # Equivalent to: map(x, map, paste, collapse = "/") } \seealso{ Other map variants: \code{\link{imap}}, \code{\link{invoke}}, \code{\link{lmap}}, \code{\link{map2}}, \code{\link{map}}, \code{\link{modify}} } \concept{map variants} purrr/man/reduce.Rd0000644000176200001440000001157513426303100013736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reduce.R \name{reduce} \alias{reduce} \alias{reduce2} \title{Reduce a list to a single value by iteratively applying a binary function} \usage{ reduce(.x, .f, ..., .init, .dir = c("forward", "backward")) reduce2(.x, .y, .f, ..., .init) } \arguments{ \item{.x}{A list or atomic vector.} \item{.f}{For \code{reduce()}, and \code{accumulate()}, a 2-argument function. The function will be passed the accumulated value as the first argument and the "next" value as the second argument. For \code{reduce2()} and \code{accumulate2()}, a 3-argument function. The function will be passed the accumulated value as the first argument, the next value of \code{.x} as the second argument, and the next value of \code{.y} as the third argument. The reduction terminates early if \code{.f} returns a value wrapped in a \code{\link[=done]{done()}}.} \item{...}{Additional arguments passed on to the mapped function.} \item{.init}{If supplied, will be used as the first value to start the accumulation, rather than using \code{.x[[1]]}. This is useful if you want to ensure that \code{reduce} returns a correct value when \code{.x} is empty. If missing, and \code{.x} is empty, will throw an error.} \item{.dir}{The direction of reduction as a string, one of \code{"forward"} (the default) or \code{"backward"}. See the section about direction below.} \item{.y}{For \code{reduce2()} and \code{accumulate2()}, an additional argument that is passed to \code{.f}. If \code{init} is not set, \code{.y} should be 1 element shorter than \code{.x}.} } \description{ \code{reduce()} is an operation that combines the elements of a vector into a single value. The combination is driven by \code{.f}, a binary function that takes two values and returns a single value: reducing \code{f} over \code{1:3} computes the value \code{f(f(1, 2), 3)}. } \section{Direction}{ When \code{.f} is an associative operation like \code{+} or \code{c()}, the direction of reduction does not matter. For instance, reducing the vector \code{1:3} with the binary function \code{+} computes the sum \code{((1 + 2) + 3)} from the left, and the same sum \code{(1 + (2 + 3))} from the right. In other cases, the direction has important consequences on the reduced value. For instance, reducing a vector with \code{list()} from the left produces a left-leaning nested list (or tree), while reducing \code{list()} from the right produces a right-leaning list. } \section{Life cycle}{ \code{reduce_right()} is soft-deprecated as of purrr 0.3.0. Please use the \code{.dir} argument of \code{reduce()} instead. Note that the algorithm has changed. Whereas \code{reduce_right()} computed \code{f(f(3, 2), 1)}, \code{reduce(.dir = \"backward\")} computes \code{f(1, f(2, 3))}. This is the standard way of reducing from the right. To update your code with the same reduction as \code{reduce_right()}, simply reverse your vector and use a left reduction:\preformatted{# Before: reduce_right(1:3, f) # After: reduce(rev(1:3), f) } \code{reduce2_right()} is soft-deprecated as of purrr 0.3.0 without replacement. It is not clear what algorithmic properties should a right reduction have in this case. Please reach out if you know about a use case for a right reduction with a ternary function. } \examples{ # Reducing `+` computes the sum of a vector while reducing `*` # computes the product: 1:3 \%>\% reduce(`+`) 1:10 \%>\% reduce(`*`) # When the operation is associative, the direction of reduction # does not matter: reduce(1:4, `+`) reduce(1:4, `+`, .dir = "backward") # However with non-associative operations, the reduced value will # be different as a function of the direction. For instance, # `list()` will create left-leaning lists when reducing from the # right, and right-leaning lists otherwise: str(reduce(1:4, list)) str(reduce(1:4, list, .dir = "backward")) # reduce2() takes a ternary function and a second vector that is # one element smaller than the first vector: paste2 <- function(x, y, sep = ".") paste(x, y, sep = sep) letters[1:4] \%>\% reduce(paste2) letters[1:4] \%>\% reduce2(c("-", ".", "-"), paste2) x <- list(c(0, 1), c(2, 3), c(4, 5)) y <- list(c(6, 7), c(8, 9)) reduce2(x, y, paste) # You can shortcircuit a reduction and terminate it early by # returning a value wrapped in a done(). In the following example # we return early if the result-so-far, which is passed on the LHS, # meets a condition: paste3 <- function(out, input, sep = ".") { if (nchar(out) > 4) { return(done(out)) } paste(out, input, sep = sep) } letters \%>\% reduce(paste3) # Here the early return branch checks the incoming inputs passed on # the RHS: paste4 <- function(out, input, sep = ".") { if (input == "j") { return(done(out)) } paste(out, input, sep = sep) } letters \%>\% reduce(paste4) } \seealso{ \code{\link[=accumulate]{accumulate()}} for a version that returns all intermediate values of the reduction. } purrr/man/partial.Rd0000644000176200001440000000514013551356667014143 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/partial.R \name{partial} \alias{partial} \title{Partial apply a function, filling in some arguments.} \usage{ partial(.f, ..., .env = NULL, .lazy = NULL, .first = NULL) } \arguments{ \item{.f}{a function. For the output source to read well, this should be a named function.} \item{...}{named arguments to \code{.f} that should be partially applied. Pass an empty \code{... = } argument to specify the position of future arguments relative to partialised ones. See \code{\link[rlang:call_modify]{rlang::call_modify()}} to learn more about this syntax. These dots support quasiquotation and quosures. If you unquote a value, it is evaluated only once at function creation time. Otherwise, it is evaluated each time the function is called.} \item{.env}{Soft-deprecated as of purrr 0.3.0. The environments are now captured via quosures.} \item{.lazy}{Soft-deprecated as of purrr 0.3.0. Please unquote the arguments that should be evaluated once at function creation time.} \item{.first}{Soft-deprecated as of purrr 0.3.0. Please pass an empty argument \code{... = } to specify the position of future arguments.} } \description{ Partial function application allows you to modify a function by pre-filling some of the arguments. It is particularly useful in conjunction with functionals and other function operators. Note that an argument can only be partialised once. } \examples{ # Partial is designed to replace the use of anonymous functions for # filling in function arguments. Instead of: compact1 <- function(x) discard(x, is.null) # we can write: compact2 <- partial(discard, .p = is.null) # partial() works fine with functions that do non-standard # evaluation my_long_variable <- 1:10 plot2 <- partial(plot, my_long_variable) plot2() plot2(runif(10), type = "l") # Note that you currently can't partialise arguments multiple times: my_mean <- partial(mean, na.rm = TRUE) my_mean <- partial(my_mean, na.rm = FALSE) try(my_mean(1:10)) # The evaluation of arguments normally occurs "lazily". Concretely, # this means that arguments are repeatedly evaluated across invocations: f <- partial(runif, n = rpois(1, 5)) f f() f() # You can unquote an argument to fix it to a particular value. # Unquoted arguments are evaluated only once when the function is created: f <- partial(runif, n = !!rpois(1, 5)) f f() f() # By default, partialised arguments are passed before new ones: my_list <- partial(list, 1, 2) my_list("foo") # Control the position of these arguments by passing an empty # `... = ` argument: my_list <- partial(list, 1, ... = , 2) my_list("foo") } purrr/man/set_names.Rd0000644000176200001440000000054113426303100014434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-rlang.R \docType{import} \name{set_names} \alias{set_names} \title{Set names in a vector} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{rlang}{\code{\link[rlang]{set_names}}} }} purrr/man/null-default.Rd0000644000176200001440000000057313426303100015057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-rlang.R \docType{import} \name{null-default} \alias{null-default} \alias{\%||\%} \title{Default value for \code{NULL}} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{rlang}{\code{\link[rlang]{\%||\%}}} }} purrr/man/insistently.Rd0000644000176200001440000000552513426303100015052 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rate.R \name{insistently} \alias{insistently} \alias{slowly} \title{Transform a function to make it run insistently or slowly} \usage{ insistently(f, rate = rate_backoff(), quiet = TRUE) slowly(f, rate = rate_delay(), quiet = TRUE) } \arguments{ \item{f}{A function to modify.} \item{rate}{A \link[=rate_backoff]{rate} object determining the waiting time.} \item{quiet}{If \code{FALSE}, prints a message displaying how long until the next request.} } \description{ \itemize{ \item \code{insistently()} takes a function and modifies it to retry a given amount of time on error. \item \code{slowly()} takes a function and modifies it to wait a given amount of time between each call. } The number and rate of attempts is determined by a \link[=rate-helpers]{rate} object (by default a jittered exponential backoff rate for \code{insistently()}, and a constant rate for \code{slowly()}). } \examples{ # For the purpose of this example, we first create a custom rate # object with a low waiting time between attempts: rate <- rate_delay(0.1) # slowly() causes a function to sleep for a given time between calls: slow_runif <- slowly(~ runif(1), rate = rate, quiet = FALSE) map(1:5, slow_runif) # insistently() makes a function repeatedly try to work risky_runif <- function(lo = 0, hi = 1) { y <- runif(1, lo, hi) if(y < 0.9) { stop(y, " is too small") } y } # Let's now create an exponential backoff rate with a low waiting # time between attempts: rate <- rate_backoff(pause_base = 0.1, pause_min = 0.005, max_times = 4) # Modify your function to run insistently. insistent_risky_runif <- insistently(risky_runif, rate, quiet = FALSE) set.seed(6) # Succeeding seed insistent_risky_runif() set.seed(3) # Failing seed try(insistent_risky_runif()) # You can also use other types of rate settings, like a delay rate # that waits for a fixed amount of time. Be aware that a delay rate # has an infinite amount of attempts by default: rate <- rate_delay(0.2, max_times = 3) insistent_risky_runif <- insistently(risky_runif, rate = rate, quiet = FALSE) try(insistent_risky_runif()) # insistently() and possibly() are a useful combination rate <- rate_backoff(pause_base = 0.1, pause_min = 0.005) possibly_insistent_risky_runif <- possibly(insistent_risky_runif, otherwise = -99) set.seed(6) possibly_insistent_risky_runif() set.seed(3) possibly_insistent_risky_runif() } \seealso{ \code{\link[httr:RETRY]{httr::RETRY()}} is a special case of \code{\link[=insistently]{insistently()}} for HTTP verbs. \code{\link[=rate_backoff]{rate_backoff()}} and \code{\link[=rate_delay]{rate_delay()}} for creating custom backoff rates. \code{\link[=rate_sleep]{rate_sleep()}} for the function powering \code{insistently()} and \code{slowly()}. \code{\link[=safely]{safely()}} for another useful function operator. } purrr/man/attr_getter.Rd0000644000176200001440000000212413426303100015001 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pluck.R \name{attr_getter} \alias{attr_getter} \title{Create an attribute getter function} \usage{ attr_getter(attr) } \arguments{ \item{attr}{An attribute name as string.} } \description{ \code{attr_getter()} generates an attribute accessor function; i.e., it generates a function for extracting an attribute with a given name. Unlike the base R \code{attr()} function with default options, it doesn't use partial matching. } \examples{ # attr_getter() takes an attribute name and returns a function to # access the attribute: get_rownames <- attr_getter("row.names") get_rownames(mtcars) # These getter functions are handy in conjunction with pluck() for # extracting deeply into a data structure. Here we'll first # extract by position, then by attribute: obj1 <- structure("obj", obj_attr = "foo") obj2 <- structure("obj", obj_attr = "bar") x <- list(obj1, obj2) pluck(x, 1, attr_getter("obj_attr")) # From first object pluck(x, 2, attr_getter("obj_attr")) # From second object } \seealso{ \code{\link[=pluck]{pluck()}} } purrr/man/figures/0000755000176200001440000000000013426303100013633 5ustar liggesuserspurrr/man/figures/lifecycle-defunct.svg0000644000176200001440000000170413426303100017743 0ustar liggesuserslifecyclelifecycledefunctdefunct purrr/man/figures/lifecycle-maturing.svg0000644000176200001440000000170613426303100020143 0ustar liggesuserslifecyclelifecyclematuringmaturing purrr/man/figures/logo.png0000644000176200001440000007453313403735151015327 0ustar liggesusersPNG  IHDRxb]esRGB pHYs  iTXtXML:com.adobe.xmp Adobe ImageReady 1 ).=@IDATxUOrI {'TG2:vl(*b/ v+(R @( SkΝ͝;3:w+]|̉W62~֠M53gGf4;/ 7~?sf|Φ;ԸJ*>nn4~fWJ}zW4VO,)n_4tI1RW_9ƽߺޞ޾Ɔֆ {{O]>vow˞^ղ[>ҙHcQY"%Y}}ؾT mĭ6ciAFZeaQ}à͝$n%J,uHZ}Mj/H})ːx'" >+"v?`m{+JORXH}|c[~})z97w-2;{SΎ>`z}]J%΂P]ilW?߰x#7PuOڗ.Kbqغ}ctvm驫o =@u__`^Sgu-iJjʔ!?vGt56 j%ocN{⠃&Ǝ׿WĨc)y4Umu}•Oo]#_hk?V-L59aƀC· H-틾b>2:!j7*R boڸ)nO66,u1HUf㛾Y%h(v~?k s$T_vvU;{Dq1yd::; q{{zolhLds*2js{l>#>)ʺ>Me¿J @M1xRo|dig$Z/#^߿m1{IN '%>C]#H=UB_`O<>?~ۗ};=fN>>@V2ز'7${{ۣ. nz^#__kQkJ;+B$:RWLvKcĈQHZg(J9nRJUx^{_vv1b5?_o#3l_*t>/I[W˩d: un Aq Vo_WwoW}uZ,>g&N5zzz Ti|+嶨UDWmn h G?Y|$8Ѿc B\Ϸf¿Jv9&7/?|` ]޾&P#OĶ%gx˛샑nl˳#mjJe7D2K"'P1QI>"}(^6G?L߾"F;6z:v=ǕO=`"a϶x3~u {)ر-ydeLg\|c_::Dg;}V-E{%@Het* ӓYWUց@Hh7!D" _޺u[~K>XL5$ l޶hŢo ?ܵO?;&\kO_UcB7s+QwHH.> [U{JI'F.ԱA!W*q-*> \MψrIkz*/RUJ V]wFlT;3}|̟XPjdly&%_^7}Ȟ ЩR׸4u{>xk^3fJDwtl^ %V ̅"TxJLFW3 ? =;6a765"jÒQǗ|o&|[Y_~k: AWrj4T =^yJ-?0[2(I%SҠNMr)ɩ$ $K2W P.nT@!SU%Agl +!xy"jW"S%`$K{DK&PJePc$:n-/m5ͨ5h`'5n6ĭ]XhiG|{S=}y/J`~qxq҅pa i8+&]YIjstFLEJ%HQ i˭h;8:dIt'+)M=i9$e}fSaOáK.{Ϡ؍  KnK(v%_Ev:w>x;3v?~"xK 3g/gAR]DR*1OJ "DDH`8(.]" /ZmXBt;D0:ࢨmG:azO=X'We|#qny1-=/N'=b9Ò?~ a[ԨaOyGVT[,H`J$ȃ``PiL'RscmpL&{[cS%SfYM*Rxy?RP~G~kMtv%qտ#wCV%u˟ܲ!#Gq/ :G2A"t7 ?bi#G|+#>r4HdnOAN$?b@K| D" !{>5s/94JT/$SؙHYi֞MCC'iRc4WT6osS8,9aI+aɕd?㛋ӲdZ}Njx oZ.:g?g`g'NIH$e&BD8)-%x)^`oE$gIkbJ9ֶ7< &@{ɟ,dgKO^T8ZiZ|̈WVydJzlsS}],Y$~_?qRۭ;t#KKa.ybӵSv\o;/ƛM %ܿeC; չP?"ўQ;0rr\şJAꓘʕ VJT%7ubm۶w{͞{͚㦛EI\@cǩg̉G4~unq)$=@wb;*i*_4^uΉaXtq|SY}wOtćM.y:[o׼gYzj`h@p(@ @}E⸶q}'>//8pUǴQfG{AJ}br>Qf}QhMZx߽)L B;m`-~r\W+6o럷_3N~E;#7mo|K TӁcׯ_Skh Қē͏o{"i܄\]cFM;~3: NHV<Й?g}N׿(Իڋ䀩^Nj69k /10|B33l؈xk_rhh / *;67wnm>Wp'c{#Gb}iN9m,:z u54 2~Iܗ3w73TKGk~{C\ybrVf߈xzO^CڀZd2xHzqg[;f\2ÎdQ#*ڨn3XUjX"Damڴ>7|}S{u[W.&442YMқʱ4 3|gֱܴJsݸT0K[Xj:645Ƽ1}xx~ʘsQx L- .'Y7_y*L`ҶDso}롓#nᮜ[7༗U/;QA=(+WYLl[52 o;;wVGsc;Aw?SGOknϥ5YЅAP}誹$O6伮P%~S$yTO4CrZusN^?tVjL{3'|RP*TLFKH1Ӏ*C>*,lEklZH ~yq5gk7bJ{&?ѨD=q1ЏJ p]nZm'&<-s p6vμtkbfK,{Gtj:E(زusJN/"-sM\x jLTjZwf2Kb 9f6˃ mLk)X\gK"d\ȢezKEs)>Gt\l~.NUƷ~RS8K14 {k[lhAK'tCHP> !r5氳+/z*Xkd Z/29C)1O{w}G6_kkqZ虸⇗slWZrȼ~j0V%vd,ó diq$|_.;>KQ^?f_׃zɴ7 ^C'꨿) r;8uף0^)}'ᬺhIBrލT''AsLߔLʱx|PE{1T?2 #}`e@gǽޝg]Wo]1g1ykW^c5=}o9ː1`!͚RSK#ܨ4(Z65a2kA.Z$\-sxL΃[B5Tc鑍*`ʵu/yMV³.a~>c q9= مyّq.% b2%`-o͂ѓ/ {_·$uk֬(_4C۷\RRd7-Y7)>0%p7Qi E6V!12xFtܑ9˲YjEU5]WtDp@۾jKm@@p< 9/g;fK%*KF2`geonuk>8x1Ӧ*'^74[wykY:~hQW_fƗYiԘ1ca/ u(ab?} c9{#B>7#N94Ln貰D><؎Ec|\Y޲DE^S&OiCmA|E|C5RtCmQ'0(ɞK$0$_J8>K&˧ ݪw$k|ʥ_dVάۜgX`pN}]g;٨iIKmUmI6]RK8f3%O[h i/v1nmT;!<@ ^j lO&Y0L{'$lL@T'LhF`'Ra^çP6"ZsQ\eY ESr 'MPeg}[8Trs9قs]THMc w6H<$ t> 9#&L3*;!g-pQԟ | ć>06TrxIm"SRC= C(S밹,Gev ؅AOąϭ e8UGS,ުylɀSHҎO LN Ny(r,,LJ2ba"-PU?xv5K0IY$SewGul9⅒N/]΀ ~ͬ"0ud2tBFDp`:9PҤ@W֖Ϩam,^)f `4^a^]а(27f}i6 8GfO\{<͚Nn$l,.zx;IV(R@,/ SliI,sN(mW\sC5(%Sgm3Ӌ*5B^̪mX0U\RYWFиox2`~%ռ @ @d$uNuwg=JnYE )HD L'oxCN<9# ,8JᱝX%oOf541!#LD*6QLғJXj.By$d{v$rV-_#{l~q1ldZVfa2P,B&V$Rf(IΝCki ^ǶRVv0+[hwf˛)8#WC8%LDڥ%t g} I} U9rV"џ,e1⚫=@,~iP~ EbmHPR&kgkKHrE}O@.Ň?8vqFцJR"粸*5f̴$ )xooFG4,C\@j:"0HS%R91l+ϕX pS ]!ҙh,UW[ʐIXS%Q%pA<)!z?'F{ͱy4R'XTmK94LĈ0/Ȑ+ဨāT#xq SK239Q%,dePQV2 %(>2TfvPu׶"jCD^]]#l,K*2C\ۦ' #!c’ycL fY H *<8 ,)q 3,\=?%q}wMe@Arki~ D2TrhyԘYl/_?b+Qxk^G>Ƣ Ɋp7=!%B ѤOrWE[+₳ҷ>ǫrFl+y rǞ,S:ATj"`gXO"=V-i&#A&e|e^;-DvذaN29p&CnO=c Lt[OI4Y[+9f UA-E8,,'MI`TzԄ~_ŵXo{s-#>ꆸ+bsKwe>D&-a7&!`CNc h4t2fCdHJ2HjZ˗YI ^˫b=2 i뉻N&%{nɜy9KWj eF^1D"1PlcQ6R!֯R}1tpۡL;q/}1xDU521vC.2DQDjN1d d,dD9ʕK~6VX]teĤݦcg.ɔ BYGfln'NWZ'Ll)ծZ/O'MA̘rU ([SoSnJ#aeAG:Ib[ _B|Eۀ١Vp/6.} *XFicƌYaz4PS#Dm$ q]pbǙLޗqet6ns^tMcUXxlAa'&O3:uf鱝<9긃>LYQKpmrz$nLEAA,;ynTiF `֮viJFP aII ,h!*; !Alf ڥ!vkxH+.8$e`{X\+܈ B;+Wǚǘ0~kNa8oCB-^y9^fogҵX Bv;]dQ\AÀuJNBoCK=xQ(@]1!G{ëYRV<&q\`}}V}|Ҹ ݕϾ?U=d89~D1 +) fzE(eHGIh3}q.<߂]׿WR׃0~l?}=q f3ɭSoI,uajhĈHn':(l/꯾-?ƢMԮ!: I<-%TG1Z{fDJv`5B3R܈]='&Ƶ]X1|Լ#1cbYYT7r &&**"\n4N=%mX&jƪOO.D㞚@<O<{{]c,|•K"jZ@?F-*Bg @/uY!/gM'f3+ѨR9Y*sF"K>̜GZbY4BhTCR(m"wut;Q=}y_,N؋:[b)- R0q0K9ݯǘg{72 ރeb[Xc|٥[6x)鏞- ~5Mlz%K+D\=ՖFڔ¨bPӐJ k);] c=}3)v?3?3G;|n;GfnW#=mprXU , ֎$pFvw.h޺y p#"5pyM]jfKX8"xckM''OE}3 E-/E6ok1/W-["tXxcCf4%))Mg l@#j{_Vθ鶸;EĞ{웶_1#~2.J?1}h#x1vyٱ7@q˧Fuv -' fM:jRHnhp]CLG$d) *'%Vx$JB(ü|)aJn)βsHrӞivڳmژQؼq]5)3ʲdr&)=}ZKCHeX1'q^O 0HN64{"4k87"C40 U<ʍTc>li~u ~vF)Yi 4 i%b\NK\dR?Q%29yl8h,rZƲm$CeȊ4lB2c8}̍9~󫟰EԊTi:HC/fMa3*+0\';@G!7^A )]P6 EH;,Aefp&z}*6ƅ+t@V+Җ&§D!H'pW"֘Ul9AO<Ўz!aP+F&NX~wzz$z}ƝsJ?2CtHO;2 oHj~o뺸ж)!wc.J#hݺsى:yWCF.szk@#$m P8d w"N<9ARCE` ]0 6èiB )$iB4Vܢs;0H^)Ma"S]ȬGXXZܐ;I^-jT*Lluү%eҊYo~vy܅Y4=dLSz{($\ &ƌJPQAR)f:K[I{mTNjZJۄʢ"d [įcN "9Z{C#E?{Mn݆*p$R6{on$L@ =D!H;ᘹBm SjC~rFdRzs)CEtx@ 7= 2փ8,ƍX|MGֱj&B0m>`p%q &T8yÓ̂p9Z0Ks 'e"S)dU.w;ɓգ[F$Zd yDŵi9%iEJB%STJ }N}qUxđu(u\k[2 yh؏,'x?1Bf*6!PS$Ic>׬^zv2X~e 7IOxg=RڹN 99oBtCTuW=&[V^EE˩yM$GeCyhp?ϣԅ2qq҇ -Qv\?@.LnmR\N8U" 0y& x82D'YJ_`D:MUj&_kN<8Q6i}"?x`#3ޓ* l©;}-7 MlXNdV뮻1sgNP u d%o Y̰*ӅZ(CC6H71O)>BLfMJs; 2l#T%OF¤G&.`R ;|g?].y:X6X';',&򒪉Q SOy*J* DA)!JiR #I5S=N-7A.R=lD)62Nxo4VзR*RPvVD4ay?W].l5{ C Q2VBlX K\l aj>[o P`* ׵3g@%RsUYȒËϠʔ;EgUmUN29;ݯ?tb";s|><,n8dԸ+#CTͲI;o(te͌f5p.ѿ<.!ξ4uf~O/YIyѪ ]*w18F@f1{OJW^BIX>zێ&,'6HlZ!pRo~KȔ[JC6VI'XtJrK[*߈pExyl_!dIj_:bb ?sН~ }YCql}׼w/bĸ˰,'] ]^Nuˇ]|4z=fvS=cv閛lO1-&QcR2J y(3  %KF:3N'Șv+&ʼusv|u鼵Xk]S3i5 -SQ^6By7)Lx ު@eå:T`=+qk4 ݸ{z 2[䓙WӢtv\ITv_9Gv RɣN*m/p#8\'wuy_59:f5Y9£G=qK_{_υNڄSSpܪA*6*` Ͳ<TINj !]Xɴ]#`H QMI>X&,K {֑~ yvV5ۍA%CJM,p]7] ћ[ J2ge+wݼgVmg-$6v "5hq6T-X#]bAHߑZT}q޿-<1&ty{ 'ljH;V9HQ2bNP_υJxm*yXf jϪ-*q"#$$0s[@6\\fAXtuv٘ 0&;KJ G-mR"cy[o6\M 9a~ҔA b` D2YNphQ2A&4:4 ҥjA)!Ҧ/-&O:^+ Ș&G(WQͭ|q1Sf PU1ka*jN-lmɝV&Fx\ /ƌ9z_ȝU/.EnA$o.fԶ3i/?)SOUvThv,++q2qCU^9"AP 4# 'I"BXJ.S~ 񓟱tϦ:ckboLׯsd ptUj Lq̓ rئ8mVᐘz\Xnj :/'nZŻveW8ڱ3cyIԲEٷ)jNzTCYUB*ݮ^=E>uz,QihuL|X?+U iYAr37@©""?>icĀM8"m}Nc%-IӧVxY!2{XtV OX"꾓Nd3muZ/0$J%U82dfDtC5.x\qa#G48vv1~<;c Kc<4 ~]Ȍns2mrP2Ҁ&/*Z <ě[竎Z_*FrrG#3.%sZ<ڷ+cYj96T*mV?2G GQ LcP"EHJ[osqo ©`Z7ZɬC)̯W, (4ԩi +%d Fy㩙-k*=ˣ0G7*׶ڵ48h ;hm)Q`X뵁0-,㶛㮻om7upĔB@{3v(fOnl`751rΎOщ _-8%>0f5xgÄ)~b)1s8s&NtF3S{Ͻ_1mbSNUGIEHu i_;Dx($^s}(vyQv l@]vI$D;(UDW%Ѭ3 hy4Tx (ij2%_„/X S"y H$` EK%he˗7)Vm}sh;u6n缕tgrykeѳ/ehEs@`O؇HI N{`;$RMocjtXi8Eػmr"sD601"`vԂ"΀# =vؒiaL:5<9J)UVR% c%T%%SM>U{Ia0 {A܃H 3fG>X1J)VYC\ WIb; % r׬Y7xs=!|jqB};뙷= ;D 6é-ZzYU NP2 ȟ[`idh;O\aNx(H)2!E ΂qrzȖ;r Sw- Q::yON;Pl }U͞;oGYU,O^&yw(Е[:d^UwUBi:Ig6B,!u-Ynm![6q ԲR5fLD!=MlI1K2p(Y z-ex)Q->JcA2 `XJb}?dWL-&Q,݀0rN 9SN4mڌ8e &(_R~f:277MQpΖP+V>CD%0L4RP81 JKO)\c_w` '0ٸl]%6OFWIJ{V%z/" -QY0v3nI`n%yJ,$TB⢭ްhcL7߭GlaĞY3A(l *(V~$!6JG]iڈA6U+AD0ZY6L`crdl#y@-3ۚkHܒ'0&v2c{i=|rmkȜ3"`%0`zΑs`7.TbλMC݂>,fKFZ?D3&ں[72Y2ߊJ\%Sȓ_[_Ӡc6_kԍnf*2@2) DVbCdJY$—C^ZFC6hr!V֗6P%p( Yv鬉5yʮ1bhKI,DeُchFSZr' e|Ǝɉ/mi6dX:uZߴ>60o%bT@̛w_,~.p1P7 VUu]KkeB;مӎJ qbC!cO'Hy%cJ m Wrs/֫HsZjh2Rs5?ݾ<( qnL ]I@M } 2,yxūu8Ə먄pT:(} \"|j= >WP,x阵d`j`UeE7CzXմ$8w"|Fh_i@.';N/bvDĈR9OZuv|"*zw"˖I/yyL2vGeD C4ykQd![H(> Ϲށ6ü 9aNdvHu<q^2\%~%1eY2E-?/Zzl{|VLL,[Ja.~r^ǰm*"'*yǥ߸$}~L5b[N黆 >lƲ}.M YIN NlE~PۈE+Kqqī_*o =bl̀FDr ,e&rxĥÔ\UsfpjLW+-?)GCFI! UUE  K(/2LP>BAr3fK*9@\Bg,#HL}uh,O~Yz4F/\:iAf)['K?3g^+W,ZE6f7 +.:1!ohϓ8e_`/idDZJ gL(XT6\ym m^N6 D*u n^7nWt'weַsh8®E-X܍F>}ݫ-q =ndp߮]jjzzJ/J؄;-3S{gƝ0+UAz':UȖK|W{g]eyބ$d7Dbu4#b;LkǪ*(R\Q+eR,x8e: eQ MBwoHҙlywG;u~be f28&8\5?$UԎh56c2*$u&VBQAv]YΎ\3~Ek4k*&?y @\Id 'Nrd3̨Y\v QGGLd"znZxa|yWQ,_v~g+\Rj8I@@ PK|2<:_!-;j^mRSf,Gĉn : VWvF?B$q|bRrӚ apq@ԮzZM{+U;$k PvumV7c0ق=&}`/& c_^Vf\fɯ*CZ`aݏgzPLkQ֚.H;1HpRG5DQ !qKNLTt(m*À8 B;Mt N ;Eͫ /L)=^jk(ʙXJv4~k%S8.vcei( :Ut_)J&SJ(-~DĺI߲u;u#WO.KFI7~"lExM<^+rS̼s~]G}Yk5ܴi͞-x%ơ+;ZZPa@5/֕7UOrWo:R]޼$.1"d$wխ)Aa89NpȓWRzz˹"*ԫ\,  F@rj93[Sư'RÐcԮ ! q=jH'-X|h BڜC]l`ңG7;{?^q۴ɷ:q'Cf8?4F >\&Ec `?,+pوuLƬB~TqEXͨI/:˝&}:˚sje}KD=3R #\ٚO[}9Ipt0j/Zo'n5?$P338I> szVo~Q]eY #U5H#Q)+vCȦ/i N{M6Acu#ts; )5pYLBN,+å2Ie8^3(N]UCŶd"oIv˼|a5 e;\&šnZSg]?w>H간4hXfn k%J"G iE-xe/m#ng iu\ \u'zT2ӶW7l?|;s=1zH? V˓n#(ݧɩh5%kI.^Vr6nd?_Mlef̈́ӲTεEP0'i\!+LDYUTM{+*Xd͘;ݪcMa1d -E:[WZS::#*H4kV֗[Q^] ;^1 \px.4Ĝ[gA@qz Ro]={楧fQI C\ CҰ2 )` 0*@\SS[H܌;Rgo{sJ[SyiS bJfjBcKehGMxUi&Qa۶m/Uo#B Uf2${k;tIl"w&Sc%>d#.Сnkdhc!Zqǟ>8ݷ[2˅n͓E"Y3Wr\ >c!n16I1g=4Ö.^ bB)"WA -$ b1hI$cD< [h3mdY!.{gjv|C]9~;ʌtIcpKJ%%!%4_ es:EqmG >ՌC5Ԗ5~?uw?S_$p 1 @5q 5(n {3VRr~v ~hِdN R y,}hw]: ı}N;C?w$ЇiS 3_^u؎gIo?0olP18(!*0C^PspQ@|K뜶+ذv6+txŲw Mˉ=dW]c82#bpX87E%XR&ޑÇX@^RnSRS(m@ \[e[r$N?L2Yg:N2()ɯ!ÓzivK]u8-#p0[0صp#}m_4>,ùPJNnhXjٞ !VvVOj3齠cZQ ZJ-jKh<[IJ5KԎK"-q. (E /\"_{ \e@YrfůjbW 'E`LM28TizӛM?w Kޏ~ žQ ,[hޏ즛n@E"*"V6 H/CH[ZzrlL !W4H7˺o]%Xi0ou:]4M{Ki+ukؿuˆ&!Ҧ6g0|'>хF{}{%~֊*dKu.L2g] H ,0nbi̐)AQ]QIHPY#%aNW`)؁|u6#~Op!ԤD<M߽{=lƋLRQ)wP uMlfQ^v/3NU:k% ;͡%İϱ%{-.R#E =ؑau8NWLu$;òǵB:=)%1ҥ29$r$[Y3Yݻ_2';x$-'H: l!7UWMOr'{z[TX|?cW$gL~T` k7qkJtȚ%wI 23dyK\+O t-Zyb'ybVTTܞcX۪;P%oԦH!늑T "(_wGa</Vc <Y\3=;94+:? #xgrZc [fKfFV(*WZ0-.Ѐ88:aW$#NzWX̓i[[<@! =,&w OËW1?[Y =8tJa.sLX2"=}=h 3Z҆Wbwg:J.Rf[e zEXg " %'D K)sEFgiWB{OغU,ed_`TqLR:WNXKS.ݤ~g{zVbFg8|x%-. w{GH\<߷4ٴoN;eef9m62!"O,mCYLN}4p}D%bF/-pK.(VLc:fZs՞wvĝ{%7'5V%mQW^X2.+%Wid@[R`ũ2wBES2!Ê! :;{:T|%rJ~6Smm&6>UE _aݻ|]?d&?q4]CJv&,)[@XP!'ZZZ*lD\/T,T*},<ۻoPc :-_QƍT߻ J!|.G" -fm=>8g p3uT,b]ーd(aDU1+)%,y5j#>TBp٪XF::c?Z$9/~jo.,j '<\RPN-+Q|Vr\'pAUZةx:Oy54$24&*k?nl~+\f]j1Aز THIIx=OyYW \VFVZE_Eiy iiL)kad''$'7؊+ p#&: ?6ڢxm%?n8^mNf-v(c vFV(5Ū|HZWQ'8FKc҉s8_80=͆v%Q؟hv{m 7}矴>saĩꎱx0:va Jh7H3&*X oluiCc'dRE'a;J/-Ņm#Q}߻yt9gr瑚W9 1g\Xş#¢}ǫ&#m09SMM͕0^93 v_Ys@7vQ‹"SMQm }5P`/csw~rmk҆eFg`/=nM& T| `Z-)5p64>Ǡju^pQ IENDB`purrr/man/figures/lifecycle-archived.svg0000644000176200001440000000170713426303100020103 0ustar liggesusers lifecyclelifecyclearchivedarchived purrr/man/figures/lifecycle-soft-deprecated.svg0000644000176200001440000000172613426303100021370 0ustar liggesuserslifecyclelifecyclesoft-deprecatedsoft-deprecated purrr/man/figures/lifecycle-questioning.svg0000644000176200001440000000171413426303100020661 0ustar liggesuserslifecyclelifecyclequestioningquestioning purrr/man/figures/lifecycle-stable.svg0000644000176200001440000000167413426303100017573 0ustar liggesuserslifecyclelifecyclestablestable purrr/man/figures/lifecycle-experimental.svg0000644000176200001440000000171613426303100021013 0ustar liggesuserslifecyclelifecycleexperimentalexperimental purrr/man/figures/lifecycle-deprecated.svg0000644000176200001440000000171213426303100020412 0ustar liggesuserslifecyclelifecycledeprecateddeprecated purrr/man/figures/lifecycle-retired.svg0000644000176200001440000000170513426303100017752 0ustar liggesusers lifecyclelifecycleretiredretired purrr/man/lift.Rd0000644000176200001440000001360513426303100013421 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/composition.R \name{lift} \alias{lift} \alias{lift_dl} \alias{lift_dv} \alias{lift_vl} \alias{lift_vd} \alias{lift_ld} \alias{lift_lv} \title{Lift the domain of a function} \usage{ lift(..f, ..., .unnamed = FALSE) lift_dl(..f, ..., .unnamed = FALSE) lift_dv(..f, ..., .unnamed = FALSE) lift_vl(..f, ..., .type) lift_vd(..f, ..., .type) lift_ld(..f, ...) lift_lv(..f, ...) } \arguments{ \item{..f}{A function to lift.} \item{...}{Default arguments for \code{..f}. These will be evaluated only once, when the lifting factory is called.} \item{.unnamed}{If \code{TRUE}, \code{ld} or \code{lv} will not name the parameters in the lifted function signature. This prevents matching of arguments by name and match by position instead.} \item{.type}{A vector mold or a string describing the type of the input vectors. The latter can be any of the types returned by \code{\link[=typeof]{typeof()}}, or "numeric" as a shorthand for either "double" or "integer".} } \value{ A function. } \description{ \code{lift_xy()} is a composition helper. It helps you compose functions by lifting their domain from a kind of input to another kind. The domain can be changed from and to a list (l), a vector (v) and dots (d). For example, \code{lift_ld(fun)} transforms a function taking a list to a function taking dots. } \details{ The most important of those helpers is probably \code{lift_dl()} because it allows you to transform a regular function to one that takes a list. This is often essential for composition with purrr functional tools. Since this is such a common function, \code{lift()} is provided as an alias for that operation. } \section{from ... to \code{list(...)} or \code{c(...)}}{ Here dots should be taken here in a figurative way. The lifted functions does not need to take dots per se. The function is simply wrapped a function in \code{\link[=do.call]{do.call()}}, so instead of taking multiple arguments, it takes a single named list or vector which will be interpreted as its arguments. This is particularly useful when you want to pass a row of a data frame or a list to a function and don't want to manually pull it apart in your function. } \section{from \code{c(...)} to \code{list(...)} or \code{...}}{ These factories allow a function taking a vector to take a list or dots instead. The lifted function internally transforms its inputs back to an atomic vector. purrr does not obey the usual R casting rules (e.g., \code{c(1, "2")} produces a character vector) and will produce an error if the types are not compatible. Additionally, you can enforce a particular vector type by supplying \code{.type}. } \section{from list(...) to c(...) or ...}{ \code{lift_ld()} turns a function that takes a list into a function that takes dots. \code{lift_vd()} does the same with a function that takes an atomic vector. These factory functions are the inverse operations of \code{lift_dl()} and \code{lift_dv()}. \code{lift_vd()} internally coerces the inputs of \code{..f} to an atomic vector. The details of this coercion can be controlled with \code{.type}. } \examples{ ### Lifting from ... to list(...) or c(...) x <- list(x = c(1:100, NA, 1000), na.rm = TRUE, trim = 0.9) lift_dl(mean)(x) # Or in a pipe: mean \%>\% lift_dl() \%>\% invoke(x) # You can also use the lift() alias for this common operation: lift(mean)(x) # Default arguments can also be specified directly in lift_dl() list(c(1:100, NA, 1000)) \%>\% lift_dl(mean, na.rm = TRUE)() # lift_dl() and lift_ld() are inverse of each other. # Here we transform sum() so that it takes a list fun <- sum \%>\% lift_dl() fun(list(3, NA, 4, na.rm = TRUE)) # Now we transform it back to a variadic function fun2 <- fun \%>\% lift_ld() fun2(3, NA, 4, na.rm = TRUE) # It can sometimes be useful to make sure the lifted function's # signature has no named parameters, as would be the case for a # function taking only dots. The lifted function will take a list # or vector but will not match its arguments to the names of the # input. For instance, if you give a data frame as input to your # lifted function, the names of the columns are probably not # related to the function signature and should be discarded. lifted_identical <- lift_dl(identical, .unnamed = TRUE) mtcars[c(1, 1)] \%>\% lifted_identical() mtcars[c(1, 2)] \%>\% lifted_identical() # ### Lifting from c(...) to list(...) or ... # In other situations we need the vector-valued function to take a # variable number of arguments as with pmap(). This is a job for # lift_vd(): pmap(mtcars, lift_vd(mean)) # lift_vd() will collect the arguments and concatenate them to a # vector before passing them to ..f. You can add a check to assert # the type of vector you expect: lift_vd(tolower, .type = character(1))("this", "is", "ok") # ### Lifting from list(...) to c(...) or ... # cross() normally takes a list of elements and returns their # cartesian product. By lifting it you can supply the arguments as # if it was a function taking dots: cross_dots <- lift_ld(cross) out1 <- cross(list(a = 1:2, b = c("a", "b", "c"))) out2 <- cross_dots(a = 1:2, b = c("a", "b", "c")) identical(out1, out2) # This kind of lifting is sometimes needed for function # composition. An example would be to use pmap() with a function # that takes a list. In the following, we use some() on each row of # a data frame to check they each contain at least one element # satisfying a condition: mtcars \%>\% pmap(lift_ld(some, partial(`<`, 200))) # Default arguments for ..f can be specified in the call to # lift_ld() lift_ld(cross, .filter = `==`)(1:3, 1:3) \%>\% str() # Here is another function taking a list and that we can update to # take a vector: glue <- function(l) { if (!is.list(l)) stop("not a list") l \%>\% invoke(paste, .) } \dontrun{ letters \%>\% glue() # fails because glue() expects a list} letters \%>\% lift_lv(glue)() # succeeds } \seealso{ \code{\link[=invoke]{invoke()}} } purrr/man/accumulate.Rd0000644000176200001440000001504213426303100014603 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reduce.R \name{accumulate} \alias{accumulate} \alias{accumulate2} \title{Accumulate intermediate results of a vector reduction} \usage{ accumulate(.x, .f, ..., .init, .dir = c("forward", "backward")) accumulate2(.x, .y, .f, ..., .init) } \arguments{ \item{.x}{A list or atomic vector.} \item{.f}{For \code{accumulate()} \code{.f} is 2-argument function. The function will be passed the accumulated result or initial value as the first argument. The next value in sequence is passed as the second argument. For \code{accumulate2()}, a 3-argument function. The function will be passed the accumulated result as the first argument. The next value in sequence from \code{.x} is passed as the second argument. The next value in sequence from \code{.y} is passed as the third argument. The accumulation terminates early if \code{.f} returns a value wrapped in a \code{\link[=done]{done()}}.} \item{...}{Additional arguments passed on to the mapped function.} \item{.init}{If supplied, will be used as the first value to start the accumulation, rather than using \code{.x[[1]]}. This is useful if you want to ensure that \code{reduce} returns a correct value when \code{.x} is empty. If missing, and \code{.x} is empty, will throw an error.} \item{.dir}{The direction of accumulation as a string, one of \code{"forward"} (the default) or \code{"backward"}. See the section about direction below.} \item{.y}{For \code{accumulate2()} \code{.y} is the second argument of the pair. It needs to be 1 element shorter than the vector to be accumulated (\code{.x}). If \code{.init} is set, \code{.y} needs to be one element shorted than the concatenation of the initial value and \code{.x}.} } \value{ A vector the same length of \code{.x} with the same names as \code{.x}. If \code{.init} is supplied, the length is extended by 1. If \code{.x} has names, the initial value is given the name \code{".init"}, otherwise the returned vector is kept unnamed. If \code{.dir} is \code{"forward"} (the default), the first element is the initial value (\code{.init} if supplied, or the first element of \code{.x}) and the last element is the final reduced value. In case of a right accumulation, this order is reversed. The accumulation terminates early if \code{.f} returns a value wrapped in a \code{\link[=done]{done()}}. If the done box is empty, the last value is used instead and the result is one element shorter (but always includes the initial value, even when terminating at the first iteration). } \description{ \code{accumulate()} sequentially applies a 2-argument function to elements of a vector. Each application of the function uses the initial value or result of the previous application as the first argument. The second argument is the next value of the vector. The results of each application are returned in a list. The accumulation can optionally terminate before processing the whole vector in response to a \code{done()} signal returned by the accumulation function. By contrast to \code{accumulate()}, \code{reduce()} applies a 2-argument function in the same way, but discards all results except that of the final function application. \code{accumulate2()} sequentially applies a function to elements of two lists, \code{.x} and \code{.y}. } \section{Life cycle}{ \code{accumulate_right()} is soft-deprecated in favour of the \code{.dir} argument as of rlang 0.3.0. Note that the algorithm has slightly changed: the accumulated value is passed to the right rather than the left, which is consistent with a right reduction. } \section{Direction}{ When \code{.f} is an associative operation like \code{+} or \code{c()}, the direction of reduction does not matter. For instance, reducing the vector \code{1:3} with the binary function \code{+} computes the sum \code{((1 + 2) + 3)} from the left, and the same sum \code{(1 + (2 + 3))} from the right. In other cases, the direction has important consequences on the reduced value. For instance, reducing a vector with \code{list()} from the left produces a left-leaning nested list (or tree), while reducing \code{list()} from the right produces a right-leaning list. } \examples{ # With an associative operation, the final value is always the # same, no matter the direction. You'll find it in the last element for a # backward (left) accumulation, and in the first element for forward # (right) one: 1:5 \%>\% accumulate(`+`) 1:5 \%>\% accumulate(`+`, .dir = "backward") # The final value is always equal to the equivalent reduction: 1:5 \%>\% reduce(`+`) # It is easier to understand the details of the reduction with # `paste()`. accumulate(letters[1:5], paste, sep = ".") # Note how the intermediary reduced values are passed to the left # with a left reduction, and to the right otherwise: accumulate(letters[1:5], paste, sep = ".", .dir = "backward") # `accumulate2()` is a version of `accumulate()` that works with # 3-argument functions and one additional vector: paste2 <- function(x, y, sep = ".") paste(x, y, sep = sep) letters[1:4] \%>\% accumulate(paste2) letters[1:4] \%>\% accumulate2(c("-", ".", "-"), paste2) # You can shortcircuit an accumulation and terminate it early by # returning a value wrapped in a done(). In the following example # we return early if the result-so-far, which is passed on the LHS, # meets a condition: paste3 <- function(out, input, sep = ".") { if (nchar(out) > 4) { return(done(out)) } paste(out, input, sep = sep) } letters \%>\% accumulate(paste3) # Note how we get twice the same value in the accumulation. That's # because we have returned it twice. To prevent this, return an empty # done box to signal to accumulate() that it should terminate with the # value of the last iteration: paste3 <- function(out, input, sep = ".") { if (nchar(out) > 4) { return(done()) } paste(out, input, sep = sep) } letters \%>\% accumulate(paste3) # Here the early return branch checks the incoming inputs passed on # the RHS: paste4 <- function(out, input, sep = ".") { if (input == "f") { return(done()) } paste(out, input, sep = sep) } letters \%>\% accumulate(paste4) # Simulating stochastic processes with drift \dontrun{ library(dplyr) library(ggplot2) rerun(5, rnorm(100)) \%>\% set_names(paste0("sim", 1:5)) \%>\% map(~ accumulate(., ~ .05 + .x + .y)) \%>\% map_dfr(~ tibble(value = .x, step = 1:100), .id = "simulation") \%>\% ggplot(aes(x = step, y = value)) + geom_line(aes(color = simulation)) + ggtitle("Simulations of a random walk with drift") } } \seealso{ \code{\link[=reduce]{reduce()}} when you only need the final reduced value. } purrr/man/reexports.Rd0000644000176200001440000000347113426303100014516 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predicates.R \docType{import} \name{reexports} \alias{reexports} \alias{is_bare_list} \alias{is_bare_atomic} \alias{is_bare_vector} \alias{is_bare_double} \alias{is_bare_integer} \alias{is_bare_numeric} \alias{is_bare_character} \alias{is_bare_logical} \alias{is_list} \alias{is_atomic} \alias{is_vector} \alias{is_integer} \alias{is_double} \alias{is_character} \alias{is_logical} \alias{is_null} \alias{is_function} \alias{is_scalar_list} \alias{is_scalar_atomic} \alias{is_scalar_vector} \alias{is_scalar_double} \alias{is_scalar_character} \alias{is_scalar_logical} \alias{is_scalar_integer} \alias{is_empty} \alias{is_formula} \title{Objects exported from other packages} \keyword{internal} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{rlang}{\code{\link[rlang]{is_bare_list}}, \code{\link[rlang]{is_bare_atomic}}, \code{\link[rlang]{is_bare_vector}}, \code{\link[rlang]{is_bare_double}}, \code{\link[rlang]{is_bare_integer}}, \code{\link[rlang]{is_bare_numeric}}, \code{\link[rlang]{is_bare_character}}, \code{\link[rlang]{is_bare_logical}}, \code{\link[rlang]{is_list}}, \code{\link[rlang]{is_atomic}}, \code{\link[rlang]{is_vector}}, \code{\link[rlang]{is_integer}}, \code{\link[rlang]{is_double}}, \code{\link[rlang]{is_character}}, \code{\link[rlang]{is_logical}}, \code{\link[rlang]{is_null}}, \code{\link[rlang]{is_function}}, \code{\link[rlang]{is_scalar_list}}, \code{\link[rlang]{is_scalar_atomic}}, \code{\link[rlang]{is_scalar_vector}}, \code{\link[rlang]{is_scalar_double}}, \code{\link[rlang]{is_scalar_character}}, \code{\link[rlang]{is_scalar_logical}}, \code{\link[rlang]{is_scalar_integer}}, \code{\link[rlang]{is_empty}}, \code{\link[rlang]{is_formula}}} }} purrr/man/map2.Rd0000644000176200001440000001266313551365051013341 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/map2-pmap.R \name{map2} \alias{map2} \alias{map2_lgl} \alias{map2_int} \alias{map2_dbl} \alias{map2_chr} \alias{map2_raw} \alias{map2_dfr} \alias{map2_dfc} \alias{map2_df} \alias{walk2} \alias{pmap} \alias{pmap_lgl} \alias{pmap_int} \alias{pmap_dbl} \alias{pmap_chr} \alias{pmap_raw} \alias{pmap_dfr} \alias{pmap_dfc} \alias{pmap_df} \alias{pwalk} \title{Map over multiple inputs simultaneously.} \usage{ map2(.x, .y, .f, ...) map2_lgl(.x, .y, .f, ...) map2_int(.x, .y, .f, ...) map2_dbl(.x, .y, .f, ...) map2_chr(.x, .y, .f, ...) map2_raw(.x, .y, .f, ...) map2_dfr(.x, .y, .f, ..., .id = NULL) map2_dfc(.x, .y, .f, ...) walk2(.x, .y, .f, ...) pmap(.l, .f, ...) pmap_lgl(.l, .f, ...) pmap_int(.l, .f, ...) pmap_dbl(.l, .f, ...) pmap_chr(.l, .f, ...) pmap_raw(.l, .f, ...) pmap_dfr(.l, .f, ..., .id = NULL) pmap_dfc(.l, .f, ...) pwalk(.l, .f, ...) } \arguments{ \item{.x, .y}{Vectors of the same length. A vector of length 1 will be recycled.} \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to the mapped function.} \item{.id}{Either a string or \code{NULL}. If a string, the output will contain a variable with that name, storing either the name (if \code{.x} is named) or the index (if \code{.x} is unnamed) of the input. If \code{NULL}, the default, no variable will be created. Only applies to \code{_dfr} variant.} \item{.l}{A list of vectors, such as a data frame. The length of \code{.l} determines the number of arguments that \code{.f} will be called with. List names will be used if present.} } \value{ An atomic vector, list, or data frame, depending on the suffix. Atomic vectors and lists will be named if \code{.x} or the first element of \code{.l} is named. If all input is length 0, the output will be length 0. If any input is length 1, it will be recycled to the length of the longest. } \description{ These functions are variants of \code{\link[=map]{map()}} that iterate over multiple arguments simultaneously. They are parallel in the sense that each input is processed in parallel with the others, not in the sense of multicore computing. They share the same notion of "parallel" as \code{\link[base:pmax]{base::pmax()}} and \code{\link[base:pmin]{base::pmin()}}. \code{map2()} and \code{walk2()} are specialised for the two argument case; \code{pmap()} and \code{pwalk()} allow you to provide any number of arguments in a list. Note that a data frame is a very important special case, in which case \code{pmap()} and \code{pwalk()} apply the function \code{.f} to each row. \code{map_dfr()}, \code{pmap_dfr()} and \code{map2_dfc()}, \code{pmap_dfc()} return data frames created by row-binding and column-binding respectively. They require dplyr to be installed. } \details{ Note that arguments to be vectorised over come before \code{.f}, and arguments that are supplied to every call come after \code{.f}. } \examples{ x <- list(1, 10, 100) y <- list(1, 2, 3) z <- list(5, 50, 500) map2(x, y, ~ .x + .y) # Or just map2(x, y, `+`) pmap(list(x, y, z), sum) # Matching arguments by position pmap(list(x, y, z), function(a, b, c) a / (b + c)) # Matching arguments by name l <- list(a = x, b = y, c = z) pmap(l, function(c, b, a) a / (b + c)) # Split into pieces, fit model to each piece, then predict by_cyl <- mtcars \%>\% split(.$cyl) mods <- by_cyl \%>\% map(~ lm(mpg ~ wt, data = .)) map2(mods, by_cyl, predict) # Vectorizing a function over multiple arguments df <- data.frame( x = c("apple", "banana", "cherry"), pattern = c("p", "n", "h"), replacement = c("x", "f", "q"), stringsAsFactors = FALSE ) pmap(df, gsub) pmap_chr(df, gsub) # Use `...` to absorb unused components of input list .l df <- data.frame( x = 1:3 + 0.1, y = 3:1 - 0.1, z = letters[1:3] ) plus <- function(x, y) x + y \dontrun{ # this won't work pmap(df, plus) } # but this will plus2 <- function(x, y, ...) x + y pmap_dbl(df, plus2) # The "p" for "parallel" in pmap() is the same as in base::pmin() # and base::pmax() df <- data.frame( x = c(1, 2, 5), y = c(5, 4, 8) ) # all produce the same result pmin(df$x, df$y) map2_dbl(df$x, df$y, min) pmap_dbl(df, min) # If you want to bind the results of your function rowwise, use map2_dfr() or pmap_dfr() ex_fun <- function(arg1, arg2){ col <- arg1 + arg2 x <- as.data.frame(col) } arg1 <- seq(1, 10, by = 3) arg2 <- seq(2, 11, by = 3) df <- map2_dfr(arg1, arg2, ex_fun) # If instead you want to bind by columns, use map2_dfc() or pmap_dfc() df2 <- map2_dfc(arg1, arg2, ex_fun) } \seealso{ Other map variants: \code{\link{imap}}, \code{\link{invoke}}, \code{\link{lmap}}, \code{\link{map_if}}, \code{\link{map}}, \code{\link{modify}} } \concept{map variants} purrr/man/is_numeric.Rd0000644000176200001440000000126613403735151014632 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predicates.R \name{is_numeric} \alias{is_numeric} \alias{is_scalar_numeric} \title{Test is an object is integer or double} \usage{ is_numeric(x) is_scalar_numeric(x) } \description{ Numeric is used in three different ways in base R: \itemize{ \item as an alias for double (as in \code{\link[=as.numeric]{as.numeric()}}) \item to mean either integer or double (as in \code{\link[=mode]{mode()}}) \item for something representable as numeric (as in \code{\link[=as.numeric]{as.numeric()}}) This function tests for the second, which is often not what you want so these functions are deprecated. } } \keyword{internal} purrr/man/done.Rd0000644000176200001440000000050513426303100013403 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-rlang.R \docType{import} \name{done} \alias{done} \title{Done box} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{rlang}{\code{\link[rlang]{done}}} }} purrr/man/prepend.Rd0000644000176200001440000000156313551356667014151 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/prepend.R \name{prepend} \alias{prepend} \title{Prepend a vector} \usage{ prepend(x, values, before = NULL) } \arguments{ \item{x}{the vector to be modified.} \item{values}{to be included in the modified vector.} \item{before}{a subscript, before which the values are to be appended. If \code{NULL}, values will be appended at the beginning even for \code{x} of length 0.} } \value{ A merged vector. } \description{ This is a companion to \code{\link[=append]{append()}} to help merging two lists or atomic vectors. \code{prepend()} is a clearer semantic signal than \code{c()} that a vector is to be merged at the beginning of another, especially in a pipe chain. } \examples{ x <- as.list(1:3) x \%>\% append("a") x \%>\% prepend("a") x \%>\% prepend(list("a", "b"), before = 3) prepend(list(), x) } purrr/man/pipe.Rd0000644000176200001440000000032013403735151013420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{\%>\%} \alias{\%>\%} \title{Pipe operator} \usage{ lhs \%>\% rhs } \description{ Pipe operator } \keyword{internal} purrr/man/imap.Rd0000644000176200001440000000472313551365051013426 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/imap.R \name{imap} \alias{imap} \alias{imap_lgl} \alias{imap_chr} \alias{imap_int} \alias{imap_dbl} \alias{imap_raw} \alias{imap_dfr} \alias{imap_dfc} \alias{iwalk} \title{Apply a function to each element of a vector, and its index} \usage{ imap(.x, .f, ...) imap_lgl(.x, .f, ...) imap_chr(.x, .f, ...) imap_int(.x, .f, ...) imap_dbl(.x, .f, ...) imap_raw(.x, .f, ...) imap_dfr(.x, .f, ..., .id = NULL) imap_dfc(.x, .f, ...) iwalk(.x, .f, ...) } \arguments{ \item{.x}{A list or atomic vector.} \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to the mapped function.} \item{.id}{Either a string or \code{NULL}. If a string, the output will contain a variable with that name, storing either the name (if \code{.x} is named) or the index (if \code{.x} is unnamed) of the input. If \code{NULL}, the default, no variable will be created. Only applies to \code{_dfr} variant.} } \value{ A vector the same length as \code{.x}. } \description{ \code{imap_xxx(x, ...)}, an indexed map, is short hand for \code{map2(x, names(x), ...)} if \code{x} has names, or \code{map2(x, seq_along(x), ...)} if it does not. This is useful if you need to compute on both the value and the position of an element. } \examples{ # Note that when using the formula shortcut, the first argument # is the value, and the second is the position imap_chr(sample(10), ~ paste0(.y, ": ", .x)) iwalk(mtcars, ~ cat(.y, ": ", median(.x), "\\n", sep = "")) } \seealso{ Other map variants: \code{\link{invoke}}, \code{\link{lmap}}, \code{\link{map2}}, \code{\link{map_if}}, \code{\link{map}}, \code{\link{modify}} } \concept{map variants} purrr/man/vec_depth.Rd0000644000176200001440000000067613403735151014442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/depth.R \name{vec_depth} \alias{vec_depth} \title{Compute the depth of a vector} \usage{ vec_depth(x) } \arguments{ \item{x}{A vector} } \value{ An integer. } \description{ The depth of a vector is basically how many levels that you can index into it. } \examples{ x <- list( list(), list(list()), list(list(list(1))) ) vec_depth(x) x \%>\% map_int(vec_depth) } purrr/man/exec.Rd0000644000176200001440000000051713426303100013405 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-rlang.R \docType{import} \name{exec} \alias{exec} \title{Execute a function} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{rlang}{\code{\link[rlang]{exec}}} }} purrr/man/as_mapper.Rd0000644000176200001440000000426013551356667014460 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/as_mapper.R \name{as_mapper} \alias{as_mapper} \alias{as_function} \alias{as_mapper.character} \alias{as_mapper.numeric} \alias{as_mapper.list} \title{Convert an object into a mapper function} \usage{ as_mapper(.f, ...) \method{as_mapper}{character}(.f, ..., .null, .default = NULL) \method{as_mapper}{numeric}(.f, ..., .null, .default = NULL) \method{as_mapper}{list}(.f, ..., .null, .default = NULL) } \arguments{ \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to methods.} \item{.default, .null}{Optional additional argument for extractor functions (i.e. when \code{.f} is character, integer, or list). Returned when value is absent (does not exist) or empty (has length 0). \code{.null} is deprecated; please use \code{.default} instead.} } \description{ \code{as_mapper} is the powerhouse behind the varied function specifications that most purrr functions allow. It is an S3 generic. The default method forwards its arguments to \code{\link[rlang:as_function]{rlang::as_function()}}. } \examples{ as_mapper(~ . + 1) as_mapper(1) as_mapper(c("a", "b", "c")) # Equivalent to function(x) x[["a"]][["b"]][["c"]] as_mapper(list(1, "a", 2)) # Equivalent to function(x) x[[1]][["a"]][[2]] as_mapper(list(1, attr_getter("a"))) # Equivalent to function(x) attr(x[[1]], "a") as_mapper(c("a", "b", "c"), .default = NA) } purrr/man/flatten.Rd0000644000176200001440000000346013540423760014132 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/flatten.R \name{flatten} \alias{flatten} \alias{flatten_lgl} \alias{flatten_int} \alias{flatten_dbl} \alias{flatten_chr} \alias{flatten_raw} \alias{flatten_dfr} \alias{flatten_dfc} \alias{flatten_df} \title{Flatten a list of lists into a simple vector.} \usage{ flatten(.x) flatten_lgl(.x) flatten_int(.x) flatten_dbl(.x) flatten_chr(.x) flatten_raw(.x) flatten_dfr(.x, .id = NULL) flatten_dfc(.x) } \arguments{ \item{.x}{A list to flatten. The contents of the list can be anything for \code{flatten()} (as a list is returned), but the contents must match the type for the other functions.} \item{.id}{Either a string or \code{NULL}. If a string, the output will contain a variable with that name, storing either the name (if \code{.x} is named) or the index (if \code{.x} is unnamed) of the input. If \code{NULL}, the default, no variable will be created. Only applies to \code{_dfr} variant.} } \value{ \code{flatten()} returns a list, \code{flatten_lgl()} a logical vector, \code{flatten_int()} an integer vector, \code{flatten_dbl()} a double vector, and \code{flatten_chr()} a character vector. \code{flatten_dfr()} and \code{flatten_dfc()} return data frames created by row-binding and column-binding respectively. They require dplyr to be installed. } \description{ These functions remove a level hierarchy from a list. They are similar to \code{\link[=unlist]{unlist()}}, but they only ever remove a single layer of hierarchy and they are type-stable, so you always know what the type of the output is. } \examples{ x <- rerun(2, sample(4)) x x \%>\% flatten() x \%>\% flatten_int() # You can use flatten in conjunction with map x \%>\% map(1L) \%>\% flatten_int() # But it's more efficient to use the typed map instead. x \%>\% map_int(1L) } purrr/man/rate-helpers.Rd0000644000176200001440000000306613426303100015056 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rate.R \name{rate-helpers} \alias{rate-helpers} \alias{rate_delay} \alias{rate_backoff} \alias{is_rate} \title{Create delaying rate settings} \usage{ rate_delay(pause = 1, max_times = Inf) rate_backoff(pause_base = 1, pause_cap = 60, pause_min = 1, max_times = 3, jitter = TRUE) is_rate(x) } \arguments{ \item{pause}{Delay between attempts in seconds.} \item{max_times}{Maximum number of requests to attempt.} \item{pause_base, pause_cap}{\code{rate_backoff()} uses an exponential back-off so that each request waits \code{pause_base * 2^i} seconds, up to a maximum of \code{pause_cap} seconds.} \item{pause_min}{Minimum time to wait in the backoff; generally only necessary if you need pauses less than one second (which may not be kind to the server, use with caution!).} \item{jitter}{Whether to introduce a random jitter in the waiting time.} \item{x}{An object to test.} } \description{ These helpers create rate settings that you can pass to \code{\link[=insistently]{insistently()}}. You can also use them in your own functions with \code{\link[=rate_sleep]{rate_sleep()}}. } \examples{ # A delay rate waits the same amount of time: rate <- rate_delay(0.02) for (i in 1:3) rate_sleep(rate, quiet = FALSE) # A backoff rate waits exponentially longer each time, with random # jitter by default: rate <- rate_backoff(pause_base = 0.2, pause_min = 0.005) for (i in 1:3) rate_sleep(rate, quiet = FALSE) } \seealso{ \code{\link[=rate_sleep]{rate_sleep()}}, \code{\link[=insistently]{insistently()}} } purrr/man/keep.Rd0000644000176200001440000000317613426303100013411 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/keep.R \name{keep} \alias{keep} \alias{discard} \alias{compact} \title{Keep or discard elements using a predicate function.} \usage{ keep(.x, .p, ...) discard(.x, .p, ...) compact(.x, .p = identity) } \arguments{ \item{.x}{A list or vector.} \item{.p}{For \code{keep()} and \code{discard()}, a predicate function. Only those elements where \code{.p} evaluates to \code{TRUE} will be kept or discarded. For \code{compact()}, a function that is applied to each element of \code{.x}. Only those elements where \code{.p} evaluates to an empty vector will be discarded.} \item{...}{Additional arguments passed on to \code{.p}.} } \description{ \code{keep()} and \code{discard()} are opposites. \code{compact()} is a handy wrapper that removes all empty elements. } \details{ These are usually called \code{select} or \code{filter} and \code{reject} or \code{drop}, but those names are already taken. \code{keep()} is similar to \code{\link[=Filter]{Filter()}}, but the argument order is more convenient, and the evaluation of the predicate function \code{.p} is stricter. } \examples{ rep(10, 10) \%>\% map(sample, 5) \%>\% keep(function(x) mean(x) > 6) # Or use a formula rep(10, 10) \%>\% map(sample, 5) \%>\% keep(~ mean(.x) > 6) # Using a string instead of a function will select all list elements # where that subelement is TRUE x <- rerun(5, a = rbernoulli(1), b = sample(10)) x x \%>\% keep("a") x \%>\% discard("a") # compact() discards elements that are NULL or that have length zero list(a = "a", b = NULL, c = integer(0), d = NA, e = list()) \%>\% compact() } purrr/man/cross.Rd0000644000176200001440000000744313403735151013631 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cross.R \name{cross} \alias{cross} \alias{cross2} \alias{cross3} \alias{cross_df} \alias{cross_n} \alias{cross_d} \title{Produce all combinations of list elements} \usage{ cross(.l, .filter = NULL) cross2(.x, .y, .filter = NULL) cross3(.x, .y, .z, .filter = NULL) cross_df(.l, .filter = NULL) } \arguments{ \item{.l}{A list of lists or atomic vectors. Alternatively, a data frame. \code{cross_df()} requires all elements to be named.} \item{.filter}{A predicate function that takes the same number of arguments as the number of variables to be combined.} \item{.x, .y, .z}{Lists or atomic vectors.} } \value{ \code{cross2()}, \code{cross3()} and \code{cross()} always return a list. \code{cross_df()} always returns a data frame. \code{cross()} returns a list where each element is one combination so that the list can be directly mapped over. \code{cross_df()} returns a data frame where each row is one combination. } \description{ \code{cross2()} returns the product set of the elements of \code{.x} and \code{.y}. \code{cross3()} takes an additional \code{.z} argument. \code{cross()} takes a list \code{.l} and returns the cartesian product of all its elements in a list, with one combination by element. \code{cross_df()} is like \code{cross()} but returns a data frame, with one combination by row. } \details{ \code{cross()}, \code{cross2()} and \code{cross3()} return the cartesian product is returned in wide format. This makes it more amenable to mapping operations. \code{cross_df()} returns the output in long format just as \code{expand.grid()} does. This is adapted to rowwise operations. When the number of combinations is large and the individual elements are heavy memory-wise, it is often useful to filter unwanted combinations on the fly with \code{.filter}. It must be a predicate function that takes the same number of arguments as the number of crossed objects (2 for \code{cross2()}, 3 for \code{cross3()}, \code{length(.l)} for \code{cross()}) and returns \code{TRUE} or \code{FALSE}. The combinations where the predicate function returns \code{TRUE} will be removed from the result. } \examples{ # We build all combinations of names, greetings and separators from our # list of data and pass each one to paste() data <- list( id = c("John", "Jane"), greeting = c("Hello.", "Bonjour."), sep = c("! ", "... ") ) data \%>\% cross() \%>\% map(lift(paste)) # cross() returns the combinations in long format: many elements, # each representing one combination. With cross_df() we'll get a # data frame in long format: crossing three objects produces a data # frame of three columns with each row being a particular # combination. This is the same format that expand.grid() returns. args <- data \%>\% cross_df() # In case you need a list in long format (and not a data frame) # just run as.list() after cross_df() args \%>\% as.list() # This format is often less pratical for functional programming # because applying a function to the combinations requires a loop out <- vector("list", length = nrow(args)) for (i in seq_along(out)) out[[i]] <- map(args, i) \%>\% invoke(paste, .) out # It's easier to transpose and then use invoke_map() args \%>\% transpose() \%>\% map_chr(~ invoke(paste, .)) # Unwanted combinations can be filtered out with a predicate function filter <- function(x, y) x >= y cross2(1:5, 1:5, .filter = filter) \%>\% str() # To give names to the components of the combinations, we map # setNames() on the product: seq_len(3) \%>\% cross2(., ., .filter = `==`) \%>\% map(setNames, c("x", "y")) # Alternatively we can encapsulate the arguments in a named list # before crossing to get named components: seq_len(3) \%>\% list(x = ., y = .) \%>\% cross(.filter = `==`) } \seealso{ \code{\link[=expand.grid]{expand.grid()}} } purrr/man/rerun.Rd0000644000176200001440000000230113426303100013605 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rerun.R \name{rerun} \alias{rerun} \title{Re-run expressions multiple times.} \usage{ rerun(.n, ...) } \arguments{ \item{.n}{Number of times to run expressions} \item{...}{Expressions to re-run.} } \value{ A list of length \code{.n}. Each element of \code{...} will be re-run once for each \code{.n}. There is one special case: if there's a single unnamed input, the second level list will be dropped. In this case, \code{rerun(n, x)} behaves like \code{replicate(n, x, simplify = FALSE)}. } \description{ \Sexpr[results=rd, stage=render]{purrr:::lifecycle("questioning")} This is a convenient way of generating sample data. It works similarly to \code{\link{replicate}(..., simplify = FALSE)}. } \section{Lifecycle}{ \code{rerun()} is in the questioning lifecycle stage because we are no longer convinced NSE functions are a good fit for purrr. Also, \code{rerun(n, x)} can just as easily be expressed as \code{map(1:n, ~ x)} (with the added benefit of being passed the current index as argument to the lambda). } \examples{ 10 \%>\% rerun(rnorm(5)) 10 \%>\% rerun(x = rnorm(5), y = rnorm(5)) \%>\% map_dbl(~ cor(.x$x, .x$y)) } purrr/man/rep_along.Rd0000644000176200001440000000055713426303100014433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reexport-rlang.R \docType{import} \name{rep_along} \alias{rep_along} \title{Repeat a value with matching length} \description{ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ \item{rlang}{\code{\link[rlang]{rep_along}}} }} purrr/man/modify.Rd0000644000176200001440000001641113551365051013764 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/modify.R \name{modify} \alias{modify} \alias{modify.default} \alias{modify_if} \alias{modify_if.default} \alias{modify_at} \alias{modify_at.default} \alias{modify2} \alias{imodify} \alias{modify_depth} \alias{modify_depth.default} \title{Modify elements selectively} \usage{ modify(.x, .f, ...) \method{modify}{default}(.x, .f, ...) modify_if(.x, .p, .f, ..., .else = NULL) \method{modify_if}{default}(.x, .p, .f, ..., .else = NULL) modify_at(.x, .at, .f, ...) \method{modify_at}{default}(.x, .at, .f, ...) modify2(.x, .y, .f, ...) imodify(.x, .f, ...) modify_depth(.x, .depth, .f, ..., .ragged = .depth < 0) \method{modify_depth}{default}(.x, .depth, .f, ..., .ragged = .depth < 0) } \arguments{ \item{.x}{A list or atomic vector.} \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to the mapped function.} \item{.p}{A single predicate function, a formula describing such a predicate function, or a logical vector of the same length as \code{.x}. Alternatively, if the elements of \code{.x} are themselves lists of objects, a string indicating the name of a logical element in the inner lists. Only those elements where \code{.p} evaluates to \code{TRUE} will be modified.} \item{.else}{A function applied to elements of \code{.x} for which \code{.p} returns \code{FALSE}.} \item{.at}{A character vector of names, positive numeric vector of positions to include, or a negative numeric vector of positions to exlude. Only those elements corresponding to \code{.at} will be modified. If the \code{tidyselect} package is installed, you can use \code{vars()} and the \code{tidyselect} helpers to select elements.} \item{.y}{Vectors of the same length. A vector of length 1 will be recycled.} \item{.depth}{Level of \code{.x} to map on. Use a negative value to count up from the lowest level of the list. \itemize{ \item \code{modify_depth(x, 0, fun)} is equivalent to \code{x[] <- fun(x)}. \item \code{modify_depth(x, 1, fun)} is equivalent to \code{x <- modify(x, fun)} \item \code{modify_depth(x, 2, fun)} is equivalent to \code{x <- modify(x, ~ modify(., fun))} }} \item{.ragged}{If \code{TRUE}, will apply to leaves, even if they're not at depth \code{.depth}. If \code{FALSE}, will throw an error if there are no elements at depth \code{.depth}.} } \value{ An object the same class as \code{.x} } \description{ Unlike \code{\link[=map]{map()}} and its variants which always return a fixed object type (list for \code{map()}, integer vector for \code{map_int()}, etc), the \code{modify()} family always returns the same type as the input object. \itemize{ \item \code{modify()} is a shortcut for \code{x[[i]] <- f(x[[i]]); return(x)}. \item \code{modify_if()} only modifies the elements of \code{x} that satisfy a predicate and leaves the others unchanged. \code{modify_at()} only modifies elements given by names or positions. \item \code{modify2()} modifies the elements of \code{.x} but also passes the elements of \code{.y} to \code{.f}, just like \code{\link[=map2]{map2()}}. \code{imodify()} passes the names or the indices to \code{.f} like \code{\link[=imap]{imap()}} does. \item \code{modify_depth()} only modifies elements at a given level of a nested data structure. \item \code{\link[=modify_in]{modify_in()}} modifies a single element in a \code{\link[=pluck]{pluck()}} location. } } \details{ Since the transformation can alter the structure of the input; it's your responsibility to ensure that the transformation produces a valid output. For example, if you're modifying a data frame, \code{.f} must preserve the length of the input. } \section{Genericity}{ \code{modify()} and variants are generic over classes that implement \code{length()}, \code{[[} and \code{[[<-} methods. If the default implementation is not compatible for your class, you can override them with your own methods. If you implement your own \code{modify()} method, make sure it satisfies the following invariants:\preformatted{modify(x, identity) === x modify(x, compose(f, g)) === modify(x, g) \%>\% modify(f) } These invariants are known as the \href{https://wiki.haskell.org/Functor#Functor_Laws}{functor laws} in computer science. } \examples{ # Convert factors to characters iris \%>\% modify_if(is.factor, as.character) \%>\% str() # Specify which columns to map with a numeric vector of positions: mtcars \%>\% modify_at(c(1, 4, 5), as.character) \%>\% str() # Or with a vector of names: mtcars \%>\% modify_at(c("cyl", "am"), as.character) \%>\% str() list(x = rbernoulli(100), y = 1:100) \%>\% transpose() \%>\% modify_if("x", ~ update_list(., y = ~ y * 100)) \%>\% transpose() \%>\% simplify_all() # Use modify2() to map over two vectors and preserve the type of # the first one: x <- c(foo = 1L, bar = 2L) y <- c(TRUE, FALSE) modify2(x, y, ~ if (.y) .x else 0L) # Use a predicate function to decide whether to map a function: modify_if(iris, is.factor, as.character) # Specify an alternative with the `.else` argument: modify_if(iris, is.factor, as.character, .else = as.integer) # Modify at specified depth --------------------------- l1 <- list( obj1 = list( prop1 = list(param1 = 1:2, param2 = 3:4), prop2 = list(param1 = 5:6, param2 = 7:8) ), obj2 = list( prop1 = list(param1 = 9:10, param2 = 11:12), prop2 = list(param1 = 12:14, param2 = 15:17) ) ) # In the above list, "obj" is level 1, "prop" is level 2 and "param" # is level 3. To apply sum() on all params, we map it at depth 3: l1 \%>\% modify_depth(3, sum) \%>\% str() # Note that vectorised operations will yield the same result when # applied at the list level as when applied at the atomic result. # The former is more efficient because it takes advantage of # vectorisation. l1 \%>\% modify_depth(3, `+`, 100L) l1 \%>\% modify_depth(4, `+`, 100L) # modify() lets us pluck the elements prop1/param2 in obj1 and obj2: l1 \%>\% modify(c("prop1", "param2")) \%>\% str() # But what if we want to pluck all param2 elements? Then we need to # act at a lower level: l1 \%>\% modify_depth(2, "param2") \%>\% str() # modify_depth() can be with other purrr functions to make them operate at # a lower level. Here we ask pmap() to map paste() simultaneously over all # elements of the objects at the second level. paste() is effectively # mapped at level 3. l1 \%>\% modify_depth(2, ~ pmap(., paste, sep = " / ")) \%>\% str() } \seealso{ Other map variants: \code{\link{imap}}, \code{\link{invoke}}, \code{\link{lmap}}, \code{\link{map2}}, \code{\link{map_if}}, \code{\link{map}} } \concept{map variants} purrr/man/head_while.Rd0000644000176200001440000000177313426303100014557 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/head-tail.R \name{head_while} \alias{head_while} \alias{tail_while} \title{Find head/tail that all satisfies a predicate.} \usage{ head_while(.x, .p, ...) tail_while(.x, .p, ...) } \arguments{ \item{.x}{A list or atomic vector.} \item{.p}{A single predicate function, a formula describing such a predicate function, or a logical vector of the same length as \code{.x}. Alternatively, if the elements of \code{.x} are themselves lists of objects, a string indicating the name of a logical element in the inner lists. Only those elements where \code{.p} evaluates to \code{TRUE} will be modified.} \item{...}{Additional arguments passed on to the mapped function.} } \value{ A vector the same type as \code{.x}. } \description{ Find head/tail that all satisfies a predicate. } \examples{ pos <- function(x) x >= 0 head_while(5:-5, pos) tail_while(5:-5, negate(pos)) big <- function(x) x > 100 head_while(0:10, big) tail_while(0:10, big) } purrr/man/detect.Rd0000644000176200001440000000477613551356667013775 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/detect.R \name{detect} \alias{detect} \alias{detect_index} \title{Find the value or position of the first match} \usage{ detect(.x, .f, ..., .dir = c("forward", "backward"), .right = NULL, .default = NULL) detect_index(.x, .f, ..., .dir = c("forward", "backward"), .right = NULL) } \arguments{ \item{.x}{A list or atomic vector.} \item{.f}{A function, formula, or vector (not necessarily atomic). If a \strong{function}, it is used as is. If a \strong{formula}, e.g. \code{~ .x + 2}, it is converted to a function. There are three ways to refer to the arguments: \itemize{ \item For a single argument function, use \code{.} \item For a two argument function, use \code{.x} and \code{.y} \item For more arguments, use \code{..1}, \code{..2}, \code{..3} etc } This syntax allows you to create very compact anonymous functions. If \strong{character vector}, \strong{numeric vector}, or \strong{list}, it is converted to an extractor function. Character vectors index by name and numeric vectors index by position; use a list to index by position and name at different levels. If a component is not present, the value of \code{.default} will be returned.} \item{...}{Additional arguments passed on to the mapped function.} \item{.dir}{If \code{"forward"}, the default, starts at the beginning of the vector and move towards the end; if \code{"backward"}, starts at the end of the vector and moves towards the beginning.} \item{.right}{Soft-deprecated. Please use \code{.dir} instead.} \item{.default}{The value returned when nothing is detected.} } \value{ \code{detect} the value of the first item that matches the predicate; \code{detect_index} the position of the matching item. If not found, \code{detect} returns \code{NULL} and \code{detect_index} returns 0. } \description{ Find the value or position of the first match } \examples{ is_even <- function(x) x \%\% 2 == 0 3:10 \%>\% detect(is_even) 3:10 \%>\% detect_index(is_even) 3:10 \%>\% detect(is_even, .dir = "backward") 3:10 \%>\% detect_index(is_even, .dir = "backward") # Since `.f` is passed to as_mapper(), you can supply a # lambda-formula or a pluck object: x <- list( list(1, foo = FALSE), list(2, foo = TRUE), list(3, foo = TRUE) ) detect(x, "foo") detect_index(x, "foo") # If you need to find all values, use keep(): keep(x, "foo") # If you need to find all positions, use map_lgl(): which(map_lgl(x, "foo")) } \seealso{ \code{\link[=keep]{keep()}} for keeping all matching values. } purrr/DESCRIPTION0000644000176200001440000000172313552331245013140 0ustar liggesusersPackage: purrr Title: Functional Programming Tools Version: 0.3.3 Authors@R: c( person("Lionel", "Henry", , "lionel@rstudio.com", c("aut", "cre")), person("Hadley", "Wickham", , "hadley@rstudio.com", "aut"), person("RStudio", role = c("cph", "fnd")) ) Description: A complete and consistent functional programming toolkit for R. License: GPL-3 | file LICENSE URL: http://purrr.tidyverse.org, https://github.com/tidyverse/purrr BugReports: https://github.com/tidyverse/purrr/issues Depends: R (>= 3.2) Imports: magrittr (>= 1.5), rlang (>= 0.3.1) Suggests: covr, crayon, dplyr (>= 0.7.8), knitr, rmarkdown, testthat, tibble, tidyselect VignetteBuilder: knitr Encoding: UTF-8 LazyData: true RoxygenNote: 6.1.1 NeedsCompilation: yes Packaged: 2019-10-17 08:02:23 UTC; lionel Author: Lionel Henry [aut, cre], Hadley Wickham [aut], RStudio [cph, fnd] Maintainer: Lionel Henry Repository: CRAN Date/Publication: 2019-10-18 12:40:05 UTC purrr/build/0000755000176200001440000000000013552020016012515 5ustar liggesuserspurrr/build/vignette.rds0000644000176200001440000000034113552020016015052 0ustar liggesusersmPK0-I[r ƍ!.6RI?w\")N2әμ{lB.^!5;+ Ir^X}֊R`J sNES[\{+͙7Ԣ܃O!0-]&0ׯx #yܥ1`3olH0?VFBf 2B78o ag1 purrr/build/purrr.pdf0000644000176200001440000063241513552020015014374 0ustar liggesusers%PDF-1.5 % 196 0 obj << /Length 1077 /Filter /FlateDecode >> stream xX[o6~ϯdy),KRtu "Y(:Xn"+X~\sx.^A |z<_a[~0 c8,"2>W3839 0Z)FR FVAF*Nj7C$9-  u3\r0̗b]&:ʸpjTx̽X8hFN}#~ $PoQ]L6k}@5I eڿ.ѲR>RڠtUuheȲ0|ٻˀ8u/> zq9f ynVƻD7V|ޞtsoAJec!sJ( {!o!Xўv}L[IC?|܁ם9*=کI&1#كv0 :@1닑-U's'k^;` Z81"͟ Y@rK(ӰmnM>3>ڪHL) Jlf9``o⺶aϦo=99r1cu،_2;Pq#'qWf G iAPUC&N H*]W(Pm(MiUJ+ !'1Gl5{])0 D8_ TP endstream endobj 2 0 obj << /Type /ObjStm /N 100 /First 799 /Length 1412 /Filter /FlateDecode >> stream xڵWMFW#Z!-DI)ZD`fzv,_W3{hX^rO[2,Ӟ9f,z&0E&=SC`J$SeJ14S@ CdO0<Ӛic` Jf|̌b&"4YD&խfNJ9Nf`y2WYqyg`c7,X< ,!9ƾ 3XR@\DjCΤ0b И@p&F*0%SYKLL<L0c?$Uj$D"/RS1xC$dHM "WP~i,yHPA薚Ji֑-Q ,C:#2r`B1swRIyHo("{N!*7Dd@HR%L2j9vXD*%%"R ڍu0V4Ax)e&`J4T"S< "eՂ$`-x:u;4ήX7ʞj^l6cU|Ѷݞonʦɻͱڙ2GiӦoZ߷.zpu.S7L mnFۦbOZA64͗QsjNX}I2jid.cSARS=oi?dPSj$y:8% j̅k)92͗QU7J5T׏-lÙC ^è ZDJD7[zl+r^KXi:]E;ɋi%/up?nr&͞X[cVi{e5rEwguo32+vޏ 2oi]ܧ9pB;Tyۢ.Af2?cm:N4i_ϧץӠ # |ˇ`7,o xuw)_753Y~n+mU}t+pK< Z?0tG5z4it1L xqx7;WMM Yo0pmMnzdGYqh+Dž=~3?WW -(yC}%Ƕmy_nhڻPc┍|A§`+WI%e(aB`D|1r,+5hC1w;xc޷ <$FkO:"p~O4<: -yίk?Aȃ \+!>xnYFɂ'  endstream endobj 250 0 obj << /Length 1528 /Filter /FlateDecode >> stream x[I8WpAт'5Ij63}KR.6 inC@h}[bާջLx)J## /qF_>Fl XA1:InA+l+8)=d4A/4ye@d"J|c46?FשWϧ9LItք"by1ˆAA;ߌ bfZVr'jaCCϗA/b-+I䰾b *wYݡ|m#$iBYeay 2,b[@/%hʜTUn'sدB ŋTS5Ec0g.=[o&:6b)4q5"yn b]n}%*]Q36FE T j/*zE.ZOq_ez5 f{q9/2?fPf7B[77z&Ѳ 5K'aRG>:ʪ]L0~=9`+."᰾f ݭG%>w\e֧k;*&]ŘK5evCԫQ!RѮ%tAeVIvc̝ykBBF# qgFŲ^:^y t9IsVrӉdC}FJ>oMѽ9s.d;la,O`-+}dJx!HĉaϺ6"L$7b ʇ MbD+_PKA'y (( X~D4f&t0Wʦ֭8 M+ؘLu&J9b]k. 0E"s ?bnG]ti:SpuY 5/&a$FsCm߆FoC1֨+ f|;9Ϧ{mjX"E[ů8jDn:Di6T}@UN ۜvR/і=oNVcM>Of\\;1ё7jD49\Ŕ EEGy7B??JnNM:Ny&GfeӼ}ajY{pU.L-hsm"L?$~J'|P]F4}n&}_tk?дY=*ݰ%D[` 2W%} MЛa ])c1eL%ʋ(JC&ZnZ!D?'+_;t?t76 endstream endobj 287 0 obj << /Length 2552 /Filter /FlateDecode >> stream xڭYݏ۸_aƝCx@hS\QC{֦w$g}hzi`cߌêX}(J%\V(rUɂOf;fқw QHRIٽlyW `o[VI|c]𑱘z0zAoEYoeQk'?޷?;C?<7n'`?C1Pe( şpjRH8lh~8t7솨TON+ITTfb}l Gԟlhֻ rMl[*Ptx;A]pؒMIʲ`e Ҭ]%#neD^;f+X=h~Cװ{Gh~U8(Qe9eAc#NXNqˆx،b'~+ 6)Æ i#ޯSXs%Nz?&g4Z!Ÿ9Kzw~qA?]zYP¥ l+~ZDȋ. /hDѽ[7UXE:֭k+_Q;+UPj/<5Ԯ.Uʹt kJSRhTj~G=kyOA3U*0$Fd %68GX3a wqO1w  qv&\s|'1 "SOVÿ/cé`gf88<.CHn}֧e# 3-q;}\tF PJ(yRqRwSDCo}-17{&})YI|6+IҸȀrSZ!$W eL`P`{_C|0 }Iwm{rB<2c# ϮhiWR%ePG2QkPc؞VEU@c&| 3ֆOMz+k{i&> stream xX[6~_1ҵZHҔ҇fdXSKR߫-ٞIZGt.st4v^_|w}UJPqެ0I<YջuzysóWiLL$E*Ԩ)] ܋hUA\ȗz2rMwZJ&8f1-ݞvܬ-ÿ0 \w+\eQcp$a~uekj!-+|, d" @e:ފ)\#B"U[ c;b bCf\$E> Na pjQ!\vŌ+Wa\.XytG_aK((yPA& ]RD'n9ߝ+i[`*ciio1mè)P?K{GP A MؚknDz#[ji6Zj6a1X  P䡲02 S/7m"KKvE_I5OhE'wX{!Wz"†x'"aFOs@l\bs3}`hq.kgo3@XqHnחCSRdHf6pl'4O;ܚO 2 .U3$d+j^xviCJK=/NUi0,ҿ=_-&<*(!ȓ^fρຖя'8Of!ƢG^~t3T ='c]'/y9G`."PaP >}[N!PaHcV뀞d^(l\ad%Plu@ 2W?,7{'pc\12{`th66' v[zIZakk{mzK0;aFvլ?7vZg6Lˤ!a5~F9 yX'HAաtp $2m_4E O |fhM^^ٖ흓o؄a6o CWWEn)zׁ_ɐyx*1v):4;9yPkFQ= l"ޙgN܉`{;%Q%Tf[qHWZlɛ Qęm]QטDu0;}rd<4j"zbia0TĮghtd}F mcө?~K;_F*9(D=dٲxHmE10.}钲IјK vk&(fy O0p'c-6ȋY^`mΉ栌ӳeҰX? AmѝexrUZWM/p-aW< Tթ<ܶ{ku\оYcvg'gx'/dz VU//,P endstream endobj 306 0 obj << /Length 1445 /Filter /FlateDecode >> stream xڥWmo6_!d(f5K^m@놢S[Ldɣưݑ'Er6>H;x xǫӗ 2a\9Q$1gJ*x7ύɏˢѦ(z귧/eHnIT%] ==÷Ɔ h|rm>g`"-umDm ♚Vw.ǻN]#]qǴ4jz6yu#O& (31r5.˖p_t~'38wuU%3ES5flzJ=mi}..{A*:NN@Uɫ?' )O<΋z6 ^\ h ٻBG endstream endobj 316 0 obj << /Length 1325 /Filter /FlateDecode >> stream xWmo6_!(f17IT ŀ.- Fm RR^G"Ʋ؊ <#h+DDu &Q@ \dv2{}!}CIYf>Ћ@2]jRTٟGIFOvt$ Egk',N 2\_4j[rI^3V\ҾGG a}筽^);ٴvn)B#-֟E 6$>o76i<}9v+L_UZ޼u޳x鲤&_Lp'@Uޜ<ՕeH$0]7fkw;;]b{^Fu7@mǭMACj;q[xlQ >aj [xR> stream xڵXKs6Wh܋4Hq'L;m$$qJ I֥EJk; \|X~x Φ)JcO/S1b<e>D3uu3?q#SPią`Fم^P/o9n~ܾt7.HA㵇8EҤv-wUuuuٕ`l?Wug;Tʦ(v@v@ \"@~X:1gʡyH0K=D-`s!Ntp hmkUjl<8 P؜F3k646C+deGH)bۂD}eZ~fl ,5 wn9lt|p2\F9;n(eӎ*mX`ǂFEըrbZO?rZADt &VgJ"xvRڦ-UX'"S!EE |9;csDz!UDq\PD({7uǷS 6DB{(j/VBJXH@(ɨ.s""0>r˵v_uſ,Z͝׻q8eRt(87[97TC2`meM|[8ё5Gy@+++}-T; i/phLyBgeX rok* w%7ʎ61z1mѼ=cSG2fQkL3`l@jZkuk \!uX! s9ekaBiu7FlmT GYV#˝@' aglܕ!Bf爻,QݮT~\F-(5t=scwYmeI Qݺ15 LQ/ mm\@2܉%,Mst@JDZU,сa҈`9W۠1gJTT Ƹɑ cP_줁 _bzB5czy܌)5[fy-Zuk{¸S%AT;‘%6R1$(Dj9.|TUW  LEvJ(?ob8X""%rpB&1m07rU66tl6Ĝ? g~IQ8)"RjٹU}vegZCK}g4ޥ+tCLk.ﯮ`khnlA3@:c#1,P|/+uv4y-T299'z}И_bru#OId0Ci\]i: P)H9sbeQ !Xi#Ƈw:?VW21 AsjCصݸ@ʸ=~Rm[̗6`@)[&Rn[%yЍ5 LWCfd\Gd~Av,3"d>tv2[/o7't3*-SYu:v3z mS( [ z C rbRWB; e6 >Lm[@(>cLU~niW>{i-u P{~ 屣ܻ5A آ{˃-nJ&O0Y"ui VCT`$}GfΪTzyB 2§Vӫ2mdHП>~eY`loנZN $!t endstream endobj 213 0 obj << /Type /ObjStm /N 100 /First 883 /Length 1879 /Filter /FlateDecode >> stream xZK7ϯ.p!$"H8$e@(hC">_43iXJB˟m{sK!rTЖP@MZ`jh[`P)-A*U7$Enr6 %+8fC̒XF jP V6t/Y95tgNPE)}&TYXƚja J>4QO% $āE/2_w]0p2,Aؿ@Lحcb6X3fq \مARlQ7ɾ Vȭ:q ¾]HAx]c}Qߕ :ULyQ wdA4CPX%L-Э+m)FE}(PVc Oi%ii)͒jDváRre:B k䌎H U\+%3(xӠO.,AvnZ$/[$̮DEd;(T`>L*# ƘJ#,>RuQdj $`GSk>%H 疬,_,_ib/6'oW'/ӛ__b|u|^I$QM[kf EXy 'ΧP(j!P,usTCIQRIx~)<3 Z+ExsX*ڜҎKE ⧛vkO=VR>< _Gyg'+H0,=y/W›C<Xi>;]6.m~[ph9l%M;*ZȎ|S,Y!ysƮCkC] -  ~4 hG?~4x?~[TQ*]EeXTn]= _`(5nCR1D,M`qq^@Hp/PDr!ACX'0X ѼA%LeTkx5K::[PKLxf4H{֐ž_J%3ۈѡ ,-Rk3H6ԿPQ :apH#(:Tc`~ 4Dyk 86Le<-0/v1$IG'7ԌzZeLܒ<҄=pHFq{u1`VbjtɵEE+Xk2I_J2k˗ &v1itMƉy"qsL ˔gP(mU 3Ny"qs(IMM6u#$UvyL2d6% 8Ҙ ѡvj]DPL/8&/QR' ;(I~'hSbic͝U-$&$(+o _|\,%Kе~shrDޥK LڏhD%zˣwv^iMrDo\86DL>xuڳ߻wtg6w^*vl#2?M]J&^.%?vĨPES?E _dcQ]Jף(7YO|1_yĔO7 G }Ryqn9Yu+C endstream endobj 342 0 obj << /Length 1415 /Filter /FlateDecode >> stream xڭWmo6_!x(&1WJʀ؇ k}銂i[,y㑎i Wy_f?.߇XnXq'];tQ;&K#m/[ٶ3ϼޭ \mU K#y1'Fax_, ׋e{nYzC]uFo/ 0M _'C^.DJ )-kXNEۛVաko*Xwo-Rh3j:/}eqLh๰ l4HDZ#ۮf~,uOm2YobsPKc{'0ٚ"5 ,hvuDe[մH"z pS0*C;3=mQ_J(C}e/f&=5vS;(o ]ْvRU/|RL{bg  %M  &[i_"ex7Dc6ݼFXUz'HC_'?#dhXBK endstream endobj 357 0 obj << /Length 1408 /Filter /FlateDecode >> stream xڭWmo6_dfc1#Q% ۇnŀm!+2Zl5RԒ|oM9MסHEYwϽ6z}w5\KQJ1 /}GQܻgnߴ|UHħ(iT|kd /q~4*/n_vyyK@ 6AhB/LJqRrFF>ȖNrZwY.;Q;5(:ecmFGido]7SX7IA isGl)̘h8@)rj[l6BX-,KߏbtWʭY.Kш1~/SƼ~?dr&82?r2.aLP@4#D T^VjKD!X`}0/k rTQI~ѻϭiX(c[8/$o@5'ߏ-We+Q&>EҞ@V)gqAyݙDۘgr mnrHx˫هY^e;# DaxwZt @1Q f,E$"(2(M[%d ݼJi4'㌑"o3Qu12G=MwHӼ:v (Ll{۲ ~;ǞBr82M5n]B S_EZ>ݦhǃac \'աׄ!Q-V?^0tQ?5"W J-υN/% V+^_J sUPjD`NFN7;)TȦJ s #U֟C]۱,4"Dqbh2Tf]j@GMUܔhYв^Ksy ySwnBvSޠoMI}6aB <߂e~քQ-DA@ƳH'ڡo߼95> stream xڥYK6W( @{HѤhm㴇(d^+%GqPzy~wqٷً*b2V[OpΔxaV[?W?xJ &C`clqՌ;/^KEPEZ{Ka1Gޝ]|!X{;3~s0*,Dm?W _wϓ<'ΊĹGa&'foQE$q 7Uv@MGFX$ѐG냚VKiA =ovCzkSG:%t!RDZ 풤H'0-u4A<$#T55 ^ᮊƶi|긘qpV/g@S,D BgZh~{DN]Wzp ׀T9u- 6' f+>m9_,۳Ss$Uc>sֵP Q'bp'8eե5SB:Uj yY"zOQ{Дƅ!ىJ%ag?q F YcCgtNBM4V@)'ʱJ:bܖ[A[ w@6HnKL˄"FL'hZɶYޘ:Pӻ7oN*q-;]J/C>`OcYQZ/Z)<3 w%Ү"e܍n6i}A:Z`u4eU3)8K;:!M'M<YXO fy]0C}\1,kr5 Ǭ2ps҅%gKUHr]hc!4$nb DRЄ[_DiPrPjb98W?*Kֹy@i0L SK|y3Ăʙ9.ǝ'i,z˄Ϣu3 s8 ia$Q__8෰a!`[ڋ=;j/uleO&vY} Rx}j/+C#:'7a>9˃1(CʿXj^(sAm^@)F? #'Di0`v[e{`6WY0mɡAvQ?R*8A]<3h}9RqrpJP4zHe1`,,RCYzLrTS; :tހxAsREôX1'KvEqnV82#2"D3P ds)݀pkG 5rDGLыWx( j0D+ZFA;Q8T;- R8imlBdahU1 qoizQp8U &v{4?td䦸mvPNY<2 2'{@KB oC61?ݫ LExIFPyЋneKS0R4pAw:x\e-maW !Uw{׭y3*Ċ0oc~4=Mgkx|D(RZ]T'6A⨃FH'j ['0Z0ç׃G8| 8}Ox\PGhhgZ nliQTv9fZWWD?Xy&?QI]&wMz$ƞ | ⊍QnaJ:}29Wٿl endstream endobj 383 0 obj << /Length 1237 /Filter /FlateDecode >> stream xڭX[o6~ϯRKŖb)<{e`%hQI6eh^0vyy%I\hjXEZ:c-Wrena6|k}{X7Ԑoo K kB+߫?*M%A;QTSĄͨ[N  Rl2s6d`:L+Qx=_) 54#O5u*l|KGQ55%&G38u|0IT&/Q'%E74d݃P^M uü-aQh̺1)]vHM+5Mɯ0W24# zPY~.CW6!w5GxEY_0d]ݠ ;92 f.8^ӇK慨1قu]\6zwRW%!u pϢ m狄 )A=(LXps{(' _<=#Dno;g=j#O3Y%AxV;xX,i6nwVSYM,;Lk,sTl.$8;Y/d7ۖD_ 7ؔ.\FiBF%G QU˘v:}N=>hCjnHVѝkڍ-85K3eS<#g]nZ0g%WvU1 M7WiاYFZb\qErhm0ЁRǶ:U!%ʥת8 iF,5@}g7k7 gTBC85ے)0*#ڰ&M91Pp$-QaY v^ OO~QNmYwem|^}ړv endstream endobj 391 0 obj << /Length 1750 /Filter /FlateDecode >> stream xڵXK6W9IQ=mHm#Ѷ[r%9{o)Q}(| -ofG(~YY1V8^pClWhI Ҕ=>ڋ,Ŕ3Ϣ/Nm1'B1%Ɗ[~Qkry 4Fz=߉ z1f1XY/vtݔrųm]zff=/bw[o/$x c*RZ6EjD\?܅6:w#ɴ+_؝{]+,=g)41RP[Y=֥%4&[tڈ_ klM)cm/|X&XܴFFyWn I(`5NP\# (hS](C D6^^{;![KhCE:`2hK%(NdsvHg4H`j m˲bR+-ru^7([硕mjh1/7{ czѕ~;QʚN j'Em9M"0GZ8:N}^$>8M_7C` ݁!`&7g^t_PdJO<( qBPVRHy eX-q8LrRg.gr*Q.DU #6C:&m14"DYА Lftd}&~~82\S >iL.㉗?47!df27S:~Q2)Nt>@| ]hy 9~=H BkKdO&&9Y4ږYp 7:m7(تdt~1)j@2%Lv"URIA.W::VG+:'^R>-6f !Ʃ=̽x2 ~NQL\|PiRU}8hN %A ~R@5%޻2^nG~:IcT^ u(K]2q!f:7UǀP?NYF1VM.к9^,(c–f AW  J .ES+u*,+{T.1Xꔗ[Iek&roE<j9UR:;IzIgsMͶwvXWRC j% @ x/JX/N؝Vu?%eܑl>d̽&Wׅ.> stream xڵV[o6~ 2Mbݰqѡ/kܧhr6NË˶ma"sCֈߗ(IB%s($8 -3e5}]qV Y2!4`=܃,2sNb'Tz8&Ca[4" }nU=L;otS4_$ ;nzīWN2'޾upQkk2QƘK NݫnKv8+:g+.;^3GHQ%KhPAkuȘ :rw nj{V,m p)хb_0ﮋ G!aO.'lDZ W2X7'1 MCc_ɟ18{} E<0a)B Nb_ |2]5qf~FoKDb,pQ}px<=s&m?xC8)95& endstream endobj 415 0 obj << /Length 1241 /Filter /FlateDecode >> stream xڵWmo6_/dfH˰ dPXK[ LZiɓ:;(ERdZ OxCzz~YnKH[=F) DE!%2r}Z~s'f$"|4Pus:n.{6h#;o9y] `cob<, I677YUT8e)_L:aMJBY8 &\<_UZuVU8ޜPlJN2-pì%@ڝ1ktN$4ib?RIM8 M-u}(j%Qtz8'vJ-m\ GdM5IcwN"ޝ4+!_+|JSp4ZUN,r+Trm].7"O:E9_.#:tMi` rX^e vKlu}; !/*ܶ X,Xګ+/9F\$d.!L9IbmH-I$\kMEMg79﷏j72Ptc% -ۆ?0 F9ϯP-H,fy7lMgٿ3[cA@"_}D,&$Hbب<(mp9l|+5̓ n]86yB 8-bZ:,*H;Xo%pa9/Cr+{pUl/ʺiZZi[]Wg/pm˜bΥDPFdgŃ8VZw6aU ({JrAe2GFQZ^Z32Xu4 ) \0p %9>v{/ӌ#lhb]e!1Sp2/AѷA~Fq-]C^ bU.y`peR۹g\ !Fvckrۡ.3o+> stream xW[6~_TEe/`Z%n*jTuSJ 0οX;I+yefuy0/A ܻ=1b"QȨwyohoe)R7]^3>:`Zjv6nFzyެ wNNkJ# qĴzCˢUz;0fB)YпK#+e44unwUS**u`MBE$yXONZb^=G\!2x^ӉIbNp 3EP::~#UT2R.vM)6dXJ3Zu:6v˻*UE]hg6.xQ wdiU /#߼zH=~$kMNsQv},jt>?i苦Rjogj/\\է4tshb;ӹT .!,Ds"rzHEitrp`I.x.SrGL)t);Aaegl0~2v.&b-Syt?W1K "Faf#-PV /Z]8ei-fos 4ٽ Z%E]\oZ֗uP'spNQUġPP_5x:_&vKI^q>ueX/I[I~ ؅9t#(uM2vAza endstream endobj 351 0 obj << /Type /ObjStm /N 100 /First 875 /Length 1425 /Filter /FlateDecode >> stream xYKo7 бhD$hɡCjo#Ʈ~8zw65=G|P$?,RȹlS ЗDO R4{߂c`fYj()}<~Y%P*ߡ@6@1 ,[Ba;c[c` =Y5ah6+ sQ\`v}|d.7%Ϥ)S) %n,kB5cS4H*4W%WJj&U1݄pYnec\\!hc\KKԿIfl vcB qex6AIa6&/]qWIyCx%`.bF쥨7ؓ CGP JnU4%-('!ʘ {D`WJv{L\/g;e|$K*\ZG7@a.VnxRu?X0D-cγ< }? /̆x~92f6?9}b1@FF*VX .P>ß/Kh< h͞=[`͆\_OfËbR:~~^qێae5ń" aifWᇃw_Y1A ;đbN8?>j+LiaϿBkk[)9 º>;;چ>E"RlPZjtuیx{E ̢N̈́| Xl }Ͱ}Dn:</0k8X)ԶzqvzyNd~"b$ؤj-$Xs/vF7f¶k.-ҙ }]I,Auee"ߧLL-XSJ} FV endstream endobj 447 0 obj << /Length 1293 /Filter /FlateDecode >> stream xڵVo6_G~Jb Ȱt@_m^"P, K%7#-Gq{OGx߿&_Ww"41}(%BASVy1d;)NN HRΔ۬˾Y-,4`GD`]|L6xUQtTwFI,YPAQdCQVf#'W9)y*,|qE>++틬G*5X)_fl'>8biqwqwL(#"I]1>U}g*Jo4$@>"y^f- 7YϙYOĐ|Hkt|Uv>FGo6'ͺ=5$3D^|Pj_Hî7P@'Ǭ}I Srv_ܥ%"aq((=$KlMDz7A˶L bFܦQEs`f7!ZHg=Ǵ133S ,y|qR=.LgIߔ$KAc h$~p5 +;tEsG'ADGYۍrA_F9Qc7+ O ]5;`y+޲Y#!R%"ф|ͪ޼ HN8אzv> stream xڵXKoFW(x_|-EKRP@RuoOe[Aٙof"͌~eyus',8`lQB`|fty7w< B!Pfb"V4^2{,T̖Ou]ϭ7w Q*A ~!>2uK qik_oq.RE Ve RYjEnc{q4T|p QZP2vh\q#A>L08bmB.1Nňa` byd@(۶dǢIl'y^Bh8VL9,ѕ-rOV6 ~=C=z\BxZ#'mR|(Ab?H4sPvXdwMyǩ;39B&tETT䪨H5) TߟzH9k#@`bi+޷[Yh wy2[3r"p/LL8q]8kn QIUT[!T+'tsa b|?uY@[90%l\f+Y#+=(=I~ڑº \'PXjcF꽕^P2=?1b|:0祩|; yOnRGj8[~fxj+% 4R7wC>Ҋ-Nɾ$"DgyhLuIb_`>-5TML\z1v`2869Zcj{Y̥uͱ a3)5gjXKsAL@k~,G<s}.@p(z a,I,ד` <%}f#Da2zrXGڣWoN^G"U0tEwL]b:x芍;Y45ELt]/sLvM([,6*WP]gJSDQOLKZy]L;Yjj$"A4LCyRB#X&ϕOCEQuFln{`jA%E-Z@l%(.QRtt<ջG endstream endobj 495 0 obj << /Length 1655 /Filter /FlateDecode >> stream xڵXYo6~$uC&=PmPl"S6ESqX(s~3 tQ_a%#0(& RZݓvKV5Jr0OXV"؝W]yOKŀ&^\IےisMZB˼"N rc7i,,g3I[EFŐ\L+Z-sɨ=7uq'EOپ>IfڜJaK4 3܄0Zh#phw+kb>b]7ov=@ojaBD8,y  霅&mkMi:ĝMeF%Kڼp5 bV9kMd&Nc U4.*+Ͳq8tj9Fx]P[9b$eEx"x=wtI'l*+/5y1 G\c%a2Д9k8&{7P[Rfy1OI#KGX;B{\>)±W6mK/.nV7!zˊ+P._҄5#Inu_'&dj 3p@B Q"}a"al11K7iKUZE<$QQpvK[L<|ϒ4'{AƐvCtP,oc<6N[nmv`xA}vU9KHSSAE"IA^ 7h\ BGQU J].l_A$n K>\xn,:z\R6! F<~̾ ~9UA`5> stream xڽWK4SX@+M$8 :H2U7{:F%3{ZMjiihf'Kir⺧\јG0]Zi 3fS)YJ [j QK{}g@{BN+'7Kb0;+:dcR99{]SX:awp7瞫,rb-LBXF#hY.uo5bw_)ov>LxߛT6~]|b6rhiNjE+B8-J'g%3&MUDʬ bNR/lMziǎ%\ܲX^s9T ȂZ"YȁҮ9=mz[ATcS;k]CHM/M/[щ%^v~~ŠxZ}@ ؏ 5A!PկsDIK) ] Oϛ 3U:\d:7d]^R#X=^٘hz*^3O^`"x;Չ3=D7G# 1]k1y5Ib%S7 ?M2P5|SlKHK3%ʅ#ꩩ;ڶ҈U?l3 +7x<;"HW2 C#{%k"D(MGv60Ŷ#N-"P-$jא9p]qlRkr endstream endobj 521 0 obj << /Length 1635 /Filter /FlateDecode >> stream xko6С ԬH l2,V+:`$:*K$>#eQ EJxw{7n|P8"i¬g% }pW7.h8Ya8'#KrICE{.H,"I-)w,|aL„Zh3 ^W%\|ȼD's+XU=t8\nd#'\RS!i-:QFY.XDZeWO\\:`π=,ע,XŎ1ux$ 4 '<ШwQVow"墘ki#DEB3Ul]S¦$a;H@1ȏlthTth;H(v~eS!$潣SUT?(Q4~?Y.h⁎!ϨZy^( #ʙSvmcu\V |AӍ<NAgBCC OE9]Ǯq j#U`<fEbxVNI-NMJFX3`CX)NAh|# sزpPO (MiVb#l[ZX*2UYHĹORBDy[l>b,$^b)OOEOl9meHl[!ōVmHdl-UD k8eZ_c9, u5NCU}?vS. )g5EN@㬧lJC֟߉oNeLg@ e\сD}0asno^j+)j1|0Qd[Z-! )}ʆ5RAoplAGaZ"kpݫS˺nRL h-yU[T7*,J ~@;'=Vc1GT ı])aB7#zf-ZǼ%lP+Glz_vYmԛ")u 4dQMx"rhGY[Xzuyiߌ6`6K6**(AIC{AU'ou7.KlE=XNՍoG:mg?^`Q^!T,NZw 5N@'f?|C`BҶފ̛*xzܢezǝi J0q"R">RFTL_йU1JS™tjō|`1Mg+p+sp?7wj?> stream xڵXY~_a#Q8%,hIn +SnO(Q3A`JEv/˷("Od{<aq(w^S[84FHHg_I,DCsA:͏}!N=!  c`z!|ߖ?iswA*{n)S'nx/dnW2CFA.DPGopEO:i-RdɤM͂6`%恧ہ; I L]UC45ΨrVIa*AzMRgk60^P2̨=Q6v:YH%յokB13"2/mSRfROѰ::˪/8I#קR^am'ѴԨ4LBiҮK*yZ1az*P6!ILٮCiQ-0CtHfB /s 6NHp _+d10<ٯ1,%d)MQPB9=U݃؊byDd"Av[;*tEAԫ/WfHL{qkCkؼnK8']6^ L 7BvO ݢ׿tvsvJ ӓ*dWI|lE# mG 5\*jD`Ҷ-&>U ժ][޾h/ c׭ ^61mcB('jڶ-)by4YZ}CᜓݢbU`nNmpUE' _ dx*wof}^KԌJn%Er{-I({='@,V޻!EK!И+[C(8P#Z4%31LM 5E0dkw(1na?NyuYNAzQz;hLP668yaԅaxV|qffc#ʮ{H&!T'w ך eSc͆fvLH`F9IܳH2<8xـT㡚LBqǎcUۡ+&bDo90 &=V\t{T uSS~zfX9N76o{hHx[$\B+>?ȇ{)p(D iR9vEMq00"#e[VIS[u]l}J . ys(? 2h)^!Cmùײ)QmL,<}a4T9Ƌ8mTxZ)S:LEJjs?6 ¤t7[d7+>'HAeB`F Q?FN!`I,!-b9M/N7# c|Ζ8SP ʨ|[DOb/_{U(0m!7ď%=|&nj_b~rβʞʹ=>P;Aqde"4]|~"=\E@*ƍ0TMW]AJXsxm D|;2 l4-#ܲ>^/88o0w6H͔zZ|ᦱ1k3xP>~/d endstream endobj 551 0 obj << /Length 1199 /Filter /FlateDecode >> stream xڥWmo6_!(*K~ lCWD\$R )'#E-ʒm0 J|;>w) vArc2Vjσ6DQLb$Y&o{8M;jdPr=9J*Ycㅞ4~vϢw`~2<~iRUOF,fOGILV *c6cͧ`d̰FxE78˖d׈E[=cs {USUkOktm^7e?,;`Kϥɇ2,k endstream endobj 444 0 obj << /Type /ObjStm /N 100 /First 870 /Length 1669 /Filter /FlateDecode >> stream xYKo71p&0QZP|hF"\߬e5Cƒ8f ,ƙM&ggElg|aQ,&_LhbBALIY&{Il~08"D1ԄwxOI,T:t$,ɐ R0F>^:R 9L IpfL̐r@=ul(9`ΘL87%]Y0+R f ,0R h)&pYͅCzf}-_X%@82HO,؅"ziPR@:}u4 >US|u9p۞#`CF#v:snYrR;!(DwK-Gb4`8Qt֔`dLEp&i"a1zEFq *EoraJIjv΂ >`jP`VzH n/Lv7{{Mpi|lY][tyr@@˪I8Wp6l} v_.O );pXyFtށyӁES?w=辯g:cw״o :iGr~8=mCwǓwsHDK-X㼪 R"&`Vڮ^-- kW'Un*W ଇ7V !\ S\NO! [5O,Lw5N69eC#ר硜dNi_fsxh4sQH[_9s74Odi_ݢG>o}QG8W\#9͸Eܫ^L`npQF'3;3=W Xɢۀ(X'elB4 UyKBaGS;9 b  2 .6#OĐMym|ONήPT^fUέU^M)T 0 pCP-.~$55555[KCr#3٤uM;j'VV/F?x_AIjY;MfR zz6 oC= &$U.0OwY!k {Z/lBt^lFaBݢ6<|톳v݀'BS+`(*n,'VPg$#lNټzg_-  N8be= XꄵFLTy@BX_aƣ_-Q5^ɺ}jyMR~xYRO!!ny,*SgTUWCԝmX&җs&hjRb9)ɡ[P}^ث8tpB . ǤR]>0%D?d{GRy^\|^GCEH\>8 \XJwm|ȷ (@4٧F Rs[rr'=O7ɆlnL:a("}0cTxuœɖm4MrǞ^3lz9@`xlq$< endstream endobj 558 0 obj << /Length 1558 /Filter /FlateDecode >> stream xڭWێ6}W[bF݋@$m @SDD$ѕu^dQ+o/̙?C] -~1HMր{z<ս3_ҫy{^n@ Գ_KNjȇن{J64u zw0UzTfY/&yc]edf_%<բ9*aP<6o͔z3qhG.ny6(߶D]#d8?<$̅gÃ允ىHeMK.of{V|!97,er=% xC̺93>kI#i׮>J'NSI`OQDYh<_8Y šB>(59|bU>rQs!Iu ^qk| 6̅k@,V'é]eݎ=vlHxұbz~74" Vk[BLnrY?oĸPoOFcqp@0 s":1 JO+0)V:֛TKl+C) $agbJعGbs8:,"d=kwO57I _& yJV ^~"t'?Ď)5YN7BiJb|KHZ[˩fs3Ri; :H'edU裁za\|dq?6xkd`NHc#P}܃qvi ͒T2sFѭE`бɟ8^yQR\d /C}noAݏX)EVOǽ(ǂdÆ*c ^~BgwlQwO! t)t6<_v endstream endobj 567 0 obj << /Length 1503 /Filter /FlateDecode >> stream xڭX[o6~PY^DI nk Eu cӱ0YtI^$$$x9w}Npp,1u@0F,$ƈ3\F۫~h'$9fO5N6~&zҞzW ﻭ*;~|ұ WaCc~ʚvmirw@t,HHf^S>Zz,N5\ۧD]7f.0Kf:Czk-焃)Geo@\0DH6 Z0F+udST 6$86 !>-$y.7= Q2xM!x\h_ Ei4$)~p=~uI]FSuٻI&k69!MpU҄MWUeݺ.m;qܘ#m#p;J]hRV핬l岞G8Ԟ8vqWv5iK킳ˆ 曶͉|gta i<[o7B/u"4͛b^ )9(H?m0!S hCxM>gq>u$46\|a;o!r߽^􅸽w,(#I49n3^Fp¬`e\W+*;~rZ6q#Yu`9/?_ :AQD߶Ιgr{3@j+E/۽ٔ =Nc7pROYt5hj*$O U]#MB| 8YNt{Zӗ8?{5gF̝CJ ="P+X=< Mq{X}Mwרv_t8~L{4mf?0 f(dԷ={ƔqC~[ 6Jx0ц.MR nzymkBSdy8ߏT3(GA>_tNѽpٞe{ endstream endobj 582 0 obj << /Length 2183 /Filter /FlateDecode >> stream xڵXmoܸ_Hq2zmRC; ZJ; Nb!_ş^zGivY+,v+Y۫Q: Y01$/|b ɈvCě5rٮ߻9d0FAƲc3]QS7Qν˲m%:Tޯ3d&2pR^n U8Ϣ Bh&c|>@qвDT ,j!k5X]&itC} kVUx-9\)3R}jݾDK|5n1WjY>ϚeDq(t)8cqڗf}潳ݪD$ȡު_|?)<,Ƽ T.4Rora({aw؝Kѷ{ybA>ˡ>b8USVςg2yD18J:P4hEYO$|Mx !4VCG]ZU焻k[8ajM _Uq+شQy4oSGa1 ;`C{g`@~LnI0ppF3+궕%!YDx9da I7w1x"ڈ8b71w;:qrHAYAA &!Kӈ⳸#o;Qrk'}}4(Q/ e;h/~`G'[e%BCr{Y6\D{'yIdw.D";{nYc#Ft'?uU*iӻB^C͹>.s/4rrQX[HUe1ua-T2DV%!4SQ+ )s[mLʴϹOQ CO[!1w$H]:VK}`_Y & nFIխJQH չ^#X9F5M! M0Ba!MqJȶ~{cdF65_'( %:XҬ#ECaueDkZ "!Å#Xa.9ٹ5!PQ}:1w Oh]M4*Rou=> stream xڵXYo6~_!DES E }(oap%ĵ-;C;haDr7uyr9)I#9s]G. }\ՒF7~~0AZS.ZFw: \H-_)IU˷Q ףBRd?rWz_z6~lU&E]7eҌga.ڬ#R@\=k[vFgL2@侩Z{,/NYw~RE\XOM9UGX+cY!K[vk-Sެ_aVW |]=r'F-ZgɪYKU}%u[ |ap5NT{98oM= Ɏ,.vQ^Ή羞ȵ 0?#mkWRs2&dl?U&RWƠVlbd)3̊cLWq,;gF} Yy6o/ tx9Yq&yPKK'<C:qgLgVfQ9~ߍj`4l|ECѧM|Cn~˭y+T/{8a0 }EtC4"W+R&v %Mib K,~8ڙeêV7O8 L4zFT;h8\Jhg¯l,ȫSGwvU{@# > 5{􎶼*V%vƁ쌖) l L\S7MDɠyRG1F`B K?v@pߗRQ.Eu(P6S;i5m4< ά+FCGeJI1dN رH`ٶy NƧKwx𮜞Pɹr54x̃1q K"?hoN$!7ٳeZ#C 0=ĺhW( eSpUnidllݤ@(0; ;@aڝp hʪ@Qhƕu݅l+sZK͡t@L)۱7$}͌C[)pqڗ<2:=]SC<ʋQqu+WfE5L}TBpRy8+  '9lu#K^S7l_9>3fDFqTݥ-p0:]%;ncVwO^%7PUg[0KD[oSv>ʮsg=~V3 asq²~J$zO!XDV)wlQ3P!w?23hEW|~#4?Ze;&b.k r̡ endstream endobj 608 0 obj << /Length 1826 /Filter /FlateDecode >> stream xڥXY6~ϯ𣍮&th-($Ed[,:Q^{DJ$|̐,v 7o_,X Jp,€b.>-q<MB5rb$\43=z&eUڷDA4 }&>m*@1Sj[ 65}ë,KTw~?|xVMˋk.&*!%]wʶf =FA@VYy^U6iC+/Mc*Q42 mrUyg>TǑ^[@Y&k΋D2Aʁz߶fhǽj>Q(ot5Yjj 0zёb!&Ul6K7$`cvNn1(JW;0,g[nrUm%[Taq-ΌNL/zINIãbZ63>3z~?Y3@_f̟0/f&/wc8n{.'O|[e4 ˜[NCNI%'(哇 (t_uCU I;uD.c `B!%$ bd % w=c5M $'dOjJ!|Ϭ9 /E%ΜQ7vNl)BB**"T6)L?B4{@S4,"e-'(6G^zpҼ]&LVkL-'\&`=cD&&c\1g}2MPv$U~Jrb/լʎVZNH4W#?\|Ѩ0%t,a¤uXg νrgu ?B0!ͶIW yQhFz]]fYpCI \46QRWؘICps~׫>% g4m]{OvňĄ ر;Phqң.Yc꾾SC^hƙ> stream xڵWo8޿q7K ]ՓN&m٧mW9`90Y 8%i:4u6yı,zw[/b0V:Z q(/}j&oq}X?Yxۏ±ё5wc^o=ɾ:C{ 9=)ԓ\L|bTdCqK(Lϴ9ךN.)AL3ò 8 eJ@.fЏ%_n% /UH@xчLԂ@KW8[O1^3qGZxc4%$@O0>U#L`~瀅rs5ﯺ.\ACD]ҺIR.oJ1p':8FfkAܸNk+BlPWZ 6g 4:ř(绗/)C9Picv t- f%*pm.٠% +_8aV'jݠ2˭`|>b\~qie '~)Qy5y %ʕj'?;Vר6M-TaX^6mGQ\6WL>\+ڐc@3 FenQxfjʠ!uJ ͐^}绻)+rrIDTFqP 8u>b8]ΑθKj___/'eg>G@}# *1[)mʻQ_PD2&ӵq-̪Yznpq&iozgpA.!/ Xht%DÒ[4F-S+% ;i!\O7IN)5K%-j%i!8(r䊫-ڛM; Χ=$ xߣ"4yP5FBNR~N\Pg+P)1=`>fL*FfК(aJJK N0"d35&wJ}w6; ܛ'JLv ZM.<`kb xtYbkk=gG{4tg`#ZNQa A| K E=nNwl0vu i endstream endobj 630 0 obj << /Length 1393 /Filter /FlateDecode >> stream xڥWK6WIChHݜҠe"Y %K{gHJ^ǛE9ۀof^ETrnF) bII$xp>KU_rRFY&"ˌz/_s$+C]D x]yXF6m徦:.W~;]v[ ; %$Roh)8?,hC+*F aH5QF5jMRiVS1ZgaNjƭ廙WZ4>Go)ner*n 4ZTOnOj;g>) "aAV>|Ai-k A=k8,! $dpt4a]%ŒGt^-G+E'6nx:4"4$Tqߺ)3ehwWd&ۼڏ=y=*RB]E1 IMd,WEp)|Sw-ra 9bJ5֓p1Eܰour=@n&`\6 Z<+ۖ&HB#P؎+Z/׷\nb4f$EoM^֕iJm0E7:&0*;}f+)7CW'3,ĺn-(E팪7lgpwP(xlG!I C:9"pC {0B&c9.YFi4Ĉ8`J_i8jf4kYݹωE#zVr?>4z_|`aŴ9tu E |ȍ׀E?M"nɦp13yqB'C_nAHszLp)!`(!߷O3a*& ۙ'`>l0[Ow߾,;~a|?)wUSMU؁:\w*e endstream endobj 555 0 obj << /Type /ObjStm /N 100 /First 879 /Length 1537 /Filter /FlateDecode >> stream xYKo7W\!9CF<@ vmX)8G~ZۊdA+k` 8C.Q#cN.X f%U@"lkvctMkhy+٘ȐH6!&$S p-F`QrQ:@LHDA)xN%2RЬHFaF)^ylr F|(DRWΣ\v &"<1'AϚ11]TqQ(кQ *WCr X9dƤk4 fMM.QBu05`>".( q)a% @}Bfʘ$j*@ @38$#R0i+]RMՐXۯl?B, 0?Cb;D@`&/B PD.FlE&(Fj(FIN5 ܝ(I 8F{{k^MQst]~:2j^.N&1>465o]ɧ+wp8GrwS+#2{7s[ԟN}tfrÇޱ!>5OG5o]nn5Wɨym'ӫKdbr/g&mjILNNǯg\kg~IK2i˾xxBWvxfd _pG`.[4bFfZy_tuiwĊ<-DWa%6K -<^k+n`VR^NOG;t qy7qRz2H>>3WY}UGHA]L<4 A [ 0yX=6K7!Å̟h<&J'Rru|%;,'\@dRl#{G(B]Q@p@< FPDmB^a]-,ʀ&o /;NN?_Eލ>朤ڋ9)A}5yݾxZyZ`KG`9F8u 1Uσx&_Y!y>XG"gA7 NO/fX`C4%VzU{y@*; x7]2[3wIU;ӊک% C|LxCnn,d 5qS \*r sru-.߈[]] ٰ1`ވb "WT;):>(,QG}u=NœRJc.Wr+Y~ߡ@EꃭcH?%ĦmiF=IXP^5q|9yg'ɸ?WpNpZ[Dc lh{=1?1?1{ endstream endobj 663 0 obj << /Length 1940 /Filter /FlateDecode >> stream xڽn}Bo ""Z7/ őM"Z[/s7e[~̹_|uUXxu_ Ι*9\_֊o~燏ZMN4c1;sȏҞz RNoU"M#\?fqf{0E (RE1Xg/z,y{y@T"MEXnڍ}7Sr]("IE' .# ~^cf$fY*~!f7m=AUޟ_dz \˪Bfgw)U'""aQH$nzחMM7TˋɚnzQ麼-3n}s(}Dh @ bUY,*bZ& [G%ԙhu t*XIJ1QS!4㱜A{ٙd*G o}/ d N|߉4Ʈt?t}`ZCz@mhn@)8̱eQ\fo_iofN yx؟~qY壕{eNYUNEVˮE0;6Z$SOh8EOdy,$ 6 EPeӑ7&B2ji=%=M7##B0 )Θ~G$L̽o|uSUDHiN余R99P^C"EМOue $t{[0Rq"-9C -wA Y*"w 5ʮG˨BcFB@gXjHCV[b,dI=e`F*Ljoe] yw]v4'Y|;x$ȄOԥ$*m8:jZJ-@큜+P:0$sUbQᛚH4!1EUb e䧊q9TlV}~B Y!G:/uyH,<ƾ+ $\:)9J6GhC-׳} mggt} a3P0')!:QEP ?zѦe=ə2?o 96 /'1F;W'!uXE@)/C.+l^USߛL韶 ѿ ]-Aؐ/ڍ[tZ뢰 3ݕ^MfR_5:2ci MHcKR_&?й*sTvh`>_w b endstream endobj 671 0 obj << /Length 988 /Filter /FlateDecode >> stream xڭWK6M5zZ6)P4!n/iRm+$>䷗4G,Èܙ3ZQ43v4 5IH%e'mN6=Fmǁm RlC`\0I9×D%7Yf5mri|J좁^rxE@> :dP&Ix` UiI˦N÷^wCiiBG]Ơ^{_ܝ^:VU?3?hUT^ %{̗(Y[-.6UX>~Vmbi:aGZG1zUlq]y&] b̋b,wG%YR<ڻr0jF=9/:0DiN̫b_Re]z JpǶO?T!n:kS:3\֟l6 endstream endobj 677 0 obj << /Length 1855 /Filter /FlateDecode >> stream xX[4~ϯ dET u]_`t2x|̙]_l·ܟ‹B(*r{]Qo>f| lqdVgJ1}~W:X9/Q,1f%|> Ǵhi+k:Pv-' QCuE]WSECi4QYdW{D~f˭#O.L"Q_n~kYv)4NM6mPN{vpw~MKpIQ'r7S~8!'v^?h$w4GwEP|~Y4TjjQB=%KDtI9c rJm`솫*Ncu{ d 岟E`'jr~H%6ݾm{c)'LG YHr$|pJKd5 d !?Y",,1r`+9hגE?tXޅZq$nCm3 apyr6x$X-d*M9<Ne9)]Cxn'i`~v;paؤۭ'Z}ˋνmlלs)s/jQsEg؎iW"\.鲲q[{BAlj[bu I;vC$x.TCi?r3ChkL*} KsjJYo&XL >| ,0^2z|U@m mJbTnBe8ZsFTvLrX/ HL+9 dZ]v(8!IX~gC5f5g>6m'i"?ۡOJexM~ ?W!hV2>֞y G"`-z(V+ڂsF5o^8cs< Ǣ,5dWzPH|ugxIIlZSIJ\]2ݶiS qS!IWCW%LSX ; ھO%Vf xƮ –;nb-ska 7) n/h.p-Jf"1 <'54zi4 &u=7Zӥ#vXoGUFot3ˆc 6;9 BS`[jh07'8GPMtgX'X;i (ypl/xSЋL endstream endobj 692 0 obj << /Length 2046 /Filter /FlateDecode >> stream xXBpTkrkZ-"ES\${J"B,IOп3C{:0p^;Wǫݽz>dd1WwU*}1+V?nu7Y<$)d!+_37ʣYLbУ ~?RW?yohtFtBx xߨc/RLH&F+BAH04476@ґ l&Ȅ$$dC4+/H$ԏwWz3Ulh;5G55vzWt'Kshy>h>uS㯧CsԬ:ʦTm"B)S|kB"$.O8p-NqF"-9c{5AWװ '#[RS`Z,eU(I]+уA zږ#P=L$M0EA6^G2?S6ʺPcA^jb$K62&j(ckUΔ0N"ᪿF qFG[Jҿ5CQ&'Tom'zh39:eu\Zd$c ZTVzwb8v( +<(!ofx poB:WU[-{hs=H!2qYuLs8?m[F ,O a $O2߻i"ۧ8ZTg;X1ew9QH;#]v?c˼rnjě,w>^ZM!h˜ Tj)ƲΫc!{ `BB@ \G kljDXi`G5b@IM%:ṴށEi2Ԇ>:#C 40 KD{W%ĆP]r#J^(7~;-R/u?@# <,́@#E/?͌ȇ?W,*h8spH4BsFC1{QX3 O%!dv_[&I0@Tk*S͵ޤnkuH3MZys4)o栉ZwS[W^EwLje~S 'eY0i;(yR7 $'B26tL/}ΒRË)T?>!f$MSw3F@*闛P'Ÿ0^38x|kmikb9 oꨫ[dcGWt.-YΝTh כoԓ^{kEVng{ vW XlI꽭̴G[E6r][t!O5%p;}TY?4^}iM0G7rQy{Zʉu[F<wVwyl)pp6 +6TVZ8jh;Q| QBe)>텺%Sy[&\ [۫@{eӗbL3eW"&eOKyOlh2뚁iS>W}U|XC`.kҦp-5Â6A|vS'A/M|azK(De=ݳ>ab[\\<[\cv hY<2p4O}ׯmd=BmZZ^k0״zy]v+7߱m: GAuu б1 3‚h6D~z{nMPAnY# %C/WNћ\t/kc`7C1ۦT=fpNn?6KM5j.ptѯw=ϛ^y}wx֧͆0~,?CS endstream endobj 702 0 obj << /Length 1505 /Filter /FlateDecode >> stream xڽYo6ݿB@_,f):ChluҠ`mf+KD~>ƵStw$6^~_Q4"Q̂cDYF`]\/_?~&!i`vZen?3'L4 V5u$ր(^8ȃw:zg#=!CC"1P{%U TI:UZx.sJ2F)C1'hh=~"V^UjUY2 aҐYE\Æ?&hZQ9Y?`N9bLbpD12W |.*%]ӷZmRFo柸u+Ua}crstO5Fe qjmwYY@ bItSJq^l -,YYF_V 27;o g|Gb %/]w;F4E|ǎOgr&w^BbVK{ Aۥ+фXJA7B}DH(9O>ʉ(۲ҫVF'!scyJ]_[0 _k>#T^cqGtj9W P6G OPH|) 䥬>4"jve {H37 Ԕ@ojUZ¾WrVB;M2s).v,aU6_4D8Iz(V[Qlyg i<8744E^vu h`*CY 9MC49}Cd8x$ }x)_Sa~Ou51/bGm 6 A zO7պwr0%mRF/k#^ 鹕GQ\rlTZ7BTWt>9H|J3o+N۸LOMjM.GVk#;=HkV_N 0ˮ)%?(.gGGfJ#+ QSw8FzOwOcySV*Ұ] Ԫ;=zdALrm7}ޖ'-ި3{v%Zo7o~6?A.\ғsy:z洮ͫ#Ωfc =ǮG4ϗwZYL-g魛m#NJ}E gJ_ MϞnd9BrVv=8s>9GMg(G~ԗdq@ LMC..2j}E O-hd8`.~gzIZ<刑xrnz{Wv  "`eG0R 0RXKdy0FUX7kjmrMhru^eGsU!aL8/)څVRZu.XB1^LVT<`ҦoX[4 endstream endobj 725 0 obj << /Length 2568 /Filter /FlateDecode >> stream xڽYK#ň7&`}5:V3䷧~%llvuXb/ŏo|J."\<T" XorΫ{f(Qv8MwHB‹k4k+eZ ,Sb7TxܷGS44kMuڐBAUtɧgZw\1!+>!SRwsL9hq_5!&}rr%=;s+ʤ4Iy<@iQ|,zSumPrvn=zEQo!@_Ёͦ}n0aZ5'wGK* v-X3$<pDRehAvw@ Rn̖~ZtϟP,_w 8KfZb2PRMYPHF0m7GN-Oe61R#s-%XH*vQ*N줺QCl8!ur@ߙ̅vౠB½"hP~L2Na|'[-wȏ% D٥ms(dzx>8iڪ02Z F)\0vD1Ľn4tJ2.bLocz:u:ӃTOWh{繌pن@FE)ձ]gkM= 'D_; y7ѮQ2/;'B&_Vn}svZ{Os{$Z6Fs^Y.N1kn,˚>eWErQ;UhvsMN ⇓"mr {")uS^Bw[AnRtca :c:HR%š!P v;7boSVYl 1 x@ٴgQf! m8d z˓%A&۞@jḁsw\ lqm{P:T|jMZ\K$ _'_Ҫ~&('=uHL֢L~2U=#n0: ,/V; r5G5ETRƩ=-6wh衭Kn[„=_>51'j| 6^DQJي@R.A\3NnʶKDZ'WG7fԾ4gZELz|d 'L83<*]pGAĂeو-/>֞>Ns_g ր`l7*TZ)B*RuՕ|rWs wW>X3{懒d@UߛMW7pl^pYf{&%Wt%:tRhaBAl,2LAvΐ0G,4aqL%IfA _jHYk IDIXEPٕ3]PUUwe8ԕ] 'b* qIށ=)s ~rl+}*-j{5=ZUIm=dy֜J7E ois9BSUnۍqaFJE-u˶-G 6qxm!]HJW?M0:ՁvrpcKgH1Ϊ.Y cL߳u>tJ1w.0ssn[݂%G_Tq,4GS`:WSS#i*K =ruﰺyև /mqD0>d>r }jWxE{|ڇX5?ȒTݑnT6#DxZV@op EbjIZ4[ S'qqU5$1jX"Hޢa( ЍwYOkwtUSK֚Eo{i,*0kl/2jǎ];- ~`/nN endstream endobj 732 0 obj << /Length 1229 /Filter /FlateDecode >> stream xڵWmo6_a(l1+Q/u@7$Æl6tL'\%Qh'>R<ʢ,n$@D[rufhxX|CAџA|7aВ ־©erd;]AG{b9wKGcaq~l* DNJ\F YTd$4Y~ͦz4\đ<]MfNK!=x$y~fGOlP4Crb( fˌVJyІb($yBI%y<"w*j z{h  _*_E_^ =PB.ZG]%W h*mnKQ<>:/:N] 2 r orgn1?&۽XUky2oCQQuKk:vƬƜCqDMܟ%`עKuClئ D+Ý7p= 2`Rj̛5v8nʷr<J0XԦm˾rಙef`Fs-ٲsŕpav:M+\湩~֎RU|> stream xX[oD~ϯԈf7ߐz8=IMN//vfs4T73lM5gA҈FrQGUpsVZxy͢ Ц%YDf꿼4H@6Jv4V͑!yg[b~a@ ݽm9/'t^pa~D(xDPJ#偖kZ3o]3Bne$릪e-fݟV(W~~m`FiY_g3噹LY[϶]wM~יӽ|mWO;](wͷfXe)ʫ'2{3MUOqz[sNx"D{E9,&d5weUَߊokԲq5d?F#Zz+CA {ɱLowE'JYV sqUU뽢ʑuIw[UƆNؘ[r9Ⱦ ]º[fʿ`3 6eNc_3v&r(l;l+IE'>""8wT@΃ND! :ՠ q>:IQG?3 u:"9fZTPsS[<p8B8 upej}a7oRutV(> stream xڭWo6~_!d( m5CJԯb+aɀ=lX-6ZblJoߑG*-'iׇ4;~DC?WA$Y8Rȉ#JwV +NIHRjJz,t7^^ j ‘-X5&+wF8K0doR꾑(K[)4p:!p]SW2Rd7u}@\QҮlƵ[-e3_X]̰Z%7u=Y;r^NH I]Wl?jJso꼸|ɑ[eu&^!(-Ghaј ) 9})xS7BU}w1X}:Hd)wCGdr 2/շ&6fx" e(mn Ⱦ$Can[qUF@ e_If'ÁftL<8ŧaC 4v M[}tpH̕yd;q,"Amgm'b>IfMUzZhqi ve^dÎ6y^ b gaԄOڢ6WYk$) y1qhjS* F–%ϑeZ}i~ڗka-sT֭=l аRǩrz-UWPj҉[nx#xHx[" ᢏ\ِ# ؽ({VPHIiK}O~IXiKoGΌC<;; ?*:RMkNT =|T]7=+FMq?hא,jY_#|sh>a697b5v{թ?0"/LuIЮ endstream endobj 654 0 obj << /Type /ObjStm /N 100 /First 883 /Length 1776 /Filter /FlateDecode >> stream xY]o[7 }EW)Q@P-(,u[#$^_N7uЇ=U(ꈢI9Ku$4*bqENN.ş2J((hDq4$td4YE#a('^"Bsu =ESX!,UU H)d]]$~J@21v%&tl6+6Sd`$b6CǘmQ%rM$@vl8 8Q-\l ,,!B!U'xD XRLЇ'XFaW$_vVk(.02RTXGJv) Ci 1+DahK;%Ш$).e`WX&exF(4[*.)* p0Ju$`i 13z-bJ#57)l [iVef(ezBfTtͲ$̂\N #HmMATM1>&3ab0,_fp\%05av\3Ԧ< oFp_0\Wgӹs;b> ǽ>`x){k^ώ_5/ܭzlXv<_P[]`|1P+nA uF29~!}#Ee/7i]vIH`)_"fK8z3z DYŋW I^P&PaF6 kFK yK5n4q=Xްm-oaXo1n.}=YA |_lwN5j55kRg¢RҥK=JE R=+]ŎR.؄c7 jEDb@ Ϊ eT벫GF'%L[HWBN Ұ5ou%PxvMWͯǦ89G'S?;_NG/^(9c]v6ce)H:|3 ᰭ,`.{_ԵqœZhY> stream xڵX[8~﯈Bj%j$NNLf>nws0a|ѳ$rQo$N KC(8u_Uܮh}խ>|,NG璐å@-yz z|!JHҠ8,} , `)z xaPo [Fՠ!IdaFbΦjx`dr8"9^?:bRTtݭdyϾ~} ҜejNx,MI2en ]6]ꉦG'ޣo嶯,T(L\~Q።޸~61Yh# 3H!jP0j/i&^0k(%i:޶T'ar6Exl!XX. !'K{Z%uq[궻 oM̍ Ql,;,V<̘@ B4s$BVK.UПn6S08x4%0xJX9M8 A5 _c#)" ʊcRA8P*qxLvs{1t'0 -!''y, g /Y~kdLZPl3.owB3”)926B lCҗF_{BɃKFzrC@!`5?.`G(^J ]Ai@\(;CjE!#>UbˑG/2(1MS^^u̜e~ZpKKK֭Dh:}m5 ,-bɤ;"lG~ϝ9!3*G a9.;-@ͤs. endstream endobj 775 0 obj << /Length 1265 /Filter /FlateDecode >> stream xڽWQo6~P@̈$Knɀ!(yҢc$"*E%~HT$YvmCBR<x{?ޮg8D(>A"y̻$qȏV*A|!/VQxKJ̱o2'?4xt3j?rg5,9gVD4q%aLy>Hd`>!ZӔPTpHDN wK3KO .PwE{nշ?甀hXZ;r_Y׿7YqW H`<t 7f6BP&]fCdգbֈ "A RymmJe]6+DŽKZ_XB%%U#CoZ yuN)=- @Z X[AXkDqQSEl"3`?r *i??Lr;92NuVЊI3ufV.gr^#P!*-v;#=0Trl6$.\L5srW-: C!m "ZK o4m#8∥^(sQ@zlҚ3N߼YHǷn[ ;{;Oh:aky8iqNcg_{8T#+^Hm)rf-+gHVGP@$t3'dߧ p4} *q߃]!0rv2S+Yz`h 췮mwuʭ(JB+ȏvA08@CJ~bBIŒ`AnTO؈Ey9~t:ݨJXvr#Z GD1QU>6'JYV2"R4lY0?N jTۖ\SZ#Tvh(Vȝ|w{s3aNȼZ-cH9͌q⡋סK!B c kr' v}mW9s1ejsKԵDdK's"x~)nf{A, ]l}]Gd'vONSUom#i endstream endobj 785 0 obj << /Length 1922 /Filter /FlateDecode >> stream xڕXY6~_ hsD>L  !ӻdiV"KDu>U,-U:*9\,/?\_GH׻C"KCDbq]C=/^c㐳,N*HrZ@hWx%2ܣ+%aOn> 1V<#Fx\$ :RVn-yRݨe U6߉6+xS cߤJ%A]fFYۮIl}܉aGtoe Ŗ$MeC{pѰQ+] X4J@3@HRם,0h^!mvhէnhJd+&!Tm)yRɾnu}WIC}[sjM}p8jWstK{=fq"(7,S Ja%KC8p C-%\&5YbඈD: y$a - "a&-׀p8`YWcU#@"@/"Z BSS2gq[ݛEUMI6dwz8+W1 0),g0'DHkfҽpohCٷ{5'Zuh{T0*<"pcӪ5%")rS+-]AuRÐ_L l7言e{u(ٙZh=9N)8FK0wI˲vV`s@O:2zͿ~Jv׶s b}Nv?pXr.%:h(XT~*G] ni$ F-fGzŪ(2=pZًC2ߙSd! zUS/3n[A5 #AXw1ड़AOL{]v[}nx> stream xڭW[o0~ﯠZPn%6]TE&F?c8u{ >ͶaOMO.0pcm[<טÙϦ/|%MB+v):Ո;5&L>y;|鎛C6Zn~Wg36u3~uЙWm}k1P&&(r1H7b:bib噉פ$[/8+pl+ [BڱTç|HĸXE,mWgDңH !Хd&/HF Qk%A-%W/CJB1Ԧ-)kr`ݞkMc ЮPh$uQڒ&OMOJLKA Ot<8֤WZ̯lK@}AUձH5hMEft "UÈjbGD׆^S^̈CcĔri=s \ Ȉj9}=$<"E&YdѭzM?5 ۍ].rc^Ր*1秺ף>>ٍo Z%j)eM3 k0z$`-k;΀zmo)xWPsmeӁ.{85:Xp!*l^cq֞ȼ}[AZj1H:u/0CD11Ύ]@#*uIm;1ΘPxoJIKjLq",g#ĥ2THsl7Ylͳqg3.h.pHIܛWjͫx6[wXó^ Oi)g~xgqI^/&C*2ٱ D0NOv endstream endobj 800 0 obj << /Length 1274 /Filter /FlateDecode >> stream xڵW6=9(8PlYv--el]n0r(xl{andKz;;;?/^8:cCOVdY~Z}L@j[׫ſ S쐳b Bŷ,ős[s' Pa'sX뛎=C0 CߋH8"KFʣ eҖV4k[(ML0@a_diզe12l(*$r<F|O燱ۍ`ϱy% UmK~(rM߿:cR?z1>b4D}^f^ݥ`lK]/K֚0e&fyI 8!1D=!gwlc&(fٓdR`G)wU(&"3+^s )y~'kfa;;¼V-7V~#hh: JڽE eƧl*"E̺TV̒H QIx*)GhCiN˜$0pA6a-e-3z &|YrY@>!QtzxEϩ`9Jx֡g؄Ƽܤ1r&GP<#!# @MN$;l{3166OR36; lPk})5 ͇۬qm [*{~o3\@wTL)6=78itaR1fʖg; ʔ Tn8M"J4cGeص{3dz@%\T%WKC^+ȫL6O)OQq@;i3hm@G! <z3+Wj(MSyC~T-^)Mm|!NmIcЀm*բjld\|lO6KVد5mayjcWIiCԓFYOH?$5u? |vߕ+& 3Dc5]R z"M n)=-T 0$o==>5:bs3K |HLlWyxQHTxL1/mIY=jVq"oԽi<Jhx#\n4W`M1I"n{f9h5ģ\u9cauyo,\xVpU.^P~ endstream endobj 819 0 obj << /Length 1434 /Filter /FlateDecode >> stream xWK6WvfHꝶm R&䐦 LJpw}Rym Eq#uvu^,~^?C28v%>Ŋ˻CU$Av >sőgOZ0I(Qb*Pp ˹( n2pIc`_ٌs#1 >0I>q/dVF&{!q9l0 xƵ[󁚕K r)EW4I${2rNNgW%Jh-WBlTNݸ,(X%@P`}&%_ Y)PV- z,Q^+ͽ5^.{\4ڬ*CE>?omfe[W.dTzB*`Ҟ;W<4|/. 3-OՌb^źڇJ|/Zꫝihy7?&aؗ =mqLɚi~jS+'x~\<ܕF0Du}Z 6_)tT[ LRhBKIQuelj i(x8Nq=ls᠄rmU91CQ\>SW-TioS mO14\1ʝfcK4&rUsu ք:+5ܼ%bdAȞ/qkI|J,#u#?2˞M6Ծ_]a D5 8A3ØժC9푅1d-0՟# endstream endobj 830 0 obj << /Length 740 /Filter /FlateDecode >> stream xT[o0}W~C0mm q˺ 2&i"c.;>DKli\0 $LO )5PY^'I/N.e0rm(M:b.%^Τ(帄#4)IӪE5MmBuYCtPao6Gw!$ϱBh̠qge\V*٦K뛅jx [rVuwZҽC5ozP$0hSZ0a ܗs1$v2U8ۚX30yjenۦp/YΆv*!Ȯ8Z0 qFE- £ToU*~ *G<ؽ:Mg";ߖA\#_W brYޘEA/pjU ;S} g+{zBK|W|3)2vU\̡L]yqW֑8 [M_^ߞ3Jɔ֏$vwTzjp%yl7W8d?f|v.&؀k4#8> stream xڭY[o6~ϯ1˛(@΢ŢmtP(6%WM"eIAF4˹~"=e8nD&Td`Y!0w~gJVH5ڎ`w7Sh.'meb2N*>yrPOiH=Hp@T+ۣ*s9+Ɵ(̃ݚ_ao֚l_pe[&%tj}%0҈'JfCh{}4͘7Np0?T2?_֮xv/fk_tjڹIX05mU0um2pIVHqf%XXH³J)8Ż58XބKB""&ci6{]0BInE{4ѲTZ='t L1 GuS~;;>6z^n{V>V?̄s)C1+d\)w6Ѻ5Q""e" "¤﬩(# )p=oHl-kwF}W 8qT (хSSD1qٌq_ %[,O 4Y:M9ap_/~oGʂ2a(sy^mI:;y@{3{}G7inF1nue}9!jֶ܆fR25ׂr?)v̋tbK1 ϱgkc Ov`ņYm@1pz'mw)s` ҼiI[._)]{7MfxhnH'O))9 Ldr[kpM]UIaX'ig,DdS?gCܤ^:HnRYpTmDz)(P@ﲌ! 6cBm^5XWPP!oP1YۉA%_#T_joxs  ^`@KY^Ժ&FݽP<ίT0tJ V7>~$>b;ؔ ]_\wdջ'nngNh'LP5WCع@DiK%an7mAreSwZjA+u̍r8;;tlIsk5srR~RwVL]} ]&v(]ٟ WK98?u Jڗ>sBBM{SD3U$4::LT1qo+ {_*wT%q8E/J-@WA х@;=TS/5E(ޑNWB1dg 8qαwڽsJa vN%d@,bX0"9e`8 b M;xl.mq\#/qf!nP7IUs*rQ/+aPʑߵ$kKҔ\CAЃmeַ 6&Cm.%8ClZvQ (N+^'9~rQ0m(IP BLYs.5pG+hS"` $KF0P"QmjpRK=:؟]m yRNٮR%+q!.?0܇)rTO6$|O2߉5밝0>UIǥă1ϸK S/qG̓_ nkHtCۺ+=[iz5ͶҍH9N G`?r/2u?ZX endstream endobj 758 0 obj << /Type /ObjStm /N 100 /First 882 /Length 1670 /Filter /FlateDecode >> stream xYMo7W\(ΐ!#@>@ Ni{Q%CȏUXTӖ`p8\DJrIpW.;v:M1']LJuI>X񌖁 )+Y;]G S`TTx# /-kwlܑ/[3LFrt6p, ȃwkb_N'swp'Q%Sw,^̦'o;v7]u~EF8t%|0<.W\pѝ^Ncc"U'_×i7>6|uLq;(l%H^Mr@%zO[7en0+O&]zj H`5֛0A,|ʦK3卜fg']O><*ϲ*h4j[mM *'98俕FV |pR/&0qߌ6fCIF,+ſ$U_UQ[\?ĖpJ-/C4m ;r.Jr( JR.˝J3BP}Ҿ 1Uy~~z!p #cWdPI\Jy~glwlR2n;4>˻b)OV7e^֬D KX Z#8rpYnҖ\m-D.I|ɵŧ5ւ &!/[\,N/g~$.DyB= 2G Zk[D7!>>Ȫ[%~8c)}!͙RG`,)[ N8+5b#]S8}Q;v> stream xX[o6~ϯ027KlZaC`bc$*"KI SsԖb$r<_9q 5G++˭939~qb[UGsoWU14ts|Y1L@ 0Z5uI37YӍƜ]ŜLx6ȏ]~ 'o׃_`Bpߠq܍w\gBvJh0Rhb]Pjn;NuOVc sʷoJ#xHp1ݡM)vZ}aZb}JRP!+Wą] ^"n:#o Gd$L Sؓ(gTȃZ)* I)R~j 㿞QX?wH\~h8L>g>̜AW|&HR%40[=.kG5V׀g^tZI,ǽxIMhVƽeWBXnCڐp,-ApiI?0O{U%NN[Qۯ,t4x2>a!1 S6Vz B^<3 _/Fc&-z2 cO4'5Ϭ,d) bZ"J׀og+ʚi&Tf/;M`ҍEhࡘ_sk?W!Aآڼ %'İu D扆y9͙vU ?!iZ5TmǜuaFۺ .kp1JC$nvV_OUL&N?pW+DgN_O>Pmr)4)˓wjVĢQʘC<*=inDŽW1r(tmҍ'c^R~e{8{: V7@؆'ymjBbe8/ʥ[mJo{ֽ$OE%O: 8- Ӎ5хeW endstream endobj 865 0 obj << /Length 1552 /Filter /FlateDecode >> stream xڵXo6BhQbzPbaIۡ(&ۗhv`(Er O:{4wvw^/~X-xg?"9QMW!ۂ[~k/B!to<kD$YU^g?=#QY\ԭrӞ7OjQ%l^X5ћFV%JJ2vjߵ,*#|yz s|Ƨx~\wUi\wH>O DS]PfeB B(("+eMsC^3G?IXOuDx ^bmCQ8d. 8-p'Aع6.NS8C1~M偨Q偵a:"L>?dQKbďj$|),:Eu^U6]byi;vqE8?u1a|&#'zNid)UǮ&XY7~i>)( Ūur;UPmZ&lHg$XF\Y:/+.ˇ 4D< ~;Uߟ^C^!HK٫w}3?1( fi\ k/d^`0jiv ҍ?nЉxaC3]Dk#"[o&Bb+7I BPL;Gc_w#&tׄp<ܶӑ5A&7 H8oif+;;sNt;M܆*1 (R-F>TvrB*[36ÍXf\EA7jCJXPh]ةQ ,蠽;%.b7^,h7Z(%8+x=mJV瞝tR`SK-.[ZUƆQmM G 8h@.; HuHyبK# =Zue" d9h.[oO;|қ8VF@̸;2\VD m4a~`Ҙfxt+ή6*kEM7ڊvU5<3SjkItMDeWm|kb5Me]%U9;0/( ?)ikd:m},A4\KOAN!(.̃=KL4 e$KAuPTVB 1u^e䬕n+RllβAL!M&?6[pi endstream endobj 877 0 obj << /Length 1952 /Filter /FlateDecode >> stream xڥXY6~C ḧ#E[@Qӗ(VaK$ΐ%ڴw>p8CϾY^x,fqZ4 C"8 Vevk=-Z5'QHI+EeH2 sڥ!^|9x5cA H hB4ҼhX0zPv(}sICj/EztD\v&.]ohZO0#6hj}Үtj+}1SpaJknhyp7ڥ %4TM7X&˛6oo8+7( "Mo&G]9vҽj[ƇNqE&:<]MC9Q_nL̚vDE?uuI- fW֯sq/:f((ʈ8I\%2UB@n"-A(=E/ Y[|E*h&E=`1 cj_-$ycIvvz>ȯ4YP}HL%r0EBRzRC6OeIÈ$,qkiE]VI8+i!k [Ꟍ )![5^wGȽ4 YzɭZĎ+}i$I2n%~ T($<|blX'P?廦9'(7@]fM4@BG3#cN@#DJ S^mNuZA9SspheK'.Jçjb:ץ:KKIX*{_.gD0qL5@ǰ]U-rSn)Uc#쌝Si<|x Ce&WcjP"ռ8E(eoG0dN/Tu/:IXXez~> VEJ󹯄V*\!gZjA8EH8p5QBh 7|յ~˙0o;"Ar6G6oz3-0u,'{A:2SNBf5):?l}x#  zo>BŹmɠq:h1.ÞE=u@m_7tšn nʭKg0nl,<=fZ;ͬYD8 Y|V2Z뗣/6ۮ[V=UW޺?$2XdLߎ*2V#[W-^ŵ-9vNzm" w~wmuC ʞ(L"䯽jp1+`/4VZx{8X("SZYz?:Z)acXu2)ŰGԧ稝zp_"r͸bO0D"$s<8\-.E>X|h 鳣No*`ޭfĚ\ endstream endobj 890 0 obj << /Length 1014 /Filter /FlateDecode >> stream xWK6W[k.6@q$- ڦlv%QA{Jll fd{!GffK?)L#/ `D  }vїclH]nd$m㶸ٔ(ݒ0nX4l+unhFr4T֗nddm)2lۥꟆm԰o \D#@7\w7]/Z|b7WZY_GӸ&Q;qZv'{qD. v%H )J yFr~079؝UQlb[*v~'zՁ*tz8͟2> stream xڽXio6_x(&1C@5ŊCw-˶6Yrt,ɿCg7@I}q~reVBzrgs=0Z˭SD^~x}ż 8$3l[ng"\܊[[`UXwhQJ٧VxUS7`h8eEa@/n4Ârl盿*ȶz&es& KǠ, kB\g|"oGړ2*SfH`-HkOu\J$O$EaDb!l >YeL`^d``ط?BI]t*ܜ%a 5JEY$Ne*64򌠐3 qxTq&dO? N }.>xq_bBh mYv#tgPCMt' EhϿ;!b8alۮg(NvM)g娗d%x Q!֛^lme:*+YXj+9z[Cwy̵pl7,dC}?vZC/ig8bؼpza8l!Ľ8T&dmxNS-;clЫ_/='?e.zWtx7IF!РIFSjSzؠJPn46C[~ʒk\=}5RA]GdƻyD7~|e~f_T6)P1bʽ*DVk.jxXqO%A̞,^> stream xڭXm6 _aU-`/@ð逡- $Z;d~ԛ/r@E"M_g/gqHI,A14RhL*xR2uPFPbCs;h+[E>VH'd9G8;^;>]rp,ცe)*rT~>_8 +I3kj$.i;!;M|Irc6$W0;²;21u%+&$Yxl1*}PvE(P23)R֢ޘbwM?ZSx ׼H*^o`aͺplǻ;ZټiA(k5QKRm) zil2f[L1"sL3pu3bGԤok3dۗ[y#jQ6}S$j;F<}%1L_y) aY(ýSFb,A2 +nʭ68cG2.Cz|[?o ɉJizt M^H;i"< _8W 85,=oej\ ;&[qPNp=_ӛ:E"I7bӴb#jVlP{Gk4@މOz6rNk^@z~[bH:贫S[- ~t̹2k`u+꧰y>xy2l3NQNk<0K4c0_Pfly `}-j;Rȶ$iH\[ZxbL ? }c^hj~\%X=k%8+hZ(>Ee5+6cui__NC]dk^}Vߚc/<;oK]Yl8s>IwlkY5pu|$iםÎ8=*7&(֕#tNq#9JN{\B&l^UӴJ̏>D\+)ɖӿW}>Z*fٝePw.tPI֦2 @1kr98%&P'`r7{+(.N,QW?ϖ!#=MDQLmIV@3`|T.[QS5QL%6`Љ?0"h/> stream xڝTn0}+ 6X*mlE}hEuXnrQ>cV@v#BȷsfxfLP|L. R0;D A(P$C]ֻNlvACBq၆8d X>#g޳mQ~^cs`X\e$٤rѣUtc\ 24 &$sAԹҷעvŧ|k-9R}=k2"NsBˢ~NiÊN§s;"skp|> stream x[o8~_zŋm>]=r[! NJH4m3:V*offlr̾8>| 2 gt]2#ĕf?nJ#χoȌN)rfs~?g?fYJo7s9!CPW0|^?'A!ʗZ]t+G{F&ZB=_sRǎ/8C\jHyu2KQѬ!E.3moƖ q:W☵@l" P{.6' Fe,˂yYoReD& Sẑ4\iH@ (UʐpܢtLrC;nllfy9tF6mxNBo{@%鶀*b&fiZGWy[&{c7!d6.<&;+g&ѥ#<$כ(^6E2b3b.`>{μ>ӺPJztgCd$Mte*:U?.6 Xb%Cxԓ[(E;bNf\tK,7uWT&5$ZGݺKL7`|eb;ˆJeKA;4Qʸhvlk{;KefX6Ը6kl$ q(<ꮨ>ͣZJs줉fz:؁ٻFaEWP $1V#hsdlOix_8%9%8jӍwZ5;-ٛz;*RʵRД 2G HY뿚Evw$۩@֏O6"(.0j<+޲U`Kiӫ0'< &|QY'#U (o|`{Vr6'ŗzrXO/3z|Xx!|/89)YϐDGy="6q."yBY?XL>j/6u sI&j#n:=~a <x2p# HRiVr+lE uhbu|c,V0^-D?|ݲ|#<%JSu/ W]ċKZvj?JlwtUD}tw@Mk]KDw5 -+q}W㖙:tRݚR+;\oW\ݡ (?IM2esFC橏~} endstream endobj 853 0 obj << /Type /ObjStm /N 100 /First 881 /Length 1880 /Filter /FlateDecode >> stream xZ]o\ }_H-$myzAP8nvf8C3$ERi*DUO0=ų'fG?]RO/W$yZvދzw[|y]9rJ߶|[: #=v5m.@ [nv`OG]"\1F]F{YȌn"/,ۇn= ڞhW;MLuoYSBYх/3~xS]/. voիnOQHmPV=X.WSm~^/hoOn}`n{EևÏ=q(TctY mG\gݛo9{{y?#}_G$RzG`$]ְ B-}}>0".`FLGf8w6jl}q̻p[e]Bf['SAV{Eݏ8.qfnSbFl`ݽמm'>p *H;:Ks꘩v?F& Rvzk#X(c11_|2d'oܯ >|2dp|ø>n*]߸s|:t7|uy|6k 6g >|6Ɖm_|}_|}7x4>|~ÇS 'uOffifffifffif晙gfyf晙gfnǽGӅBSVkN{;d\xw;/O5%nQVJuhQݧ,:nFX v<%:jRb(Ha =g2j8s[[_D4ՏQ (ߋQ RpjGp(^YsUR?؅Ѽeq\KcLv k/sn78ߡ֡3&)h~>&IC_a_ endstream endobj 1158 0 obj << /Length 1740 /Filter /FlateDecode >> stream x\Mo6W*~Nb;00 ŦIr׏eGiJ b2I8r͇MD (a00bo3qI) ?|zx YWchk#hR$>cˣ,A8 $+l?fu Ib'R4M€=uϝA@hv;Pnp=46 Q~|m$W IPB PmS!^J8P{6h( 6%9#6[2T~mi0v[N{!3W1\Iw[Q-$cӖ˘D9lnMGZө8k6,q CAl s Nuq뱴>y G=V+Xkox,zȦH#})k;:a{Ig՞HqlR5JY_RurD#E=H2-lƪBx*Q1]2׷"W2voL]bPYMuae,<,g[E:BnU*Gi"{Θ4@^\"^>p⨝$X[8hyFFwി0{͠N*?)0]UpdjPD Q[F H"<` 8Nl[[A;4}_#8`{c'< 9(ݽ;3>Y+5]eVEÂZgO#e|uۼ4UѶ!1 ϕ/tb;;B|ݹ=Ֆoo穏f0SӢHi@I*L2L'qVXOցguz5RZ]hy4nd*7#6ZHYL;S%D]Dz*FH?\ŸGZ|{jf8>~whwoŔR2}t,0Աh0V˥!&@/ (]B; T93.sRE6@t qKܣ `m90weM(\Iix2^m@--k\MK䏃Coaua^nia3~,Ytێ:Y֍x}ް'.빗a'oUw=d~א,R~дy^dļ~(SH;ɠAW 3i(1gu2/k[m90ݗk\#f6~lXTq^ѓpm]+I5@/z{-=hvt\[5ؿ D ;]{}(wl5p> aMRx}͆Gnon endstream endobj 1037 0 obj << /Type /ObjStm /N 100 /First 950 /Length 2623 /Filter /FlateDecode >> stream xڽ[ˎWplxYV`( EA F !@9^,6 LG*)6g(LDV:Td\t!\UO}pBO4M~:ڽ Nҹӥ E^VXFtan6ڠ&-8!G"ҀcZD%ݣ̋ ioc(5<(ө8p.F  P n7tA'دg*{ǀֽa0҃ZM 1z1F&x9N0GYsbcƤ1#)?&5&M+nxbN/>vƼ{hEef -.CA-)øEKs1;f~x}-PQ 7~D171.q)BGkE3bdDce,u8-}x"p۠&!ˀ!O&Ҷ<ѨK   HAutxm}|ǁ7P#nzmd >A$F8fCmLB{5 sb;v2Ă"# )GU+3(HbՆR+y!F҆, WTΝ ,>pBH@>,Rp |QfF̑hGrY2004 :21(trġKIXw q$$H:B1*!pEJܱ=&ss2@9LY5r GeGd@RBtqXBU(eșHd3xz}5#wY K"uG/dX *dX˵C"2I,'-dk5S1=,6{H]ըQBBɡ9slИAsVT;HJ-9uMjgO2fXC͓fcJΥ }vEӎ#=-7_Kb5H(fZkD*tDGc@-R;L -bΙe o %1PʨJAIk#&g TV:,b86aF?}Xu}zeIB]$ʪ{06J"t'ϓIdܐC6!Iс   ő;HYG+!d ՄLRau;t0bdECnIT} q_$²Hy!=ʒ [$X6qXI.q%yW[_@B\ƇD ##8/X!@o*8@!G.cl@fbG1ލN[Vi_I(9dдp+ -9A"+0!Y|# O&1Vn$"$~l1I3cmQ1J 1JJ4lJ$-&/23yZjpqXMz䵑Xm%,sp~[ڼrX$vŽJb ,%bFBQfm*;Bp$ۙ^@z` (Zo#3aRWJ}#@Ya"ظ,T2f'pV~[+PɸV콺s>7b=DnJM!vΫ!ȍd8 AKqp#x2%L\IU\)EQ' ;yGdҲ'8E5$FCi.'mtRlR>,w/>}lcS8ĺT&R߼PmnnM[X38{79ܡJku=v 7 kujZs`wXir_aۋ}gEKwLГۤCF{~zqpkϏ% s77@\|xGju|ߏop#=K?O:ӯ\~gϿ?~bWhQP++25`,~ZN⯍6eِlSOi>SOkgò|45{"D'rO={"DDDDDDDDDDDDDDDDDDDDD<y$H#G"D<y&L3g"D<y&\i 4( ɆfgòHdJdJdJdJdJdJdJdJdJdJdNdNdNdNdNdNdN////l$$$r e R e R e R e R e R e R e R e R 1γwvTv{gϏ*9a"\BP?KsjAMGҍz6 ;36f$!5RF%tmGgR?e\Ipu%!1 endstream endobj 1161 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2212 /Filter /FlateDecode >> stream xڽ[ˮ#߯2ٴzUIb,AØ,9[MZh0$JCqAV5J-j"sЊfr U8ce%e>'ZF%%Xo94q?N3[&\Խ8^D{(bh1,2a)InR碄-8rdE* ns=VKsD/]cnp^>:Zz$VFGڂ*LmeVz> } < .Z%DVBVQ[ڂ>%"/z:Gdx(`t1eIk_N}&%hishz:gRPj1uoI{7*=uɵdfpwԕmOL֬/+_i֭1%jnt:b)bE&n+Q ?{p*^̹GH&7VR|ܾۗOo>򏏿T /?xOm~x߿&Þ{\o'}_>|(\n+I|6) AmBꡛP7P@ևm\BxC˧ /P"D:B\6mczJ *$g T/x~Yj,L`}HK.lX6yXe=2*XoC|$DgĸKB b1FJҶm-O&C0[;1QWi;Qʕ.Q ~Kc _gc`N$`B0yԺ1up] ]&QTɄ ZeT8`K1X(Y*" {*a#7mTV4.a<@-Y>qiݑf#jAĕ66g J)W渺=@ tl &q%I R ~إH"@ aKBY` `KLex{9R}-Yt`0f,B8;yY 2b<@d KqS A@,wY>Š/ AOA Ȳ,C=Ȳ,y@n٬h,["(eD,Ğd+[D~jS{TB\Ƙ=+? GccI:$&@EG4be Mnbq•q=K14åAs"XdVl Ikf*ǣq*ZĬ;=;jz̵yd?`jZA3cRa6xc@r,5/_irIWR@<\u~&Wx+M5ELkum#i(B.Y8Pi-],: RߜCC_Q#l1+/o#l2a~<>@ ٕ16a|{vH"3tU؈1A.OEY/Y{CSIוa(xI] ]ز4d:oi2mt҈%nאxXmUf\fo 3e-I V @ dS\Ku qaP3R E`o7xMxm#8k^l :RpIYiQb nl1G%x_š 1Ds{wS*W3=rk[0wu 6@ v&xQ vZ D="Ns"k_0({SIP&k@qYo#cc[IQvHHC7LNR]>K&Spqd0lɼ&-MrQᵳ%S[Nu$>`rB2Aɓ*2A5|]z vZ ¤AGD Λ彑?ȇ endstream endobj 1173 0 obj << /Length1 3085 /Length2 27484 /Length3 0 /Length 29025 /Filter /FlateDecode >> stream xڜvT˶&C-w'Ӹw .kp,\\ O4M\]_xts@{t@cC)Oe' to:Z=e¤ /,sfIs6 ?55LJs'Q YmY:IZ(Z:[ mL*dhd?T-,ANNZ2GM,AVN<̬,K'w;863lwqwqrE~Bf߈ ,q#߈ `XR+o`~#pt]7GF芿8oF調j8oE77k#q:[Z[:-g-8[ژ-gg%v6ut7[;Ď 0r44615sC_⿦o,M? 0qS4SJIlmw޼߭awϜ7fYl\^9ocGo0te;?ÂUz.wM0Y[dNpcl~upw|2 r5u? ]vÊ\ep {CGS?xKg:TC_2K{n% \Lu(2,c?X%v.c&q8;.?|U1 |a3;[8p0p=5x]JS? 8Os{4u+\.r׳ |{Y(SSwScY;c ꠖJ"7ƝQ3 Xѡ5?ӤЇN}Z3^)wOz yw@'G|. #Fa Lc5LL(lwDܺVyh)Jbw,>>o idku>gbUݣ^ 1,g1tK9V@EEVhVY8)0&Ne:@ 4j7'hE !H]}bfo訛aӨ_LRvME(&8P-`d~Q;i.6W oeLJ:"9ઔZcNJHLcn~=TZY^>k:.sKf5k*m3° +CS(PTq4$ BdLg|@Ne| ǥ:2ê1҇̏i7"א%oG?UGWus&9 w?Snm Ӟ$ j[S,x%eO5ق(v@0uOle%dW=Md3Ҏ4l) ޜLZӇŦTK {"x+o8zRg o?M 7XgI+/{7/1L%MЪ&TU=o݋|9&°ymJOB)yD} ɿC{]a/riR=sEס;Ÿ́ܕ=]~N'y)ƚ']8- BȡGuM<#YbuYx*V9J`<#U~ɓ^Oiobʗ-[ϒ(&:@3:NU5ǬޕMVľX2<1(ݕ\&(~V3ڋ#wiCE`b={Ilp9bvV_ L6JArX!j[":7Cb\X=k4a]Q%."BVM ܵZd1c mwʽ4m pg)tAXwv"#np桰5,nk b}dk=Dj-]mk)PC֏PB\8JKAly-F2WBj;@d@(]hGi!|)/޹H EB 0eK38B1ڢ9nAeR笈KL9}O s&Z|憎+r% p>CO.Bޕ3:uxKЫR}&㐚7D?0#r ]G"`f瀋O $oܦvb(YȽ9}6AW^,#; HLcT@5L*J :b6=N Ʃn0nvi5W}@Q|p+DԶ %T9hBlZQjO1j;];JNx(heckڲE9b-Ńg><8߻W2OKby!/!9`Mgr ̤/(ma[Z㎂L~j9+ͬ4菾5䌿t&5߯+ At佷 dN)M+"颐`4e$DiY#uJg d#zn'$^a4>h;"RCP,&eݧBۯY\{h=Coۂ,@Lj9u:-oljO܋xrr?|$ph)+=T'xǭ:q#b"힘:L)*g L'_ڰ2_cP De+Vf|uR"pYΖa)bi3m36!>$b~~^D HXMrz3x_D#Z ~-y3&Bs!Q8YOA 3-kl\^P(FcD̎c g"u6X~TsfG]@-e~ݕ!q{H]&w*C@ Y[#k.]yxhqbf:b/#=اmZ+0wScڍdKH9F.gFM uɤ oW2=~b9:Q{]YuhՙAsFVDl! vɻ _+盙^PEN42$?6NI?pyd^lzt-.z;8.tRYy#@#ƅ3ů~"z,?ό>u%փNCt!OQGȁ"Ma28\p$ fdТ;=[_UHW(*T!q >b=Uδ&XXUʋs̺#+NbXR"v,?|Tknkd j} u~yڵ~ZBH-~{-#wW0+Q)%DU2߬+ΗL?WjpEQq0ǀP/=(GΘ? QX~q ha26uq$/{5ѣHfͰ%9H:h?\smB)iF^"s`z%;>ǒ;[&&x< S*uEQdrrLa_ #OM};t ).t^?h&T`6G bPc+lm(31\tgc Y =z(r>m5yxoEU#-8?mN՚rVN:RvMOZ#xKǭmC,~{$էrx幙wb?7AMEvy:~1&wxVFl1 1U|o g *͘l)qQpᨘ?F;0^ HrHI5mXJ(i-CܸI|EكFСLQGhooyQA6jJ} *C SIVed ғFg:CH7ϝgoNX)V,^ LN/A%;E 8UL.Go(с6}[2k&b᥎ϊ[ F08 73l-Pqnj\6[ꭵ(Ͻ׉}0m4WI5V6mQ߄AYxģ=ȧ?s!A @/GSe$F<̥dN1IH79lPevx;(T4?Yr[ȇuX~.'/6=#^+ςbM_/Z9_^{9f?oauEѴjvj_v3’Ae"$>Ȑ~.#bv-|cK Zԃ8(*Mk!>?.ۨ=U)-˾ޤ&鮙S$[-ka(^.Z%DE%a]+,mb RN:i#HF@=1IhSahO v']cX'dXKFMkRun2/#R;*g7j]BX\!}wA Bџ/4ΕX$9M.یQS݁ͨsM0dz6,N F?)N('a7[YeWR '\:nqx"0^?-MotmTFaFw2ɴ#. ([hB;,OΗ%=&:ݭkF*sprpVNٻ;!z & #/3D$p9kG^a:sc&-QZ jIiA؜~9WgH'\ciX:V]JOɷU3H>d[5N6ز%ː tC6%HU~ɜy,p{_撝\9F۴m[_PZ78.3?hy:Ȃs5/A}R lD$wg\ WD"qvr<4+?kn|H:ceYJk1&(Wkt9k;&|n ~K IKG>Ywڳ:Fi<˻ݳ'" OZnb% pX(nۣ3]g7՛:sLb0*jscan=f[涏_%unyX@8T i|UmG"tR1Ӂ]*_l.˚̾F&Լo 9Y(q!P/\+GeS'MKZbrQǓ`1>j DG\8i3GuW|pHeyh7-́Op׽fʗ05M$S̏Ɠq3 ۱OAPN1n#a|׫B@Zi3rE((y63%+|V^@Vj֪҉,^1';CU7nϬFr~Dos}7H3y!z^LU= N֪6kG+iڪAZ`+UǕI^ܒ"^>%um7rܯiwm eub?噬~P- vG `~~bQ [.qLƅaJ5܊-:`5Gt;ďomLcXvqx?d| z".waEˋ~(dD-{JOrPSn+/{keT"܃wl,XG nAvQpsa 5‘Wj vL)%^X{`jDj{h!Iא4|GZ'ϕu/ep3F\sLbl/V~N_(-_k|KB^-/UtU>3 _fx?xs~X[Pp==iH4houJw$otEgKGX`6~-0{UIVLM@D}'o0/0O:`bQشd *9~;+BU^o2z`zIWJζN$:+SKO6Kgay~%82T'R?Z!KgM1RH=_&07}:,Odxe.oDفZ<"gQu[IGi{!"j{ $ۀ=#IBQ\Xz0"$3Ȕ&~;TtLB҅GY 4$J~];*Dz-q>LI´`  .7v6egԹ$'2R#XōECՠME/[#if_h;}-1 QI!43Cm¸RC:3Ly0 ]9g6d#Y7w3q|No8<ȁ{g3Jjbֳ+u#7͡w F:xW[2*WOAq WWy5%75W ~He]op*bΓ[ߒI!/q_UytSxsU\+Wp'r<g5޽r3Frs.D\P.'/EG-_>]c!1o[4hEPm0j@!tvg"S1ݓ 2Da>1TW_,!N!<&: 5pC? DCyUl nDƸiG;>RmGlJO>NWHo~2 Sq Z&O(CmpCPO_f ѩB+zP\6g`7I ?btCgI յvykDh75bŁxf>aJ1ª뮂,)u%ֶ"&!!UTogTH4](7ތqO{׈Jczv-Eb^5hzr ѢU}W(q @O**4|$h`6o\⁲,:lR'ܥc5*,< :eP\{c,qsw$W*$Ԉ)ސs\{5Bφ֦8;Nh*7WGhC1`PP̦4Adjy d+ AFE-):NA g Y rivӗXs%Wz57~L˜2AOg*b'ϳIeʭ ]8|RwhV &;&p"3kk=A=P8N@z7QYh/q\'uHvC Ki9 귕0|gFܷYM?mjŭMG [+@a!e4}aZB$گ|rm[޸N`7%Uf<>$)Qxw'No ; ~Ә ױ!WW?1+S9Ox /`0BL6 GnzV=${s-hcvG&Mۺk5)sor>U7Z,ƒYFkmDT~9ś@ bQd,ĢWDQ;WnI!\"|_B:JC9|MMFTwS9PX-[e)O0j/d;șX Sݍ>4-mt]"ťi~ 7! ߗm靺+1no;vY$r>|F2>Y%;lM.1Ge~(UtƲmеjգ7 &oa^gCCώaِh"5BQJ7>캰diG|.6.VdcN$T$Ũ11Z5JjfyRvCD;t :xo|dIJy>J 55J١NۑoK#3B|BZہc*pn "ak` uR6'|tJ-EΉ)Z.wEt}`8)8OkB& k<@ȪT*[n} !:: kj-ZB9u-di Ҭ[?_`wE,bE.f䊊Nvi*GB]L:)G+ũe˽ֶKΜƋ45ZD.:cřv>vgtݥ2ĞwD qL;Kq>yoZHOgI2̵EP~jb%שEa~fGw?LX#$: W]#+Y.:Z ~{CA3!9/~҇=ȖޛNizfDJ[^3ǂTFR>i򋉂=, Rk'zH,KdžhO~,lE"O#XȐ}M[fƁ [t;}0W<:tyΥFSv>(bnHwW(o$T@`TP1q<'}:II2J\`w!eSlNXuq쁊%B+7;)V@E^'ζQЙmQօv7M cki.JyK`nɞÍ <|՛3 1 ;ٝMhxC*}`D&WZy4Z8Zߖ5]:?K8"֓ XRn0GcD@a +ݞ=w81hrkxbVE^hKߟe$ͽeFL+gu6ƮmxVTj(MJ \~@bCI6LoOF U!NU;t};LuL*]cR~sœpuxS1aYXqVFŷ6G/ 0~fl,pz< W7Ȍ ,xf!,)ܻӛ$Nh:}-cC-(ɓjSOZFpà!FS;eƺ|W t=r*Nk96a]١ؾkV%LLyL;8&]5IV@(-+Ho͕xT2 FzSI#6sķg7T|l:Ʊ9F3g(6fT3.ѸFuC0#9U}Vuœc%b QiRa{W Z8H(.֞tk"# eذNo@fYϓ"D:S9O4N$ic*k3YT6fct/K3L)@Fm{ijB;L/|ʎVb8M],¬QƯ:.?&0Ѻfdi߮=$1O*~(ILsbi5O==TYX$=!+^fґ+ge|e閵ٗrB"기Bjhୄ ڻsl{r<8‰8.R_"uL=Vi_k*9֭{pX]OݍI]p-!ڝkz%L[2O hX@(%]HC\GLQ`6'B !WlšS!kkջ ;AiH}lSz6>k`-CDa݈&$A:uEܗ{ 3 z-񁣏f$. O6z4U U*Ajݡ+Z9X.H(5|9 f(ĨW?Kw%2W/C'~Ld(=t߻d7:%"a%OTލ1 l֖(iı^qK]iFٶx]|\! QE|d{Os9 aơl"mc̊F LDw p++1|q@#Y&Lmޖu%KwǺ4n.T9ܗ.w#"ɜ4ނN/_vz`-kgUQEUTÛ]5*7 p91 Rf^ eAeQ{fY\_0xe|~sLCW-e($n$.5x1p3m잛“M۩æFvGL޸Fhf2 ysI߲ mǔqHhr(=nΟg!К<ە,{63VPnnzCaTB("6 Ka:x 5!yx2uFJ[e.TwIVg+j I;KSdhN}x pi;]PfЊ'}]O[0x4o]3zRv:w66$iV{9Np[f:ZfYUe/s zܱ|HiȽ_bSz']T$|e,eN|.G7ٱ1[FL5)مP5/ 6ȱ)eG̑Tk꼉 !ʇ>'=fĈ*2+5f9u)1Ӷě.G%y9}&&S^S~ 1퐎rL9㺘1ݾo&HApO٤r Y@N%hDA$W\b Iϥ[ݱٻ~r&2G9"_{ѡ /[)9H&r?YLbg gFtP_HZN‚ |Pj L4i(]oكtXmk5}-\ͳS!O:()^0eˉVVnXyW0i@vA1WZկ;YVk\yr΄? g`־Y=Qd9}1Pr$pk[ c\ueBl ai448>h9rAp/P]\Mr.9 CfFR SMKE< {ʷtsw} cHkb #؂ڦ5{:+$yTxd絾?֌>;7Z܎tab!NKiI!$WJϥqf',S`Yk߸y6 Qg&(&?r/﷮s;>k UK賘2BK>$2;*ô/r'2f#BB4[Hܽr%q.[r-e/{}pٯꤏxP-[>%'FU׆ZSo S\ʡHJ}i4M z=JiF' AoaaxDBO+a$=Ͻ+%@+I~8 QM _W+JV2́FwI5#/a8Lk?RdEn5>bjncMTӟ]ւ̋ ٟS"x2񱵗'`G(=DgМ]eO'H5jY]B9ԕՙ}7܇ 4.7V/sb"q ((=C){݃ 1=ph]׿e,$pf/d"u7KA$ͬT.bk;`"+ʪ -Zy^MhKPX~OvCK62F+I*NnlXy4S/@~WA[m"1s˃|zXΫO־15aėRX`h k#4{&ڍ:+'DO@Cȟ6X-O^P)Q (Bmg"7G\~(n16yP[rhiϊKq*]tnyМߍz-egy{P&ٯ4yG J7DZQ__Xl_ &+㔕WN8_ FgiyZDŽ䁆BŸhέ4'ePbD"Lˢia=`8H?}u$ęU:!`۰{_CJi(o $ψ̐#;ӲђL@H|4+qÃpm?9-3mU1YH:?|jfryhOto)JmЮ݈jU&{BM",@x}b.zU`|n׹"򾽬2Kͮ 4~n Rd*焴a! ' Tv/faFdmodl WJUҚb$!4Z,a<,#m m'@E+Ci8g ~c? q[SvOsjy+#E]f6dl>B5`DNVl&.D5.?ʼ8b} r :u;pA}>N[%{M -8KiS}zvi\a(M {ZI*$z?r'iIZTxx3 aʽsHt?x M+azm@/ 8 `~tӇWwvBo&N,R9cOLF갊0ם] Kx|+sذx'b{wNH͐!^˝̸Cc);r!#HW>3\־ {Rn-Ys8迳8F&rǟ)Ln>#5훁x% Id _-|[yt3zT]؄IگM±d<@^G+4Zl"p&q GԪ*~䥸K%]!7a/mU4Hnz練~OQoB9h .W$_8g/IbG-yB@\* 6p|S<ZgoX&~wksx%"=1C4}[Tp=Kr=fSNsA߃'pK??Su v4b! n};էyH" u/ޗ5E wm4pN!_>OU6yU1s3SN&SgȪ'a[/o,(QN㑥&S eE)E;Ȇ!AzVhFVT\^k*Uc侃!z>'ӦtLo`O9"Ϡk#5Hãi,"'ߙUyF/, Zv}5"(*% [KGY*ky  7ӴgG\D.%K# n+`%aVo 6~MG蕃b;;h(<: t0lTv;9#Gٰ֫6l^RfVAQRxXzጄ Ai̋p4d\z ȆG/9sBXf F'.7Z)Mp6.R=nz,b{/3: ȵz*.k0:y>W:Pj:kN!e%7b/!(~\exW ʶ HpS]P>0M X>y_FUəkP#" S㖼DśjC5ǙP[[F-zPa-B^VidB 2ݓҦ s(`k*L4mMZyJ=XY.p0M\|f6N?P9=JOcTU9Mϙ+8T@RyrbҿưJLi{vd?-&Ǯ>x& A2IM\)"OC!6 Yj-wԑ|q[!)nDZT32oxfC 4 f6~sKxC7!>Uu'?Ιؔ8MK;>!k.?\穱s9Ő{qFTk.㌶,<~(<(Z|ƳtQ1+-*֦7Ʃl:$Y9 XQT҆}ns5|ީi<pCi}}) _$$5SRvLA;-U0-z[-&ְuW4<٥,;0>Fa:dH".)$N'ma8'1cu< b$ZO^LY pFzBŖxM8WwAM2wJ; O=_^4#>RR:DDkDZc˶HewQT(=Q$iN=󄖡WCJqDc43ʂvO; ʈbǴiJ{sקQ^ @SxXs=k{T3H|$;lƦb"tE n+SgJB 5,kY۹Ry; }87)7sq4Psz`C䶂Q$+CȻ+l) vx9X_Te5Pg 3Qq40?0y >cjVJDG^! E-|8^'TF0 ukǴ56VD{ۆr.L+Q-_Ϝ`!>Ђ$i`][XvxT`ϡ6v,n$}ܨ_rg d0y%e:ڨ0+ ]"l+T+Tf]UەG1 Ef]t*;g?9b6 5<ęW=TxsG"r9vۙ"to|,/ z( >VH 7CiZRqR޾.{k,lvwJcxD+h+sjGG]8=R/#8x{qʩ֩cj̛2 @cv!87GHIIK3v ۈ~X;ά%y s%wg"z/_ӧduB;2t[Oe%^E9 hl<`N `AOKO- +>fyv[7bQwU1^lccȼ%K|kyzVT$J20V~s OkpgOg&y.NIPƹvm}\lyYR*=0C"!$x7 ء~h-;ݕ zzޡ(Valk-[ :H=; "Sr3[܄yF:wo3ԳR]Df&_ >i`1AG}y&hy* `ɕe]Ie:;x Dȏr) nΨPkꥀUUJ)Gkj! 6}3~TpלbCOizwBI _1j [ |0wm~covLj9_;6\y0D6 _V $ąY,0XZh;p+x>X&pZ&q^mn_1u1qcKl:TMIWK3dk[Q!B%}r8 }vM!dDr`y@;'| fKVwpX̚ȍ%rpn*R_ BÀkYڜS(Ss-+Ke-/aTHFUrܘ._LOY)`7Ϯ16+I(`ԍj)P_TfeQYn]l ODIokg M"Z"rdY*D:P&y jDwvAYw }`ԕ][w Z oJLH'|;kR)x)ZقZ6ɂȵS4sݏksgCM2u)ol1Ak(+aXlSgO *Lʖ3 `YwPF4Ν3>12?x/<0TEđ:Ivj`# ]"t%)\ZK jċQ ܀.b[U#nN+K5+{39_>X(ԎEpZ)a gLљEJd NUٝݧr ADRgkUQ(Iis^&|dۆC9ؓ{0y'#-[%#Ќ ӺbK@NA#MM*O"l2UE8H/dKE܋\c0`^nmc% ͩHwpR@15Ɠ> K.w'צ 9jUA^xa' a̳]g֘p$^̅kΩ퓸*6M:{A$q!pYqLN7TgI,e*Dloe]V&f>!iv/M6e"J̎&,"X J6`Xbp [E}RPsfE}zy9jih<:'&{/ͷ脁++2/.ɉŨ@֣Yr%[Sճ6&Pm%6*,q[afl"Ztv[y8=Q>"%fQZMEȚxȲ҂-YWEܸHIT`'7d[ M8$A2*Ws8!wbuCv) otýahWӎٹQ W^10-N'nS+ VWL jkw+=?IWP"J*M$tRC>F.A/Ր1iTt":%>Jځ܍ u׌lRmZ9GoMH)Qׄ JS\-mr5<S9r.gk9o;sH ~YdiBծ}rBD@!غo^qTDB12)G^tt"VfO73S2ɶU~Ǟ+랏W1`pϻbN7?+ɵ2+t8XF8Io__zIf} ʧ-&~> 9W(G㑌@-\Y@å $Hkw ~vh\7dy?A[jhGmi˃ ស1ę[-,h*w$.jPTvl}I\gi'"z˃o 0? Ml廥S:; 0v$t~A=sEY' ){6 p L_7ąxT?M{8Vvύ"*?6RGx~ף4 .J!f:;ǂkOĻ͔ l,w qK`h˜IDy*BCjࣴ pWǛ3h~W3$M) u@ݘJ-'nY|?F'ۊ %ggTNYpBBQvˬY^E厮'=@sV dhC7Ad.o2W w-`X",It!"=3E-ˍfAY_S:uWa)uФF}nyg\Cph02J0O) 9(`IH04,"r0paA 5gw$ jF 7 ټBBDukG8NkBHSlSpQ)xE rȷ~iӡ=YkXQcʦD zy%vM%F}P#&K/WbJ"/ߎ{2m @FGhL>zqz5ئ?%g.S#6/Ur1~c޳ڍxͬ4FdfXDtP:S+QTp[ fQ$/V #G[[ы.BQ JI?.-ӆ oa_TNBDF\TAoL+NZ=u|ԱNqɫFN-%VrPɇAM<~B"+|7E2҇w Rk\~B^Rx,ģȑpPd*еQs@EZ}Ӭit3nr8@b_۳ SVeZN~Mg捃T5߹ +T;[/՚xF!pR %1 7nR[ʹH9CE!8Սm:Y+v[Za'XYA:Pq0<+e昉.T,&N$>uhcn9 hm]~Z!:Ӷ |V>~ ~ր"6fJ70$"NH$r9d92̾Nbev WoAҬJ'è5tD<5fp1*ßY˼4a gx#tL+uEtA"` 1֛ m'@nD@; E9H6c#^c ]=J rqHDfH()xX IgaȎIHŷIۖ:˥Яbf#XID2BYizC@Sԓ7lFaIC&owZct]!QHn,ŚnY%Q-ED99"H LUaJ̲W9n 'Eψ%?Rܠ) |[Xl@gU`l[<ܭG |V\ݟiTWV6k_ endstream endobj 1175 0 obj << /Length1 1144 /Length2 1528 /Length3 0 /Length 2250 /Filter /FlateDecode >> stream xuSyQa"AXHx\dDg"B+1+|&WY#]AĆ#t rt&TA>Z4s:¢gBvP#X4L,SB ]3i̜!>@͝[q?,fδ6Ptw'alPXp+c62@gH4Lx`Ѹp;џb B;E`B !@5|SGa5 V ku^(o>H0fn_T06x)"o1WB;Blľ  îWALd3Ep?5wO-47˝dq\xӽsiiWsYw! 10uL 2)5,fμ87 `px.1"`P @7C0sN0aB0 Q̯4xf.=eςAp+P/AIg'ϐc0nYXm,Zn+t^fD6r)m`9o9L{c" j湥i0=gCT~Ф5EkcϝWFWO;T&#񺓛Qz|%1͏(u#%[҅S.x^Ѡ[ꨂJvU}E*&6޼d(۴dzt̬]ӣ뫻5S^ّX}Dkm60dx0t~zli^Kɚv󶞆{k'֩#%ILf=?x$6wjVurhu(237k<]iu4Mтָ'" ^&?S^PZo#fn=q-ޞ'IS 6Ɖg'v5+:+E-%F#/7삯O$1w_H\W8PAݓҨ@BT9>2hZJ?U7[qf*L&\꺪#oXl-Aih\Fѹw)}ʭDءx5{b 2+: M%w:~uxe[ؤ=j*/ާ z:V]q[e"Y)sa@&YDtd[~Lwp[:eMY1uX|ƹڪ~9qluL,a$+o[{$mr>[4|x~p7>Qi\XZT< 0\8e@<2}llDUޭ\Q=D-)p#1ve9k|U\3)J)}AؾގWuЉ<گ4kli3[}!FW7=81&A[%E R9etI犓%?Hd)g֍{}:drވ>~s@ҞhReQ? {#nq69WxKKԇn7r겜p=*VmI.xu$ #c|?M>ՙe:Y`{Yt2C eͺiۍ{6i8U捞5 K֭^]%+ ڍ#VE\~E"Pk~%lLs+ęyoj UVHF`iͶ8QO 6kKZ$M sSC] ąhv~B1Ja:`:>LcKRa-4&w([nR(UK}5*a㧬'R4>o R:`4V̷(2語rnxjo \s͓T҅ اPPhy`#qRãvEjA fR[SiNuC%eNy՝թsG9޷h{cdE>!Gm,)hi|-M7Q21dՈDZêhEm 쩒\h endstream endobj 1177 0 obj << /Length1 1626 /Length2 12161 /Length3 0 /Length 12982 /Filter /FlateDecode >> stream xڭveT.]wn޸Ӹ;ww  8 3gֹs̝WT=jJR%UFS{c`ikbo`#(4|9))ŜF K{;q#h <<<1{'Ks F]+-==ÿ4=it4P}|mlv@U ,m1E%-i):@ ht2(X,Mv@Z֜>r8@ˏ0 /dk t;ف>fXڙظCof7 'G2%{gQUI\8AFj;[~f&.#͇ddi A2L-l<>j$sp0FN6@g4οl'74ath>-,Ɣ`GY_&s}&|mݵ|F^]KL#TK<Xc|i9z|}wT 's {U]+My7F!# T;GgdQ@/‹qnW4J+s"`fX$F}w/,-W.gœb}Wd: _B"fl1/PYz./c<΄f7*Ƶw pk sCO[1;0UXMTp{@/!::O Izq7L} '4RY S-@2ݟ/ܡF߆/*ouk%77obhlۇ!8o+:2.O_DY;˪4>h%--~&|Eʊ*5Q]'?ۮK_yӁu:-aG'@ۄ?iy}GtiUَ@iyjN.#{ZRHegP[h(%A^yZ +9=3*[#6ƒ1z'5᫨ )vx"i Juu-AY?khӪL GZsceNo"kU1Od`NT3}3x8V!V>,,\Y}ح20ʃ,>H{ Yuspryv-UDlb^<a]^\aOEh{OM/U<&a(Hª_nt(ޣx'.O/0r6FX4.荃M_ARq dh4Bq~PQ,f5]J;Tars!%[}a`Xp 6a+sHv™X~9:m&)"o痢;lT;*$w-gy^.OMAp.ӓ_)?.?f"㾠fq|qHP@X=)}{`>jatf/zCQ \F;kn $=ϩe^.BE2riĸM\#PV/BաfUVcujh h,ed4yHjS 愛ӋPHj%6;Mغ@%oE<Wx7D9cz2 bn?5r)(9?.Oη{so ֫;DpQL&;!zF Cf 'r+^5),j?3@nZ>*7~C~]&uL'Дbd ^@7{޼m.:Wl S)/=Hr]l&]#xbMYkC\/|scT݈h;}\o0~j4,σYX!()IhS4k+Ɉo?rsU%6N3JʶBmah;Hd)܃w~Dq柇,>ӰhG^lޱDw[`Azo!Gi{g^̪նW c7z**e~A Ýn}f~R Fvh 3G<?UA=M֧]SJqo? ~t tg!hؚ; EL-Z"^ TrNt$'m8E۵b=v02=c-M%_!$`;Xyͬ-~3O>qp0*Yst6++TiMثn^G:+nR*gm ~Zɰع8hȶ bb!Ezj1uh5|RVGm٤L:Gbbڑo$Kmh BB4/Xfshu%=_-<OntgUc2YWմGox ]=<%P3ЭV Ad4`H^dDdz0D(ZcnN[o]x1γKMڷ~Lbħ- w^%4j_7MaزcաK}O7 oD9=x䍹;~ʦ'̳V"FRx"_J",V'-f)2 -M4B$]̗31-6蝥 @9Uvpsn@L7.&NQL"L/܋ͧ4yfj3+axX0tt$\~x9)tkrAx &cލ"wcw׬;_~>|$s mF{g=?`H#~%lE~#]ɰx Zש^,(jH"5.~ӑIc/ˋy"}B!*`ZdnZaKleh 1qm]\A 9Ja]Pa'_~Q]A8OiP A:UU΃X&3gX7ݰpG3k6-(C.̝vmX,/g[Fʬ)j{ZdΒ̢'iUg6?XE Qg~A9+aK =e/sըi\[^+E%GMo >m_z ,Hi6<5/gt]4YPA> 6p|./pcb 38{y0 aA"xdg,NpE f!}nSqhOb"BOUa]`o=hpA@|jϒ9cguޚ9}@uja=xjs}hA^PBnl6W?%D{#䢆ps3 -L8bp5Q6l* ?vEe&2q욡S‰b6XF(iW8լl4-kk8,:Z2k[ndT2N$r2P PxI$4ТZ8*^X)J=bw⇛5 IS L%r×R-VH{9lAT,}ΙpO#~3)?l Ǎ}j6ݽ[9:<עI0 errȢzHF-Ek armp rpeUwH?%Dg %q& I1d/-,x˕MSŨ'pN=`jDD͒ [9_duk} z5c 9r-ԓ ˂-6&\ٔϴ{(GHO_n-u &|y=Ve|HKTLJ7xj?"aµJ>ti᪩C$hQ&˦p3Lj@-\JA5SQɌf|Ci-ߋkws3Rfk ``z3+cy6.ii|_۪N& ]NG| !XpSdcM\cS\C9w:rg ,WIZ#4?srF<r/Uٯfxw.Eֺg)Oq"ebdv+CP?,5I ]|ypTb@uOFߵߋƀù5Y+~sbCH%/JɟYD?u'zݛ#>w  jՀr+w5iJUu#"5%ߎOR;r0w.W+wf I4!k+vqO:1E]%8m ]Lo#Y\޶pXяUv,FJ>{,\vǣFnlr':)- &f"G( #kDh5DgV]_t+lrF"DF#o~D7JVh$nb )}ZyR- <MEO>hH3g❫~{QsswB܀"B^o?nji:f^"/:R \۶gѥ\c.Lfu՚Etl#>֢ѽZo`|+ػIV\[kXz|b/WP3CBm bK("W+C ٹM_O 92=wZ6=t~ %Y1 y>5\ !SA"2|qu^ qRX{ŌB&+kel!3=;4g?Ti#^BP9:ziV,#yzއJgPaI"-RM3Uqa/}! ı:)ZKl78~%fX[|Ic15WM(kn^V }Wec'=Û(,7yRlM'?5UKU\;ق( oi4ksn~7&JA쒐yWxQ1H+d*x,ttx7V/Vtd0P+c}VuB6ƢοoU6qmG=&:V(K]켮޺% #_=/U:d`K ONe͔⿵VMiE1tm|ܦ4ZT %hwan(-YAWmYh (]"gG1p ͊և`|D䀪JCؑ?ȳyzmDW̾(2"F{ #x20,_YPO,^ĞݸLw~K\gfKb}LdG+ᐑrO_?A/%A9e$j\10A_V%\QWE"g#0*>xv_K&Tg_IZ ۟f6H-tw޾hv(h[ Jd1NOM(j?'ɵ~5D}=7 @lkSQtXgX2IлnK`g ~"T/N5!q'ILr5 ӢpzT,@d˔΢JnsJ><(dYfe 7J`Í C֥+(:r!po$ ` .LSMT 6j!_σ/\Z^W!q֑I_!>|q N zb 8izfNs.P-"#oS88ak{ZM#WwCȝc.SТ&3\*fY.8$k+vxɞ7Lp~mkJ$͵KRcx$_34i+L؎SsHm1?>]bNW-n:^Şfs#1O`5U4D$[(v%jcZPS1,LWBYJ"(aX˹YohXF D@1N|kM•X[k(2pȱ—3h>L] {qb|7.?^f}R/,^/(g wwCj;烣*9D*b݄gY9'* .k}A?^AhWy.V2B87lAIyz Qצ၅GK&{Ϻ/,Qv^GZY[=,0P'`2zkAFN~iA^A38 .vVڱҠs qiJGW^R~^o.2Gֹ;|+o dxG7B!ҶmDAHU~gFh08 )}o}ej,lox *M/X,6qKHEbCH*w"`@}ނzf%w!fG,F|~blwe1?.e&(z051c"}.`:Zm)}ϋ#"08 >c9L/K}Йr[C%5ssrGb"'W럺TOe'R6nxLdhh9@4A9d!R@yz$csx?ڽ| 1T8*|v' jF"h|(9k"|0P$"Yw;)ùsrpLY# P]& ͏3}{!<1;E!"U6: JUSwt8;!|Nl;.|Əm\Ef#ԼZ+`HM]}l=:|p*fU_2db025|Ii/C.߮:I{s0w?I&2*hUB+^&b_R}jAEfަh,Ļ{J]M y;Ұ38E-Li">*Qh^M&o>U UbL||IԨLZ,'FDњ(4l\S&ד\"R&ޡyJ8*)$,._/?q5n ,Gph~5|<T҂NF v {/8ʆqlZ,n@th^ds%z\Xo_)o t%De2EK W%'zxRypڣrTc7JElA%UւLYXnƒ/F_ƔF dCÉ8L>UpFTPKw۠USl_m>rcn7CPT_$1/|$]E '=tXa0=_QXaROʈđ̭WwU9D Cj/-;3:ݟJ{9CnBk',9˛:C"H P91$BIu۫/z"fn{} oTHc^Š+!r<`Pww0q)ZM{M ~~e,@̐K~rSzMvUR/mELmo+kA]@tl7F E|lcG\g0ҼG};d9$L=)3 -5$] /i7wkM#s "ſrC2 !?ge_I.Q߄#i: ɖ!nSW8CjzC~dr)n'NUO? \ؤrbT5({\yݐ22nmD ywsx_+.O$JtPM+5y |`,"A,^1$^bSBR7&S׌H${&`S休 ,wdȂ5fIW0˷Is@*[K1Rt> stream xڬct]%\ضmm۶m;FfUl}q?5Ƶ\{MFB'dbgd*ngLD 8)q)`DM vΦ S1Kp[8(Ք5hhhS jz:m\MmLmB_;-Lf@kSRB^ ajkhh Pt1dƦNT3;Gc;[?9rMLݍMQMmNN@'8.&$WnfZSsrv2v;FUwvUZSҿtaj NgSwbLNֆcw+ 'f@ p457t46ur gzC{{ky?r:;Z21i79Y501[nb?uj?3C7 C;[k,ߐ;Hoz/>WhqkkyCd m @Ϣ6t=O^Z E/5ā&@gc ߞKfkbh 5 cbd/:U ?$[ejk_+K׿g,*gUjL;@M_@Ly3tv~_?OFQq65;m!Gm-UvmΘ'2=+ù+odJ@H}Yjq]_z.W{]} gҩǡ4>LkT<B-424ewM))땾Cdqz'q-G'}G5NkBnZ_tzFtH14>:2{KCcrJaxd TݦQBHƔqB`%r(l'v \OK8!2*е,uʾ~ϝn ,NR̶N)(9`"ȉ7ڀ#@&Ə%X?^'Xه[j`CΙ".[/e(Y#ԫrk>/hV3pe5(n:72W0-fBh<;=bl G2{M#Z=e`c}YS>ꆛiDVfw fF'gX1] R'B#bQAOk5a' SFL0K<9l(z66t5C,AHq;=^V8ћS\q | WOgg~{v Js@W"RMÃ?!^ɶ<l5,H56wi`"$^W%dFM+uF{*|{ġ?c>f8R\%\/BJV/@BrT4 g&E&xEH1Oi5SI/gjuw-%c':Pyw\}k6|1X56= Rş%}lJlhs w-zDT7)F#n0l.sae$`O]+i%@}{ccjhb#ʕЍLRwaI T DwV}4O R,isWiaeyxGS4E^9?հkv/ ^.kF׹EnF1mFŢ<+Sypa JLk;uD1@؃*kї3vC~c$MrfLBN4͑ zDmH2o0m+Q`M~659I&+$J?sGw8)t ћ(Mf)I0dQ_p&G7a`z %s^eL(v8oL;R -+ǕGTO>ٞU8;tP.Zɠ_h?1KyPr-nІG8br= 8)_6#EJ4<< ADOe:}8jnvZ 3kIV0>4}ΪߦyP$^ C\y+܇dHZп2qIѭ}:K.8˲aƎ퓢 ŌydnqRΰg~_E&ϼ 6ZksQb.4@60ݚ}իQUҴǣmз@9zīeG,`~D iUOmdv!3t}[C1+" С o;1A.Bfn,#LhPc˜WI;ceK=H-]a.{k&MJ z[5Xap`Y->t+$;o(OD(>bMHٲ^ CS }CSߩ'Xdxsh>ꂾ;>}a5:z:Wɷw;B}r6`gq²C~~~7@Է$r/j pbÑa!vy0Zډv>pكJ_bZIJ1[h,ue(90sL&4ݼϚ\`oj LX.C eܯ3C`גaavT4rz@2a!2*IrǬϟES^&Ko}~GًjfS B QPSOQ0":b\sT\VMRGih Lyo)yx[o3 +(ƞ漏Wx#?Mܚc_pGb"VGf(]}E>\VV~}0 ;_` 03"%i$( aɌTE1?^;c#Ш VcX媕 $-vumZHz섍yjH'x FOYkF@Wwwu?/Λg\nhjL[U9WYXUwZm.Aټ=?h?(]ZԴ56!'%Z|ï%Ӽ!!M8@AH*.*i+/,hWľ_V;v#jjʶ)C2䅓נ`gOQ-'5qL+,aXiYUPT% kL&"! u{)ؖoϸoӊ_~z/]>}UO cf (:MT k}O'>˽нgYŸ(ce:֘F ΂i&7t@aM!"Voyzn$2j5.SRԕm|^I܎d+ZLLTkbʎA7ЋG1ᴁ$-a 46-!A4񃦥=T']WG6i(s_2S<>5m\!b?_ Rիo3٭g"*,BRmrWV֊ptk>7h"] 圻}܅ X#9|CH{2;Z4=O(Y[+9?Q(]c~H}>%!sn?ev [5v! xTB^Fjl Uw,xF}fZ'Gp?LNrY Ƚ) r2j t4#F{rxt?s:L#]*vB!Ǥ3Q/"u)Y.P}A(F{)$*e2 E5h\Vd V߿hthgy ={EIf͍k D?Boގ%P,4hqxq=/ihΜ1IfJljY&(١Hݰ4gyې`ᬄ}U늷M"\bp٩mϼحJ lzs~bZ|kuN N^Ǘۓs5_I!z̉!cuYlrfcL&r&m= /g =@!fJGt0+A\ #äH>G,zjj0(X,'n%9j(9ݕAw'Y nCaltyi<<[$gvP ZK(v"_&1ҋn6y>^>j,g I^Q._QH Ilq՘^Yg&lɦELד^/h9isV M0.Xf( $O mQЕQ\+_XI22JHdf_ XaE eAw6/2 U6,.vj 0 i:";\|!P{6/ w(H`s T?jмpɳ$@Xnᛎ0{uWT[r5: {7;)Ae0YoE֢dD4< 5zB؆齱\~!L[zU3X]FY@DgFK>§@a@| IAnE*{VzjjyfQ9=28iq!+پ'sC,Zύ,OtY&uz]q1į>c7<{zku&b[ SV3@lwu]2#{NsPW;0q#;j~Vhut:ffe⾤2HAѠ-m.X!TFF(uI)aĦC-nSE#ryO&!5'߅H͸^į`zL 41.JRw?J]ml:"Q)i#!r4T6Ȫ`Ԝ<29:W7Aä۟Œr_tdTg'A6r:8x$NrJ@<%*FJ\p`#} LՎeK!/lNV{X [thQ?(cc'Ċ՟IÄL 퐙ZfkL̎y>k珩!?" M`%}",DZXto: :lټ&A {G?՗6FfJ=<֭ꑽTCHxXkšӫږSȺ`{«"(:)pP c>ߘ2P𰤅棑% `FvC^jte~hx~Oraa:KD:e6Ԗf,!cu^Ug ؞|7.ӍE?UpB@@iQg 0E_UPRvp|ډ49~t+w09@A+&ZV[6,LTRuy( 2UQqe-չsS҉Q;P~v(NBS}Vns&D?XvKo!'*-"W#ikN@sӭ-  ΉJ@a6]67p&jљgil2Z&o;< s+:ݬeGڀ$| ($*Rvl2ghJ;q(gy>mΫBTVu;bRa钵f9"/l`@a_y;wh/ńX2A.U~lE#N։Es_&E9hv7?[&m'A`C"^&;=v aLgpC &WoEyWDto#]ey4:_"Lp}dwu wsuP! (r}~ GOd(H+ʹ+}]ΑEU^?BUWWaT 'qlQAR`9G"{,/w{/ "v18z[ +4=VH㓺s%<`K}KzL|ryy2[#r3=C 1=TSp8گ<.zfBt^/!+uj.u9eU|LV5vk\}NS<2ra*Ha[ì>=I%KcLn];MچB>O(jKx9ela@)sx}9'-Eu;m$y۫ÂzªJ<)~' 筱D5>`,d[+ߞ^5 q8|~Ⲋu"rlY\U<{-:v_+Z5m F(2Hw?W!VJI:a0ă|}2YIH4*UŰq&ߔc ˰9Q&][U+}Oc7Uv sZ"?Kt=džS2HOw2ay`Qa8s|V `ؒIqbcNS'fHhpF4Ïguxb']TlCNI1xvq Ocg0 q%CL]+8fG13l-_4mDeW,o]&| g yK!i|:H[vT0wԯxs6iߺ 8\6)z]B,.lz1&6|^%b<x"3;Hn?Ipm'tsr)^fKR_H/ܐ6 +(v"^] ǯk'UlԚ;Xf抈DnZf44[>mJXu$h(ѫ:cSAiDi%}%rKI\vdڂތg(ՐMq#eKa猺:ikK d1GهSs?@P2Rd\kH\_V@ංQݱE7o'ēxnjU4Nd.&IȘ'Y%uRcK=oYThk!u4.b2׾&MqMr%BDߝ[p_!>(AT^&$ս-Ks8wg^I( :&^@hDR_ڸG6;V҈/XiU1&t_9 ޏ@8Ʈup*8b5p=nвn\Ju:3gNL$iށ`q;J($e7.ҠI8K%CriԻ00,zk3uʴ0++$,”:L䚆tLwwHh !_rOwm$4Dngb*:t"q9LabkcV& 2U[\qs[-]@4;uoү>?J7tVYt ՓT pqe5՜6q10K{>d5Tp߁>%BOyVAI!ªfKAukuvV꯵E\~,>zz+;;ZVgŰO*:ߡMu1]6kWURL"e6xfXܑhda\|;rjg*_ruk9Gu^_g\kIiX@YIN:i8 N2 ?[c[M(5'ڞDdO!"k obS7[roa)"3'~ J;qZx埣,g<~D=A`No0M; C fS_jp6ܭ.V3n?)#=w~ T&MCs% ΚcwЮøۓ fɋfKȡ%SWR6+gW+!5O)3𧕀6Sf eOQGiC}XR?#_chҦ=>y(Aر)#RV)͡ǠCbh+Mp,jk j1Ճ hiKoٽe()(5WoVf4DŽwO(z 4z!3:qmE6D4 OsUKpI C#4m*XJqy.}sTs&He$@FH+?ݥl]@ȩr_(|}Tޞs Y=4 Ncxɩ.D~F|}l{i_3PqwuIv)v=!oĵZ:'2+ `R_cf-D sGY.F at6p*xC k:ևd)Fp}PlU͂ChF ~ς/sq(c`y^>)m utxy(3:Al*n߄'ϡ6hr9w!=QL1ڧzA@+M=م V_Peg Mp?'Ruix2-g/8*E?rdz@0a,?T;YǷ5ȤyuowdG!E+7'01'>>gJrT(ד>x']lC.Q&I\D6~ӵ 8i#Fnl 0爵`m^l[^ q,VY\y.e#nSC X@hsa~iFĠQP |OfM,\N# \5$(<뮦 4.W|g|N:x:`묝'?Kcg4~`-;<&Ҿ7{W|d㏳'xqEN?-3tWt⭃"]N O@ ƴi"Ârv<HIϋ&XySӋY;T=ӃQP7IK w|8ԿH$Muo@D^r0,DZdU4%$f7c$)wxc5 EXgZfhh}+\w{@x0N+=}2Ϲg>)[٪ zlX 뷉<GG(yٛ(L_絋IS-8Y VJYJZ`b# 7v!Z۱-O2@S FB^vyxI(Gҫ$uվ88PI.dO=ncY{; T'FU~~?=-]-b}B70h#mAMOqۅ%^Vc-EYuD/.9Y҈s\n;JɄd/}j` V-B-ZmL.0t{h\ z< +q3uIkf'@s=|ȨC!0V @^}.#㋛hAeXR[%#9ڗ U4UqJo5ؖEsH)hƹzWez`qzR/,PB%pCXq(g69U)67˴q(݄'pEI9T.iE09KZ ,4k$6*shGNmtRxIᡎxyhXdc[&dti=n5:!f^ z R6㉻*EPRi1&/RB [9SC p1TO8:1%I9U9I@'<%e9ҕ<)iLA}K[j_ZTw,ìSݞ H I ޱQ/MV7 Ց;_(-U)Z4XH5 &"l[UNbek6gZ0-({G5-N?P-JN9]>vs1J8I@qPBϠ,gq¥CuuRk?ۓ<".t/0*D /Ug!A&_|^*&]\C @&{d~`")Z8c5AαɵxlyT0m%\@CUKP-=I&I` ?'Q%827'K -U9,`yƃ TIDZ RF-&d__J}۫Q 6LJo7ˑEW#Q -2 -D0p5.b>[!샡gAZ)5Ev$e۴?l%Oyhݣ8_RU=Of *(B{,>2*~(cѧm]>H G+Erjś!pb[S&=Bѩe@E6^I.1FetL,]gy|y `:b:1 :+MWfkXc5lJ'!CB(^DcYAkH).Q]f 0JXbA.5.8GCSG;C'n 7>ʛYFYܬ]X=A*髲#9J<_PM5,**9S춹U]B<\z{Ad#-nځň50{]!j$g黁dAWJ'.G#Ң |"q2vziϓNu΀ 2 }&A,6/ݒN Q:A#chJy<ϯBiee!CWLH#aŷ"|!#;oD oȼsGNεX,*B֢ MetJlVHF/.Lg0="H9c !l{kS16sK\T4YRؗ*Y^$utJK]XN^Q^bœ4yty ߔ%2Yӛў/ geAV/"_}y ybLgk>':H5t\xքV.ģ9TE׿]BKre`}stТjQ}}!DFWWt&0Շxe49H^rq`D?;%OCe'D}/ V)]`#$Jr#i&qǶjhњ+)ekLP7a%t>8g`)XYAi$G\4j(% I ]s9CZu?yLûCD4ԭaRlXvQ#NIT. ejq!;(+>/? [jT< m!6vшeq>.nK? $&S[ac6t1ȣ52 rk 3ͱr|*q>݀!57L ː|P47s&ͣ&9y5zأk{Q􍺟.cG {(dCF7.$+giTw^5߮I"& HqY>pa>W^G0NO"' ^ m(!Oc=(-f&Aa (gRr/Pb&mK1no`ßi0#ͮ-C[[ĽSJ)gM׺mg)%%{EuKF0RTMpɥ#^-4H\)@!&ᤲŰY_~~Y, կ+<1V[+6D GWיڛ'CX{v/2\iwl<{'<Y[,:swp\T!qwbQwJz 5~ԝ 5G7+t'#~xwS7SC 7n_VȎrjU_52SwtO)'ۚ];(TxYXI'81ꀢ3`̻@"]l 0rI&ܜ"O%{‹17:C4dۭ|~l&v/٪ A`$$Rk}HPcEH |%(a =\~ w endstream endobj 1181 0 obj << /Length1 1644 /Length2 10609 /Length3 0 /Length 11459 /Filter /FlateDecode >> stream xڭweT]%!`ݵiq' ww .%NA{g}3g>KvZiޫi2,@2N`(3; @UQʼn_YdxsH̡N`)s(H @;??? @ bkmik322 `; C_)5A u$UUdt*YbPsp(Z z _h4WW.qW9}uyZ !&h uX=:ln ڭIz{%SsrZBרjR2jc8Y:Y-ۂ]P'o, h q0zJq' 7W[epY@4_u!9B]AV,h1-mhgEl`gO k@'BcUq'-'k<2n*掯x]2`(.suAJB&5m8Uf~.>62 -`eڷ`  z Ӳ_ *^%V]ie-i}2k:);\^g<]e'JH8y|y|쯯55~.Clue? [:& |4-\\^%g^ Dd)b%# ZK34!e? )i*v_aX8%xy?҃3,ԏ7m;/~0I Fڱn΄I#T; /@*@\;[xFڂcڤ>  v_"~'a̎G4'O9z 2si|F|pu\l֭~Mgɍ6n=픓EvMl"^,< =Ř䴖I]ǒ I8[K_ 7Љ ,d%tuyEiEF'ŚCQ`e1 3Dzqbӷ c8C~("ш/Q>iW97 YKS\ų=wr194׾)&݆]_1EͦwPNaJQETrR .X 662F4ڮ lų,H;ߥu<ev>n[a֔՚PZ nMhhU;/J.be'@qrYN\rzn+$SGIK?[diHO#e}N)&5)ҩޤ@Rey>RэTe쮒RU )eIUq;b9zֹ`ݹ{~qèaIa^Aⴅjd懲!sUVZjN>2VK}?s=mvbĽ׬EzQEN ͱ^vz"U$*هJF$-R?¯vrV TZ%Χ|1Q0c/g ;٩6QW7>nH=q*M51bW=uE/'T̀z674/wcѫƇ,|,}[̘MY~[U@=E_iU=YTš#$!{D6 KOʉǾ~W7iG4CD9S9/`q8TX~C[q*X"(oNS3V DmS6W&Q1/:"@r_I4x%beIbTGlPў )4q~Iicޢ2M977+?@eo4yY.R?$ڏ&=լC3Yt.rBZԲR-N%U>հ_pӊx6zs9yԉxdg*u]kQu$T+Hn&Yf#ŧyqQ!{AKF B /<]>s􁖭7L dW$-NtdM*pVs)@V}$ޜ4TIMTgҒZu4]KJB&x(k:c_">5LdHE>AGNu{Wi_\b9Qz4鸷0xy2it+LIИ;LT1)DnM~ #COao%8Gl0Q}bTmZ<(iy{uc1Tތ;@m.4ߔreFf9bԩh 6bo}g5X.*y*IכtY?Uhn"Gs*AI{|r"\ G\l;yi˚yowarR#tw^Nla& n;$9(7?V30k 769.A6zKL3`$;++[C#\'6FC7UcfG*GQ'k퍛Jgb+DDg2uBq(@`W>m B㖿 UFF=hFAC 7?7E_f x*pNCy[tSFj}ir @O\ؽ}?'|]|E*ۘ0\Pj;xkSFMTrI۵qa&d`G=z ‚L> ˻Fz1YOQN ͕&u>7?$hA}C"a7̐,ʱ&$H1$ak^`X#R,~1pN(ŪÝ*+kǓ=c)tHa\_ܢ|{!ԸIE-HANwZ(8h)YB^2|b j%<=$"vm=Hq D͓>jxi.[MƧ:(H+oƾd C9l s`ƦXGT/*^ }R;a+ʕՑ@Q&JVȨ84KYӓ/1C*5?{휜5^R !(Q" ZfL`ag??Jv6\\#\M2:"`Sμ0(R3+قt?'NZ/*nG!xed o{<+47 #ҽVOMAh9eZHr=b]@'Ic7H rl;]*D2j6 AMvNz}fT:pElџg0 $k)s67ن%7 2.znG]JV8^bg;Xg͵"ɗp7g.+W p+{瓗ٙ9x1+w cO&) ϜЌo}yýC Z>[$^{y)"ߤ3St*x56P.qж0KB`2Q'^"axz|A^wvΟ_)W` Ʉ5{غXɩUrÜ ӽwK&QiкS(ĕ4G'.3xOᑴؽj[ z6Ae0=ݔN%Ņ(~ۂe;~m.sAk6uql`W?A]%bpGEF Cx:ldwa`ҋeD&3)|U0i~=vͳ-ʹã6p*l~YPq0<{BTLUk/qvXr ؇&&3Bb$`7I?Q܁JzΩlrQb/Rx[W;gLH(,a:d)N"YJΤy pfXE?ɜ폒`l^̗SeT- ˦D8|Q&H0Fn'XCv0SoK< PI9,<[OC}u(zUat@ۢ]¤YF+QCb_wD+ B~|XswxѹW4\jQq Š S !GJeF wu|>zt5Ḑ.xP:H]GďVnMSMF5v㷳xߦdJ'g\Qu薰˨&ݯDHg_ v'[+g-~^!7 ̆:uIR/Qi1]GI_m’~i?KK5S}t@ "aw0=dp,N1嘙,\l +y(,t^y) 'f`bin\0bp74[x%iV ~ȹF)0[Tj"Ҕ6$D峘5g@Ie #*j(~4f6VHmqi ς[A51>:fVhky[m(5lM-io-qA{hk2K\ԄccvǛwb ^n7ZLC)-خ5-P@M9,F=X쐷_'Pp>_Tt|hdQC^6>"&dkQSyW$+cD'[]~U>.`gӟqY*D;#g0G_Yw#kGՔ¢_M/uL<2KDwp~`µ>ɬء wa&RX]Q h-|q(bHLF107k0~M`c,0c<1'W4{?PW':+rBƈu`#sk~R^"36  =/č ی݋,U*)a^CBћK?mh\sPBˢV}Vf{ߵZ'´UYƟ8-:^;0,p򜟃t'\/:{B0S,VV:&OT-n BmCX *1OxM"sWX0O'lI?;i/۞zьQn&*msRV#!C=oX*=R}?%CV lim/T^COT3x@H1#CnjܶݬCt?M^s/ߔF2:UtY.lGĐȞ'c[3ֲLh&{@ub9P@뗘Q_]xynioZ|y3JL҅}OҀ| n`Y!(+^j+GYm5]0䠥m1]_QLA@hQ`j+8ggttmW!D{<`f },^Jd509TMHˑ>z+zY)i&5Mˣ|@'RuȫtSF5iy̅,-} Z ɢ{ߜ^\=]h3bzp?)Cz+ )9Tmn|J'fPڿ $ 8d|z?\W 5ΦvQDŨgJ˺P-(mSuWfT |(A=huI!P7 7J~kt9fqZ0]Q$\0]o$\ rqF`)m? =d5hϿ=O#^d-dz9La59Jl+&+p)+];-QBoeTӀ#O#_W70%ieD<\ Ȳp%,?ƦOT)iTE8. ~W`90A*OƏ iJ= ut$Nף˕q=v 6˛ ]uW7U68ʦ`@GDi ;rn-yv'9 mjf(?REFFL {R>EHa?+ZG_ ']7j.ٸk 4ذbF 26sl)f8~aZhhؒ 2]SoS*888߃$W6/gr)}.|6J0|$O>ɮ8^4_ܙsbUq0')ʮgoDX(=rDRk7"I>K ,4OqgDx'N96'۩nghyn k۴FMYc.u:\ٺҕֳ솦~F8Wo2e P$lQO Uth(:UApB(|=~Q#:|`DrǦ)Xa#,ih:k޷q^nH{tUmŬhw"b,a;b '-T̯vm}[Aau3|=r|yq+Z+4n%l'4!5L_{ܐ캀KYZ@_q`)ENMws6Zn̴q(;oCo9t8nd.3QdQuZnzk?K`cWZU̟ln~Njw+bL:pVVnND?|>x64 Ou_mE+򱒒\J`BKBmؔCSaZH >@-}m Z%ؔ˹;N,z<$a=\DD&6Q84."=OO> z@ +R!!/*V;HK cvEˣC1P8Ie7+h11T3s^=Ryцԭy˹dYEp#M_/+.bUiv"8ζ>g_c!wi:S8/Us{"C¾ 6ɧ0ҕW&7~|j0&uRtϐ̓8'7}}"ECl ]ʃZ87tYv̆xʍyzߢgj(P'2#bFfUw <#Jn`oLE endstream endobj 1183 0 obj << /Length1 1647 /Length2 14691 /Length3 0 /Length 15544 /Filter /FlateDecode >> stream xڭcxm&m۶mmض1;v&Ξ=3T\ku 1P΅ oiklo+o%K 4wr1|alpdd"N@#K{;Q# 7@h L\\\pd{O'Ks  JQ{elin zp;\\_ QPԒPJȫ$v@"]m,M&@;g  `Ҝ| 9@/3 ttvzX:̝\`igbjO_r3%da}9Swvq6qtp|EUw.F.vf_&/bdi pz0tv1_i:[ڙg' ͗n?o98x_Z+Kg=WLvp 􋔝=rSW܀N z+ #S{;O) A+$e>(o!7r+Gu-jc#od3Ecd5Y? ±4ZxYOw!;/-t*ZX̌l._r5;S#T-,Maۿ*`QSTU?l)+~u?#iٛ?=tL\:fƯaG.fVrg9#'K#=##?>y/nLM##;ӯ_`W'/ *.ٛXfb M0:4Tw0| oh\ _8\]ڑڋy=3PvO rnXhd}K kvs?yFZ-M3a%G%\(WHբG|Ry ^AU=!/keb(o;^NkT6dܰ$ M79/'$N*f uV7^o~S|*A}2<05WvluaeτV]&fR &+@h\W¢,tzɖcW4`a5L/ϩȖR‰PB3il[#-A*i`݆$x[}ǫ63F? p5FB̮.ArkAV";]Clj!bӱx]/hjIԔ@ou28~or\` oc SWߚTV޴4ȀYSSEdrQm~mr)bNhlkE=0pHv/pG?vpq1Z;H-Wɠ{V(bq]7g % B!xZ4~ 뙑^pce9\orQP ߪtD8aS=vX[%Ur߻g7ho8[I;46R-a w%6{:ImNk-X% \0f]3]zOL9w6O10߉ci7fCnh͕*O,8l} ;6OZIM)!nxGwЈ_oCgzakcXN8?q{RlHo\GV $ƛ#qwb*oi[LHعdwrV-KpM5dަ=fևXG`昨7aV9bp Ϻ.vʉԍ6Bx/~+)HRFVhmZDg3N*ݷֆFvY2t}N Zr# ϲ+MGht*k.+nFЃɌ;`Wp.O>Jx_7f-`ege k[ut^x6S<ڈ=Aw a^x#sQaWB 7 DE:L/խ0k44-yNYĠlǩZJKJc 0˼vSeSrxDz0WݕT Ԧ7R6rLِJ~^~=2,K$Izshl R>>µ)rG LVp5m"PϻL8T4 Z`U7̳r{qΩV/0xHw#o2ʭVpv풚E;exsv_ov^Ia45 Vn|[GL>c;ɚDnQyOܩu3UL>jVխ"IWBr?drEK݌}y5@k9)>6{ *YQVcvuk0y ml-bo9'Phz".R|4Ӕ׎bTRږԲ$OttbPt#=u() ́?VjHdWP4K{G{e\ \55܁]%8(!9i dBr#S %BW9&5<Eg|E7B+YHrpPYF~ooFuqHV۠eK{)N_s lb7E$9&V f@Fā),>gRo'?Ѣ 1w>R|2d\X0ș[+ Q2zmMhhqw y7d=FG]9-6cgk+3G[ƺ^sd(wOodU>~4ONɒw6hn?휘Ջ&h`-G\[zY[75~.!Oq<ν$t3lcߍ[Ȑkg7E aX*ڲc(H6,^˅έFȲ!ɿ3"y$0)X>c,7z3-!"<~+kw-b&_ Q| d)O". IJ F(jp3 ݸZ5\x5f{7֎R32h̞OLލF{R^;IL&,]CY@u(ᏸ.bDƥ&£A!+6->D ċoB9bdC"]+=2{B"D)hT+I~gA-Ln{h&w0 \\ѥX+T'h`kՋz4i0Q*;͎!hث-*es)W٢ьA\Ddbq-v㦆Ȋd;(ZCWY3Gstnzښ}bs=JR< /jv?](**50xjߛ~]>:%3%oGBr,ZrjJgQ@"MՔLNI(M4;4?0)pmy#ڮIoV sS-iSl_OQ7벧M߿Ac M`\"&tS1ě;`HDW-÷+jjn{RdK$_ FvJ\ak΋7n'gmw8sAk[${D!piF=G9;muC?5 r[W^鰰Vu+÷XQ-pN*%pGa6c ECD]~zJE[(\]yR @_rԽdan k  ^M2dS1>bt D[q@m bȋIOJe:Իv4_Qc-#L+ 1J$=V=w d*+C,M[JnNyMݻzر)d,g"ڸ|-s̼faxn<ǵ]YL$]Gyo yXqh۝udQ"HB%oZ+) $(hZiy/DW=z[GX8rк۱փDKV.i!qnfI$+5ɣv?JUi0|L l3Sqѣlev@ `FuT+bUW?YIYE3T쿆nT~~h\Fhl瓧X8X#:b"[l5`\#ėJV"nN2,Sm1Un鞉w3a &jsB>^˷Wi-ֺ[hY6ow '[V5=WhpT6SzyOkb7b_u?{`N%7ț]|ֵB~IB~0X/fa]'t[H t:L5k[Ad0y&oh l ҄ W͹?dLdɹ ë*0r:'Fi9Y<'t\1s#0t;-XS-ehny/_(pWI'!_Dbb\_t!-d</8(8iDlN"xMx%O+<޳v{=X.b~_5w[#Hػmx=% UCR(9mGLyMn>hEQ|8 ߍnP?Dj1Ozd3qpM Nڠ`GlL'!v1s5b!듟`( "~%͠knRV^PqϹhk+WzN=6Vr].zafG8Jy tu}PPٸ5e 8nƭ3MTF3̅^Qqp,'Ҽ+|_eoUʚ𢟝G9$[[䙱_ 7qsvڮivWí~a,꾴oL ]3Ys߈G@KSHGU_4?NИ?>#6a*2;',k&+8dSa}DKձCV~6.XBTR@ĖԎz+-{{rLɖu2:"nfD;n [oPw e9YkZjrΚ@`„`w?C\G89$b՟V;ST.AzHX;臉BD`0 Z)*׸M>BFlRyB&|G%ȈY97pv}0W"\! Z֣4e+1 cWp 7:׮n Y] r/84S|s}l1rb@*jDNdh4k;6 WdQLϩF\j 6:vc iTK+?LdH*FnPFB(k<3t9=s岈{39⣕DBN g(ю4ٺO5vg>@Iy|9#Gi ǖ&iL|ޢߪ;`LnLWQ>$o`p hv:u~.K-r"t'm Ŀ̸j. T "(XKzeC}Ltq>&i`^P4MĊ0>3YM&x_i=:j@)h[W*(B#Mx[ UQwanEa!=0 =7&>+E3Kz;%op+"͙$[zoZP~saP)Yl\ &Vr Kg&$ M=^0-A>tU3D31AR;]Ǟ ȯ2B%aX<@!N)i ax=' X!Ol%p.g[7 I~,&m[죳ޘs[& n2*O"=TQrݹ\Xw{YyqgĜc|S,x< IكV4iI|  "ʈ: VYrD22Eݙ 1/Ƚ\s)Uo>[b62b*oc't mZ煏]AJEgnT.Xܼ/h!/Cª% )}%yњC67yө`GpWѣfHj ~~^q}Y(򔎽䱏f0D>.q]nyN$ lD)#B'i7n+yב56¶i;QWK@GAYx{ÓG'V8tGd 2mEARFv{"߲:J wM(l`'#H^?Sȹݽt3)BmqOň޽634-# 2l(@B8_U☿m8,xvc⪨[k!j9 J:fg ]\-)Hhf[dN,x\pS⢾Qj=ϖz_@] rZn6n5)n[ :u$nœzrGB1u #}ѸZ^cqafHnDHf|ȟzjlMŋ[ &=m$@b6F>^P.AM7r|goP֏2?ϵU}_?IX,EKhRf^ lAv/ɕd7IɐvnǴgrXرW;d}$SztZ&/')ݠ@'T-YD: {G(ȓ;0aJY,};C2W8-Py{kgӐ# 2[&څBUsf䣿E c" <%ӕ&깾a8HXWx|U;1Ӹ ;ӐMX;% m%!Z ^bX@گzJּ , |~Bw$L+fbkfEk-2jcfHJ[eU&E2?ʤP\G;9[!XT[Ђ!&/r.ԖtHi@$tJWy B1  wf1pO/La+ITP}wϲ-B}&$ I,kV=Zu⎼%b1I_k44oM׀sC2Vakx2lӏH]8?˖IӇpLq2 $asT6H1KY?=VDE>L\/S| nW(%XԪP6Z!s4F*TB;fi qۗ(w[d|l |k`(K m"Oitu p;VsN4_\6nЈ ݝ29\I75w`qUHMx#vw7䀳:{|`$Z!0ݸaa׽6caf;}9<7ǐCsܟN^,>U*Larv~SdЩpe8w,wΰg0@pN:@ R+&RAY~[aˍ 1'F z1/WZ mS ;; ?,0!{Atwo{Z7 Ws{iթ/7VEzo D9|z.8KFiOeeI/ El^Zj9Sۘ`V ?3*ϩڌ-b hSxd/b(i>ZύiZ*극ƙX, Tcmat.|T?s~-kiKSAVIQ4sk o-L ٻqe ߁:d}TxKʽbhOh[B ;g0+"Zu~C V`x}FmF Qb 3?wLT$m}vLIw:(?Ђl&[ORmKu,9FARVo ^^Y (oFziն~?r֗d, jg\Xj:=*/28߅CzqGn 'C38EUv,m}y]Ɇgo}]!:  5-nv&p{;'C r I&oQ}zaCeZabH]@(e+Nv/+3o\H+u# Ɓk; `4vMI$(\[Y[3ŠxI4D^OHnB:F"U ?Y zFs^u G;?m>{2oeeY$gX0{psAN@FA'S=kSySxP"6V)hhھ&aO(lPrᴀKԝ(nI}cqڻ.9"#~$2@YDcWoSbl) LWՅtS8} &QXpm lRn1w#k#*`ƎbgV A~+")6ײIeuL_&2ٟ6yÃڃ X2)D&iCy$b~mZz8:ПSRR :UE.=NI]%sXbFOɧ*f~51>H95Jo#1:1H821 s1Vfo zs@ KBTjks|M4Ay K'EthW:50ڬlc&:P., `bF7 Xc{IF9;yюe=L.>"Q䩙~fJ<}_Bi[>/ mZKemInB8&ddO˼T `g,Q˭6M}_AI$n~WvRމ\"2KpL'龟Ϝ"׭O+/_.]` }j玁*493Y}p0ZC*aPlËb3 uUr@^DZ{ r$T 2%eUÿh"d,C@>*t+r~N${\-!6UI᱄.iK9*;\-#mW"ߴJǂ%qCZT@Q{]/ޢDnă2vj-s-sXPˣ?8>j%M UةRG9ACYFEr,rw֥EO[,pR񀹃Aih;IީZv^ }a[UH|Nx&Dυ_ , ML&npe kFa;/= '}<#syJZ+AmQu5X9 6#tˀ}>Ǒ++F‚,MD\EuQ/Zb;obnp*o\0ݮ^Tt0#㲮|E:*"3|5 OR? Z=bc\N?ez y(u~Shz W@-DIş%!\ћrYCMɫ'z l3+`ӅgSԥfUulu-z $ &4eEsIv4K܎॰->K`hL|j`ELqn~]E826N?5ɔ))Qo+O_<ųY3ׯgr ~-'cZ:Z炒9?vo6Bv`1 />->8P70\и@\o۹{&}*ַ2\{DURקŁ]^%wJIk(M뗌LV&JwX0e313aW=XLhpuR6g;q‘3%{᤟XAWM2p 9=1! E7b6Vsn^)$ÍHS*PWImcSS{ $ohJ%>"К笈84bz|;?+aͯdV/ Eª& Ղ`JEj9dSmJw8*OI N `=`ϛm;eRL_=u֫;aI/٣ Q>!K{W0V.01gO[M)&J2!mO~oy7|=?El[TSh~-eP) h&[i"M..(4 TMsYxMV1zFOM}AG\GﮀibXN^H6b{@@O163L7$g+8W\AeTCƓLq嵱s˨7Sx](3W2 'EplPGQFi?To^*|մAe6ݿ!| 7/I+C.DԤ64 W-.PdT+nMbitJ7 $C-pEK[~5f8H;=Xg6ח@3&7VBM˚ME8RUSnN6xj#fZMr1 !>T欠( dut7eJi٠_{<8/֙#4"C VM%0*zuw[f BEmDU%?78:+YTP_{Q䁄F\0߼Vג+-U `m?lrbuJIR[BְX,ϐ^\у='cj,wɤV_1Ќ Y<0&I, : H7w&N|ej'4D}4tFzͯ׮e*}w^M=aQ^?kp+ZK Dh-FTǃFMI)Jnz-w/-#~|.X!if b`L&a{*[s'-;Khǹ$A&aԠ(%Cnu[ x\6|cmΣXxN'n!MnrO֤r&XD(ǡ8Vf ֋`QhР~v2t3FG ks$94AODH߰ΠӵuYlsмTYiri7T \WD޺YÁ/CO¯D8 ]־NXHVg!l7ָ|)!zh_iVdqs[#5pb!A`'܀'xDo@ 9袜\s|ZOlB`#FTAb1Y> stream xZko_[_@P n<ꤹ Zbl6葦wfw(Q)3Eq.as a468bC-<6$1&Qz M LZE0[ia-8Vpl@w(0N!t牐Ն%3G%ZZ8HV@Xb@N@EUfW4`#X2$# |HEXWPpE,@3  \sՅhq &mp,'JX  εh 1#C#3h"pՁ.g` #S``80F9@#F#QL lj {HBށ`0h3 Xa(ء sE!E3,?zs a@Cl,`   ěA:sӸz.w N`&Eup<@-a QBKpXG}q\`q 9&Z8ڀ%[05" q6FЇ|5U#z8_L;Aӧ=)+N)IpGp H"JL"gF:VAƠqTXcǎTBDW }гˊ8P甫]/}uoUHZؤ$. xiƙp/F2ٵBC* m%UmK~X xpsFFC22m{5 د%rmmN09Еv]ݯ礪KGr(WE,a_WpÓ{6g4_सXOs8/D/n t*b6?O2tpt*ㇳiUqѷif_ !>}/O=L_7-4.|6r\r1^_N hEHy>Kh-"*Oh~,Vehc:O3NS4AO|J/i~E?~^,E_,bFKHtZ,謜t:ʋ9\B+#x.z=]/'i],W%hi=_il,K$!K,hв ,/4BEQs<-EA?Y,F8*Ymx>vϞ?;eyu^v>w/JDxgX^,m ;m;ٰJŪ_=KV̯^bR08r ! k 3Røb2|30@HC8u){uKRQt+ O B+Cw[+}޳ O=|tA u5(͆SWi yL@,;SJe$$wI;3G⾓ o8{|4 5W 7@x 4HyjT䶂ϯN{CvAnj&Twn zw-2? 5a :]+&Tu@+t!z˧]FJ lXC뎋%y'S H[E'} d}'**QhC@+ F`VUX7*T@Alg=bud+mGo6včN|j%|6?_%oE6+yUkMxw Wd%w>' Bk"o- [7\(vlre]vm;=*&6=[7du c+ yznCeznS=[qϊ7Tmئ~m wӮT7aoWl)*I{Qq KѴf:mVg_K{kF_~ XN U/̄Jggדx^H_XJ&]nF/ PUDC&@t}>L  |!@0C#5aXGk`VYF;س} D޵=v7k{0w5nqj ܶ A`WFl;mggmvxl~ endstream endobj 1189 0 obj << /Type /ObjStm /N 100 /First 989 /Length 4284 /Filter /FlateDecode >> stream xڍ\M#@ora6ZgFXH]ȏ*vؽUG>3cuw턶ӾAvZwʚNV>>vFNxIYI;wWwq$:߉^N 8t|TFIvOoĻGtR?uҺ$(}DBz})%"TӓsOSwIwZYtPdg;mǓI;B9Dv}gc# -)TgE9ꓝdOI;'H2z$#&*#[hY:/sD}WRbtu+:م.&!8P qufJu ̡HkXA*$8no1q6'8NED$vVLMy^pdZ պOsF6iMFX~ 6H[k%񚍃7fl&\Hc٬Cr6>Z)\ͺX#Na߿0ĭw?7x h|/=" $' >&}div$pˎRզ)oӸN_q#ڏuzӓ8M@޾m?Egqg{z=VRzze]tFSWݹKD䕪Ip)';L'tMsB#! &3.j\`70TY`Ҽ wïx8_Cڝ!J#k5ey$p!v!Kdw |kL+*;oK]PEmkiizŠ|rK}<@VOP5%uҷmQl7hW=<'|]{|,:պD/f쾼qkKeB@vKOC{xIQ$,d͒KͪoEjU[*! ^ UVTTyj+V>ai:_QXzZl;3"U> Q QGf;쟐A)EN Y34ՠ0*AO]f gU5kbuؾ6y.+V\0Jd( lhOǑUj~ƈɫbu+R,2pM:&؊f8^0^a|Օ9fk% Y{YS` *9\bŚC3HVӯm_]iAB6/UJ+gQ-o4֚7΀}:Q%ʬ+[QeUL[b >PwL.ש 8Y:%GivH6j3u5%TͰ˝IxQy<$i3Om Kq#TJHx9%bWojWWnf]iq|;{;H[y "{ge'WJഴ=~eHdT2 p3-4nU%6O',pؠtfV^&yV^`54bp9ݣ N{fY&{;".{0RZ6᪥0ۆ8IU x0V9j-]<$ py;b$6ϹV/~m]:'>2vpH8,bl!pDr%^oVxZU_㺡FR$=@Mz8}ɍ5%ޙ+vDaٳjvTWm~t1tl|< 1HDGߩvM'l-aK .'+1fR &Qac7:15ۗ6\39Ӆcq ΛLtgD I%̳7]ygaRf!TpĠͳV+< t%ӭG{OqI4m,%.$#?ܭ$t $虎HDz/$RF8u`uZ.JkR-%UqlPu\nUǥ=tH(a<6)x?ͳVu`xѽq)RV,P 5h.( aEX8[ :Ӧ+&v(wuXa62:I_){j)]Ƥ,Ta٬ Nq@o^T}깴ǝd}5ԥ%CHD^abeb cp<[KL}DF"Fت Kq*vjmI𻇅}?5|n7#YZ.HֲuA9Ho9g L{>eAg\iCcR,eJ$ROw [dR'1B:u-rHo90ZXNdlb@qb$ :ͼEu) HNf{:%e~0H2޺JLEFvOpk0O0Ҹ,";kYhAc'9F4svl"; ky>rYƤ"2Rb΢"=;-( |vj`>([XA5ճa<1szmήo/K,!,>vIQ,n$Ԃ $0- LKFe+yo9wL+L44.} e %ӊ2Lkv֌5[Etpi͑i^y\xq)yi{Pfԕ%oL[ L˃i˼`aybo9y 4:iZӞ |#"iޮ0`:pH`:u l]BX;Z%D2ZBQXKUMS!!L ^@u;;6%(i!8'/T7@9F 31xfMDcXZK Yh/Y/7ࣥb5::FO4[@<,wN+ R,uPf9-.l7z.ZeR^=ecPvI8{ =rK(W(N*jyt=kм(Pu_zE\TXoTu+ QM jÒDt-*,IDӢYDϢYፖE륍.BnE\m^f:->[ѬDYdBE}RVDA{Y@j]fMf)zqQ)pxt54kќhV֢7,5,N3f-Z@hVFMfI4 >qaёh~.mVүV,f ͈f f'f:ӯoWL)^ SGoXa&İ wD bXEZh|CbXKJ͇߰a zu<^OHѭvPV Ir=aKHQŕ/R}hzt)ATA4.EaXVðk=tqTZ݉iȾ7~-ӟW?9=AOk}y; ?=: mIgS`;=HG4䉘<?& C?]yiF1y#&oXE[2>?cV?8 endstream endobj 1290 0 obj << /Author()/Title()/Subject()/Creator(LaTeX with hyperref package)/Producer(pdfTeX-1.40.17)/Keywords() /CreationDate (D:20191017100219+02'00') /ModDate (D:20191017100219+02'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.17 (TeX Live 2016) kpathsea version 6.2.2) >> endobj 1275 0 obj << /Type /ObjStm /N 15 /First 137 /Length 470 /Filter /FlateDecode >> stream xڍTMO0W=[BHnZTq H&=aUo/yvlzST(5Cc%os%Tmq3J.2Bބ84F;l (?hU\\3sU8cQ޶Og/Unܜfcqy9P?A 4^1A6A6A61T2H"蚧mR^3,PMP#@%>,.<{N"s1\0\0\0da^f#TTDL2s% Ԉ.2^ęk!aq8N:}õµ'dt{?MEw27̙<)2=RQTS^}޽d+5ُ~nRKWt#w5hOf{50v 63Ik endstream endobj 1291 0 obj << /Type /XRef /Index [0 1292] /Size 1292 /W [1 3 1] /Root 1289 0 R /Info 1290 0 R /ID [<3D78B657FAF36E8FB4E949C55B6387F9> <3D78B657FAF36E8FB4E949C55B6387F9>] /Length 2987 /Filter /FlateDecode >> stream xIy:['4yVKWi՚g}1&cHp @9$ /B cāll(!P4w螷k~ꜣjPjTA5Y%]W[9jjy0_p|مj5EjSj4K6&qХjj-W_+ծR{֨=Usn\kZzؠH͝6&jH6Sj`+lS2>knj>i]j0\F5wUj4´Y}_ͳqYN R;V0Q{F(SZ8j4O)ej/5O×jqgQ4y/՞k^jԞi^j՞j^jo՞h^q'kހji-NwZ\}{qGj7Oь Z2nZ~vK3X{K0ߨK"0/ob2XKSu7qjVZӰ!U3.nn;x]^8Rq!xǡY8gpNiyqn}/ t6܁p+Ub{pCx O<W79[|9l~B#|ztR_sm4o9o#ZQiZ[v HnInInInc m|7B\$m|YmSj6ܒܒܒN^Sȋb_mooXH-mly{;gVZ[۰//4u:3q7buT,k  yoLbc)i6[heF+SV@"ӕ#}w)/@YGG`߈TX 0_,Z p* zXafo+`%a\-^(~q( 1 {܌pΨj8nk 7M A8 Oڐa0z&U?qŰl(C^+`|5^pTێ8 ܂,ރ@'!fl3x>^AD wfwu>g'r&a]J+0|@wCw+Laaf)A V׳4f,K~1ݬNo<*486HD#477777 T8)@#9/cyh Ưz!4"Ј@# 5gF6*hXmXm8o 04SF^yiy 3)MI$"J֓F9hmhUl,4rA ٔ*6FDz|/dJ,~~e??MrsssދELaZ?iWs^ttt/U=gQygb{{{{{NȆNz{{ S:{ݾ缏}˘4ƢIcGVQ)3˞˞^za腡^z)]QSݽHzwjjjc:v>E1j?aL< `aJd1,E)=nԖ@ Ka-濷!f1ͽ1} c-&+O!7{>ڰR{I0 桵g,_ڊCjX V,zhm6߯Z0Z} 6 `;. ^0 k#`RTf۵vm> 3`XV\P5ɵխ\mXV3` w*D}E!X cZK+j˷W0axҷT)şНg3y% split(.$cyl) %>% map(~ lm(mpg ~ wt, data = .x)) f_coef <- function(x) as.data.frame(t(as.matrix(coef(x)))) expect_length(mtcar_mod %>% map_dfr(f_coef), 2) expect_length(mtcar_mod %>% map_dfc(f_coef), 6) }) test_that("walk is used for side-effects", { expect_output(walk(1:3, str)) }) test_that("map_if() and map_at() always return a list", { skip_if_not_installed("tibble") df <- tibble::tibble(x = 1, y = "a") expect_identical(map_if(df, is.character, ~"out"), list(x = 1, y = "out")) expect_identical(map_at(df, 1, ~"out"), list(x = "out", y = "a")) }) test_that("map_at() works with tidyselect", { skip_if_not_installed("tidyselect") x <- list(a = "b", b = "c", aa = "bb") one <- map_at(x, vars(a), toupper) expect_identical(one$a, "B") expect_identical(one$aa, "bb") two <- map_at(x, vars(tidyselect::contains("a")), toupper) expect_identical(two$a, "B") expect_identical(two$aa, "BB") }) test_that("negative .at omits locations", { x <- c(1, 2, 3) out <- map_at(x, -1, ~ .x * 2) expect_equal(out, list(1, 4, 6)) }) test_that("map works with calls and pairlists", { out <- map(quote(f(x)), ~ quote(z)) expect_equal(out, list(quote(z), quote(z))) out <- map(pairlist(1, 2), ~ . + 1) expect_equal(out, list(2, 3)) }) test_that("primitive dispatch correctly", { scoped_bindings(.env = global_env(), as.character.test_class = function(x) "dispatched!" ) x <- structure(list(), class = "test_class") expect_identical(map(list(x, x), as.character), list("dispatched!", "dispatched!")) }) test_that("map_if requires predicate functions", { expect_error(map_if(1:3, ~ NA, ~ "foo"), ", not a missing value") }) test_that("`.else` maps false elements", { expect_identical(map_if(-1:1, ~ .x > 0, paste, .else = ~ "bar", "suffix"), list("bar", "bar", "1 suffix")) }) test_that("map_depth modifies values at specified depth", { x1 <- list(list(list(1:3, 4:6))) expect_equal(map_depth(x1, 0, length), 1) expect_equal(map_depth(x1, 1, length), list(1)) expect_equal(map_depth(x1, 2, length), list(list(2))) expect_equal(map_depth(x1, 3, length), list(list(list(3, 3)))) expect_equal(map_depth(x1, -1, length), list(list(list(3, 3)))) expect_equal(map_depth(x1, 4, length), list(list(list(list(1, 1, 1), list(1, 1, 1))))) expect_error(map_depth(x1, 5, length), "List not deep enough") #FIXME expect_error(map_depth(x1, 6, length), "List not deep enough") expect_error(map_depth(x1, -5, length), "Invalid depth") }) test_that("map_depth() with .ragged = TRUE operates on leaves", { x1 <- list( list(1), list(list(2)) ) exp <- list( list(list(2)), list(list(3)) ) expect_equal(map_depth(x1, 3, ~ . + 1, .ragged = TRUE), exp) expect_equal(map_depth(x1, -1, ~ . + 1, .ragged = TRUE), exp) # .ragged should be TRUE is .depth < 0 expect_equal(map_depth(x1, -1, ~ . + 1), exp) }) test_that("error message follows style guide when result is not length 1", { x <- list(list(a = 1L), list(a = 2:3)) expect_bad_element_vector_error( purrr::map_int(x, "a"), "Result 2 must be a single integer, not an integer vector of length 2" ) }) test_that("map() with empty input copies names", { named_list <- named(list()) expect_identical( map(named_list, identity), named(list())) expect_identical(map_lgl(named_list, identity), named(lgl())) expect_identical(map_int(named_list, identity), named(int())) expect_identical(map_dbl(named_list, identity), named(dbl())) expect_identical(map_chr(named_list, identity), named(chr())) expect_identical(map_raw(named_list, identity), named(raw())) }) purrr/tests/testthat/test-head-tail.R0000644000176200001440000000117713426303100017354 0ustar liggesuserscontext("head-tail") y <- 1:100 test_that("head_while works", { expect_length(head_while(y, function(x) x <= 15), 15) }) test_that("tail_while works", { expect_length(tail_while(y, function(x) x >= 86), 15) }) test_that("original vector returned if predicate satisfied by all elements", { expect_identical(head_while(y, function(x) x <= 100), y) expect_identical(tail_while(y, function(x) x >= 0), y) }) test_that("head_while and tail_while require predicate function", { expect_error(head_while(1:3, ~ NA), ", not a missing value") expect_error(tail_while(1:3, ~ c(TRUE, FALSE)), ", not a logical vector of length 2") }) purrr/tests/testthat/test-recycle_args.R0000644000176200001440000000123413403735151020172 0ustar liggesuserscontext("recycle_args") test_that("rejects uneven lengths", { args <- list(1, c(1:2), NULL) expect_error(purrr:::recycle_args(args), "lengths == 1L \\| lengths == n") }) test_that("recycles single values and preserves longer ones", { args <- list(1, 1:12, month.name, "a") recycled <- purrr:::recycle_args(args) expect_equal(recycled[[1]], rep(1, 12)) expect_equal(recycled[[2]], 1:12) expect_equal(recycled[[3]], month.name) expect_equal(recycled[[4]], rep("a", 12)) }) test_that("will not recycle non-vectors", { args <- list(1:12, identity) expect_error( purrr:::recycle_args(args), "replicate an object of type 'closure'" ) }) purrr/tests/testthat/test-pluck.R0000644000176200001440000002050513551356667016667 0ustar liggesuserscontext("pluck") test_that("contents must be a vector", { expect_error(pluck(quote(x), list(1)), "Can't pluck from a symbol") }) # pluck vector -------------------------------------------------------------- test_that("can pluck by position", { x <- list("a", 1, c(TRUE, FALSE)) # double expect_identical(pluck(x, 1), x[[1]]) expect_identical(pluck(x, 2), x[[2]]) expect_identical(pluck(x, 3), x[[3]]) # integer expect_identical(pluck(x, 1L), x[[1]]) expect_identical(pluck(x, 2L), x[[2]]) expect_identical(pluck(x, 3L), x[[3]]) }) test_that("can pluck by name", { x <- list(a = "a", b = 1, c = c(TRUE, FALSE)) expect_identical(pluck(x, "a"), x[["a"]]) expect_identical(pluck(x, "b"), x[["b"]]) expect_identical(pluck(x, "c"), x[["c"]]) }) test_that("can pluck from atomic vectors", { expect_identical(pluck(TRUE, 1), TRUE) expect_identical(pluck(1L, 1), 1L) expect_identical(pluck(1, 1), 1) expect_identical(pluck("a", 1), "a") }) test_that("can pluck by name and position", { x <- list(a = list(list(b = 1))) expect_equal(pluck(x, "a", 1, "b"), 1) }) test_that("require length 1 vectors", { expect_bad_element_length_error(pluck(1, letters), "must have length 1") expect_bad_element_type_error(pluck(1, TRUE), "Index 1 must be a character or numeric vector") }) test_that("special indexes never match", { x <- list(a = 1, b = 2, c = 3) expect_null(pluck(x, NA_character_)) expect_null(pluck(x, "")) expect_null(pluck(x, NA_integer_)) expect_null(pluck(x, NA_real_)) expect_null(pluck(x, NaN)) expect_null(pluck(x, Inf)) expect_null(pluck(x, -Inf)) }) test_that("special values return NULL", { # unnamed input expect_null(pluck(list(1, 2), "a")) # zero length input expect_null(pluck(integer(), 1)) # past end expect_null(pluck(1:4, 10)) expect_null(pluck(1:4, 10L)) }) test_that("handles weird names", { x <- list(1, 2, 3, 4, 5) names(x) <- c("a", "a", NA, "", "b") expect_equal(pluck(x, "a"), 1) expect_equal(pluck(x, "b"), 5) expect_null(pluck(x, "")) expect_null(pluck(x, NA_character_)) }) test_that("supports splicing", { x <- list(list(bar = 1, foo = 2)) idx <- list(1, "foo") expect_identical(pluck(x, !!!idx), 2) }) # functions --------------------------------------------------------------- test_that("can pluck attributes", { x <- structure( list( structure( list(), x = 1 ) ), y = 2 ) expect_equal(pluck(x, attr_getter("y")), 2) expect_equal(pluck(x, 1, attr_getter("x")), 1) }) test_that("attr_getter() evaluates eagerly", { getters <- new_list(2) attrs <- c("foo", "bar") for (i in seq_along(attrs)) { getters[[i]] <- attr_getter(attrs[[i]]) } x <- structure(list(), foo = "foo", bar = "bar") expect_identical(getters[[1]](x), "foo") }) test_that("delegate error handling to Rf_eval()", { expect_error(pluck(letters, function() NULL), "unused argument") expect_error(pluck(letters, function(x, y) y), "missing, with no default") }) test_that("pluck() dispatches on base getters", { expect_identical(pluck(iris, "Species", levels), levels(iris$Species)) }) test_that("pluck() dispatches on global methods", { scoped_bindings(.env = global_env(), levels.factor = function(...) "dispatched!") expect_identical(pluck(iris, "Species", levels), levels(iris$Species)) }) test_that("pluck() supports primitive functions (#404)", { x <- list(a = "apple", n = 3, v = 1:5) expect_identical(pluck(x, "n", as.character), "3") }) # attribute extraction ---------------------------------------------------- test_that("attr_getter() uses exact (non-partial) matching", { x <- 1 attr(x, "labels") <- "foo" expect_identical(attr_getter("labels")(x), "foo") expect_identical(attr_getter("label")(x), NULL) }) # environments ------------------------------------------------------------ test_that("pluck errors with invalid indices", { expect_bad_element_vector_error(pluck(environment(), 1), "Index 1 must be a single string, not a single double") expect_bad_element_vector_error(pluck(environment(), letters), "Index 1 must be a single string, not a character vector of length 26") }) test_that("pluck returns missing with missing index", { expect_equal(pluck(environment(), NA_character_), NULL) }) test_that("plucks by name", { env <- new.env(parent = emptyenv()) env$x <- 10 expect_equal(pluck(env, "x"), 10) }) # S4 ---------------------------------------------------------------------- newA <- methods::setClass("A", list(a = "numeric", b = "numeric")) A <- newA(a = 1, b = 10) test_that("pluck errors with invalid indices", { expect_bad_element_vector_error(pluck(A, 1), "Index 1 must be a single string, not a single double") expect_bad_element_vector_error(pluck(A, letters), "Index 1 must be a single string, not a character vector of length 26") }) test_that("pluck returns missing with missing index", { expect_equal(pluck(A, NA_character_), NULL) }) test_that("plucks by name", { expect_equal(pluck(A, "a"), 1) }) test_that("can't pluck from complex", { expect_error( pluck( 1+2i, 1 ), "Don't know how to index object of type complex at level 1" ) }) # assign_in() ---------------------------------------------------------- test_that("reduce_subset_call() type-checks", { expect_identical(reduce_subset_call(NA, list(1, 4, "foo", 3)), quote(NA[[1]][[4]][["foo"]][[3]])) expect_error(reduce_subset_call(NA, list(1, attr_getter("foo"), 3)), "must be names or positions, not a function") }) test_that("assign_in() doesn't assign in the caller environment", { x <- list(list(bar = 1, foo = 2)) assign_in(x, list(1, "foo"), value = 20) expect_identical(x, list(list(bar = 1, foo = 2))) }) test_that("assign_in() assigns", { x <- list(list(bar = 1, foo = 2)) out <- assign_in(x, list(1, "foo"), value = 20) expect_identical(out, list(list(bar = 1, foo = 20))) }) test_that("pluck<- is an alias for assign_in()", { x <- list(list(bar = 1, foo = 2)) pluck(x, 1, "foo") <- 30 expect_identical(x, list(list(bar = 1, foo = 30))) }) test_that("assign_in() requires at least one location", { x <- list("foo") expect_error(assign_in(x, NULL, value = "foo"), "without pluck locations") expect_error(pluck(x) <- "foo", "without pluck locations") }) test_that("assign_in() requires existing location", { x <- list(list(bar = 1, foo = 2)) expect_error(assign_in(x, 2, 10), "exceeds the length") expect_error(assign_in(x, list(1, "baz"), 10), "Can't find name `baz`") }) # modify_in() ---------------------------------------------------------- test_that("modify_in() modifies in pluck location", { x <- list(list(bar = 1, foo = 2)) out <- modify_in(x, list(1, "foo"), `+`, 100) expect_identical(out, list(list(bar = 1, foo = 102))) out <- modify_in(x, c(1, 1), `+`, 10) expect_identical(out, list(list(bar = 11, foo = 2))) }) test_that("modify_in() requires existing location", { x <- list(list(bar = 1, foo = 2)) expect_error(modify_in(x, 2, `+`, 10), "exceeds the length") expect_error(modify_in(x, list(1, "baz"), `+`, 10), "Can't find name `baz`") }) # S3 ---------------------------------------------------------------------- test_that("pluck() dispatches on vector methods", { new_test_pluck <- function(x) { structure(list(x), class = "test_pluck") } inner <- list(a = "foo", b = list("bar")) x <- list(new_test_pluck(inner)) with_bindings(.env = global_env(), `[[.test_pluck` = function(x, i) .subset2(x, 1)[[i]], names.test_pluck = function(x) names(.subset2(x, 1)), length.test_pluck = function(x) length(.subset2(x, 1)), { expect_identical(pluck(x, 1, 1), "foo") expect_identical(pluck(x, 1, "b", 1), "bar") expect_identical(chuck(x, 1, 1), "foo") expect_identical(chuck(x, 1, "b", 1), "bar") } ) # With faulty length() method with_bindings(.env = global_env(), `[[.test_pluck` = function(x, i) .subset2(x, 1)[[i]], length.test_pluck = function(x) NA, { expect_null(pluck(x, 1, 1)) expect_error(chuck(x, 1, 1), "Length of S3 object must be a scalar integer") } ) # With faulty names() method with_bindings(.env = global_env(), `[[.test_pluck` = function(x, i) .subset2(x, 1)[[i]], names.test_pluck = function(x) NA, length.test_pluck = function(x) length(.subset2(x, 1)), { expect_null(pluck(x, 1, "b", 1)) expect_error(chuck(x, 1, "b", 1), "unnamed vector") } ) }) purrr/tests/testthat/test-compose.R0000644000176200001440000001031713442732317017203 0ustar liggesuserscontext("compose") test_that("composed functions are applied right to left by default", { expect_identical(!is.null(4), compose(`!`, is.null)(4)) set.seed(1) x <- sample(1:4, 100, replace = TRUE) expect_identical(unname(sort(table(x))), compose(unname, sort, table)(x)) }) test_that("composed functions are applied in reverse order if .dir is supplied", { expect_identical(compose(~ .x + 100, ~ .x * 2, .dir = "forward")(2), 204) }) test_that("compose supports formulas", { round_mean <- compose(~ .x * 100, ~ round(.x, 2), ~ mean(.x, na.rm = TRUE)) expect_is(round_mean, "purrr_function_compose") expect_identical(round_mean(1:100), round( mean(1:100, na.rm = TRUE), 2) * 100 ) }) test_that("compose() supports character vectors", { fn <- local({ foobar <- function(x) paste(x, "baz") compose("foobar", "foobar") }) expect_identical(fn("quux"), "quux baz baz") }) test_that("can splice lists of functions", { fns <- list( ~ paste(.x, "a"), ~ paste(.x, "b") ) fn <- compose(!!!fns) expect_identical(fn("c"), "c b a") }) test_that("composed function has formals of first function called", { fn <- function(x, y = 1) NULL expect_identical(formals(compose(identity, fn)), formals(fn)) }) test_that("can compose primitive functions", { expect_identical(compose(is.character, as.character)(3), TRUE) expect_identical(compose(`-`, `/`)(4, 2), -2) }) test_that("composed function prints informatively", { fn1 <- set_env(function(x) x + 1, global_env()) fn2 <- set_env(function(x) x / 1, global_env()) expect_known_output(file = test_path("compose-print.txt"), { cat("Single input:\n\n") print(compose(fn1)) cat("Multiple inputs:\n\n") print(compose(fn1, fn2)) }) }) test_that("compose() with 0 inputs returns the identity", { expect_identical(compose()(mtcars), mtcars) }) test_that("compose() with 1 input is a noop", { expect_identical(compose(toupper)(letters), toupper(letters)) }) test_that("compose() works with generic functions (#629)", { purrr__gen <- function(x) UseMethod("purrr__gen") local({ purrr__gen.default <- function(x) x + 1 expect_identical(compose(~ purrr__gen(.x))(0), 1) expect_identical(compose(~ purrr__gen(.x), ~ purrr__gen(.x))(0), 2) expect_identical(compose(purrr__gen)(0), 1) expect_identical(compose(purrr__gen, purrr__gen)(0), 2) }) }) test_that("compose() works with generic functions (#639)", { n_unique <- purrr::compose(length, unique) expect_identical(n_unique(iris$Species), 3L) }) test_that("compose() works with argument matching functions", { # They inspect their dynamic context via sys.function() fn <- function(x = c("foo", "bar")) match.arg(x) expect_identical(compose(fn)("f"), "foo") expect_identical(compose(fn, fn)("f"), "foo") }) test_that("compose() works with non-local exits", { fn <- function(x) return(x) expect_identical(compose(fn)("foo"), "foo") expect_identical(compose(fn, fn)("foo"), "foo") expect_identical(compose(~ return(paste(.x, "foo")), ~ return("bar"))(), "bar foo") }) test_that("compose() preserves lexical environment", { fn <- local({ `_foo` <- "foo" function(...) `_foo` }) expect_identical(compose(fn)(), "foo") expect_identical(compose(fn, fn)(), "foo") }) test_that("compose() can take dots from multiple environments", { f <- function(...) { `_foo` <- "foo" g(`_foo`, ...) } g <- function(...) { `_bar` <- "bar" h(`_bar`, ...) } h <- function(...) { `_baz` <- "baz" fn(`_baz`, ...) } `_quux` <- "quux" # By value fn <- compose(function(...) c(...)) expect_identical(f(`_quux`), c("baz", "bar", "foo", "quux")) # By expression (base) fn <- compose(function(...) substitute(...())) expect_identical(f(`_quux`), as.pairlist(exprs(`_baz`, `_bar`, `_foo`, `_quux`))) # By expression (rlang) fn <- compose(function(...) enquos(...)) quos <- f(`_quux`) frame <- current_env() expect_true(is_reference(quo_get_env(quos[[4]]), frame)) expect_false(is_reference(quo_get_env(quos[[3]]), frame)) expect_identical(unname(map_chr(quos, as_name)), c("_baz", "_bar", "_foo", "_quux")) }) test_that("compose() does not inline functions in call stack", { expect_equal(compose(~ sys.call())(), quote(`_fn`())) }) purrr/tests/testthat/test-transpose.R0000644000176200001440000000621313551356667017567 0ustar liggesuserscontext("transpose") test_that("input must be a list", { expect_bad_type_error(transpose(1:3), "`.l` must be a list, not an integer vector") }) test_that("elements of input must be atomic vectors", { expect_bad_element_type_error(transpose(list(environment())), "Element 1 must be a vector, not an environment") expect_bad_element_type_error(transpose(list(list(), environment())), "Element 2 must be a vector, not an environment") }) test_that("empty list returns empty list", { expect_equal(transpose(list()), list()) }) test_that("transpose switches order of first & second idnex", { x <- list(list(1, 3), list(2, 4)) expect_equal(transpose(x), list(list(1, 2), list(3, 4))) }) test_that("inside names become outside names", { x <- list(list(x = 1), list(x = 2)) expect_equal(transpose(x), list(x = list(1, 2))) }) test_that("outside names become inside names", { x <- list(x = list(1, 3), y = list(2, 4)) expect_equal(transpose(x), list(list(x = 1, y = 2), list(x = 3, y = 4))) }) test_that("warns if element too short", { x <- list(list(1, 2), list(1)) expect_warning(out <- transpose(x), "Element 2 must be length 2, not 1") expect_equal(out, list(list(1, 1), list(2, NULL))) }) test_that("warns if element too long", { x <- list(list(1, 2), list(1, 2, 3)) expect_warning(out <- transpose(x), "Element 2 must be length 2, not 3") expect_equal(out, list(list(1, 1), list(2, 2))) }) test_that("can transpose list of lists of atomic vectors", { x <- list(list(TRUE, 1L, 1, "1")) expect_equal(transpose(x), list(list(TRUE), list(1L), list(1), list("1"))) }) test_that("can transpose lists of atomic vectors", { expect_equal(transpose(list(TRUE, FALSE)), list(list(TRUE, FALSE))) expect_equal(transpose(list(1L, 2L)), list(list(1L, 2L))) expect_equal(transpose(list(1, 2)), list(list(1, 2))) expect_equal(transpose(list("a", "b")), list(list("a", "b"))) }) test_that("can't transpose expressions", { expect_bad_type_error( transpose(list(expression(a))), "Transposed element must be a vector, not an expression vector" ) }) # Named based matching ---------------------------------------------------- test_that("can override default names", { x <- list( list(x = 1), list(y = 2, x = 1) ) tx <- transpose(x, c("x", "y")) expect_equal(tx, list( x = list(1, 1), y = list(NULL, 2) )) }) test_that("if present, names are used", { x <- list( list(x = 1, y = 2), list(y = 2, x = 1) ) tx <- transpose(x) expect_equal(tx$x, list(1, 1)) expect_equal(tx$y, list(2, 2)) }) test_that("if missing elements, filled with NULL", { x <- list( list(x = 1, y = 2), list(x = 1) ) tx <- transpose(x) expect_equal(tx$y, list(2, NULL)) }) # Position based matching ------------------------------------------------- test_that("warning if too short", { x <- list( list(1, 2), list(1) ) expect_warning(tx <- transpose(x), "must be length 2, not 1") expect_equal(tx, list(list(1, 1), list(2, NULL))) }) test_that("warning if too long", { x <- list( list(1), list(1, 2) ) expect_warning(tx <- transpose(x), "must be length 1, not 2") expect_equal(tx, list(list(1, 1))) }) purrr/tests/testthat/test-depth.R0000644000176200001440000000125713403735151016641 0ustar liggesuserscontext("depth") test_that("depth of NULL is 0", { expect_equal(vec_depth(NULL), 0L) }) test_that("depth of atomic vector is 1", { expect_equal(vec_depth(1:10), 1) expect_equal(vec_depth(letters), 1) expect_equal(vec_depth(c(TRUE, FALSE)), 1) }) test_that("depth of empty list is 1", { expect_equal(vec_depth(list()), 1) }) test_that("depth of nested is depth of deepest element + 1", { x <- list( NULL, list(), list(list()) ) depths <- map_int(x, vec_depth) expect_equal(depths, c(0, 1, 2)) expect_equal(vec_depth(x), max(depths) + 1) }) test_that("depth throws an error if input is not a vector", { expect_error(vec_depth(as.formula(y ~ x))) }) purrr/tests/testthat/test-every-some.R0000644000176200001440000000117113426303100017611 0ustar liggesuserscontext("every-some") test_that("every returns TRUE if all elements are TRUE", { x <- list(0, 1, TRUE) expect_false(every(x, isTRUE)) expect_true(every(x[3], isTRUE)) }) test_that("some returns FALSE if all elements are FALSE", { x <- list(1, 0, FALSE) expect_false(some(x, isTRUE)) expect_true(some(x[1], negate(isTRUE))) }) # Life cycle -------------------------------------------------------------- test_that("return NA if present", { scoped_lifecycle_warnings() expect_warning(expect_equal(some(1:10, ~ NA), NA), "soft-deprecated") expect_warning(expect_equal(every(1:10, ~ NA), NA), "soft-deprecated") }) purrr/tests/testthat/test-along.R0000644000176200001440000000036713403735151016636 0ustar liggesuserscontext("along") test_that("list_along works", { x <- 1:5 expect_identical(list_along(x), vector("list", 5)) }) test_that("rep_along works", { expect_equal( rep_along(c("c", "b", "a"), 1:3), rep_along(c("d", "f", "e"), 1:3) ) }) purrr/tests/testthat/test-flatten.R0000644000176200001440000000526413551356667017213 0ustar liggesuserscontext("flatten") test_that("input must be a list", { expect_bad_type_error(flatten(1), "`.x` must be a list, not a double vector") expect_bad_type_error(flatten_dbl(1), "`.x` must be a list, not a double vector") }) test_that("contents of list must be supported types", { expect_bad_element_type_error(flatten(list(quote(a))), "Element 1 of `.x` must be a vector, not a symbol") expect_bad_element_type_error(flatten(list(expression(a))), "Element 1 of `.x` must be a vector, not an expression vector") }) test_that("each second level element becomes first level element", { expect_equal(flatten(list(1:2)), list(1, 2)) expect_equal(flatten(list(1, 2)), list(1, 2)) }) test_that("can flatten all atomic vectors", { expect_equal(flatten(list(F)), list(F)) expect_equal(flatten(list(1L)), list(1L)) expect_equal(flatten(list(1)), list(1)) expect_equal(flatten(list("a")), list("a")) expect_equal(flatten(list(as.raw(1))), list(as.raw(1))) expect_equal(flatten(list(1i)), list(1i)) expect_equal(flatten_raw(list(as.raw(1))), as.raw(1)) }) test_that("NULLs are silently dropped", { expect_equal(flatten(list(NULL, NULL)), list()) expect_equal(flatten(list(NULL, 1)), list(1)) expect_equal(flatten(list(1, NULL)), list(1)) }) test_that("names are preserved", { expect_equal(flatten(list(list(x = 1), list(y = 1))), list(x = 1, y = 1)) expect_equal(flatten(list(list(a = 1, b = 2), 3)), list(a = 1, b = 2, 3)) }) test_that("names of 'scalar' elements are preserved", { out <- flatten(list(a = list(1), b = list(2))) expect_equal(out, list(a = 1, b = 2)) out <- flatten(list(a = list(1), b = 2:3)) expect_equal(out, list(a = 1, 2, 3)) out <- flatten(list(list(a = 1, b = 2), c = 3)) expect_equal(out, list(a = 1, b = 2, c = 3)) }) test_that("child names beat parent names", { out <- flatten(list(a = list(x = 1), b = list(y = 2))) expect_equal(out, list(x = 1, y = 2)) }) # atomic flatten ---------------------------------------------------------- test_that("must be a list", { expect_bad_type_error(flatten_lgl(1), "must be a list") }) test_that("can flatten all atomic vectors", { expect_equal(flatten_lgl(list(F)), F) expect_equal(flatten_int(list(1L)), 1L) expect_equal(flatten_dbl(list(1)), 1) expect_equal(flatten_chr(list("a")), "a") }) test_that("preserves inner names", { expect_equal( flatten_dbl(list(c(a = 1), c(b = 2))), c(a = 1, b = 2) ) }) # data frame flatten ------------------------------------------------------ test_that("can flatten to a data frame with named lists", { skip_if_not_installed("dplyr") expect_is(flatten_dfr(list(c(a = 1), c(b = 2))), "data.frame") expect_equal(flatten_dfc(list(1)), tibble::tibble(V1 = 1)) }) purrr/tests/testthat/test-map2.R0000644000176200001440000000374513551356667016417 0ustar liggesuserscontext("map2") test_that("map2 inputs must be same length", { expect_error( map2(1:3, 2:3, function(...) NULL), paste_line( "Mapped vectors must have consistent lengths:", "\\* `.x` has length 3", "\\* `.y` has length 2" ) ) }) test_that("map2 can't simplify if elements longer than length 1", { expect_bad_element_vector_error( map2_int(1:4, 5:8, range), "Result 1 must be a single integer, not an integer vector of length 2" ) }) test_that("fails on non-vectors", { expect_bad_type_error(map2(environment(), "a", identity), "`.x` must be a vector, not an environment") expect_bad_type_error(map2("a", environment(), identity), "`.y` must be a vector, not an environment") }) test_that("map2 vectorised inputs of length 1", { expect_equal(map2(1:2, 1, `+`), list(2, 3)) expect_equal(map2(1, 1:2, `+`), list(2, 3)) }) test_that("any 0 length input gives 0 length output", { expect_equal(map2(list(), list(), ~ 1), list()) expect_equal(map2(1:10, list(), ~ 1), list()) expect_equal(map2(list(), 1:10, ~ 1), list()) expect_equal(map2(NULL, NULL, ~ 1), list()) expect_equal(map2(1:10, NULL, ~ 1), list()) expect_equal(map2(NULL, 1:10, ~ 1), list()) }) test_that("map2 takes only names from x", { x1 <- 1:3 x2 <- set_names(x1) expect_equal(names(map2(x1, x2, `+`)), NULL) expect_equal(names(map2(x2, x1, `+`)), names(x2)) }) test_that("map2 always returns a list", { expect_is(map2(mtcars, 0, ~mtcars), "list") }) test_that("map2() with empty input copies names", { named_list <- named(list()) expect_identical( map2(named_list, list(), identity), named(list())) expect_identical(map2_lgl(named_list, list(), identity), named(lgl())) expect_identical(map2_int(named_list, list(), identity), named(int())) expect_identical(map2_dbl(named_list, list(), identity), named(dbl())) expect_identical(map2_chr(named_list, list(), identity), named(chr())) expect_identical(map2_raw(named_list, list(), identity), named(raw())) }) purrr/tests/testthat/test-imap.R0000644000176200001440000000143313435007002016447 0ustar liggesuserscontext("imap") x <- 1:3 %>% set_names() test_that("imap is special case of map2", { expect_identical(imap(x, paste), map2(x, names(x), paste)) }) test_that("imap always returns a list", { expect_is(imap(x, paste), "list") }) test_that("atomic vector imap works", { expect_true(all(imap_lgl(x, `==`))) expect_length(imap_chr(x, paste), 3) expect_equal(imap_int(x, ~ .x + as.integer(.y)), x * 2) expect_equal(imap_dbl(x, ~ .x + as.numeric(.y)), x * 2) expect_equal(imap_raw(as.raw(12), rawShift), rawShift(as.raw(12), 1) ) }) test_that("data frame imap works", { skip_if_not_installed("dplyr") expect_identical(imap_dfc(x, paste), imap_dfr(x, paste)) }) test_that("iwalk returns invisibly", { expect_output(iwalk(mtcars, ~ cat(.y, ": ", median(.x), "\n", sep = ""))) }) purrr/tests/testthat/test-arrays.R0000644000176200001440000000214113426303100017015 0ustar liggesuserscontext("arrays") x <- array(1:12, c(2, 2, 3), dimnames = list(letters[1:2], LETTERS[1:2], NULL)) test_that("array_branch creates a flat list when no margin specified", { expect_length(array_branch(x), 12) }) test_that("array_branch wraps array in list when margin has length 0", { expect_identical(array_branch(x, numeric(0)), list(x)) }) test_that("array_branch works on vectors", { expect_identical(array_branch(1:3), list(1L, 2L, 3L)) expect_identical(array_branch(1:3, 1), list(1L, 2L, 3L)) }) test_that("array_branch throws an error for wrong margins on a vector", { expect_error(array_branch(1:3, 2), "must be `NULL` or `1`") }) test_that("length depends on whether list is flattened or not", { m1 <- c(3, 1) m2 <- 3 expect_length(array_branch(x, m1), prod(dim(x)[m1])) expect_length(array_tree(x, m1), prod(dim(x)[m2])) }) test_that("array_branch retains dimnames when going over one dimension", { expect_identical(names(array_branch(x, 1)), letters[1:2]) expect_identical(names(array_branch(x, 2)), LETTERS[1:2]) expect_identical(names(array_branch(x, 2:3)[[1]]), letters[1:2]) }) purrr/tests/testthat/test-rerun.R0000644000176200001440000000073213403735151016665 0ustar liggesuserscontext("rerun") test_that("single unnamed arg doesn't get extra list", { expect_equal(rerun(2, 1), list(1, 1)) }) test_that("single named arg gets extra list", { expect_equal(rerun(2, a = 1), list(list(a = 1), list(a = 1))) }) test_that("every run is different", { x <- rerun(2, runif(1)) expect_true(x[[1]] != x[[2]]) }) test_that("rerun uses scope of expression", { f <- function(n) { rerun(1, x = seq_len(n)) } expect_equal(f(10)[[1]]$x, 1:10) }) purrr/tests/testthat/test-map_n.R0000644000176200001440000000671113551356667016646 0ustar liggesuserscontext("pmap") test_that("input must be a list of vectors", { expect_bad_type_error(pmap(environment(), identity), "`.l` must be a list, not an environment") expect_bad_type_error(pmap(list(environment()), identity), "Element 1 of `.l` must be a vector, not an environment") }) test_that("elements must be same length", { expect_bad_element_length_error(pmap(list(1:2, 1:3), identity), "Element 1 of `.l` must have length 1 or 3, not 2") }) test_that("handles any length 0 input", { expect_equal(pmap(list(list(), list(), list()), ~ 1), list()) expect_equal(pmap(list(NULL, NULL, NULL), ~ 1), list()) expect_equal(pmap(list(list(), list(), 1:10), ~ 1), list()) expect_equal(pmap(list(NULL, NULL, 1:10), ~ 1), list()) }) test_that("length 1 elemetns are recycled", { out <- pmap(list(1:2, 1), c) expect_equal(out, list(c(1, 1), c(2, 1))) }) test_that(".f called with named arguments", { out <- pmap(list(x = 1, 2, y = 3), list)[[1]] expect_equal(names(out), c("x", "", "y")) }) test_that("names are preserved", { out <- pmap(list(c(x = 1, y = 2), 3:4), list) expect_equal(names(out), c("x", "y")) }) test_that("... are passed on", { out <- pmap(list(x = 1:2), list, n = 1) expect_equal(out, list( list(x = 1, n = 1), list(x = 2, n = 1) )) }) test_that("outputs are suffixes have correct type", { x <- 1:3 expect_is(pmap_lgl(list(x), is.numeric), "logical") expect_is(pmap_int(list(x), length), "integer") expect_is(pmap_dbl(list(x), mean), "numeric") expect_is(pmap_chr(list(x), paste), "character") expect_is(pmap_raw(list(x), as.raw), "raw") }) test_that("outputs are suffixes have correct type for data frames", { skip_if_not_installed("dplyr") x <- 1:3 expect_is(pmap_dfr(list(x), as.data.frame), "data.frame") expect_is(pmap_dfc(list(x), as.data.frame), "data.frame") }) test_that("pmap on data frames performs rowwise operations", { mtcars2 <- mtcars[c("mpg", "cyl")] expect_length(pmap(mtcars2, paste), nrow(mtcars)) expect_is(pmap_lgl(mtcars2, function(mpg, cyl) mpg > cyl), "logical") expect_is(pmap_int(mtcars2, function(mpg, cyl) as.integer(cyl)), "integer") expect_is(pmap_dbl(mtcars2, function(mpg, cyl) mpg + cyl), "numeric") expect_is(pmap_chr(mtcars2, paste), "character") expect_is(pmap_raw(mtcars2, function(mpg, cyl) as.raw(cyl)), "raw") }) test_that("pmap works with empty lists", { expect_identical(pmap(list(), identity), list()) }) test_that("preserves S3 class of input vectors (#358)", { date <- as.Date("2018-09-27") expect_equal(pmap(list(date), identity), list(date)) expect_output(pwalk(list(date), print), format(date)) }) test_that("walk2() and pwalk() don't evaluate symbolic objects", { walk2(exprs(1 + 2), NA, ~ expect_identical(.x, quote(1 + 2))) pwalk(list(exprs(1 + 2)), ~ expect_identical(.x, quote(1 + 2))) }) test_that("map2() and pmap() don't evaluate symbolic objects", { map2(exprs(1 + 2), NA, ~ expect_identical(.x, quote(1 + 2))) pmap(list(exprs(1 + 2)), ~ expect_identical(.x, quote(1 + 2))) }) test_that("pmap() with empty input copies names", { named_list <- list(named(list())) expect_identical( pmap(named_list, identity), named(list())) expect_identical(pmap_lgl(named_list, identity), named(lgl())) expect_identical(pmap_int(named_list, identity), named(int())) expect_identical(pmap_dbl(named_list, identity), named(dbl())) expect_identical(pmap_chr(named_list, identity), named(chr())) expect_identical(pmap_raw(named_list, identity), named(raw())) }) purrr/tests/testthat/setup.R0000644000176200001440000000004213426303100015675 0ustar liggesusersSys.setlocale("LC_MESSAGES", "C") purrr/tests/testthat/test-partial.R0000644000176200001440000001033713551356667017207 0ustar liggesuserscontext("partial") test_that("dots are correctly placed in the signature", { out <- partialised_body(partial(runif, n = rpois(1, 5))) exp <- quo((!!runif)(n = rpois(1, 5), ...)) expect_identical(out, exp) }) test_that("no lazy evaluation means arguments aren't repeatedly evaluated", { counter <- env(n = 0) lazy <- partial(list, n = { counter$n <- counter$n + 1; NULL }) walk(1:10, ~lazy()) expect_identical(counter$n, 10) counter <- env(n = 0) qq <- partial(list, n = !!{ counter$n <- counter$n + 1; NULL }) walk(1:10, ~qq()) expect_identical(counter$n, 1) }) test_that("partial() still works with functions using `missing()`", { fn <- function(x) missing(x) expect_false(partial(fn, x = 3)()) }) test_that("partialised arguments are evaluated in their environments", { n <- 0 partialised <- local({ n <- 10 partial(list, n = n) }) expect_identical(partialised(), list(n = 10)) }) test_that("partialised function is evaluated in its environment", { fn <- function(...) stop("tilt") partialised <- local({ fn <- function(x) x partial(fn, x = "foo") }) expect_identical(partialised(), "foo") }) test_that("partial() supports quosures", { arg <- local({ n <- 0 quo({ n <<- n + 1; n}) }) fn <- partial(list, !!arg) expect_identical(fn(), list(1)) expect_identical(fn(), list(2)) }) test_that("partial() matches argument with primitives", { minus <- partial(`-`, .y = 5) expect_identical(minus(1), -4) }) test_that("partial() squashes quosures before printing", { expect_known_output(file = test_path("test-partial-print.txt"), { foo <- function(x, y) y print(partial(foo, y = 3)) }) }) test_that("partial() handles primitives with named arguments after `...`", { expect_identical(partial(min, na.rm = TRUE)(1, NA), 1) expect_true(is_na(partial(min, na.rm = FALSE)(1, NA))) }) test_that("partialised function does not infloop when given the same name (#387)", { fn <- function(...) "foo" fn <- partial(fn) expect_identical(fn(), "foo") }) test_that("partial() handles `... =` arguments", { fn <- function(...) list(...) default <- partial(fn, "partial") expect_identical(default(1), list("partial", 1)) after <- partial(fn, "partial", ... = ) expect_identical(after(1), list("partial", 1)) before <- partial(fn, ... = , "partial") expect_identical(before(1), list(1, "partial")) }) test_that("partial() supports substituted arguments", { fn <- function(x) substitute(x) fn <- partial(fn, letters) expect_identical(fn(), quote(letters)) }) test_that("partial() supports generics (#647)", { expect_identical(partial(mean, na.rm = TRUE)(1), 1) foo <- TRUE expect_identical(partial(mean, na.rm = foo)(1), 1) }) test_that("partial() supports lexically defined methods in the def env", { local({ mean.purrr__foobar <- function(...) TRUE foobar <- structure(list(), class = "purrr__foobar") expect_true(partial(mean, na.rm = TRUE)(foobar)) expect_true(partial(mean, trim = letters, na.rm = TRUE)(foobar)) }) }) # Life cycle -------------------------------------------------------------- test_that("`.lazy`, `.env`, and `.first` are soft-deprecated", { scoped_lifecycle_warnings() expect_warning(partial(list, "foo", .lazy = TRUE), "soft-deprecated") expect_warning(partial(list, "foo", .env = env()), "soft-deprecated") expect_warning(partial(list, "foo", .first = TRUE, "soft-deprecated")) }) test_that("`.lazy` still works", { scoped_options(lifecycle_disable_warnings = TRUE) counter <- env(n = 0) eager <- partial(list, n = { counter$n <- counter$n + 1; NULL }, .lazy = FALSE) walk(1:10, ~eager()) expect_identical(counter$n, 1) }) test_that("`.first` still works", { scoped_options(lifecycle_disable_warnings = TRUE) out <- partialised_body(partial(runif, n = rpois(1, 5), .first = FALSE)) exp <- quo((!!runif)(..., n = rpois(1, 5))) expect_identical(out, exp) # partial() also works without partialised arguments expect_identical(partialised_body(partial(runif, .first = TRUE)), quo((!!runif)(...))) expect_identical(partialised_body(partial(runif, .first = FALSE)), quo((!!runif)(...))) }) test_that("`...f` still works", { expect_error(partial(...f = list, x = "foo"), "renamed", class = "defunctError") }) purrr/tests/testthat/helper-conditions.R0000644000176200001440000000154213551356667020222 0ustar liggesusers expect_error_cnd <- function(expr, regexp, class, ...) { err <- catch_cnd(expr) expect_true(inherits_all(err, c(class, "error", "condition"))) expect_match(conditionMessage(err), regexp, ...) } expect_bad_type_error <- function(object, regexp = NULL, ...) { expect_error(!!enquo(object), regexp = regexp, class = "purrr_error_bad_type", ...) } expect_bad_element_type_error <- function(object, regexp = NULL, ...) { expect_error(!!enquo(object), regexp = regexp, class = "purrr_error_bad_element_type", ...) } expect_bad_element_length_error <- function(object, regexp = NULL, ...) { expect_error(!!enquo(object), regexp = regexp, class = "purrr_error_bad_element_length", ...) } expect_bad_element_vector_error <- function(object, regexp = NULL, ...) { expect_error(!!enquo(object), regexp = regexp, class = "purrr_error_bad_element_vector", ...) } purrr/tests/testthat/test-predicates.R0000644000176200001440000000122513426303100017641 0ustar liggesuserscontext("predicates") test_that("predicate-based functionals work with logical vectors", { expect_equal(keep(as.list(1:3), c(TRUE, FALSE, TRUE)), list(1, 3)) expect_equal(discard(as.list(1:3), c(TRUE, FALSE, TRUE)), list(2)) expect_equal( modify_if(as.list(1:3), c(TRUE, FALSE, TRUE), as.character), list("1", 2, "3") ) expect_equal( lmap_if(as.list(1:3), c(TRUE, FALSE, TRUE), ~list(as.character(.x[[1]]))), list("1", 2, "3") ) }) test_that("keep() and discard() require predicate functions", { expect_error(keep(1:3, ~ NA), ", not a missing value") expect_error(discard(1:3, ~ 1:3), ", not an integer vector of length 3") }) purrr/tests/testthat/test-negate.R0000644000176200001440000000113413435516766017010 0ustar liggesuserscontext("negate") test_that("negate works with both functions and vectors", { true <- function(...) TRUE expect_equal(negate(true)(), FALSE) expect_equal(negate("x")(list(x = TRUE)), FALSE) expect_equal(negate(is.null)(TRUE), TRUE) expect_equal(negate(is.null)(NULL), FALSE) }) test_that("negate() works with early returns", { expect_false(negate(~ return(TRUE))()) }) test_that("negate() works with generic functions and local methods", { is_foobar <- function(x) UseMethod("is_foobar") local({ is_foobar.default <- function(x) TRUE expect_false(negate(is_foobar)()) }) }) purrr/tests/testthat/test-cross.R0000644000176200001440000000157413435453655016703 0ustar liggesuserscontext("cross") test_that("long format corresponds to expand.grid output", { skip_if_not_installed("tibble") x <- list(a = 1:3, b = 4:9) out1 <- cross_df(x) out2 <- expand.grid(x, KEEP.OUT.ATTRS = FALSE) %>% tibble::as_tibble() expect_equal(out1, out2) }) test_that("filtering works", { filter <- function(x, y) x >= y out <- cross2(1:3, 1:3, .filter = filter) expect_equal(out, list(list(1, 2), list(1, 3), list(2, 3))) }) test_that("filtering requires a predicate function", { expect_error(cross2(1:3, 1:3, .filter = ~ c(TRUE, TRUE)), "not a logical vector of length 2") }) test_that("filtering fails when filter function doesn't return a logical", { filter <- function(x, y, z) x + y + z expect_error(cross3(1:3, 1:3, 1:3, .filter = filter)) }) test_that("works with empty input", { expect_equal(cross(list()), list()) expect_equal(cross(NULL), NULL) }) purrr/tests/testthat/test-prepend.R0000644000176200001440000000160013551356667017201 0ustar liggesuserscontext("prepend") test_that("prepend is clearer version of merging with c()", { x <- 1:3 expect_identical( x %>% prepend(4), x %>% c(4, .) ) expect_identical( x %>% prepend(4, before = 3), x %>% { c(.[1:2], 4, .[3]) } ) }) test_that("prepend appends at the beginning for empty list by default", { x <- list() expect_identical( x %>% prepend(1), x %>% c(1, .) ) }) test_that("prepend throws error if before param is neither NULL nor between 1 and length(x)", { expect_error( prepend(list(), 1, before = 1), "is.null(before) || (before > 0 && before <= n) is not TRUE" ) x <- as.list(1:3) expect_error( x %>% prepend(4, before = 0), "is.null(before) || (before > 0 && before <= n) is not TRUE" ) expect_error( x %>% prepend(4, before = 4), "is.null(before) || (before > 0 && before <= n) is not TRUE" ) }) purrr/tests/testthat/test-chuck.R0000644000176200001440000000455413551356667016654 0ustar liggesuserscontext("chuck") # NULL input ---------------------------------------------------------------- test_that("trying to chuck NULL raises errors", { expect_error(chuck(NULL, "a"), "can't be NULL") }) # chuck vector -------------------------------------------------------------- test_that("special indexes raise errors", { x <- list(a = 1, b = 2, c = 3) expect_error(chuck(x, NA_character_), "can't be NA") expect_error(chuck(x, ""), "can't be an empty string") expect_error(chuck(x, NA_integer_), "must be finite") expect_error(chuck(x, NA_real_), "must be finite") expect_error(chuck(x, NaN), "must be finite") expect_error(chuck(x, Inf), "must be finite") expect_error(chuck(x, -Inf), "must be finite") expect_bad_element_length_error(chuck(x, integer(0)), "must have length 1") }) test_that("halts on named vector errors", { # unnamed input expect_error(chuck(1:2, "a"), "pluck from an unnamed vector") # name doesn't exist expect_error(chuck(setNames(1:2, c("a", "b")), "c"), "Can't find name") }) test_that("indices outside of vector length raise errors", { # zero length input expect_error(chuck(integer(), 1), "must have at least one element") # past end expect_error(chuck(1:4, 10), "exceeds the length of plucked object") expect_error(chuck(1:4, 10L), "exceeds the length of plucked object") # before start expect_error(chuck(1:4, -1), "must be greater than 0") expect_error(chuck(1:4, -1L), "must be greater than 0") }) test_that("handles weird names", { x <- list(1, 2, 3, 4, 5) names(x) <- c("a", "a", NA_character_, "", "b") expect_error(chuck(x, ""), "can't be an empty string") expect_error(chuck(x, NA_character_), "can't be NA") }) # environments ------------------------------------------------------------ test_that("raises error with missing index", { expect_error(chuck(environment(), NA_character_), "can't be NA") }) test_that("non-existent object name raises error", { expect_error(chuck(emptyenv(), "x"), "Can't find object") }) # S4 ---------------------------------------------------------------------- newA <- methods::setClass("A", list(a = "numeric", b = "numeric")) A <- newA(a = 1, b = 10) test_that("raises error for NA index on S4 object", { expect_error(chuck(A, NA_character_), "can't be NA") }) test_that("can't chuck if S4 slot doesn't exist", { expect_error(chuck(A, "c"), "Can't find slot") }) purrr/tests/testthat/test-lmap.R0000644000176200001440000000227713435453655016504 0ustar liggesuserscontext("lmap") test_that("lmap output is list if input is list", { expect_is(lmap(as.list(mtcars), as.list), "list") skip_if_not_installed("tidyselect") x <- list(a = 1:4, b = letters[5:7], c = 8:9, d = letters[10]) maybe_rep <- function(x) { n <- rpois(1, 2) out <- rep_len(x, n) if (length(out) > 0) { names(out) <- paste0(names(x), seq_len(n)) } out } expect_is(lmap_at(x, vars(tidyselect::contains("a")), maybe_rep), "list") }) test_that("lmap output is tibble if input is data frame", { skip_if_not_installed("tibble") expect_is(lmap(mtcars, as.list), "tbl_df") skip_if_not_installed("tidyselect") expect_is(lmap_at(mtcars, vars(tidyselect::contains("mpg")), ~ .x * 10), "tbl_df") }) test_that("lmap_at can use tidyselect", { skip_if_not_installed("tidyselect") x <- lmap_at(mtcars, vars(tidyselect::contains("vs")), ~ .x + 10) expect_equal(x$vs[1], 10) }) test_that("`.else` preserve-maps false elements", { out <- lmap_if(list(a = 1, b = "foo"), is.character, ~ list("foo", .x, .y), .else = ~ list("bar", .x, .y), "baz") exp <- set_names(list("bar", list(a = 1), "baz", "foo", list(b = "foo"), "baz"), rep("", 6)) expect_identical(out, exp) }) purrr/tests/testthat/test-modify.R0000644000176200001440000001210313426303100017002 0ustar liggesuserscontext("modify") test_that("modify returns same type as input", { df1 <- data.frame(x = 1:3, y = 4:6) expect_equal(modify(df1, length), data.frame(x = rep(3, 3), y = rep(3, 3))) }) test_that("modify_if/modify_at return same type as input", { df1 <- data.frame(x = "a", y = 2, stringsAsFactors = FALSE) exp <- data.frame(x = "A", y = 2, stringsAsFactors = FALSE) df2a <- modify_if(df1, is.character, toupper) expect_equal(df2a, exp) df2b <- modify_at(df1, "x", toupper) expect_equal(df2b, exp) }) test_that("modify_at requires a named object", { df1 <- data.frame(x = "a", y = 2, stringsAsFactors = FALSE) expect_error(modify_at(unname(df1), "x", toupper)) }) test_that("modify_at operates on character and numeric indexing", { df1 <- data.frame(x = "a", y = 2, stringsAsFactors = FALSE) expect_error(modify_at(df1, TRUE, toupper)) }) test_that("negative .at omits locations", { x <- list(1, 2, 3) out <- modify_at(x, -1, ~ .x * 2) expect_equal(out, list(1, 4, 6)) }) test_that("modify works with calls and pairlists", { out <- modify(quote(f(x)), ~ quote(z)) expect_equal(out, quote(z(z))) out <- modify(pairlist(1, 2), ~ . + 1) expect_equal(out, pairlist(2, 3)) }) test_that("modify{,_at,_if} preserves atomic vector classes", { expect_type(modify("a", identity), "character") expect_type(modify(1L, identity), "integer") expect_type(modify(1, identity), "double") expect_type(modify(TRUE, identity), "logical") expect_type(modify_at("a", 1L, identity), "character") expect_type(modify_at(1L, 1L, identity), "integer") expect_type(modify_at(1, 1L, identity), "double") expect_type(modify_at(TRUE, 1L, identity), "logical") expect_type(modify_if("a", TRUE, identity), "character") expect_type(modify_if(1L, TRUE, identity), "integer") expect_type(modify_if(1, TRUE, identity), "double") expect_type(modify_if(TRUE, TRUE, identity), "logical") }) test_that("modify() and variants implement sane coercion rules for base vectors", { expect_error(modify(1:3, ~ "foo"), "Can't coerce") expect_error(modify_at(1:3, 1, ~ "foo"), "Can't coerce") expect_error(modify_if(1:3, is_integer, ~ "foo"), "Can't coerce") expect_error(modify2(1:3, "foo", ~ .y), "Can't coerce") }) test_that("modify2() and imodify() preserve type of first input", { x <- c(foo = 1L, bar = 2L) y <- c(TRUE, FALSE) expect_identical(modify2(x, y, ~ if (.y) .x else 0L), c(foo = 1L, bar = 0L)) out <- imodify(mtcars, paste) expect_is(out, "data.frame") expect_identical(out$vs, paste(mtcars$vs, "vs")) }) test_that("modify2() recycles arguments", { expect_identical(modify2(1:3, 1L, `+`), int(2, 3, 4)) expect_identical(modify2(1, 1:3, `+`), dbl(2, 3, 4)) expect_identical(modify2(mtcars, seq_along(mtcars), `+`)$carb, mtcars$carb + ncol(mtcars)) expect_identical(modify2(mtcars, 1, `+`)$carb, mtcars$carb + 1L) }) test_that("modify_if() requires predicate functions", { expect_error(modify_if(list(1, 2), ~ NA, ~ "foo"), ", not a missing value") expect_error(modify_if(1:2, ~ c(TRUE, FALSE), ~ "foo"), ", not a logical vector of length 2") }) test_that("`.else` modifies false elements", { exp <- modify_if(iris, negate(is.factor), as.integer) exp <- modify_if(exp, is.factor, as.character) expect_identical(modify_if(iris, is.factor, as.character, .else = as.integer), exp) }) # modify_depth ------------------------------------------------------------ test_that("modify_depth modifies values at specified depth", { x1 <- list(list(list(1:3, 4:6))) expect_equal(modify_depth(x1, 0, length), list(1)) expect_equal(modify_depth(x1, 1, length), list(1)) expect_equal(modify_depth(x1, 2, length), list(list(2))) expect_equal(modify_depth(x1, 3, length), list(list(list(3, 3)))) expect_equal(modify_depth(x1, -1, length), list(list(list(3, 3)))) expect_equal(modify_depth(x1, 4, length), list(list(list(c(1, 1, 1), c(1, 1, 1))))) expect_error(modify_depth(x1, 5, length), "List not deep enough") expect_error(modify_depth(x1, 6, length), "List not deep enough") expect_error(modify_depth(x1, -5, length), "Invalid depth") }) test_that(".ragged = TRUE operates on leaves", { x1 <- list( list(1), list(list(2)) ) x2 <- list( list(2), list(list(3)) ) expect_equal(modify_depth(x1, 3, ~ . + 1, .ragged = TRUE), x2) expect_equal(modify_depth(x1, -1, ~ . + 1, .ragged = TRUE), x2) # .ragged should be TRUE is .depth < 0 expect_equal(modify_depth(x1, -1, ~ . + 1), x2) }) test_that("vectorised operations on the recursive and atomic levels yield same results", { x <- list(list(list(1:3, 4:6))) exp <- list(list(list(11:13, 14:16))) expect_identical(modify_depth(x, 3, `+`, 10L), exp) expect_identical(modify_depth(x, 4, `+`, 10L), exp) expect_error(modify_depth(x, 5, `+`, 10L), "not deep enough") }) test_that("modify_at() can use tidyselect", { skip_if_not_installed("tidyselect") one <- modify_at(mtcars, vars(cyl, am), as.character) expect_is(one$cyl, "character") expect_is(one$am, "character") two <- modify_at(mtcars, vars(tidyselect::contains("cyl")), as.character) expect_is(two$cyl, "character") }) purrr/tests/testthat/test-when.R0000644000176200001440000000201313403735151016465 0ustar liggesuserscontext("when") test_that("when chooses the correct action", { x <- 1:5 %>% when( sum(.) <= 50 ~ sum(.), sum(.) <= 100 ~ sum(.) / 2, ~ 0 ) expect_equal(x, 15) y <- 1:10 %>% when( sum(.) <= 50 ~ sum(.), sum(.) <= 100 ~ sum(.) / 2, ~ 0 ) expect_equal(y, sum(1:10) / 2) z <- 1:100 %>% when( sum(.) <= 50 ~ sum(.), sum(.) <= 100 ~ sum(.) / 2, ~ 0 ) expect_equal(z, 0) }) test_that("named arguments work with when", { x <- 1:10 %>% when( sum(.) <= x ~ sum(.) * x, sum(.) <= 2 * x ~ sum(.) * x / 2, ~ 0, x = 60 ) expect_equal(x, sum(1:10) * 60) }) test_that("default values work without a formula", { x <- iris %>% subset(Sepal.Length > 10) %>% when( nrow(.) > 0 ~ ., head(iris, 10) ) expect_equivalent(x, head(iris, 10)) }) test_that("error when named arguments have no matching conditions", { expect_error(1:5 %>% when(a = sum(.) < 5 ~ 3)) }) purrr/tests/testthat/helper-map.R0000644000176200001440000000013313435215546016610 0ustar liggesusers named <- function(x) set_names(x, chr()) # Until we can reexport from rlang vars <- quos purrr/tests/testthat/test-retired-invoke.R0000644000176200001440000000332313435007002020450 0ustar liggesuserscontext("retired-invoke") # invoke ------------------------------------------------------------------ test_that("invoke() evaluates expressions in the right environment", { x <- letters f <- toupper expect_equal(invoke("f", quote(x)), toupper(letters)) }) test_that("invoke() follows promises to find the evaluation env", { x <- letters f <- toupper f1 <- function(y) { f2 <- function(z) purrr::invoke(z, quote(x)) f2(y) } expect_equal(f1("f"), toupper(letters)) }) # invoke_map -------------------------------------------------------------- test_that("invoke_map() works with bare function", { data <- list(1:2, 3:4) expected <- list("1 2", "3 4") expect_equal(invoke_map(paste, data), expected) expect_equal(invoke_map("paste", data), expected) expect_equal(invoke_map_chr(paste, data), unlist(expected)) expect_identical(invoke_map_dbl(`+`, data), c(3, 7)) expect_identical(invoke_map_int(`+`, data), c(3L, 7L)) expect_identical(invoke_map_lgl(`&&`, data), c(TRUE, TRUE)) expect_identical(invoke_map_raw(identity, as.raw(1:3)), as.raw(1:3)) }) test_that("invoke_map() works with bare function with data frames", { skip_if_not_installed("dplyr") data <- list(1:2, 3:4) ops <- set_names(c(`+`, `-`), c("a", "b")) expect_identical(invoke_map_dfr(ops, data), invoke_map_dfc(ops, data)) }) test_that("invoke_map() evaluates expressions in the right environment", { shadowed_object <- letters shadowed_fun <- toupper expect_equal( invoke_map("shadowed_fun", list(quote(shadowed_object))), list(toupper(letters)) ) }) test_that("invoke_maps doesn't rely on c() returning list", { day <- as.Date("2016-09-01") expect_equal(invoke_map(identity, list(day)), list(day)) }) purrr/tests/testthat/test-splice.R0000644000176200001440000000101113403735151017000 0ustar liggesuserscontext("splice") test_that("predicate controls which elements get spliced", { x <- list(1, 2, list(3, 4)) expect_equal(splice_if(x, ~ FALSE), x) expect_equal(splice_if(x, is.list), list(1, 2, 3, 4)) }) test_that("splice() produces correctly named lists", { inputs <- list(arg1 = "a", arg2 = "b") out1 <- splice(inputs, arg3 = c("c1", "c2")) expect_named(out1, c("arg1", "arg2", "arg3")) out2 <- splice(inputs, arg = list(arg3 = 1, arg4 = 2)) expect_named(out2, c("arg1", "arg2", "arg3", "arg4")) }) purrr/tests/testthat/test-as-mapper.R0000644000176200001440000000432713413636343017427 0ustar liggesuserscontext("as_mapper") # formulas ---------------------------------------------------------------- test_that("can refer to first argument in three ways", { expect_equal(map_dbl(1, ~ . + 1), 2) expect_equal(map_dbl(1, ~ .x + 1), 2) expect_equal(map_dbl(1, ~ ..1 + 1), 2) }) test_that("can refer to second arg in two ways", { expect_equal(map2_dbl(1, 2, ~ .x + .y + 1), 4) expect_equal(map2_dbl(1, 2, ~ ..1 + ..2 + 1), 4) }) # vectors -------------------------------------------------------------- # test_that(".null generates warning", { # expect_warning(map(1, 2, .null = NA), "`.null` is deprecated") # }) test_that(".default replaces absent values", { x <- list( list(a = 1, b = 2, c = 3), list(a = 1, c = 2), NULL ) expect_equal(map_dbl(x, 3, .default = NA), c(3, NA, NA)) expect_equal(map_dbl(x, "b", .default = NA), c(2, NA, NA)) }) test_that(".default replaces elements with length 0", { x <- list( list(a = 1), list(a = NULL), list(a = numeric()) ) expect_equal(map_dbl(x, "a", .default = NA), c(1, NA, NA)) }) test_that("Additional arguments are ignored", { expect_equal(as_mapper(function() NULL, foo = "bar", foobar), function() NULL) }) test_that("can supply length > 1 vectors", { expect_identical(as_mapper(1:2)(list(list("a", "b"))), "b") expect_identical(as_mapper(c("a", "b"))(list(a = list("a", b = "b"))), "b") }) # primitive functions -------------------------------------------------- test_that("primitive functions are wrapped", { expect_identical(as_mapper(`-`)(.y = 10, .x = 5), -5) expect_identical(as_mapper(`c`)(1, 3, 5), c(1, 3, 5)) }) test_that("syntactic primitives are wrapped", { expect_identical(as_mapper(`[[`)(mtcars, "cyl"), mtcars$cyl) expect_identical(as_mapper(`$`)(mtcars, cyl), mtcars$cyl) }) # lists ------------------------------------------------------------------ test_that("lists are wrapped", { mapper_list <- as_mapper(list("mpg", 5))(mtcars) base_list <- mtcars[["mpg"]][[5]] expect_identical(mapper_list, base_list) }) test_that("complex types aren't supported for indexing", { expect_error(as_mapper(1)(complex(2))) }) test_that("raw vectors are supported for indexing", { expect_equal( as_mapper(1)(raw(2)), raw(1) ) }) purrr/tests/testthat/test-list-modify-update.R0000644000176200001440000000646313426303100021247 0ustar liggesuserscontext("list-modify") # list_modify ------------------------------------------------------------- test_that("named lists have values replaced by name", { expect_equal(list_modify(list(a = 1), b = 2), list(a = 1, b = 2)) expect_equal(list_modify(list(a = 1), a = 2), list(a = 2)) expect_equal(list_modify(list(a = 1, b = 2), b = zap()), list(a = 1)) }) test_that("unnamed lists are replaced by position", { expect_equal(list_modify(list(3), 1, 2), list(1, 2)) expect_equal(list_modify(list(1, 2, 3), 4), list(4, 2, 3)) }) test_that("can remove elements with `zap()`", { expect_equal(list_modify(list(1, 2, 3), zap(), zap()), list(3)) expect_equal(list_modify(list(a = 1, b = 2, c = 3), b = zap(), a = zap()), list(c = 3)) }) test_that("error if inputs are not all named or unnamed", { expect_error( list_modify(list(a = 1), 2, a = 2), "must be either all named, or all unnamed" ) }) test_that("can update unnamed lists with named inputs", { expect_identical(list_modify(list(1), a = 2), list(1, a = 2)) }) test_that("can update named lists with unnamed inputs", { expect_identical(list_modify(list(a = 1, b = 2), 2), list(a = 2, b = 2)) expect_identical(list_modify(list(a = 1, b = 2), 2, 3, 4), list(a = 2, b = 3, 4)) }) test_that("lists are replaced recursively", { expect_equal( list_modify( list(a = list(x = 1)), a = list(x = 2) ), list(a = list(x = 2)) ) expect_equal( list_modify( list(a = list(x = 1)), a = list(y = 2) ), list(a = list(x = 1, y = 2)) ) }) test_that("duplicate names works", { expect_equal(list_modify(list(x = 1), x = 2, x = 3), list(x = 3)) }) # list_merge -------------------------------------------------------------- test_that("list_merge concatenates values from two lists", { l1 <- list(x = 1:10, y = 4, z = list(a = 1, b = 2)) l2 <- list(x = 11, z = list(a = 2:5, c = 3)) l <- list_merge(l1, !!! l2) expect_equal(l$x, c(l1$x, l2$x)) expect_equal(l$y, c(l1$y, l2$y)) expect_equal(l$z$a, c(l1$z$a, l2$z$a)) expect_equal(l$z$b, c(l1$z$b, l2$z$b)) expect_equal(l$z$c, c(l1$z$c, l2$z$c)) }) test_that("list_merge concatenates without needing names", { l1 <- list(1:10, 4, list(1, 2)) l2 <- list(11, 5, list(2:5, 3)) expect_length(list_merge(l1, !!! l2), 3) }) test_that("list_merge returns the non-empty list", { expect_equal(list_merge(list(3)), list(3)) expect_equal(list_merge(list(), 2), list(2)) }) test_that("list_merge handles duplicate names", { expect_equal(list_merge(list(x = 1), x = 2, x = 3), list(x = 1:3)) }) # update_list ------------------------------------------------------------ test_that("can modify element called x", { expect_equal(update_list(list(), x = 1), list(x = 1)) }) test_that("quosures and formulas are evaluated", { expect_identical(update_list(list(x = 1), y = quo(x + 1)), list(x = 1, y = 2)) expect_identical(update_list(list(x = 1), y = ~x + 1), list(x = 1, y = 2)) }) # Life cycle -------------------------------------------------------------- test_that("removing elements with `NULL` is deprecated", { scoped_lifecycle_warnings() expect_warning(list_modify(list(1, 2, 3), NULL, NULL), list(3), "deprecated") }) test_that("can still remove elements with `NULL`", { scoped_lifecycle_silence() expect_equal(list_modify(list(1, 2, 3), NULL, NULL), list(3)) }) purrr/tests/testthat/compose-print.txt0000644000176200001440000000016713551643172020001 0ustar liggesusersSingle input: 1. function(x) x + 1 Multiple inputs: 1. function(x) x / 1 2. function(x) x + 1 purrr/tests/testthat/test-detect.R0000644000176200001440000000252013426303100016765 0ustar liggesuserscontext("detect") y <- 4:10 test_that("detect functions work", { is_odd <- function(x) x %% 2 == 1 expect_equal(detect(y, is_odd), 5) expect_equal(detect_index(y, is_odd), 2) expect_equal(detect(y, is_odd, .dir = "backward"), 9) expect_equal(detect_index(y, is_odd, .dir = "backward"), 6) }) test_that("detect returns NULL when match not found", { expect_null(detect(y, function(x) x > 11)) }) test_that("detect_index returns 0 when match not found", { expect_equal(detect_index(y, function(x) x > 11), 0) }) test_that("has_element checks whether a list contains an object", { expect_true(has_element(list(1, 2), 1)) expect_false(has_element(list(1, 2), 3)) }) test_that("`detect()` requires a predicate function", { expect_error(detect(list(1:2, 2), is.na), "must return a single `TRUE` or `FALSE`") expect_error(detect(list(1:2, 2), function(...) NA), "not a missing value") }) # Lifecycle --------------------------------------------------------------- test_that("`.right` argument is retired", { scoped_lifecycle_warnings() expect_warning(detect(1:2, ~ TRUE, .right = TRUE), "soft-deprecated") }) test_that("`.right` argument still works", { scoped_lifecycle_silence() is_odd <- function(x) x %% 2 == 1 expect_equal(detect(y, is_odd, .right = TRUE), 9) expect_equal(detect_index(y, is_odd, .right = TRUE), 6) }) purrr/tests/testthat/test-partial-print.txt0000644000176200001440000000005613551643174020744 0ustar liggesusers function (...) foo(y = 3, ...) purrr/tests/testthat/test-utils.R0000644000176200001440000000510513435517376016705 0ustar liggesuserscontext("utils") test_that("rbernoulli is a special case of rbinom", { set.seed(1) x <- rbernoulli(10) set.seed(1) y <- ifelse(rbinom(10, 1, 0.5) == 1, TRUE, FALSE) expect_equal(x, y) }) test_that("rdunif works", { expect_length(rdunif(100, 10), 100) }) test_that("rdunif fails if a and b are not unit length numbers", { expect_error(rdunif(1000, 1, "a")) expect_error(rdunif(1000, 1, c(0.5, 0.2))) expect_error(rdunif(1000, FALSE, 2)) expect_error(rdunif(1000, c(2, 3), 2)) }) test_that("has_names returns vector of logicals", { expect_equal(has_names(letters %>% set_names()), rep_along(letters, TRUE)) expect_equal(has_names(letters), rep_along(letters, FALSE)) }) test_that("quo_invert() inverts quosured arguments", { call <- expr(list(!!quo(foo), !!quo(bar))) expect_identical(quo_invert(call), quo(list(foo, bar))) call <- expr(list(foo, !!quo(bar))) expect_identical(quo_invert(call), quo(list(foo, bar))) call <- expr(list(!!quo(foo), bar)) expect_identical(quo_invert(call), quo(list(foo, bar))) }) test_that("quo_invert() detects local quosures", { foo <- local(quo(foo)) call <- expr(list(!!foo, !!quo(bar))) expect_identical(quo_invert(call), new_quosure(expr(list(foo, !!quo(bar))), quo_get_env(foo))) bar <- local(quo(bar)) call <- expr(list(!!quo(foo), !!bar)) expect_identical(quo_invert(call), quo(list(foo, !!bar))) }) test_that("quo_invert() supports quosures in function position", { call <- expr((!!quo(list))(!!quo(foo), !!quo(bar))) expect_identical(quo_invert(call), quo(list(foo, bar))) fn <- local(quo(list)) env <- quo_get_env(fn) call <- expr((!!fn)(!!quo(foo), !!new_quosure(quote(bar), env))) expect_identical(quo_invert(call), new_quosure(expr(list(!!quo(foo), bar)), env)) }) test_that("quo_invert() supports quosures", { bar <- local(quo(bar)) call <- quo(list(!!quo(foo), !!bar)) expect_identical(quo_invert(call), quo(list(foo, !!bar))) foo <- quo(foo) call <- local(quo(list(!!foo, !!bar))) expect_identical(quo_invert(call), new_quosure(expr(list(!!foo, !!bar)), quo_get_env(call))) }) test_that("quo_invert() unwraps constants", { call <- expr(foo(!!quo(NULL))) expect_identical(quo_invert(call), quote(foo(NULL))) foo <- local(quo(foo)) call <- expr(foo(!!foo, !!quo(NULL))) expect_identical(quo_invert(call), new_quosure(quote(foo(foo, NULL)), quo_get_env(foo))) }) # Lifecycle --------------------------------------------------------------- test_that("%@% is an infix attribute accessor", { scoped_lifecycle_silence() expect_identical(mtcars %@% "names", attr(mtcars, "names")) }) purrr/tests/testthat/test-rate-print.txt0000644000176200001440000000022713551643175020244 0ustar liggesusers Attempts: 0/Inf Fields: * `pause`: 20.00 Attempts: 0/3 Fields: * `pause_base`: 1 * `pause_cap`: 60 * `pause_min`: 1 purrr/tests/testthat/test-rate.R0000644000176200001440000000541713426303100016460 0ustar liggesusers test_that("new_rate() creates rate objects", { rate <- new_rate("foo", jitter = FALSE, max_times = 10) expect_identical(rate$state$i, 0L) expect_identical(rate$max_times, 10) expect_false(rate$jitter) }) test_that("can bump and reset count", { rate <- new_rate("foo") rate_bump_count(rate) rate_bump_count(rate) expect_identical(rate_count(rate), 2L) rate_reset(rate) expect_identical(rate_count(rate), 0L) }) test_that("rates have print methods", { expect_known_output(file = test_path("test-rate-print.txt"), { # Also checks infinite `max_times` prints properly print(rate_delay(20, max_times = Inf)) cat_line() print(rate_backoff()) }) }) test_that("rate_delay() delays", { rate <- rate_delay( pause = 0.02, max_times = 3 ) rate_sleep(rate, quiet = FALSE) rate_reset(rate) msg <- catch_cnd(rate_sleep(rate)) expect_true(inherits_all(msg, c("purrr_condition_rate_init", "condition"))) msg <- catch_cnd(rate_sleep(rate, quiet = FALSE)) expect_true(inherits_all(msg, c("purrr_message_rate_retry", "message"))) expect_identical(msg$length, 0.02) msg <- catch_cnd(rate_sleep(rate, quiet = FALSE)) expect_identical(msg$length, 0.02) expect_error_cnd( rate_sleep(rate), "Request failed after 3 attempts", "purrr_error_rate_excess" ) expect_error_cnd( rate_sleep(rate), "has already be run more than `max_times`", "purrr_error_rate_expired" ) }) test_that("rate_backoff() backs off", { rate <- rate_backoff( pause_base = 0.02, pause_min = 0, jitter = FALSE ) msg <- catch_cnd(rate_sleep(rate)) expect_true(inherits_all(msg, c("purrr_condition_rate_init", "condition"))) msg <- catch_cnd(rate_sleep(rate, quiet = FALSE)) expect_true(inherits_all(msg, c("purrr_message_rate_retry", "message"))) expect_identical(msg$length, 0.04) msg <- catch_cnd(rate_sleep(rate, quiet = FALSE)) expect_identical(msg$length, 0.08) expect_error_cnd( rate_sleep(rate), "Request failed after 3 attempts", "purrr_error_rate_excess" ) expect_error_cnd( rate_sleep(rate), "has already be run more than", "purrr_error_rate_expired" ) }) test_that("rate_sleep() checks that rate is still valid", { rate <- rate_delay(1, max_times = 0) expect_error_cnd( rate_sleep(rate), "failed after 0 attempts", "purrr_error_rate_excess" ) expect_error_cnd( rate_sleep(rate), "already be run more than `max_times` allows", "purrr_error_rate_expired" ) }) test_that("insistently() resets rate state", { fn <- insistently(compose(), rate_delay(1, max_times = 0)) expect_error_cnd( fn(), "failed after 0 attempts", "purrr_error_rate_excess" ) expect_error_cnd( fn(), "failed after 0 attempts", "purrr_error_rate_excess" ) }) purrr/tests/testthat/test-simplify.R0000644000176200001440000000173513403735151017372 0ustar liggesuserscontext("simplify") test_that("can_simplify() understands vector molds", { x <- as.list(1:3) x2 <- c(x, list(1:3)) expect_true(can_simplify(x, integer(1))) expect_false(can_simplify(x, character(1))) expect_false(can_simplify(x2, integer(1))) x3 <- list(1:2, 3:4, 5:6) expect_true(can_simplify(x3, integer(2))) expect_false(can_simplify(x, integer(2))) }) test_that("can_simplify() understands types as strings", { x <- as.list(1:3) expect_true(can_simplify(x, "integer")) expect_false(can_simplify(x, "character")) }) test_that("integer is coercible to double", { x <- list(1L, 2L) expect_true(can_simplify(x, "numeric")) expect_true(can_simplify(x, numeric(1))) expect_true(can_simplify(x, "double")) expect_true(can_simplify(x, double(1))) }) test_that("numeric is an alias for double", { expect_true(can_simplify(list(1, 2), "numeric")) }) test_that("double is not coercible to integer", { expect_false(can_simplify(list(1, 2), "integer")) }) purrr/tests/testthat/test-composition.R0000644000176200001440000000146713426303100020071 0ustar liggesuserscontext("composition") test_that("lift_dl and lift_ld are inverses of each other", { expect_identical( sum %>% lift_dl(.unnamed = TRUE) %>% do.call(list(3, NA, 4, na.rm = TRUE)), sum %>% lift_dl() %>% lift_ld() %>% exec(3, NA, 4, na.rm = TRUE) ) }) test_that("lift_dv is from ... to c(...)", { expect_equal(lift_dv(range, .unnamed = TRUE)(1:10), c(1, 10)) }) test_that("lift_vd is from c(...) to ...", { expect_equal(lift_vd(mean)(1, 2), 1.5) }) test_that("lift_vl is from c(...) to list(...)", { expect_equal(lift_vl(mean)(list(1, 2)), 1.5) }) test_that("lift_lv is from list(...) to c(...)", { glue <- function(l) { if (!is.list(l)) stop("not a list") l %>% do.call(paste, .) } expect_identical(lift_lv(glue)(letters), paste(letters, collapse = " ")) }) purrr/tests/testthat/test-conditions.R0000644000176200001440000001152613426303100017674 0ustar liggesuserscontext("conditions") test_that("stop_bad_type() stores fields", { err <- catch_cnd(stop_bad_type(NA, "`NULL`", actual = "a foobaz", arg = ".foo")) expect_is(err, "purrr_error_bad_type") expect_identical(err$x, NA) expect_identical(err$expected, "`NULL`") expect_identical(err$actual, "a foobaz") expect_identical(err$arg, ".foo") }) test_that("stop_bad_type() constructs default `what`", { expect_error_cnd( stop_bad_type(NA, "`NULL`"), "Object must be `NULL`", "purrr_error_bad_type" ) expect_error_cnd( stop_bad_type(NA, "`NULL`", arg = ".foo"), "`.foo` must be `NULL`", "purrr_error_bad_type" ) expect_error_cnd( stop_bad_type(NA, "`NULL`", arg = quote(.foo)), "`arg` must be `NULL` or a string, not a symbol", "purrr_error_bad_type" ) }) test_that("stop_bad_element_type() constructs type errors", { expect_error_cnd( stop_bad_element_type(1:3, 3, "a foobaz"), "Element 3 must be a foobaz, not an integer vector", "purrr_error_bad_element_type" ) expect_error_cnd( stop_bad_element_type(1:3, 3, "a foobaz", actual = "a quux"), "Element 3 must be a foobaz, not a quux", "purrr_error_bad_element_type" ) expect_error_cnd( stop_bad_element_type(1:3, 3, "a foobaz", arg = "..arg"), "Element 3 of `..arg` must be a foobaz, not an integer vector", "purrr_error_bad_element_type" ) }) test_that("stop_bad_element_type() accepts `what`", { expect_error_cnd( stop_bad_element_type(1:3, 3, "a foobaz", what = "Result"), "Result 3 must be a foobaz, not an integer vector", "purrr_error_bad_element_type" ) }) test_that("stop_bad_length() stores fields", { err <- catch_cnd(stop_bad_length(1:3, 10, actual = 100, arg = ".foo")) expect_is(err, "purrr_error_bad_length") expect_identical(err$x, 1:3) expect_identical(err$expected_length, 10) expect_identical(err$arg, ".foo") }) test_that("stop_bad_length() constructs error message", { expect_error_cnd(stop_bad_length(1:3, 10), "Vector must have length 10, not 3", "purrr_error_bad_length") expect_error_cnd(stop_bad_length(1:3, 10, arg = ".foo"), "`.foo` must have length 10, not 3", "purrr_error_bad_length") expect_error_cnd(stop_bad_length(1:3, 10, arg = ".foo", what = "This thing"), "This thing must have length 10, not 3", "purrr_error_bad_length") expect_error_cnd(stop_bad_length(1:3, 10, arg = ".foo", what = "This thing", recycle = TRUE), "This thing must have length 1 or 10, not 3", "purrr_error_bad_length") }) test_that("stop_bad_element_length() constructs error message", { expect_error_cnd(stop_bad_element_length(1:3, 8, 10), "Element 8 must have length 10, not 3", "purrr_error_bad_element_length") expect_error_cnd(stop_bad_element_length(1:3, 8, 10, arg = ".foo"), "Element 8 of `.foo` must have length 10, not 3", "purrr_error_bad_element_length") expect_error_cnd(stop_bad_element_length(1:3, 8, 10, arg = ".foo", what = "Result"), "Result 8 of `.foo` must have length 10, not 3", "purrr_error_bad_element_length") expect_error_cnd(stop_bad_element_length(1:3, 8, 10, arg = ".foo", what = "Result", recycle = TRUE), "Result 8 of `.foo` must have length 1 or 10, not 3", "purrr_error_bad_element_length") }) test_that("stop_bad_vector() constructs error message", { expect_error_cnd(stop_bad_vector(1:3, character(), 1), "Vector must be a single string, not an integer vector of length 3", "purrr_error_bad_vector") expect_error_cnd(stop_bad_vector(factor(c("a", "b")), character(), 10), "Vector must be a character vector of length 10, not a vector of class `factor` and of length 2", "purrr_error_bad_vector") expect_error_cnd(stop_bad_vector(1:3, character(), 10, recycle = TRUE), "Vector must be a character vector of length 1 or 10, not an integer vector of length 3", "purrr_error_bad_vector") expect_error_cnd(stop_bad_vector(1:3, 1:2, 10, what = "This foobaz vector", recycle = TRUE), "This foobaz vector must be an integer vector of length 1 or 10, not an integer vector of length 3", "purrr_error_bad_vector") expect_error_cnd(stop_bad_vector(list(1, 2), logical(), 10, arg = ".quux", recycle = TRUE), "`.quux` must be a logical vector of length 1 or 10, not a list of length 2", "purrr_error_bad_vector") }) test_that("stop_bad_element_vector() constructs error message", { expect_error_cnd(stop_bad_element_vector(1:3, 3, character(), 1), "Element 3 must be a single string, not an integer vector of length 3", "purrr_error_bad_element_vector") expect_error_cnd(stop_bad_element_vector(1:3, 20, 1:2, 10, what = "Result", recycle = TRUE), "Result 20 must be an integer vector of length 1 or 10, not an integer vector of length 3", "purrr_error_bad_element_vector") expect_error_cnd(stop_bad_element_vector(list(1, 2), 1, logical(), 10, arg = ".quux", recycle = TRUE), "Element 1 of `.quux` must be a logical vector of length 1 or 10, not a list of length 2", "purrr_error_bad_element_vector") }) purrr/tests/testthat/test-output.R0000644000176200001440000000227113426303100017060 0ustar liggesuserscontext("output") test_that("safely has NULL error when successful", { out <- safely(log10)(10) expect_equal(out, list(result = 1, error = NULL)) }) test_that("safely has NULL result on failure", { out <- safely(log10)("a") expect_equal(out$result, NULL) expect_equal(out$error$message, "non-numeric argument to mathematical function") }) test_that("quietly captures output", { f <- function() { cat(1) message(2, appendLF = FALSE) warning(3) 4 } expect_output(quietly(f)(), NA) expect_message(quietly(f)(), NA) expect_warning(quietly(f)(), NA) out <- quietly(f)() expect_equal(out, list( result = 4, output = "1", warnings = "3", messages = "2" )) }) test_that("possibly returns default value on failure", { expect_identical(possibly(log, NA_real_)("a"), NA_real_) }) test_that("possibly emits a message on failure if quiet = FALSE", { f <- function(...) stop("tilt") expect_message({ possibly(f, NA_real_, quiet = FALSE)() }, regexp = "tilt") }) test_that("auto_browse() not intended for primitive functions", { expect_error(auto_browse(log)(NULL), "primitive functions") expect_error(auto_browse(identity)(NULL), NA) }) purrr/tests/testthat/test-coerce.R0000644000176200001440000000512213413636343016774 0ustar liggesuserscontext("coerce") test_that("missing values converted to new type", { expect_equal(coerce_int(NA), NA_integer_) expect_equal(coerce_dbl(NA), NA_real_) expect_equal(coerce_chr(NA), NA_character_) expect_equal(coerce_dbl(NA_integer_), NA_real_) expect_equal(coerce_chr(NA_integer_), NA_character_) expect_equal(coerce_chr(NA_real_), NA_character_) }) test_that("can't coerce downwards", { expect_error(coerce_chr(list(1)), "Can't coerce") expect_error(coerce_dbl(list(1)), "Can't coerce") expect_error(coerce_int(list(1)), "Can't coerce") expect_error(coerce_lgl(list(1)), "Can't coerce") expect_error(coerce_raw(list(1)), "Can't coerce") expect_error(coerce_dbl("a"), "Can't coerce") expect_error(coerce_int("a"), "Can't coerce") expect_error(coerce_lgl("a"), "Can't coerce") expect_error(coerce_raw("a"), "Can't coerce") expect_error(coerce_int(1), "Can't coerce") expect_error(coerce_lgl(1), "Can't coerce") expect_error(coerce_raw(1), "Can't coerce") expect_error(coerce_lgl(1L), "Can't coerce") expect_error(coerce_raw(1L), "Can't coerce") expect_error(coerce_raw(TRUE), "Can't coerce") }) test_that("coercing to same type returns input", { expect_equal(coerce_lgl(c(TRUE, FALSE)), c(TRUE, FALSE)) expect_equal(coerce_dbl(c(1, 2)), c(1, 2)) expect_equal(coerce_int(c(1L, 2L)), c(1L, 2L)) expect_equal(coerce_chr(c("a", "b")), c("a", "b")) expect_equal(coerce_raw(as.raw(c(0,1))), as.raw(c(0,1))) }) test_that("types automatically coerced upwards", { expect_identical(coerce_int(c(FALSE, TRUE)), c(0L, 1L)) expect_identical(coerce_dbl(c(FALSE, TRUE)), c(0, 1)) expect_identical(coerce_dbl(c(1L, 2L)), c(1, 2)) expect_identical(coerce_chr(c(FALSE, TRUE)), c("FALSE", "TRUE")) expect_identical(coerce_chr(c(1L, 2L)), c("1", "2")) expect_identical(coerce_chr(c(1.5, 2.5)), c("1.500000", "2.500000")) }) test_that("coercing to character values correctly", { expect_equal(coerce_chr(c(FALSE, TRUE)), c("FALSE", "TRUE")) expect_equal(coerce_chr(c(1L, 2L)), c("1", "2")) expect_equal(coerce_chr(c(1.5, 2.5)), c("1.500000", "2.500000")) expect_equal(coerce_chr(c("a", "b")), c("a", "b")) x <- c(NA, NaN, Inf, -Inf) expect_equal(coerce(x, "character"), as.character(x)) }) test_that("can't coerce to expressions", { expect_error(coerce(list(1), "expression")) }) test_that("as_vector can be type-specifc", { expect_identical(as_vector(as.list(letters), "character"), letters) }) test_that("as_vector cannot coerce lists with zero-length elements", { x <- list(a = 1, b = c(list(), 3)) expect_error(as_vector(x)) expect_identical(x, simplify(x)) }) purrr/tests/testthat/test-reduce.R0000644000176200001440000001703013435530075017003 0ustar liggesuserscontext("reduce") test_that("empty input returns init or error", { expect_error(reduce(list()), "no `.init` supplied") expect_equal(reduce(list(), `+`, .init = 0), 0) }) test_that("first/value value used as first value", { expect_equal(reduce(c(1, 1), `+`), 2) expect_equal(reduce(c(1, 1), `+`, .init = 1), 3) }) test_that("length 1 argument reduced with init", { expect_equal(reduce(1, `+`, .init = 1), 2) }) test_that("direction of reduce determines how generated trees lean", { expect_identical(reduce(1:4, list), list(list(list(1L, 2L), 3L), 4L)) expect_identical(reduce(1:4, list, .dir = "backward"), list(1L, list(2L, list(3L, 4L)))) }) test_that("can shortcircuit reduction with done()", { x <- c(TRUE, TRUE, FALSE, TRUE, TRUE) out <- reduce(x, ~ if (.y) c(.x, "foo") else done(.x), .init = NULL) expect_identical(out, c("foo", "foo")) # Empty done box yields the same value as returning the # result-so-far (the last value) in a done box out2 <- reduce(x, ~ if (.y) c(.x, "foo") else done(), .init = NULL) expect_identical(out2, out) }) test_that("reduce() forces arguments (#643)", { skip_if(!has_force_and_call) compose <- function(f, g) function(x) f(g(x)) expect_identical(reduce(list(identity, identity), compose)(1), 1) }) # accumulate -------------------------------------------------------------- test_that("accumulate passes arguments to function", { tt <- c("a", "b", "c") expect_equal(accumulate(tt, paste, sep = "."), c("a", "a.b", "a.b.c")) expect_equal(accumulate(tt, paste, sep = ".", .dir = "backward"), c("a.b.c", "b.c", "c")) expect_equal(accumulate(tt, paste, sep = ".", .init = "z"), c("z", "z.a", "z.a.b", "z.a.b.c")) expect_equal(accumulate(tt, paste, sep = ".", .dir = "backward", .init = "z"), c("a.b.c.z", "b.c.z", "c.z", "z")) }) test_that("accumulate keeps input names", { input <- set_names(1:26, letters) expect_identical(accumulate(input, sum), set_names(cumsum(1:26), letters)) expect_identical(accumulate(input, sum, .dir = "backward"), set_names(rev(cumsum(rev(1:26))), rev(letters))) }) test_that("accumulate keeps input names when init is supplied", { expect_identical(accumulate(1:2, c, .init = 0L), list(0L, 0:1, 0:2)) expect_identical(accumulate(0:1, c, .init = 2L, .dir = "backward"), list(0:2, 1:2, 2L)) expect_identical(accumulate(c(a = 1L, b = 2L), c, .init = 0L), list(.init = 0L, a = 0:1, b = 0:2)) expect_identical(accumulate(c(a = 0L, b = 1L), c, .init = 2L, .dir = "backward"), list(b = 0:2, a = 1:2, .init = 2L)) }) test_that("can terminate accumulate() early", { tt <- c("a", "b", "c") paste2 <- function(x, y) { out <- paste(x, y, sep = ".") if (x == "b" || y == "b") { done(out) } else { out } } expect_equal(accumulate(tt, paste2), c("a", "a.b")) expect_equal(accumulate(tt, paste2, .dir = "backward"), c("b.c", "c")) expect_equal(accumulate(tt, paste2, .init = "z"), c("z", "z.a", "z.a.b")) expect_equal(accumulate(tt, paste2, .dir = "backward", .init = "z"), c("b.c.z", "c.z", "z")) }) test_that("can terminate accumulate() early with an empty box", { tt <- c("a", "b", "c") paste2 <- function(x, y) { out <- paste(x, y, sep = ".") if (x == "b" || y == "b") { done() } else { out } } expect_equal(accumulate(tt, paste2), "a") expect_equal(accumulate(tt, paste2, .dir = "backward"), "c") expect_equal(accumulate(tt, paste2, .init = "z"), c("z", "z.a")) expect_equal(accumulate(tt, paste2, .dir = "backward", .init = "z"), c("c.z", "z")) # Init value is always included, even if done at first iteration expect_equal(accumulate(c("b", "c"), paste2), "b") }) test_that("accumulate() forces arguments (#643)", { skip_if(!has_force_and_call) compose <- function(f, g) function(x) f(g(x)) fns <- accumulate(list(identity, identity), compose) expect_true(every(fns, function(f) identical(f(1), 1))) }) # reduce2 ----------------------------------------------------------------- test_that("basic application works", { paste2 <- function(x, y, sep) paste(x, y, sep = sep) x <- c("a", "b", "c") expect_equal(reduce2(x, c("-", "."), paste2), "a-b.c") expect_equal(reduce2(x, c(".", "-", "."), paste2, .init = "x"), "x.a-b.c") }) test_that("reduce returns original input if it was length one", { x <- list(c(0, 1), c(2, 3), c(4, 5)) expect_equal(reduce(x[1], paste), x[[1]]) }) test_that("can shortcircuit reduce2() with done()", { x <- c(TRUE, TRUE, FALSE, TRUE, TRUE) out <- reduce2(x, 1:5, ~ if (.y) c(.x, "foo") else done(.x), .init = NULL) expect_identical(out, c("foo", "foo")) }) test_that("reduce2() forces arguments (#643)", { skip_if(!has_force_and_call) compose <- function(f, g, ...) function(x) f(g(x)) fns <- reduce2(list(identity, identity), "foo", compose) expect_identical(fns(1), 1) }) # accumulate2 ------------------------------------------------------------- test_that("basic accumulate2() works", { paste2 <- function(x, y, sep) paste(x, y, sep = sep) x <- c("a", "b", "c") expect_equal(accumulate2(x, c("-", "."), paste2), list("a", "a-b", "a-b.c")) expect_equal(accumulate2(x, c(".", "-", "."), paste2, .init = "x"), list("x", "x.a", "x.a-b", "x.a-b.c")) }) test_that("can terminate accumulate2() early", { paste2 <- function(x, y, sep) { out <- paste(x, y, sep = sep) if (y == "b") { done(out) } else { out } } x <- c("a", "b", "c") expect_equal(accumulate2(x, c("-", "."), paste2), list("a", "a-b")) expect_equal(accumulate2(x, c(".", "-", "."), paste2, .init = "x"), list("x", "x.a", "x.a-b")) }) test_that("accumulate2() forces arguments (#643)", { skip_if(!has_force_and_call) compose <- function(f, g, ...) function(x) f(g(x)) fns <- accumulate2(list(identity, identity), "foo", compose) expect_true(every(fns, function(f) identical(f(1), 1))) }) # Life cycle -------------------------------------------------------------- test_that("right variants are retired", { scoped_lifecycle_warnings() expect_warning(reduce_right(1:3, c), "soft-deprecated") expect_warning(reduce2_right(1:3, 1:2, c), "soft-deprecated") expect_warning(accumulate_right(1:3, c), "soft-deprecated") }) test_that("reduce_right still works", { scoped_lifecycle_silence() expect_equal(reduce_right(c(1, 1), `+`), 2) expect_equal(reduce_right(c(1, 1), `+`, .init = 1), 3) expect_equal(reduce_right(1, `+`, .init = 1), 2) }) test_that("reduce_right equivalent to reversing input", { scoped_lifecycle_silence() x <- list(c(2, 1), c(4, 3), c(6, 5)) expect_equal(reduce_right(x, c), c(6, 5, 4, 3, 2, 1)) expect_equal(reduce_right(x, c, .init = 7), c(7, 6, 5, 4, 3, 2, 1)) }) test_that("reduce2_right still works", { scoped_lifecycle_silence() paste2 <- function(x, y, sep) paste(x, y, sep = sep) x <- c("a", "b", "c") expect_equal(reduce2_right(x, c("-", "."), paste2), "c.b-a") expect_equal(reduce2_right(x, c(".", "-", "."), paste2, .init = "x"), "x.c-b.a") x <- list(c(0, 1), c(2, 3), c(4, 5)) y <- list(c(6, 7), c(8, 9)) expect_equal(reduce2_right(x, y, paste), c("4 2 8 0 6", "5 3 9 1 7")) expect_error(reduce2_right(y, x, paste)) }) test_that("accumulate_right still works", { scoped_lifecycle_silence() tt <- c("a", "b", "c") expect_equal(accumulate_right(tt, paste, sep = "."), c("c.b.a", "c.b", "c")) input <- set_names(1:26, letters) expect_identical(accumulate_right(input, sum), set_names(rev(cumsum(rev(1:26))), rev(letters))) expect_identical(accumulate_right(0:1, c, .init = 2L), list(2:0, 2:1, 2L)) expect_identical(accumulate_right(c(a = 0L, b = 1L), c, .init = 2L), list(b = 2:0, a = 2:1, .init = 2L)) }) purrr/tests/testthat.R0000644000176200001440000000006613413154757014565 0ustar liggesuserslibrary(testthat) library(purrr) test_check("purrr") purrr/src/0000755000176200001440000000000013552020017012206 5ustar liggesuserspurrr/src/map.h0000644000176200001440000000027313403735151013145 0ustar liggesusers#ifndef MAP_H #define MAP_H extern "C" { SEXP map_impl(SEXP env, SEXP x_name_, SEXP f_name_, SEXP type_); SEXP pmap_impl(SEXP env, SEXP l_name_, SEXP f_name_, SEXP type_); } #endif purrr/src/flatten.c0000644000176200001440000000727613426303100014020 0ustar liggesusers#define R_NO_REMAP #include #include #include "coerce.h" #include "conditions.h" #include "utils.h" const char* objtype(SEXP x) { return Rf_type2char(TYPEOF(x)); } SEXP flatten_impl(SEXP x) { if (TYPEOF(x) != VECSXP) { stop_bad_type(x, "a list", NULL, ".x"); } int m = Rf_length(x); // Determine output size and check type int n = 0; int has_names = 0; SEXP x_names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); for (int j = 0; j < m; ++j) { SEXP x_j = VECTOR_ELT(x, j); if (!is_vector(x_j) && x_j != R_NilValue) { stop_bad_element_type(x_j, j + 1, "a vector", NULL, ".x"); } n += Rf_length(x_j); if (!has_names) { if (!Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) { // Sub-element is named has_names = 1; } else if (Rf_length(x_j) == 1 && !Rf_isNull(x_names)) { // Element is a "scalar" and has name in parent SEXP name = STRING_ELT(x_names, j); if (name != NA_STRING && strcmp(CHAR(name), "") != 0) has_names = 1; } } } SEXP out = PROTECT(Rf_allocVector(VECSXP, n)); SEXP names = PROTECT(Rf_allocVector(STRSXP, n)); if (has_names) Rf_setAttrib(out, R_NamesSymbol, names); int i = 0; for (int j = 0; j < m; ++j) { SEXP x_j = VECTOR_ELT(x, j); int n_j = Rf_length(x_j); SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol)); int has_names_j = !Rf_isNull(names_j); for (int k = 0; k < n_j; ++k, ++i) { switch(TYPEOF(x_j)) { case LGLSXP: SET_VECTOR_ELT(out, i, Rf_ScalarLogical(LOGICAL(x_j)[k])); break; case INTSXP: SET_VECTOR_ELT(out, i, Rf_ScalarInteger(INTEGER(x_j)[k])); break; case REALSXP: SET_VECTOR_ELT(out, i, Rf_ScalarReal(REAL(x_j)[k])); break; case CPLXSXP: SET_VECTOR_ELT(out, i, Rf_ScalarComplex(COMPLEX(x_j)[k])); break; case STRSXP: SET_VECTOR_ELT(out, i, Rf_ScalarString(STRING_ELT(x_j, k))); break; case RAWSXP: SET_VECTOR_ELT(out, i, Rf_ScalarRaw(RAW(x_j)[k])); break; case VECSXP: SET_VECTOR_ELT(out, i, VECTOR_ELT(x_j, k)); break; default: Rf_error("Internal error: `flatten_impl()` should have failed earlier"); } if (has_names) { if (has_names_j) { SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar("")); } else if (n_j == 1) { SET_STRING_ELT(names, i, !Rf_isNull(x_names) ? STRING_ELT(x_names, j) : Rf_mkChar("")); } } if (i % 1024 == 0) R_CheckUserInterrupt(); } UNPROTECT(1); } UNPROTECT(3); return out; } SEXP vflatten_impl(SEXP x, SEXP type_) { if (TYPEOF(x) != VECSXP) { stop_bad_type(x, "a list", NULL, ".x"); } int m = Rf_length(x); SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_))); // Determine output size and type int n = 0; int has_names = 0; for (int j = 0; j < m; ++j) { SEXP x_j = VECTOR_ELT(x, j); n += Rf_length(x_j); if (!has_names && !Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) { has_names = 1; } } SEXP out = PROTECT(Rf_allocVector(type, n)); SEXP names = PROTECT(Rf_allocVector(STRSXP, n)); if (has_names) Rf_setAttrib(out, R_NamesSymbol, names); UNPROTECT(1); int i = 0; for (int j = 0; j < m; ++j) { SEXP x_j = VECTOR_ELT(x, j); int n_j = Rf_length(x_j); SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol)); int has_names_j = !Rf_isNull(names_j); for (int k = 0; k < n_j; ++k, ++i) { set_vector_value(out, i, x_j, k); if (has_names) SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar("")); if (i % 1024 == 0) R_CheckUserInterrupt(); } UNPROTECT(1); } UNPROTECT(1); return out; } purrr/src/backports.h0000644000176200001440000000024513403735151014357 0ustar liggesusers#ifndef BACKPORTS_H #define BACKPORTS_H #include #if defined(R_VERSION) && R_VERSION < R_Version(3, 2, 0) SEXP Rf_installChar(SEXP x); #endif #endif purrr/src/backports.c0000644000176200001440000000031713403735151014352 0ustar liggesusers#define R_NO_REMAP #include #include #include #if defined(R_VERSION) && R_VERSION < R_Version(3, 2, 0) SEXP Rf_installChar(SEXP x) { return Rf_install(CHAR(x)); } #endif purrr/src/init.c0000644000176200001440000000217313435516707013340 0ustar liggesusers#include #include #include // for NULL #include /* .Call calls */ extern SEXP coerce_impl(SEXP, SEXP); extern SEXP pluck_impl(SEXP, SEXP, SEXP, SEXP); extern SEXP flatten_impl(SEXP); extern SEXP map_impl(SEXP, SEXP, SEXP, SEXP); extern SEXP map2_impl(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP pmap_impl(SEXP, SEXP, SEXP, SEXP); extern SEXP transpose_impl(SEXP, SEXP); extern SEXP vflatten_impl(SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"coerce_impl", (DL_FUNC) &coerce_impl, 2}, {"pluck_impl", (DL_FUNC) &pluck_impl, 4}, {"flatten_impl", (DL_FUNC) &flatten_impl, 1}, {"map_impl", (DL_FUNC) &map_impl, 4}, {"map2_impl", (DL_FUNC) &map2_impl, 5}, {"pmap_impl", (DL_FUNC) &pmap_impl, 4}, {"transpose_impl", (DL_FUNC) &transpose_impl, 2}, {"vflatten_impl", (DL_FUNC) &vflatten_impl, 2}, {"purrr_eval", (DL_FUNC) &Rf_eval, 2}, {NULL, NULL, 0} }; void R_init_purrr(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } purrr/src/utils.c0000644000176200001440000000213313435577255013536 0ustar liggesusers#define R_NO_REMAP #include #include SEXP sym_protect(SEXP x) { if (TYPEOF(x) == LANGSXP || TYPEOF(x) == SYMSXP) { SEXP quote_prim = Rf_eval(Rf_install("quote"), R_BaseEnv); return(Rf_lang2(quote_prim, x)); } else { return x; } } bool is_vector(SEXP x) { switch (TYPEOF(x)) { case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case RAWSXP: case VECSXP: return true; default: return false; } } SEXP list6(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x) { PROTECT(s); s = Rf_cons(s, Rf_list5(t, u, v, w, x)); UNPROTECT(1); return s; } SEXP lang7(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x, SEXP y) { PROTECT(s); s = Rf_lcons(s, list6(t, u, v, w, x, y)); UNPROTECT(1); return s; } SEXP list7(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x, SEXP y) { PROTECT(s); s = Rf_cons(s, list6(t, u, v, w, x, y)); UNPROTECT(1); return s; } SEXP lang8(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x, SEXP y, SEXP z) { PROTECT(s); s = Rf_lcons(s, list7(t, u, v, w, x, y, z)); UNPROTECT(1); return s; } purrr/src/coerce.c0000644000176200001440000000603313413636343013627 0ustar liggesusers#define R_NO_REMAP #include #include #include const char* sixteen = "0123456789abcdef" ; SEXP raw_to_char( Rbyte x){ char buf[2] ; buf[0] = sixteen[ x >> 4] ; buf[1] = sixteen[ x & 0x0F ] ; return Rf_mkCharLen( buf, 2) ; } double logical_to_real(int x) { return (x == NA_LOGICAL) ? NA_REAL : x; } double integer_to_real(int x) { return (x == NA_INTEGER) ? NA_REAL : x; } SEXP logical_to_char(int x) { if (x == NA_LOGICAL) return NA_STRING; return Rf_mkChar(x ? "TRUE" : "FALSE"); } SEXP integer_to_char(int x) { if (x == NA_INTEGER) return NA_STRING; char buf[100]; snprintf(buf, 100, "%d", x); return Rf_mkChar(buf); } SEXP double_to_char(double x) { if (!R_finite(x)) { if (R_IsNA(x)) { return NA_STRING; } else if (R_IsNaN(x)) { return Rf_mkChar("NaN"); } else if (x > 0) { return Rf_mkChar("Inf"); } else { return Rf_mkChar("-Inf"); } } char buf[100]; snprintf(buf, 100, "%f", x); return Rf_mkChar(buf); } void cant_coerce(SEXP from, SEXP to, int i) { Rf_errorcall(R_NilValue, "Can't coerce element %i from a %s to a %s", i + 1, Rf_type2char(TYPEOF(from)), Rf_type2char(TYPEOF(to))); } void set_vector_value(SEXP to, int i, SEXP from, int j) { switch(TYPEOF(to)) { case LGLSXP: switch(TYPEOF(from)) { case LGLSXP: LOGICAL(to)[i] = LOGICAL(from)[j]; break; default: cant_coerce(from, to, i); } break; case INTSXP: switch(TYPEOF(from)) { case LGLSXP: INTEGER(to)[i] = LOGICAL(from)[j]; break; case INTSXP: INTEGER(to)[i] = INTEGER(from)[j]; break; case RAWSXP: INTEGER(to)[i] = RAW(from)[j]; break ; default: cant_coerce(from, to, i); } break; case REALSXP: switch(TYPEOF(from)) { case LGLSXP: REAL(to)[i] = logical_to_real(LOGICAL(from)[j]); break; case INTSXP: REAL(to)[i] = integer_to_real(INTEGER(from)[j]); break; case REALSXP: REAL(to)[i] = REAL(from)[j]; break; case RAWSXP: REAL(to)[i] = RAW(from)[j]; break ; default: cant_coerce(from, to, i); } break; case STRSXP: switch(TYPEOF(from)) { case LGLSXP: SET_STRING_ELT(to, i, logical_to_char(LOGICAL(from)[j])); break; case INTSXP: SET_STRING_ELT(to, i, integer_to_char(INTEGER(from)[j])); break; case REALSXP: SET_STRING_ELT(to, i, double_to_char(REAL(from)[j])); break; case STRSXP: SET_STRING_ELT(to, i, STRING_ELT(from, j)); break; case RAWSXP: SET_STRING_ELT(to, i, raw_to_char(RAW(from)[j])); break; default: cant_coerce(from, to, i); } break; case VECSXP: SET_VECTOR_ELT(to, i, from); break; case RAWSXP: switch(TYPEOF(from)) { case RAWSXP: RAW(to)[i] = RAW(from)[j]; break; default: cant_coerce(from, to, i); } break ; default: cant_coerce(from, to, i); } } SEXP coerce_impl(SEXP x, SEXP type_) { int n = Rf_length(x); SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_))); SEXP out = PROTECT(Rf_allocVector(type, n)); for (int i = 0; i < n; ++i) { set_vector_value(out, i, x, i); } UNPROTECT(1); return out; } purrr/src/pluck.c0000644000176200001440000002442613442743023013507 0ustar liggesusers#define R_NO_REMAP #include #include #include #include #include "backports.h" #include "coerce.h" #include "conditions.h" static int check_input_lengths(int n, SEXP index, int i, bool strict); static int check_double_index_finiteness(double val, SEXP index, int i, bool strict); static int check_double_index_length(double val, int n, int i, bool strict); static int check_character_index(SEXP string, int i, bool strict); static int check_names(SEXP names, int i, bool strict); static int check_offset(int offset, SEXP index_i, bool strict); static int check_unbound_value(SEXP val, SEXP index_i, bool strict); static int check_s4_slot(SEXP val, SEXP index_i, bool strict); static int check_obj_length(SEXP n, bool strict); int obj_length(SEXP x, bool strict); SEXP obj_names(SEXP x, bool strict); // S3 objects must implement a `length()` method in the case of a // numeric index and a `names()` method for the character case int find_offset(SEXP x, SEXP index, int i, bool strict) { int n = obj_length(x, strict); if (n < 0) { return -1; } if (check_input_lengths(n, index, i, strict)) { return -1; } switch (TYPEOF(index)) { case INTSXP: case REALSXP: { int n_protect = 0; double val; if (TYPEOF(index) == INTSXP) { // Coerce instead of cast to standardise missing value index = PROTECT(Rf_coerceVector(index, REALSXP)); ++n_protect; } val = REAL(index)[0]; if (check_double_index_finiteness(val, index, i, strict)) { goto numeric_index_error; } --val; if (check_double_index_length(val, n, i, strict)) { goto numeric_index_error; } UNPROTECT(n_protect); return val; numeric_index_error: UNPROTECT(n_protect); return -1; } case STRSXP: { // Protection is needed because names could be generated in the S3 case SEXP names = PROTECT(obj_names(x, strict)); if (check_names(names, i, strict)) { UNPROTECT(1); return -1; } SEXP string = STRING_ELT(index, 0); if (check_character_index(string, i, strict)) { UNPROTECT(1); return -1; } const char* val = Rf_translateCharUTF8(string); int n_names = Rf_length(names); for (int j = 0; j < n_names; ++j) { if (STRING_ELT(names, j) == NA_STRING) { continue; } const char* names_j = Rf_translateCharUTF8(STRING_ELT(names, j)); if (strcmp(names_j, val) == 0) { UNPROTECT(1); return j; } } if (strict) { Rf_errorcall(R_NilValue, "Can't find name `%s` in vector", val); } else { UNPROTECT(1); return -1; } } default: stop_bad_element_type(x, i + 1, "a character or numeric vector", "Index", NULL); } } SEXP extract_vector(SEXP x, SEXP index_i, int i, bool strict) { int offset = find_offset(x, index_i, i, strict); if (check_offset(offset, index_i, strict)) { return R_NilValue; } if (OBJECT(x)) { // We check `index_i` with `check_offset()` but pass the original // index rather than an offset in order to support unordered // vector classes SEXP extract_call = PROTECT(Rf_lang3(Rf_install("[["), x, index_i)); SEXP out = Rf_eval(extract_call, R_GlobalEnv); UNPROTECT(1); return out; } switch (TYPEOF(x)) { case LGLSXP: return Rf_ScalarLogical(LOGICAL(x)[offset]); case INTSXP: return Rf_ScalarInteger(INTEGER(x)[offset]); case REALSXP: return Rf_ScalarReal(REAL(x)[offset]); case STRSXP: return Rf_ScalarString(STRING_ELT(x, offset)); case VECSXP: return VECTOR_ELT(x, offset); case RAWSXP: return Rf_ScalarRaw(RAW(x)[offset]) ; default: Rf_errorcall(R_NilValue, "Don't know how to index object of type %s at level %d", Rf_type2char(TYPEOF(x)), i + 1 ); } return R_NilValue; } SEXP extract_env(SEXP x, SEXP index_i, int i, bool strict) { if (TYPEOF(index_i) != STRSXP || Rf_length(index_i) != 1) { SEXP ptype = PROTECT(Rf_allocVector(STRSXP, 0)); stop_bad_element_vector(index_i, i + 1, ptype, 1, "Index", NULL, false); } SEXP index = STRING_ELT(index_i, 0); if (check_character_index(index, i, strict)) { return R_NilValue; } SEXP sym = Rf_installChar(index); SEXP out = Rf_findVarInFrame3(x, sym, TRUE); if (check_unbound_value(out, index_i, strict)) { return R_NilValue; } return out; } SEXP extract_s4(SEXP x, SEXP index_i, int i, bool strict) { if (TYPEOF(index_i) != STRSXP || Rf_length(index_i) != 1) { SEXP ptype = PROTECT(Rf_allocVector(STRSXP, 0)); stop_bad_element_vector(index_i, i + 1, ptype, 1, "Index", NULL, false); } SEXP index = STRING_ELT(index_i, 0); if (check_character_index(index, i, strict)) { return R_NilValue; } if (check_s4_slot(x, index_i, strict)) { return R_NilValue; } SEXP sym = Rf_installChar(index); return Rf_getAttrib(x, sym); } SEXP extract_fn(SEXP x, SEXP clo) { SEXP expr = PROTECT(Rf_lang2(clo, x)); SEXP out = Rf_eval(expr, R_GlobalEnv); UNPROTECT(1); return out; } static bool is_function(SEXP x) { switch (TYPEOF(x)) { case CLOSXP: case BUILTINSXP: case SPECIALSXP: return true; default: return false; } } SEXP pluck_impl(SEXP x, SEXP index, SEXP missing, SEXP strict_arg) { if (TYPEOF(index) != VECSXP) { stop_bad_type(index, "a list", NULL, "where"); } PROTECT_INDEX idx; PROTECT_WITH_INDEX(x, &idx); int n = Rf_length(index); bool strict = Rf_asLogical(strict_arg); for (int i = 0; i < n; ++i) { SEXP index_i = VECTOR_ELT(index, i); if (is_function(index_i)) { x = extract_fn(x, index_i); REPROTECT(x, idx); continue; } // Assume all S3 objects implement the vector interface if (OBJECT(x) && TYPEOF(x) != S4SXP) { x = extract_vector(x, index_i, i, strict); REPROTECT(x, idx); continue; } switch (TYPEOF(x)) { case NILSXP: if (strict) { Rf_errorcall(R_NilValue, "Plucked object can't be NULL"); } // Leave the indexing loop early goto end; case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case RAWSXP: case VECSXP: case EXPRSXP: x = extract_vector(x, index_i, i, strict); REPROTECT(x, idx); break; case ENVSXP: x = extract_env(x, index_i, i, strict); REPROTECT(x, idx); break; case S4SXP: x = extract_s4(x, index_i, i, strict); REPROTECT(x, idx); break; default: Rf_errorcall(R_NilValue, "Can't pluck from a %s", Rf_type2char(TYPEOF(x))); } } end: UNPROTECT(1); return (Rf_length(x) == 0) ? missing : x; } /* Type checking */ static int check_input_lengths(int n, SEXP index, int i, bool strict) { int index_n = Rf_length(index); if (n == 0) { if (strict) { Rf_errorcall(R_NilValue, "Plucked object must have at least one element"); } else { return -1; } } if (index_n > 1 || (strict && index_n == 0)) { stop_bad_element_length(index, i + 1, 1, "Index", NULL, false); } return 0; } static int check_double_index_finiteness(double val, SEXP index, int i, bool strict) { if (R_finite(val)) { return 0; } if (strict) { Rf_errorcall(R_NilValue, "Index %d must be finite, not %s", i + 1, Rf_translateCharUTF8(Rf_asChar(index))); } else { return -1; } } static int check_double_index_length(double val, int n, int i, bool strict) { if (val < 0) { if (strict) { Rf_errorcall(R_NilValue, "Index %d must be greater than 0, not %.0f", i + 1, val + 1); } else { return -1; } } else if (val >= n) { if (strict) { Rf_errorcall(R_NilValue, "Index %d exceeds the length of plucked object (%.0f > %d)", i + 1, val + 1, n); } else { return -1; } } return 0; } static int check_character_index(SEXP string, int i, bool strict) { if (string == NA_STRING) { if (strict) { Rf_errorcall(R_NilValue, "Index %d can't be NA", i + 1); } else { return -1; } } // "" matches nothing const char* val = CHAR(string); if (val[0] == '\0') { if (strict) { Rf_errorcall(R_NilValue, "Index %d can't be an empty string (\"\")", i + 1); } else { return -1; } } return 0; } static int check_names(SEXP names, int i, bool strict) { if (TYPEOF(names) == STRSXP) { return 0; } if (strict) { Rf_errorcall(R_NilValue, "Index %d is attempting to pluck from an unnamed vector using a string name", i + 1); } else { return -1; } } static int check_offset(int offset, SEXP index_i, bool strict) { if (offset >= 0) { return 0; } if (strict) { Rf_errorcall(R_NilValue, "Can't find index `%s` in vector", Rf_translateCharUTF8(Rf_asChar(index_i))); } else { return -1; } } static int check_unbound_value(SEXP val, SEXP index_i, bool strict) { if (val != R_UnboundValue) { return 0; } if (strict) { Rf_errorcall(R_NilValue, "Can't find object `%s` in environment", Rf_translateCharUTF8(Rf_asChar(index_i))); } else { return -1; } } static int check_s4_slot(SEXP val, SEXP index_i, bool strict) { if (R_has_slot(val, index_i)) { return 0; } if (strict) { Rf_errorcall(R_NilValue, "Can't find slot `%s`.", Rf_translateCharUTF8(Rf_asChar(index_i))); } else { return -1; } } static int check_obj_length(SEXP n, bool strict) { if (TYPEOF(n) != INTSXP || Rf_length(n) != 1) { if (strict) { Rf_errorcall(R_NilValue, "Length of S3 object must be a scalar integer"); } else { return -1; } } return 0; } int obj_length(SEXP x, bool strict) { if (!OBJECT(x)) { return Rf_length(x); } SEXP length_call = PROTECT(Rf_lang2(Rf_install("length"), x)); SEXP n = PROTECT(Rf_eval(length_call, R_GlobalEnv)); if (check_obj_length(n, strict)) { UNPROTECT(2); return -1; } UNPROTECT(2); return INTEGER(n)[0]; } SEXP obj_names(SEXP x, bool strict) { if (!OBJECT(x)) { return Rf_getAttrib(x, R_NamesSymbol); } SEXP names_call = PROTECT(Rf_lang2(Rf_install("names"), x)); SEXP names = Rf_eval(names_call, R_GlobalEnv); UNPROTECT(1); return names; } purrr/src/utils.h0000644000176200001440000000040513435577262013541 0ustar liggesusers#ifndef UTILS_H #define UTILS_H #include SEXP sym_protect(SEXP x); bool is_vector(SEXP x); SEXP lang7(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x, SEXP y); SEXP lang8(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x, SEXP y, SEXP z); #endif purrr/src/map.c0000644000176200001440000001434013435576352013153 0ustar liggesusers#define R_NO_REMAP #include #include #include #include "coerce.h" #include "conditions.h" #include "utils.h" void copy_names(SEXP from, SEXP to) { if (Rf_length(from) != Rf_length(to)) return; SEXP names = Rf_getAttrib(from, R_NamesSymbol); if (Rf_isNull(names)) return; Rf_setAttrib(to, R_NamesSymbol, names); } void check_vector(SEXP x, const char *name) { if (Rf_isNull(x) || Rf_isVector(x) || Rf_isPairList(x)) { return; } stop_bad_type(x, "a vector", NULL, name); } // call must involve i SEXP call_loop(SEXP env, SEXP call, int n, SEXPTYPE type, int force_args) { // Create variable "i" and map to scalar integer SEXP i_val = PROTECT(Rf_ScalarInteger(1)); SEXP i = Rf_install("i"); Rf_defineVar(i, i_val, env); SEXP out = PROTECT(Rf_allocVector(type, n)); for (int i = 0; i < n; ++i) { if (i % 1024 == 0) R_CheckUserInterrupt(); INTEGER(i_val)[0] = i + 1; #if defined(R_VERSION) && R_VERSION >= R_Version(3, 2, 3) SEXP res = PROTECT(R_forceAndCall(call, force_args, env)); #else SEXP res = PROTECT(Rf_eval(call, env)); #endif if (type != VECSXP && Rf_length(res) != 1) { SEXP ptype = PROTECT(Rf_allocVector(type, 0)); stop_bad_element_vector(res, i + 1, ptype, 1, "Result", NULL, false); } set_vector_value(out, i, res, 0); UNPROTECT(1); } UNPROTECT(2); return out; } SEXP map_impl(SEXP env, SEXP x_name_, SEXP f_name_, SEXP type_) { const char* x_name = CHAR(Rf_asChar(x_name_)); const char* f_name = CHAR(Rf_asChar(f_name_)); SEXP x = Rf_install(x_name); SEXP f = Rf_install(f_name); SEXP i = Rf_install("i"); SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_))); SEXP x_val = PROTECT(Rf_eval(x, env)); check_vector(x_val, ".x"); int n = Rf_length(x_val); if (n == 0) { SEXP out = PROTECT(Rf_allocVector(type, 0)); copy_names(x_val, out); UNPROTECT(2); return out; } // Constructs a call like f(x[[i]], ...) - don't want to substitute // actual values for f or x, because they may be long, which creates // bad tracebacks() SEXP Xi = PROTECT(Rf_lang3(R_Bracket2Symbol, x, i)); SEXP f_call = PROTECT(Rf_lang3(f, Xi, R_DotsSymbol)); SEXP out = PROTECT(call_loop(env, f_call, n, type, 1)); copy_names(x_val, out); UNPROTECT(4); return out; } SEXP map2_impl(SEXP env, SEXP x_name_, SEXP y_name_, SEXP f_name_, SEXP type_) { const char* x_name = CHAR(Rf_asChar(x_name_)); const char* y_name = CHAR(Rf_asChar(y_name_)); const char* f_name = CHAR(Rf_asChar(f_name_)); SEXP x = Rf_install(x_name); SEXP y = Rf_install(y_name); SEXP f = Rf_install(f_name); SEXP i = Rf_install("i"); SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_))); SEXP x_val = PROTECT(Rf_eval(x, env)); check_vector(x_val, ".x"); SEXP y_val = PROTECT(Rf_eval(y, env)); check_vector(y_val, ".y"); int nx = Rf_length(x_val), ny = Rf_length(y_val); if (nx == 0 || ny == 0) { SEXP out = PROTECT(Rf_allocVector(type, 0)); copy_names(x_val, out); UNPROTECT(3); return out; } if (nx != ny && !(nx == 1 || ny == 1)) { Rf_errorcall(R_NilValue, "Mapped vectors must have consistent lengths:\n" "* `.x` has length %d\n" "* `.y` has length %d", nx, ny); } int n = (nx > ny) ? nx : ny; // Constructs a call like f(x[[i]], y[[i]], ...) SEXP one = PROTECT(Rf_ScalarInteger(1)); SEXP Xi = PROTECT(Rf_lang3(R_Bracket2Symbol, x, nx == 1 ? one : i)); SEXP Yi = PROTECT(Rf_lang3(R_Bracket2Symbol, y, ny == 1 ? one : i)); SEXP f_call = PROTECT(Rf_lang4(f, Xi, Yi, R_DotsSymbol)); SEXP out = PROTECT(call_loop(env, f_call, n, type, 2)); copy_names(x_val, out); UNPROTECT(7); return out; } SEXP pmap_impl(SEXP env, SEXP l_name_, SEXP f_name_, SEXP type_) { const char* l_name = CHAR(Rf_asChar(l_name_)); SEXP l = Rf_install(l_name); SEXP l_val = PROTECT(Rf_eval(l, env)); SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_))); if (!Rf_isVectorList(l_val)) { stop_bad_type(l_val, "a list", NULL, l_name); } // Check all elements are lists and find maximum length int m = Rf_length(l_val); int n = 0; for (int j = 0; j < m; ++j) { SEXP j_val = VECTOR_ELT(l_val, j); if (!Rf_isVector(j_val) && !Rf_isNull(j_val)) { stop_bad_element_type(j_val, j + 1, "a vector", NULL, l_name); } int nj = Rf_length(j_val); if (nj == 0) { SEXP out = PROTECT(Rf_allocVector(type, 0)); copy_names(j_val, out); UNPROTECT(2); return out; } if (nj > n) { n = nj; } } // Check length of all elements for (int j = 0; j < m; ++j) { SEXP j_val = VECTOR_ELT(l_val, j); int nj = Rf_length(j_val); if (nj != 1 && nj != n) { stop_bad_element_length(j_val, j + 1, n, NULL, ".l", true); } } SEXP l_names = PROTECT(Rf_getAttrib(l_val, R_NamesSymbol)); int has_names = !Rf_isNull(l_names); const char* f_name = CHAR(Rf_asChar(f_name_)); SEXP f = Rf_install(f_name); SEXP i = Rf_install("i"); SEXP one = PROTECT(Rf_ScalarInteger(1)); // Construct call like f(.l[[1]][[i]], .l[[2]][[i]], ...) // // Currently accessing S3 vectors in a list like .l[[c(1, i)]] will not // preserve the class (cf. #358). // // We construct the call backwards because can only add to the front of a // linked list. That makes PROTECTion tricky because we need to update it // each time to point to the start of the linked list. SEXP f_call = Rf_lang1(R_DotsSymbol); PROTECT_INDEX fi; PROTECT_WITH_INDEX(f_call, &fi); for (int j = m - 1; j >= 0; --j) { int nj = Rf_length(VECTOR_ELT(l_val, j)); // Construct call like .l[[j]][[i]] SEXP j_ = PROTECT(Rf_ScalarInteger(j + 1)); SEXP l_j = PROTECT(Rf_lang3(R_Bracket2Symbol, l, j_)); SEXP l_ji = PROTECT(Rf_lang3(R_Bracket2Symbol, l_j, nj == 1 ? one : i)); REPROTECT(f_call = Rf_lcons(l_ji, f_call), fi); if (has_names && CHAR(STRING_ELT(l_names, j))[0] != '\0') SET_TAG(f_call, Rf_install(CHAR(STRING_ELT(l_names, j)))); UNPROTECT(3); } REPROTECT(f_call = Rf_lcons(f, f_call), fi); SEXP out = PROTECT(call_loop(env, f_call, n, type, m)); if (Rf_length(l_val)) { copy_names(VECTOR_ELT(l_val, 0), out); } UNPROTECT(5); return out; } purrr/src/conditions.c0000644000176200001440000001327013426303100014523 0ustar liggesusers#define R_NO_REMAP #include #include "utils.h" void stop_bad_type(SEXP x, const char* expected, const char* what, const char* arg) { SEXP fn = Rf_lang3(Rf_install(":::"), Rf_install("purrr"), Rf_install("stop_bad_type")); SEXP call = Rf_lang5(PROTECT(fn), PROTECT(sym_protect(x)), PROTECT(Rf_mkString(expected)), what ? PROTECT(Rf_mkString(what)) : R_NilValue, arg ? PROTECT(Rf_mkString(arg)) : R_NilValue); PROTECT(call); SEXP node = CDR(CDR(CDR(call))); SET_TAG(node, Rf_install("what")); node = CDR(node); SET_TAG(node, Rf_install("arg")); Rf_eval(call, R_BaseEnv); Rf_error("Internal error: `stop_bad_type()` should have thrown earlier"); } void stop_bad_element_type(SEXP x, R_xlen_t index, const char* expected, const char* what, const char* arg) { SEXP fn = Rf_lang3(Rf_install(":::"), Rf_install("purrr"), Rf_install("stop_bad_element_type")); SEXP call = Rf_lang6(PROTECT(fn), PROTECT(sym_protect(x)), PROTECT(Rf_ScalarReal(index)), PROTECT(Rf_mkString(expected)), what ? PROTECT(Rf_mkString(what)) : R_NilValue, arg ? PROTECT(Rf_mkString(arg)) : R_NilValue); PROTECT(call); SEXP node = CDR(CDR(CDR(CDR(call)))); SET_TAG(node, Rf_install("what")); node = CDR(node); SET_TAG(node, Rf_install("arg")); Rf_eval(call, R_BaseEnv); Rf_error("Internal error: `stop_bad_element_type()` should have thrown earlier"); } void stop_bad_length(SEXP x, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) { SEXP fn = Rf_lang3(Rf_install(":::"), Rf_install("purrr"), Rf_install("stop_bad_length")); SEXP call = Rf_lang5(PROTECT(fn), PROTECT(sym_protect(x)), PROTECT(Rf_ScalarReal(expected_length)), what ? PROTECT(Rf_mkString(what)) : R_NilValue, arg ? PROTECT(Rf_mkString(arg)) : R_NilValue); PROTECT(call); SEXP node = CDR(CDR(CDR(call))); SET_TAG(node, Rf_install("what")); node = CDR(node); SET_TAG(node, Rf_install("arg")); Rf_eval(call, R_BaseEnv); Rf_error("Internal error: `stop_bad_length()` should have thrown earlier"); } void stop_bad_element_length(SEXP x, R_xlen_t index, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) { SEXP fn = Rf_lang3(Rf_install(":::"), Rf_install("purrr"), Rf_install("stop_bad_element_length")); SEXP call = lang7(PROTECT(fn), PROTECT(sym_protect(x)), PROTECT(Rf_ScalarReal(index)), PROTECT(Rf_ScalarReal(expected_length)), what ? PROTECT(Rf_mkString(what)) : R_NilValue, arg ? PROTECT(Rf_mkString(arg)) : R_NilValue, PROTECT(Rf_ScalarLogical(recycle))); PROTECT(call); SEXP node = CDR(CDR(CDR(CDR(call)))); SET_TAG(node, Rf_install("what")); node = CDR(node); SET_TAG(node, Rf_install("arg")); node = CDR(node); SET_TAG(node, Rf_install("recycle")); Rf_eval(call, R_BaseEnv); Rf_error("Internal error: `stop_bad_element_length()` should have thrown earlier"); } void stop_bad_vector(SEXP x, SEXP expected_ptype, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) { SEXP fn = Rf_lang3(Rf_install(":::"), Rf_install("purrr"), Rf_install("stop_bad_vector")); SEXP call = Rf_lang6(PROTECT(fn), x, expected_ptype, PROTECT(Rf_ScalarReal(expected_length)), what ? PROTECT(Rf_mkString(what)) : R_NilValue, arg ? PROTECT(Rf_mkString(arg)) : R_NilValue); PROTECT(call); SEXP node = CDR(CDR(CDR(CDR(call)))); SET_TAG(node, Rf_install("what")); node = CDR(node); SET_TAG(node, Rf_install("arg")); Rf_eval(call, R_BaseEnv); Rf_error("Internal error: `stop_bad_vector()` should have thrown earlier"); } void stop_bad_element_vector(SEXP x, R_xlen_t index, SEXP expected_ptype, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) { SEXP fn = Rf_lang3(Rf_install(":::"), Rf_install("purrr"), Rf_install("stop_bad_element_vector")); SEXP call = lang8(PROTECT(fn), x, PROTECT(Rf_ScalarReal(index)), expected_ptype, PROTECT(Rf_ScalarReal(expected_length)), what ? PROTECT(Rf_mkString(what)) : R_NilValue, arg ? PROTECT(Rf_mkString(arg)) : R_NilValue, PROTECT(Rf_ScalarLogical(recycle))); PROTECT(call); SEXP node = CDR(CDR(CDR(CDR(CDR(call))))); SET_TAG(node, Rf_install("what")); node = CDR(node); SET_TAG(node, Rf_install("arg")); node = CDR(node); SET_TAG(node, Rf_install("recycle")); Rf_eval(call, R_BaseEnv); Rf_error("Internal error: `stop_bad_element_length()` should have thrown earlier"); } purrr/src/coerce.h0000644000176200001440000000025313426303100013614 0ustar liggesusers#ifndef COERCE_H #define COERCE_H // Set value of to[i] to from[j], coercing vectors using usual rules. void set_vector_value(SEXP to, int i, SEXP from, int j); #endif purrr/src/conditions.h0000644000176200001440000000164513426303100014533 0ustar liggesusers#ifndef CONDITIONS_H #define CONDITIONS_H #include void stop_bad_type(SEXP x, const char* expected, const char* what, const char* arg) __attribute__((noreturn)); void stop_bad_element_type(SEXP x, R_xlen_t index, const char* expected, const char* what, const char* arg) __attribute__((noreturn)); void stop_bad_length(SEXP x, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) __attribute__((noreturn)); void stop_bad_element_length(SEXP x, R_xlen_t index, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) __attribute__((noreturn)); void stop_bad_vector(SEXP x, SEXP expect_ptype, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) __attribute__((noreturn)); void stop_bad_element_vector(SEXP x, R_xlen_t index, SEXP expect_ptype, R_xlen_t expected_length, const char* what, const char* arg, bool recycle) __attribute__((noreturn)); #endif purrr/src/transpose.c0000644000176200001440000000544213426303100014372 0ustar liggesusers#define R_NO_REMAP #include #include #include "conditions.h" #include "utils.h" SEXP transpose_impl(SEXP x, SEXP names_template) { if (TYPEOF(x) != VECSXP) { stop_bad_type(x, "a list", NULL, ".l"); } int n = Rf_length(x); if (n == 0) { return Rf_allocVector(VECSXP, 0); } int has_template = !Rf_isNull(names_template); SEXP x1 = VECTOR_ELT(x, 0); if (!Rf_isVector(x1)) { stop_bad_element_type(x1, 1, "a vector", NULL, NULL); } int m = has_template ? Rf_length(names_template) : Rf_length(x1); // Create space for output SEXP out = PROTECT(Rf_allocVector(VECSXP, m)); SEXP names1 = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); for (int j = 0; j < m; ++j) { SEXP xj = PROTECT(Rf_allocVector(VECSXP, n)); if (!Rf_isNull(names1)) { Rf_setAttrib(xj, R_NamesSymbol, names1); } SET_VECTOR_ELT(out, j, xj); UNPROTECT(1); } SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol); if (!Rf_isNull(names2)) { Rf_setAttrib(out, R_NamesSymbol, names2); } // Fill output for (int i = 0; i < n; ++i) { SEXP xi = VECTOR_ELT(x, i); if (!Rf_isVector(xi)) { stop_bad_element_type(xi, i + 1, "a vector", NULL, NULL); } // find mapping between names and index. Use -1 to indicate not found SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol); SEXP index; if (!Rf_isNull(names2) && !Rf_isNull(names_i)) { index = PROTECT(Rf_match(names_i, names2, 0)); // Rf_match returns 1-based index; convert to 0-based for C for (int i = 0; i < m; ++i) { INTEGER(index)[i] = INTEGER(index)[i] - 1; } } else { index = PROTECT(Rf_allocVector(INTSXP, m)); int mi = Rf_length(xi); if (m != mi) { Rf_warningcall(R_NilValue, "Element %d must be length %d, not %d", i + 1, m, mi); } for (int i = 0; i < m; ++i) { INTEGER(index)[i] = (i < mi) ? i : -1; } } int* pIndex = INTEGER(index); for (int j = 0; j < m; ++j) { int pos = pIndex[j]; if (pos == -1) continue; switch(TYPEOF(xi)) { case LGLSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos])); break; case INTSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos])); break; case REALSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos])); break; case STRSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos))); break; case VECSXP: SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos)); break; default: stop_bad_type(xi, "a vector", "Transposed element", NULL); } } UNPROTECT(1); } UNPROTECT(2); return out; } purrr/vignettes/0000755000176200001440000000000013552020016013426 5ustar liggesuserspurrr/vignettes/other-langs.Rmd0000644000176200001440000000407113426303100016315 0ustar liggesusers--- title: "Functional programming in other languages" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Functional programming in other languages} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- purrr draws inspiration from many related tools: * List operations defined in the Haskell [prelude][haskell] * Scala's [list methods][scala]. * Functional programming libraries for javascript: [underscore.js](http://underscorejs.org), [lodash](https://lodash.com) and [lazy.js](http://danieltao.com/lazy.js/). * [rlist](http://renkun.me/rlist/), another R package to support working with lists. Similar goals but somewhat different philosophy. However, the goal of purrr is not to try and simulate a purer functional programming language in R; we don't want to implement a second-class version of Haskell in R. The goal is to give you similar expressiveness to an FP language, while allowing you to write code that looks and works like R: * Instead of point free (tacit) style, we use the pipe, `%>%`, to write code that can be read from left to right. * Instead of currying, we use `...` to pass in extra arguments. * Anonymous functions are verbose in R, so we provide two convenient shorthands. For unary functions, `~ .x + 1` is equivalent to `function(.x) .x + 1`. For chains of transformations functions, `. %>% f() %>% g()` is equivalent to `function(.) . %>% f() %>% g()` (this shortcut is provided by magrittr). * R is weakly typed, so we need `map` variants that describe the output type (like `map_int()`, `map_dbl()`, etc) because we don't know the return type of `.f`. * R has named arguments, so instead of providing different functions for minor variations (e.g. `detect()` and `detectLast()`) we use a named argument, `.right`. Type-stable functions are easy to reason about so additional arguments will never change the type of the output. [scala]:http://www.scala-lang.org/api/current/index.html#scala.collection.immutable.List [haskell]:http://hackage.haskell.org/package/base-4.7.0.1/docs/Prelude.html#g:11 purrr/R/0000755000176200001440000000000013552020017011620 5ustar liggesuserspurrr/R/reduce.R0000644000176200001440000004141013435530113013215 0ustar liggesusers#' Reduce a list to a single value by iteratively applying a binary function #' #' @description #' #' `reduce()` is an operation that combines the elements of a vector #' into a single value. The combination is driven by `.f`, a binary #' function that takes two values and returns a single value: reducing #' `f` over `1:3` computes the value `f(f(1, 2), 3)`. #' #' @inheritParams map #' @param .y For `reduce2()` and `accumulate2()`, an additional #' argument that is passed to `.f`. If `init` is not set, `.y` #' should be 1 element shorter than `.x`. #' @param .f For `reduce()`, and `accumulate()`, a 2-argument #' function. The function will be passed the accumulated value as #' the first argument and the "next" value as the second argument. #' #' For `reduce2()` and `accumulate2()`, a 3-argument function. The #' function will be passed the accumulated value as the first #' argument, the next value of `.x` as the second argument, and the #' next value of `.y` as the third argument. #' #' The reduction terminates early if `.f` returns a value wrapped in #' a [done()]. #' #' @param .init If supplied, will be used as the first value to start #' the accumulation, rather than using `.x[[1]]`. This is useful if #' you want to ensure that `reduce` returns a correct value when `.x` #' is empty. If missing, and `.x` is empty, will throw an error. #' @param .dir The direction of reduction as a string, one of #' `"forward"` (the default) or `"backward"`. See the section about #' direction below. #' #' @section Direction: #' #' When `.f` is an associative operation like `+` or `c()`, the #' direction of reduction does not matter. For instance, reducing the #' vector `1:3` with the binary function `+` computes the sum `((1 + #' 2) + 3)` from the left, and the same sum `(1 + (2 + 3))` from the #' right. #' #' In other cases, the direction has important consequences on the #' reduced value. For instance, reducing a vector with `list()` from #' the left produces a left-leaning nested list (or tree), while #' reducing `list()` from the right produces a right-leaning list. #' #' @section Life cycle: #' #' `reduce_right()` is soft-deprecated as of purrr 0.3.0. Please use #' the `.dir` argument of `reduce()` instead. Note that the algorithm #' has changed. Whereas `reduce_right()` computed `f(f(3, 2), 1)`, #' `reduce(.dir = \"backward\")` computes `f(1, f(2, 3))`. This is the #' standard way of reducing from the right. #' #' To update your code with the same reduction as `reduce_right()`, #' simply reverse your vector and use a left reduction: #' #' ```{r} #' # Before: #' reduce_right(1:3, f) #' #' # After: #' reduce(rev(1:3), f) #' ``` #' #' `reduce2_right()` is soft-deprecated as of purrr 0.3.0 without #' replacement. It is not clear what algorithmic properties should a #' right reduction have in this case. Please reach out if you know #' about a use case for a right reduction with a ternary function. #' #' @seealso [accumulate()] for a version that returns all intermediate #' values of the reduction. #' @examples #' # Reducing `+` computes the sum of a vector while reducing `*` #' # computes the product: #' 1:3 %>% reduce(`+`) #' 1:10 %>% reduce(`*`) #' #' # When the operation is associative, the direction of reduction #' # does not matter: #' reduce(1:4, `+`) #' reduce(1:4, `+`, .dir = "backward") #' #' # However with non-associative operations, the reduced value will #' # be different as a function of the direction. For instance, #' # `list()` will create left-leaning lists when reducing from the #' # right, and right-leaning lists otherwise: #' str(reduce(1:4, list)) #' str(reduce(1:4, list, .dir = "backward")) #' #' # reduce2() takes a ternary function and a second vector that is #' # one element smaller than the first vector: #' paste2 <- function(x, y, sep = ".") paste(x, y, sep = sep) #' letters[1:4] %>% reduce(paste2) #' letters[1:4] %>% reduce2(c("-", ".", "-"), paste2) #' #' x <- list(c(0, 1), c(2, 3), c(4, 5)) #' y <- list(c(6, 7), c(8, 9)) #' reduce2(x, y, paste) #' #' #' # You can shortcircuit a reduction and terminate it early by #' # returning a value wrapped in a done(). In the following example #' # we return early if the result-so-far, which is passed on the LHS, #' # meets a condition: #' paste3 <- function(out, input, sep = ".") { #' if (nchar(out) > 4) { #' return(done(out)) #' } #' paste(out, input, sep = sep) #' } #' letters %>% reduce(paste3) #' #' # Here the early return branch checks the incoming inputs passed on #' # the RHS: #' paste4 <- function(out, input, sep = ".") { #' if (input == "j") { #' return(done(out)) #' } #' paste(out, input, sep = sep) #' } #' letters %>% reduce(paste4) #' @export reduce <- function(.x, .f, ..., .init, .dir = c("forward", "backward")) { reduce_impl(.x, .f, ..., .init = .init, .dir = .dir) } #' @rdname reduce #' @export reduce2 <- function(.x, .y, .f, ..., .init) { reduce2_impl(.x, .y, .f, ..., .init = .init, .left = TRUE) } reduce_impl <- function(.x, .f, ..., .init, .dir, .acc = FALSE) { left <- arg_match(.dir, c("forward", "backward")) == "forward" out <- reduce_init(.x, .init, left = left) idx <- reduce_index(.x, .init, left = left) if (.acc) { acc_out <- accum_init(out, idx, left = left) acc_idx <- accum_index(acc_out, left = left) } .f <- as_mapper(.f, ...) # Left-reduce passes the result-so-far on the left, right-reduce # passes it on the right. A left-reduce produces left-leaning # computation trees while right-reduce produces right-leaning trees. if (left) { fn <- .f } else { fn <- function(x, y, ...) .f(y, x, ...) } for (i in seq_along(idx)) { prev <- out elt <- .x[[idx[[i]]]] if (has_force_and_call) { out <- forceAndCall(2, fn, out, elt, ...) } else { out <- fn(out, elt, ...) } if (is_done_box(out)) { return(reduce_early(out, prev, .acc, acc_out, acc_idx[[i]], left)) } if (.acc) { acc_out[[acc_idx[[i]]]] <- out } } if (.acc) { acc_out } else { out } } reduce_early <- function(out, prev, acc, acc_out, acc_idx, left = TRUE) { if (is_done_box(out, empty = TRUE)) { out <- prev offset <- if (left) -1L else 1L } else { out <- unbox(out) offset <- 0L } if (!acc) { return(out) } acc_idx <- acc_idx + offset acc_out[[acc_idx]] <- out if (left) { acc_out[seq_len(acc_idx)] } else { acc_out[seq(acc_idx, length(acc_out))] } } reduce_init <- function(x, init, left = TRUE) { if (!missing(init)) { init } else { if (is_empty(x)) { stop("`.x` is empty, and no `.init` supplied", call. = FALSE) } else if (left) { x[[1]] } else { x[[length(x)]] } } } reduce_index <- function(x, init, left = TRUE) { n <- length(x) if (left) { if (missing(init)) { seq_len2(2L, n) } else { seq_len(n) } } else { if (missing(init)) { rev(seq_len(n - 1L)) } else { rev(seq_len(n)) } } } accum_init <- function(first, idx, left) { len <- length(idx) + 1L out <- new_list(len) if (left) { out[[1]] <- first } else { out[[len]] <- first } out } accum_index <- function(out, left) { n <- length(out) if (left) { seq_len2(2, n) } else { rev(seq_len(n - 1L)) } } reduce2_impl <- function(.x, .y, .f, ..., .init, .left = TRUE, .acc = FALSE) { out <- reduce_init(.x, .init, left = .left) x_idx <- reduce_index(.x, .init, left = .left) y_idx <- reduce_index(.y, NULL, left = .left) if (length(x_idx) != length(y_idx)) { stop("`.y` does not have length ", length(x_idx)) } .f <- as_mapper(.f, ...) if (.acc) { acc_out <- accum_init(out, x_idx, left = .left) acc_idx <- accum_index(acc_out, left = .left) } for (i in seq_along(x_idx)) { prev <- out x_i <- x_idx[[i]] y_i <- y_idx[[i]] if (has_force_and_call) { out <- forceAndCall(3, .f, out, .x[[x_i]], .y[[y_i]], ...) } else { out <- .f(out, .x[[x_i]], .y[[y_i]], ...) } if (is_done_box(out)) { return(reduce_early(out, prev, .acc, acc_out, acc_idx[[i]])) } if (.acc) { acc_out[[acc_idx[[i]]]] <- out } } if (.acc) { acc_out } else { out } } seq_len2 <- function(start, end) { if (start > end) { return(integer(0)) } start:end } #' Accumulate intermediate results of a vector reduction #' #' @description #' #' `accumulate()` sequentially applies a 2-argument function to elements of a #' vector. Each application of the function uses the initial value or result #' of the previous application as the first argument. The second argument is #' the next value of the vector. The results of each application are #' returned in a list. The accumulation can optionally terminate before #' processing the whole vector in response to a `done()` signal returned by #' the accumulation function. #' #' By contrast to `accumulate()`, `reduce()` applies a 2-argument function in #' the same way, but discards all results except that of the final function #' application. #' #' `accumulate2()` sequentially applies a function to elements of two lists, `.x` and `.y`. #' #' @inheritParams map #' #' @param .y For `accumulate2()` `.y` is the second argument of the pair. It #' needs to be 1 element shorter than the vector to be accumulated (`.x`). #' If `.init` is set, `.y` needs to be one element shorted than the #' concatenation of the initial value and `.x`. #' #' @param .f For `accumulate()` `.f` is 2-argument function. The function will #' be passed the accumulated result or initial value as the first argument. #' The next value in sequence is passed as the second argument. #' #' For `accumulate2()`, a 3-argument function. The #' function will be passed the accumulated result as the first #' argument. The next value in sequence from `.x` is passed as the second argument. The #' next value in sequence from `.y` is passed as the third argument. #' #' The accumulation terminates early if `.f` returns a value wrapped in #' a [done()]. #' #' @param .init If supplied, will be used as the first value to start #' the accumulation, rather than using `.x[[1]]`. This is useful if #' you want to ensure that `reduce` returns a correct value when `.x` #' is empty. If missing, and `.x` is empty, will throw an error. #' #' @param .dir The direction of accumulation as a string, one of #' `"forward"` (the default) or `"backward"`. See the section about #' direction below. #' #' @return A vector the same length of `.x` with the same names as `.x`. #' #' If `.init` is supplied, the length is extended by 1. If `.x` has #' names, the initial value is given the name `".init"`, otherwise #' the returned vector is kept unnamed. #' #' If `.dir` is `"forward"` (the default), the first element is the #' initial value (`.init` if supplied, or the first element of `.x`) #' and the last element is the final reduced value. In case of a #' right accumulation, this order is reversed. #' #' The accumulation terminates early if `.f` returns a value wrapped #' in a [done()]. If the done box is empty, the last value is #' used instead and the result is one element shorter (but always #' includes the initial value, even when terminating at the first #' iteration). #' #' @inheritSection reduce Direction #' #' @section Life cycle: #' #' `accumulate_right()` is soft-deprecated in favour of the `.dir` #' argument as of rlang 0.3.0. Note that the algorithm has #' slightly changed: the accumulated value is passed to the right #' rather than the left, which is consistent with a right reduction. #' #' @seealso [reduce()] when you only need the final reduced value. #' @examples #' # With an associative operation, the final value is always the #' # same, no matter the direction. You'll find it in the last element for a #' # backward (left) accumulation, and in the first element for forward #' # (right) one: #' 1:5 %>% accumulate(`+`) #' 1:5 %>% accumulate(`+`, .dir = "backward") #' #' # The final value is always equal to the equivalent reduction: #' 1:5 %>% reduce(`+`) #' #' # It is easier to understand the details of the reduction with #' # `paste()`. #' accumulate(letters[1:5], paste, sep = ".") #' #' # Note how the intermediary reduced values are passed to the left #' # with a left reduction, and to the right otherwise: #' accumulate(letters[1:5], paste, sep = ".", .dir = "backward") #' #' # `accumulate2()` is a version of `accumulate()` that works with #' # 3-argument functions and one additional vector: #' paste2 <- function(x, y, sep = ".") paste(x, y, sep = sep) #' letters[1:4] %>% accumulate(paste2) #' letters[1:4] %>% accumulate2(c("-", ".", "-"), paste2) #' #' #' # You can shortcircuit an accumulation and terminate it early by #' # returning a value wrapped in a done(). In the following example #' # we return early if the result-so-far, which is passed on the LHS, #' # meets a condition: #' paste3 <- function(out, input, sep = ".") { #' if (nchar(out) > 4) { #' return(done(out)) #' } #' paste(out, input, sep = sep) #' } #' letters %>% accumulate(paste3) #' #' # Note how we get twice the same value in the accumulation. That's #' # because we have returned it twice. To prevent this, return an empty #' # done box to signal to accumulate() that it should terminate with the #' # value of the last iteration: #' paste3 <- function(out, input, sep = ".") { #' if (nchar(out) > 4) { #' return(done()) #' } #' paste(out, input, sep = sep) #' } #' letters %>% accumulate(paste3) #' #' # Here the early return branch checks the incoming inputs passed on #' # the RHS: #' paste4 <- function(out, input, sep = ".") { #' if (input == "f") { #' return(done()) #' } #' paste(out, input, sep = sep) #' } #' letters %>% accumulate(paste4) #' #' #' # Simulating stochastic processes with drift #' \dontrun{ #' library(dplyr) #' library(ggplot2) #' #' rerun(5, rnorm(100)) %>% #' set_names(paste0("sim", 1:5)) %>% #' map(~ accumulate(., ~ .05 + .x + .y)) %>% #' map_dfr(~ tibble(value = .x, step = 1:100), .id = "simulation") %>% #' ggplot(aes(x = step, y = value)) + #' geom_line(aes(color = simulation)) + #' ggtitle("Simulations of a random walk with drift") #' } #' @export accumulate <- function(.x, .f, ..., .init, .dir = c("forward", "backward")) { .dir <- arg_match(.dir, c("forward", "backward")) .f <- as_mapper(.f, ...) res <- reduce_impl(.x, .f, ..., .init = .init, .dir = .dir, .acc = TRUE) names(res) <- accumulate_names(names(.x), .init, .dir) # FIXME vctrs: This simplification step is for compatibility with # the `base::Reduce()` implementation in earlier purrr versions if (all(map_int(res, length) == 1L)) { res <- unlist(res, recursive = FALSE) } res } #' @rdname accumulate #' @export accumulate2 <- function(.x, .y, .f, ..., .init) { reduce2_impl(.x, .y, .f, ..., .init = .init, .acc = TRUE) } accumulate_names <- function(nms, init, dir) { if (is_null(nms)) { return(NULL) } if (!missing(init)) { nms <- c(".init", nms) } if (dir == "backward") { nms <- rev(nms) } nms } #' Reduce from the right (retired) #' #' @description #' #' \Sexpr[results=rd, stage=render]{purrr:::lifecycle("soft-deprecated")} #' #' These functions are retired as of purrr 0.3.0. Please use the #' `.dir` argument of [reduce()] instead, or reverse your vectors #' and use a left reduction. #' #' @inheritParams reduce #' #' @keywords internal #' @export reduce_right <- function(.x, .f, ..., .init) { signal_soft_deprecated(paste_line( "`reduce_right()` is soft-deprecated as of purrr 0.3.0.", "Please use the new `.dir` argument of `reduce()` instead.", "", " # Before:", " reduce_right(1:3, f)", "", " # After:", " reduce(1:3, f, .dir = \"backward\") # New algorithm", " reduce(rev(1:3), f) # Same algorithm as reduce_right()", "" )) .x <- rev(.x) # Compatibility reduce_impl(.x, .f, ..., .dir = "forward", .init = .init) } #' @rdname reduce_right #' @export reduce2_right <- function(.x, .y, .f, ..., .init) { signal_soft_deprecated(paste_line( "`reduce2_right()` is soft-deprecated as of purrr 0.3.0.", "Please reverse your vectors and use `reduce2()` instead.", "", " # Before:", " reduce2_right(x, y, f)", "", " # After:", " reduce2(rev(x), rev(y), f)", "" )) reduce2_impl(.x, .y, .f, ..., .init = .init, .left = FALSE) } #' @rdname reduce_right #' @export accumulate_right <- function(.x, .f, ..., .init) { signal_soft_deprecated(paste_line( "`accumulate_right()` is soft-deprecated as of purrr 0.3.0.", "Please use the new `.dir` argument of `accumulate()` instead.", "", " # Before:", " accumulate_right(x, f)", "", " # After:", " accumulate(x, f, .dir = \"backward\")", "" )) # Note the order of arguments is switched f <- function(y, x) { .f(x, y, ...) } accumulate(.x, f, .init = .init, .dir = "backward") } purrr/R/depth.R0000644000176200001440000000103513403735151013055 0ustar liggesusers#' Compute the depth of a vector #' #' The depth of a vector is basically how many levels that you can index #' into it. #' #' @param x A vector #' @return An integer. #' @export #' @examples #' x <- list( #' list(), #' list(list()), #' list(list(list(1))) #' ) #' vec_depth(x) #' x %>% map_int(vec_depth) vec_depth <- function(x) { if (is_null(x)) { 0L } else if (is_atomic(x)) { 1L } else if (is_list(x)) { depths <- map_int(x, vec_depth) 1L + max(depths, 0L) } else { abort("`x` must be a vector") } } purrr/R/lmap.R0000644000176200001440000000731413426303100012676 0ustar liggesusers#' Apply a function to list-elements of a list #' #' `lmap()`, `lmap_at()` and `lmap_if()` are similar to #' `map()`, `map_at()` and `map_if()`, with the #' difference that they operate exclusively on functions that take #' \emph{and} return a list (or data frame). Thus, instead of mapping #' the elements of a list (as in \code{.x[[i]]}), they apply a #' function `.f` to each subset of size 1 of that list (as in #' `.x[i]`). We call those elements `list-elements`). #' #' Mapping the list-elements `.x[i]` has several advantages. It #' makes it possible to work with functions that exclusively take a #' list or data frame. It enables `.f` to access the attributes #' of the encapsulating list, like the name of the components it #' receives. It also enables `.f` to return a larger list than #' the list-element of size 1 it got as input. Conversely, `.f` #' can also return empty lists. In these cases, the output list is #' reshaped with a different size than the input list `.x`. #' @param .x A list or data frame. #' @param .f A function that takes and returns a list or data frame. #' @inheritParams map_if #' @inheritParams map_at #' @inheritParams map #' @return If `.x` is a list, a list. If `.x` is a data #' frame, a data frame. #' @family map variants #' @export #' @examples #' # Let's write a function that returns a larger list or an empty list #' # depending on some condition. This function also uses the names #' # metadata available in the attributes of the list-element #' maybe_rep <- function(x) { #' n <- rpois(1, 2) #' out <- rep_len(x, n) #' if (length(out) > 0) { #' names(out) <- paste0(names(x), seq_len(n)) #' } #' out #' } #' #' # The output size varies each time we map f() #' x <- list(a = 1:4, b = letters[5:7], c = 8:9, d = letters[10]) #' x %>% lmap(maybe_rep) #' #' # We can apply f() on a selected subset of x #' x %>% lmap_at(c("a", "d"), maybe_rep) #' #' # Or only where a condition is satisfied #' x %>% lmap_if(is.character, maybe_rep) #' #' #' # A more realistic example would be a function that takes discrete #' # variables in a dataset and turns them into disjunctive tables, a #' # form that is amenable to fitting some types of models. #' #' # A disjunctive table contains only 0 and 1 but has as many columns #' # as unique values in the original variable. Ideally, we want to #' # combine the names of each level with the name of the discrete #' # variable in order to identify them. Given these requirements, it #' # makes sense to have a function that takes a data frame of size 1 #' # and returns a data frame of variable size. #' disjoin <- function(x, sep = "_") { #' name <- names(x) #' x <- as.factor(x[[1]]) #' #' out <- lapply(levels(x), function(level) { #' as.numeric(x == level) #' }) #' #' names(out) <- paste(name, levels(x), sep = sep) #' out #' } #' #' # Now, we are ready to map disjoin() on each categorical variable of a #' # data frame: #' iris %>% lmap_if(is.factor, disjoin) #' mtcars %>% lmap_at(c("cyl", "vs", "am"), disjoin) lmap <- function(.x, .f, ...) { lmap_at(.x, seq_along(.x), .f, ...) } #' @rdname lmap #' @export lmap_if <- function(.x, .p, .f, ..., .else = NULL) { sel <- probe(.x, .p) .x <- lmap_at(.x, which(sel), .f, ...) if (!is_null(.else)) { .x <- lmap_at(.x, which(!sel), .else, ...) } .x } #' @rdname lmap #' @export lmap_at <- function(.x, .at, .f, ...) { if (is_formula(.f)) { .f <- as_mapper(.f, ...) } where <- at_selection(names(.x), .at) sel <- inv_which(.x, where) out <- vector("list", length(.x)) for (i in seq_along(.x)) { res <- if (sel[[i]]) { .f(.x[i], ...) } else { .x[i] } stopifnot(is.list(res)) out[[i]] <- res } maybe_as_data_frame(flatten(out), .x) } purrr/R/detect.R0000644000176200001440000000537413551356667013252 0ustar liggesusers#' Find the value or position of the first match #' #' @inheritParams map #' @inheritParams every #' @param .dir If `"forward"`, the default, starts at the beginning of #' the vector and move towards the end; if `"backward"`, starts at #' the end of the vector and moves towards the beginning. #' @param .right Soft-deprecated. Please use `.dir` instead. #' @param .default The value returned when nothing is detected. #' @return `detect` the value of the first item that matches the #' predicate; `detect_index` the position of the matching item. #' If not found, `detect` returns `NULL` and `detect_index` #' returns 0. #' #' @seealso [keep()] for keeping all matching values. #' @export #' @examples #' is_even <- function(x) x %% 2 == 0 #' #' 3:10 %>% detect(is_even) #' 3:10 %>% detect_index(is_even) #' #' 3:10 %>% detect(is_even, .dir = "backward") #' 3:10 %>% detect_index(is_even, .dir = "backward") #' #' #' # Since `.f` is passed to as_mapper(), you can supply a #' # lambda-formula or a pluck object: #' x <- list( #' list(1, foo = FALSE), #' list(2, foo = TRUE), #' list(3, foo = TRUE) #' ) #' #' detect(x, "foo") #' detect_index(x, "foo") #' #' #' # If you need to find all values, use keep(): #' keep(x, "foo") #' #' # If you need to find all positions, use map_lgl(): #' which(map_lgl(x, "foo")) detect <- function(.x, .f, ..., .dir = c("forward", "backward"), .right = NULL, .default = NULL) { .f <- as_predicate(.f, ..., .mapper = TRUE) .dir <- arg_match(.dir, c("forward", "backward")) for (i in index(.x, .dir, .right, "detect")) { if (.f(.x[[i]], ...)) { return(.x[[i]]) } } .default } #' @export #' @rdname detect detect_index <- function(.x, .f, ..., .dir = c("forward", "backward"), .right = NULL) { .f <- as_predicate(.f, ..., .mapper = TRUE) .dir <- arg_match(.dir, c("forward", "backward")) for (i in index(.x, .dir, .right, "detect_index")) { if (.f(.x[[i]], ...)) { return(i) } } 0L } index <- function(x, dir, right = NULL, fn) { if (!is_null(right)) { signal_soft_deprecated(env = caller_env(2), paste_line( sprintf("The `.right` argument of `%s` is soft-deprecated as of purrr 0.3.0.", fn), "Please use the new `.dir` argument instead:", "", " # Before", sprintf(" %s(x, f, .right = TRUE)", fn), "", " # After", sprintf(" %s(x, f, .dir = \"backward\")", fn) )) dir <- if (right) "backward" else "forward" } idx <- seq_along(x) if (dir == "backward") { idx <- rev(idx) } idx } #' Does a list contain an object? #' #' @inheritParams map #' @param .y Object to test for #' @export #' @examples #' x <- list(1:10, 5, 9.9) #' x %>% has_element(1:10) #' x %>% has_element(3) has_element <- function(.x, .y) { some(.x, identical, .y) } purrr/R/map2-pmap.R0000644000176200001440000001524113426303100013535 0ustar liggesusers#' Map over multiple inputs simultaneously. #' #' These functions are variants of [map()] that iterate over multiple arguments #' simultaneously. They are parallel in the sense that each input is processed #' in parallel with the others, not in the sense of multicore computing. They #' share the same notion of "parallel" as [base::pmax()] and [base::pmin()]. #' `map2()` and `walk2()` are specialised for the two argument case; `pmap()` #' and `pwalk()` allow you to provide any number of arguments in a list. Note #' that a data frame is a very important special case, in which case `pmap()` #' and `pwalk()` apply the function `.f` to each row. `map_dfr()`, `pmap_dfr()` #' and `map2_dfc()`, `pmap_dfc()` return data frames created by row-binding #' and column-binding respectively. They require dplyr to be installed. #' #' Note that arguments to be vectorised over come before `.f`, #' and arguments that are supplied to every call come after `.f`. #' #' @inheritParams map #' @param .x,.y Vectors of the same length. A vector of length 1 will #' be recycled. #' @param .l A list of vectors, such as a data frame. The length of `.l` #' determines the number of arguments that `.f` will be called with. List #' names will be used if present. #' @return An atomic vector, list, or data frame, depending on the suffix. #' Atomic vectors and lists will be named if `.x` or the first #' element of `.l` is named. #' #' If all input is length 0, the output will be length 0. If any #' input is length 1, it will be recycled to the length of the longest. #' @export #' @family map variants #' @examples #' x <- list(1, 10, 100) #' y <- list(1, 2, 3) #' z <- list(5, 50, 500) #' #' map2(x, y, ~ .x + .y) #' # Or just #' map2(x, y, `+`) #' #' pmap(list(x, y, z), sum) #' #' # Matching arguments by position #' pmap(list(x, y, z), function(a, b, c) a / (b + c)) #' #' # Matching arguments by name #' l <- list(a = x, b = y, c = z) #' pmap(l, function(c, b, a) a / (b + c)) #' #' # Split into pieces, fit model to each piece, then predict #' by_cyl <- mtcars %>% split(.$cyl) #' mods <- by_cyl %>% map(~ lm(mpg ~ wt, data = .)) #' map2(mods, by_cyl, predict) #' #' # Vectorizing a function over multiple arguments #' df <- data.frame( #' x = c("apple", "banana", "cherry"), #' pattern = c("p", "n", "h"), #' replacement = c("x", "f", "q"), #' stringsAsFactors = FALSE #' ) #' pmap(df, gsub) #' pmap_chr(df, gsub) #' #' # Use `...` to absorb unused components of input list .l #' df <- data.frame( #' x = 1:3 + 0.1, #' y = 3:1 - 0.1, #' z = letters[1:3] #' ) #' plus <- function(x, y) x + y #' \dontrun{ #' # this won't work #' pmap(df, plus) #' } #' # but this will #' plus2 <- function(x, y, ...) x + y #' pmap_dbl(df, plus2) #' #' # The "p" for "parallel" in pmap() is the same as in base::pmin() #' # and base::pmax() #' df <- data.frame( #' x = c(1, 2, 5), #' y = c(5, 4, 8) #' ) #' # all produce the same result #' pmin(df$x, df$y) #' map2_dbl(df$x, df$y, min) #' pmap_dbl(df, min) #' #' # If you want to bind the results of your function rowwise, use map2_dfr() or pmap_dfr() #' ex_fun <- function(arg1, arg2){ #' col <- arg1 + arg2 #' x <- as.data.frame(col) #' } #' arg1 <- seq(1, 10, by = 3) #' arg2 <- seq(2, 11, by = 3) #' df <- map2_dfr(arg1, arg2, ex_fun) #' # If instead you want to bind by columns, use map2_dfc() or pmap_dfc() #' df2 <- map2_dfc(arg1, arg2, ex_fun) map2 <- function(.x, .y, .f, ...) { .f <- as_mapper(.f, ...) .Call(map2_impl, environment(), ".x", ".y", ".f", "list") } #' @export #' @rdname map2 map2_lgl <- function(.x, .y, .f, ...) { .f <- as_mapper(.f, ...) .Call(map2_impl, environment(), ".x", ".y", ".f", "logical") } #' @export #' @rdname map2 map2_int <- function(.x, .y, .f, ...) { .f <- as_mapper(.f, ...) .Call(map2_impl, environment(), ".x", ".y", ".f", "integer") } #' @export #' @rdname map2 map2_dbl <- function(.x, .y, .f, ...) { .f <- as_mapper(.f, ...) .Call(map2_impl, environment(), ".x", ".y", ".f", "double") } #' @export #' @rdname map2 map2_chr <- function(.x, .y, .f, ...) { .f <- as_mapper(.f, ...) .Call(map2_impl, environment(), ".x", ".y", ".f", "character") } #' @export #' @rdname map2 map2_raw <- function(.x, .y, .f, ...) { .f <- as_mapper(.f, ...) .Call(map2_impl, environment(), ".x", ".y", ".f", "raw") } #' @rdname map2 #' @export map2_dfr <- function(.x, .y, .f, ..., .id = NULL) { if (!is_installed("dplyr")) { abort("`map2_dfr()` requires dplyr") } .f <- as_mapper(.f, ...) res <- map2(.x, .y, .f, ...) dplyr::bind_rows(res, .id = .id) } #' @rdname map2 #' @export map2_dfc <- function(.x, .y, .f, ...) { if (!is_installed("dplyr")) { abort("`map2_dfc()` requires dplyr") } .f <- as_mapper(.f, ...) res <- map2(.x, .y, .f, ...) dplyr::bind_cols(res) } #' @rdname map2 #' @export #' @usage NULL map2_df <- map2_dfr #' @export #' @rdname map2 walk2 <- function(.x, .y, .f, ...) { map2(.x, .y, .f, ...) invisible(.x) } #' @export #' @rdname map2 pmap <- function(.l, .f, ...) { .f <- as_mapper(.f, ...) if (is.data.frame(.l)) { .l <- as.list(.l) } .Call(pmap_impl, environment(), ".l", ".f", "list") } #' @export #' @rdname map2 pmap_lgl <- function(.l, .f, ...) { .f <- as_mapper(.f, ...) if (is.data.frame(.l)) { .l <- as.list(.l) } .Call(pmap_impl, environment(), ".l", ".f", "logical") } #' @export #' @rdname map2 pmap_int <- function(.l, .f, ...) { .f <- as_mapper(.f, ...) if (is.data.frame(.l)) { .l <- as.list(.l) } .Call(pmap_impl, environment(), ".l", ".f", "integer") } #' @export #' @rdname map2 pmap_dbl <- function(.l, .f, ...) { .f <- as_mapper(.f, ...) if (is.data.frame(.l)) { .l <- as.list(.l) } .Call(pmap_impl, environment(), ".l", ".f", "double") } #' @export #' @rdname map2 pmap_chr <- function(.l, .f, ...) { .f <- as_mapper(.f, ...) if (is.data.frame(.l)) { .l <- as.list(.l) } .Call(pmap_impl, environment(), ".l", ".f", "character") } #' @export #' @rdname map2 pmap_raw <- function(.l, .f, ...) { .f <- as_mapper(.f, ...) if (is.data.frame(.l)) { .l <- as.list(.l) } .Call(pmap_impl, environment(), ".l", ".f", "raw") } #' @rdname map2 #' @export pmap_dfr <- function(.l, .f, ..., .id = NULL) { if (!is_installed("dplyr")) { abort("`pmap_dfr()` requires dplyr") } .f <- as_mapper(.f, ...) res <- pmap(.l, .f, ...) dplyr::bind_rows(res, .id = .id) } #' @rdname map2 #' @export pmap_dfc <- function(.l, .f, ...) { if (!is_installed("dplyr")) { abort("`pmap_dfc()` requires dplyr") } .f <- as_mapper(.f, ...) res <- pmap(.l, .f, ...) dplyr::bind_cols(res) } #' @rdname map2 #' @export #' @usage NULL pmap_df <- pmap_dfr #' @export #' @rdname map2 pwalk <- function(.l, .f, ...) { pmap(.l, .f, ...) invisible(.l) } purrr/R/utils.R0000644000176200001440000001630113551356667013132 0ustar liggesusers#' Pipe operator #' #' @name %>% #' @rdname pipe #' @keywords internal #' @export #' @importFrom magrittr %>% #' @usage lhs \%>\% rhs NULL maybe_as_data_frame <- function(out, x) { if (is.data.frame(x)) { check_tibble() tibble::as_tibble(out) } else { out } } check_tibble <- function() { if (!is_installed("tibble")) { abort("The tibble package must be installed") } } check_tidyselect <- function(){ if (!is_installed("tidyselect")) { abort("Using tidyselect in `map_at()` requires tidyselect") } } at_selection <- function(nm, .at){ if (is_quosures(.at)){ check_tidyselect() .at <- tidyselect::vars_select(.vars = nm, !!!.at) } .at } recycle_args <- function(args) { lengths <- map_int(args, length) n <- max(lengths) stopifnot(all(lengths == 1L | lengths == n)) to_recycle <- lengths == 1L args[to_recycle] <- lapply(args[to_recycle], function(x) rep.int(x, n)) args } names2 <- function(x) { names(x) %||% rep("", length(x)) } #' Infix attribute accessor #' #' @description #' #' \Sexpr[results=rd, stage=render]{purrr:::lifecycle("soft-deprecated")} #' #' Please use the `%@%` operator exported in rlang. It has an #' interface more consistent with `@`: uses NSE, supports S4 fields, #' and has an assignment variant. #' #' @param x Object #' @param name Attribute name #' @export #' @name get-attr #' @keywords internal #' @examples #' factor(1:3) %@% "levels" #' mtcars %@% "class" `%@%` <- function(x, name) { signal_soft_deprecated(paste_line( "`%@%` is soft-deprecated as of purrr 0.3.0.", "Please use the operator provided in rlang instead." )) attr(x, name, exact = TRUE) } #' Generate random sample from a Bernoulli distribution #' #' @param n Number of samples #' @param p Probability of getting `TRUE` #' @return A logical vector #' @export #' @examples #' rbernoulli(10) #' rbernoulli(100, 0.1) rbernoulli <- function(n, p = 0.5) { stats::runif(n) > (1 - p) } #' Generate random sample from a discrete uniform distribution #' #' @param n Number of samples to draw. #' @param a,b Range of the distribution (inclusive). #' @export #' @examples #' table(rdunif(1e3, 10)) #' table(rdunif(1e3, 10, -5)) rdunif <- function(n, b, a = 1) { stopifnot(is.numeric(a), length(a) == 1) stopifnot(is.numeric(b), length(b) == 1) a1 <- min(a, b) b1 <- max(a, b) sample(b1 - a1 + 1, n, replace = TRUE) + a1 - 1 } # magrittr placeholder globalVariables(".") has_names <- function(x) { nms <- names(x) if (is.null(nms)) { rep_along(x, FALSE) } else { !(is.na(nms) | nms == "") } } ndots <- function(...) nargs() is_names <- function(nms) { is_character(nms) && !any(is.na(nms) | nms == "") } paste_line <- function(...) { paste(chr(...), collapse = "\n") } cat_line <- function(...) { cat(paste0(paste_line(...), "\n")) } # From rlang friendly_type_of <- function(x, length = FALSE) { if (is.object(x)) { return(sprintf("a `%s` object", paste_classes(x))) } friendly <- as_friendly_type(typeof(x)) if (length && is_vector(x)) { friendly <- paste0(friendly, sprintf(" of length %s", length(x))) } friendly } as_friendly_type <- function(type) { switch(type, logical = "a logical vector", integer = "an integer vector", numeric = , double = "a double vector", complex = "a complex vector", character = "a character vector", raw = "a raw vector", string = "a string", list = "a list", NULL = "NULL", environment = "an environment", externalptr = "a pointer", weakref = "a weak reference", S4 = "an S4 object", name = , symbol = "a symbol", language = "a call", pairlist = "a pairlist node", expression = "an expression vector", quosure = "a quosure", formula = "a formula", char = "an internal string", promise = "an internal promise", ... = "an internal dots object", any = "an internal `any` object", bytecode = "an internal bytecode object", primitive = , builtin = , special = "a primitive function", closure = "a function", type ) } paste_classes <- function(x) { paste(class(x), collapse = "/") } is_bool <- function(x) { is_logical(x, n = 1) && !is.na(x) } is_number <- function(x) { is_integerish(x, n = 1, finite = TRUE) } is_quantity <- function(x) { typeof(x) %in% c("integer", "double") && length(x) == 1 && !is.na(x) } friendly_type_of_element <- function(x) { if (is.object(x)) { classes <- paste0("`", paste_classes(x), "`") if (single) { friendly <- sprintf("a single %s element", classes) } else { friendly <- sprintf("a %s element", classes) } return(friendly) } switch(typeof(x), logical = "a single logical", integer = "a single integer", double = "a single double", complex = "a single complex number", character = "a single string", raw = "a single raw value", list = "a list of one element", abort("Expected a base vector type") ) } has_crayon <- function() is_installed("crayon") && crayon::has_color() red <- function(x) if (has_crayon()) crayon::red(x) else x blue <- function(x) if (has_crayon()) crayon::blue(x) else x green <- function(x) if (has_crayon()) crayon::green(x) else x yellow <- function(x) if (has_crayon()) crayon::yellow(x) else x magenta <- function(x) if (has_crayon()) crayon::magenta(x) else x cyan <- function(x) if (has_crayon()) crayon::cyan(x) else x blurred <- function(x) if (has_crayon()) crayon::blurred(x) else x silver <- function(x) if (has_crayon()) crayon::silver(x) else x bold <- function(x) if (has_crayon()) crayon::bold(x) else x italic <- function(x) if (has_crayon()) crayon::italic(x) else x underline <- function(x) if (has_crayon()) crayon::underline(x) else x bullet <- function(...) paste0(bold(silver(" * ")), sprintf(...)) quo_invert <- function(call) { call <- duplicate(call, shallow = TRUE) if (is_quosure(call)) { rest <- quo_get_expr(call) } else { rest <- call } if (!is_call(rest)) { abort("Internal error: Expected call in `quo_invert()`") } first_quo <- NULL # Find first quosured argument. We unwrap constant quosures which # add no scoping information. while (!is_null(rest)) { elt <- node_car(rest) if (is_quosure(elt)) { if (quo_is_constant(elt)) { # Unwrap constant quosures node_poke_car(rest, quo_get_expr(elt)) } else if (is_null(first_quo)) { # Record first quosured argument first_quo <- elt first_node <- rest } } rest <- node_cdr(rest) } if (is_null(first_quo)) { return(call) } # Take the wrapping quosure env as reference if there is one. # Otherwise, take the first quosure detected in arguments. if (is_quosure(call)) { env <- quo_get_env(call) call <- quo_get_expr(call) } else { env <- quo_get_env(first_quo) } rest <- first_node while (!is_null(rest)) { cur <- node_car(rest) if (is_quosure(cur) && is_reference(quo_get_env(cur), env)) { node_poke_car(rest, quo_get_expr(cur)) } rest <- node_cdr(rest) } new_quosure(call, env) } quo_is_constant <- function(quo) { is_reference(quo_get_env(quo), empty_env()) } purrr/R/reexport-rlang.R0000644000176200001440000000102013426303100014702 0ustar liggesusers#' @title Set names in a vector #' @keywords NULL #' @export #' @name set_names rlang::set_names #' @title Execute a function #' @keywords NULL #' @export #' @name exec rlang::exec #' @title Zap an element #' @keywords NULL #' @export #' @name zap rlang::zap #' Default value for `NULL` #' @keywords NULL #' @export #' @name null-default rlang::`%||%` #' Done box #' @keywords NULL #' @export #' @name done rlang::done #' Repeat a value with matching length #' @keywords NULL #' @export #' @name rep_along rlang::rep_along purrr/R/imap.R0000644000176200001440000000353513413636343012712 0ustar liggesusers#' Apply a function to each element of a vector, and its index #' #' `imap_xxx(x, ...)`, an indexed map, is short hand for #' `map2(x, names(x), ...)` if `x` has names, or `map2(x, seq_along(x), ...)` #' if it does not. This is useful if you need to compute on both the value #' and the position of an element. #' #' @inheritParams map #' @return A vector the same length as `.x`. #' @export #' @family map variants #' @examples #' # Note that when using the formula shortcut, the first argument #' # is the value, and the second is the position #' imap_chr(sample(10), ~ paste0(.y, ": ", .x)) #' iwalk(mtcars, ~ cat(.y, ": ", median(.x), "\n", sep = "")) imap <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) map2(.x, vec_index(.x), .f, ...) } #' @rdname imap #' @export imap_lgl <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) map2_lgl(.x, vec_index(.x), .f, ...) } #' @rdname imap #' @export imap_chr <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) map2_chr(.x, vec_index(.x), .f, ...) } #' @rdname imap #' @export imap_int <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) map2_int(.x, vec_index(.x), .f, ...) } #' @rdname imap #' @export imap_dbl <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) map2_dbl(.x, vec_index(.x), .f, ...) } #' @rdname imap #' @export imap_raw <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) map2_raw(.x, vec_index(.x), .f, ...) } #' @rdname imap #' @export imap_dfr <- function(.x, .f, ..., .id = NULL) { .f <- as_mapper(.f, ...) map2_dfr(.x, vec_index(.x), .f, ..., .id = .id) } #' @rdname imap #' @export imap_dfc <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) map2_dfc(.x, vec_index(.x), .f, ...) } #' @export #' @rdname imap iwalk <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) walk2(.x, vec_index(.x), .f, ...) } vec_index <- function(x) { names(x) %||% seq_along(x) } purrr/R/predicates.R0000644000176200001440000000310513403735151014074 0ustar liggesusers#' Test is an object is integer or double #' #' Numeric is used in three different ways in base R: #' * as an alias for double (as in [as.numeric()]) #' * to mean either integer or double (as in [mode()]) #' * for something representable as numeric (as in [as.numeric()]) #' This function tests for the second, which is often not what you want #' so these functions are deprecated. #' #' @export #' @keywords internal is_numeric <- function(x) { warning("Deprecated", call. = FALSE) is_integer(x) || is_double(x) } #' @export #' @rdname is_numeric is_scalar_numeric <- function(x) { warning("Deprecated", call. = FALSE) is_scalar_integer(x) || is_scalar_double(x) } # Re-exports from purrr --------------------------------------------------- #' @export rlang::is_bare_list #' @export rlang::is_bare_atomic #' @export rlang::is_bare_vector #' @export rlang::is_bare_double #' @export rlang::is_bare_integer #' @export rlang::is_bare_numeric #' @export rlang::is_bare_character #' @export rlang::is_bare_logical #' @export rlang::is_list #' @export rlang::is_atomic #' @export rlang::is_vector #' @export rlang::is_integer #' @export rlang::is_double #' @export rlang::is_character #' @export rlang::is_logical #' @export rlang::is_null #' @export rlang::is_function #' @export rlang::is_scalar_list #' @export rlang::is_scalar_atomic #' @export rlang::is_scalar_vector #' @export rlang::is_scalar_double #' @export rlang::is_scalar_character #' @export rlang::is_scalar_logical #' @export rlang::is_scalar_integer #' @export rlang::is_empty #' @export rlang::is_formula purrr/R/pluck.R0000644000176200001440000001353513426303100013065 0ustar liggesusers#' Pluck or chuck a single element from a vector or environment #' #' `pluck()` and `chuck()` implement a generalised form of `[[` that #' allow you to index deeply and flexibly into data structures. #' `pluck()` consistently returns `NULL` when an element does not #' exist, `chuck()` always throws an error in that case. #' #' @param .x,x A vector or environment #' @param ... A list of accessors for indexing into the object. Can be #' an integer position, a string name, or an accessor function #' (except for the assignment variants which only support names and #' positions). If the object being indexed is an S4 object, #' accessing it by name will return the corresponding slot. #' #' These dots support [tidy dots][rlang::list2] features. In #' particular, if your accessors are stored in a list, you can #' splice that in with `!!!`. #' @param .default Value to use if target is empty or absent. #' #' @details #' * You can pluck or chuck with standard accessors like integer #' positions and string names, and also accepts arbitrary accessor #' functions, i.e. functions that take an object and return some #' internal piece. #' #' This is often more readable than a mix of operators and accessors #' because it reads linearly and is free of syntactic #' cruft. Compare: \code{accessor(x[[1]])$foo} to `pluck(x, 1, #' accessor, "foo")`. #' #' * These accessors never partial-match. This is unlike `$` which #' will select the `disp` object if you write `mtcars$di`. #' #' #' @seealso [attr_getter()] for creating attribute getters suitable #' for use with `pluck()` and `chuck()`. [modify_in()] for #' applying a function to a pluck location. #' @examples #' # Let's create a list of data structures: #' obj1 <- list("a", list(1, elt = "foo")) #' obj2 <- list("b", list(2, elt = "bar")) #' x <- list(obj1, obj2) #' #' #' # pluck() provides a way of retrieving objects from such data #' # structures using a combination of numeric positions, vector or #' # list names, and accessor functions. #' #' # Numeric positions index into the list by position, just like `[[`: #' pluck(x, 1) #' x[[1]] #' #' pluck(x, 1, 2) #' x[[1]][[2]] #' #' # Supply names to index into named vectors: #' pluck(x, 1, 2, "elt") #' x[[1]][[2]][["elt"]] #' #' #' # By default, pluck() consistently returns `NULL` when an element #' # does not exist: #' pluck(x, 10, .default = NA) #' try(x[[10]]) #' #' # You can also supply a default value for non-existing elements: #' pluck(x, 10, .default = NA) #' #' # If you prefer to consistently fail for non-existing elements, use #' # the opinionated variant chuck(): #' chuck(x, 1) #' try(chuck(x, 10)) #' try(chuck(x, 1, 10)) #' #' #' # The map() functions use pluck() by default to retrieve multiple #' # values from a list: #' map(x, 2) #' #' # Pass multiple indexes with a list: #' map(x, list(2, "elt")) #' #' # This is equivalent to: #' map(x, pluck, 2, "elt") #' #' # You can also supply a default: #' map(x, list(2, "elt", 10), .default = "superb default") #' #' # Or use the strict variant: #' try(map(x, chuck, 2, "elt", 10)) #' #' #' # You can also assign a value in a pluck location with pluck<-: #' pluck(x, 2, 2, "elt") <- "quuux" #' x #' #' # This is a shortcut for the prefix function assign_in(): #' y <- assign_in(x, list(2, 2, "elt"), value = "QUUUX") #' y #' #' #' # pluck() also supports accessor functions: #' my_element <- function(x) x[[2]]$elt #' #' # The accessor can then be passed to pluck: #' pluck(x, 1, my_element) #' pluck(x, 2, my_element) #' #' # Even for this simple data structure, this is more readable than #' # the alternative form because it requires you to read both from #' # right-to-left and from left-to-right in different parts of the #' # expression: #' my_element(x[[1]]) #' #' #' # If you have a list of accessors, you can splice those in with `!!!`: #' idx <- list(1, my_element) #' pluck(x, !!!idx) #' @export pluck <- function(.x, ..., .default = NULL) { .Call( pluck_impl, x = .x, index = list2(...), missing = .default, strict = FALSE ) } #' @rdname pluck #' @export chuck <- function(.x, ...) { .Call( pluck_impl, x = .x, index = list2(...), missing = NULL, strict = TRUE ) } #' @rdname pluck #' @inheritParams modify_in #' @export `pluck<-` <- function(.x, ..., value) { assign_in(.x, list2(...), value) } reduce_subset_call <- function(init, idx) { if (!length(idx)) { abort("Can't pluck-assign without pluck locations") } reduce(idx, subset_call, .init = init) } subset_call <- function(x, idx) { if (!is_index(idx)) { type <- friendly_type_of(idx) abort(sprintf("The pluck-assign indices must be names or positions, not %s", type)) } call("[[", x, idx) } is_index <- function(x) { if (is.object(x)) { return(FALSE) } if (!typeof(x) %in% c("character", "integer", "double")) { return(FALSE) } length(x) == 1 } #' Create an attribute getter function #' #' `attr_getter()` generates an attribute accessor function; i.e., it #' generates a function for extracting an attribute with a given #' name. Unlike the base R `attr()` function with default options, it #' doesn't use partial matching. #' #' @param attr An attribute name as string. #' #' @seealso [pluck()] #' @examples #' # attr_getter() takes an attribute name and returns a function to #' # access the attribute: #' get_rownames <- attr_getter("row.names") #' get_rownames(mtcars) #' #' # These getter functions are handy in conjunction with pluck() for #' # extracting deeply into a data structure. Here we'll first #' # extract by position, then by attribute: #' obj1 <- structure("obj", obj_attr = "foo") #' obj2 <- structure("obj", obj_attr = "bar") #' x <- list(obj1, obj2) #' #' pluck(x, 1, attr_getter("obj_attr")) # From first object #' pluck(x, 2, attr_getter("obj_attr")) # From second object #' @export attr_getter <- function(attr) { force(attr) function(x) attr(x, attr, exact = TRUE) } purrr/R/negate.R0000644000176200001440000000066513435517016013227 0ustar liggesusers#' Negate a predicate function. #' #' @inheritParams map_if #' @inheritParams as_mapper #' @return A new predicate function. #' @export #' @examples #' negate("x") #' negate(is.null) #' negate(~ .x > 0) #' #' x <- transpose(list(x = 1:10, y = rbernoulli(10))) #' x %>% keep("y") %>% length() #' x %>% keep(negate("y")) %>% length() #' # Same as #' x %>% discard("y") %>% length() negate <- function(.p) { compose(`!`, as_mapper(.p)) } purrr/R/head-tail.R0000644000176200001440000000132013426303100013564 0ustar liggesusers#' Find head/tail that all satisfies a predicate. #' #' @inheritParams map_if #' @inheritParams map #' @return A vector the same type as `.x`. #' @export #' @examples #' pos <- function(x) x >= 0 #' head_while(5:-5, pos) #' tail_while(5:-5, negate(pos)) #' #' big <- function(x) x > 100 #' head_while(0:10, big) #' tail_while(0:10, big) head_while <- function(.x, .p, ...) { # Find location of first FALSE loc <- detect_index(.x, negate(.p), ...) if (loc == 0) return(.x) .x[seq_len(loc - 1)] } #' @export #' @rdname head_while tail_while <- function(.x, .p, ...) { # Find location of last FALSE loc <- detect_index(.x, negate(.p), ..., .dir = "backward") if (loc == 0) return(.x) .x[-seq_len(loc)] } purrr/R/arrays.R0000644000176200001440000000513113426303077013256 0ustar liggesusers#' Coerce array to list #' #' `array_branch()` and `array_tree()` enable arrays to be #' used with purrr's functionals by turning them into lists. The #' details of the coercion are controlled by the `margin` #' argument. `array_tree()` creates an hierarchical list (a tree) #' that has as many levels as dimensions specified in `margin`, #' while `array_branch()` creates a flat list (by analogy, a #' branch) along all mentioned dimensions. #' #' When no margin is specified, all dimensions are used by #' default. When `margin` is a numeric vector of length zero, the #' whole array is wrapped in a list. #' @param array An array to coerce into a list. #' @param margin A numeric vector indicating the positions of the #' indices to be to be enlisted. If `NULL`, a full margin is #' used. If `numeric(0)`, the array as a whole is wrapped in a #' list. #' @name array-coercion #' @export #' @examples #' # We create an array with 3 dimensions #' x <- array(1:12, c(2, 2, 3)) #' #' # A full margin for such an array would be the vector 1:3. This is #' # the default if you don't specify a margin #' #' # Creating a branch along the full margin is equivalent to #' # as.list(array) and produces a list of size length(x): #' array_branch(x) %>% str() #' #' # A branch along the first dimension yields a list of length 2 #' # with each element containing a 2x3 array: #' array_branch(x, 1) %>% str() #' #' # A branch along the first and third dimensions yields a list of #' # length 2x3 whose elements contain a vector of length 2: #' array_branch(x, c(1, 3)) %>% str() #' #' # Creating a tree from the full margin creates a list of lists of #' # lists: #' array_tree(x) %>% str() #' #' # The ordering and the depth of the tree are controlled by the #' # margin argument: #' array_tree(x, c(3, 1)) %>% str() array_branch <- function(array, margin = NULL) { dims <- dim(array) %||% length(array) margin <- margin %||% seq_along(dims) if (length(margin) == 0) { list(array) } else if (is.null(dim(array))) { if (!identical(as.integer(margin), 1L)) { abort(sprintf( "`margin` must be `NULL` or `1` with 1D arrays, not `%s`", toString(margin) )) } as.list(array) } else { flatten(apply(array, margin, list)) } } #' @rdname array-coercion #' @export array_tree <- function(array, margin = NULL) { dims <- dim(array) %||% length(array) margin <- margin %||% seq_along(dims) if (length(margin) > 1) { new_margin <- ifelse(margin[-1] > margin[[1]], margin[-1] - 1, margin[-1]) apply(array, margin[[1]], array_tree, new_margin) } else { array_branch(array, margin) } } purrr/R/as_mapper.R0000644000176200001440000001000213551356667013731 0ustar liggesusers#' Convert an object into a mapper function #' #' `as_mapper` is the powerhouse behind the varied function #' specifications that most purrr functions allow. It is an S3 #' generic. The default method forwards its arguments to #' [rlang::as_function()]. #' #' @param .f A function, formula, or vector (not necessarily atomic). #' #' If a __function__, it is used as is. #' #' If a __formula__, e.g. `~ .x + 2`, it is converted to a function. There #' are three ways to refer to the arguments: #' #' * For a single argument function, use `.` #' * For a two argument function, use `.x` and `.y` #' * For more arguments, use `..1`, `..2`, `..3` etc #' #' This syntax allows you to create very compact anonymous functions. #' #' If __character vector__, __numeric vector__, or __list__, it is #' converted to an extractor function. Character vectors index by #' name and numeric vectors index by position; use a list to index #' by position and name at different levels. If a component is not #' present, the value of `.default` will be returned. #' @param .default,.null Optional additional argument for extractor functions #' (i.e. when `.f` is character, integer, or list). Returned when #' value is absent (does not exist) or empty (has length 0). #' `.null` is deprecated; please use `.default` instead. #' @param ... Additional arguments passed on to methods. #' @export #' @examples #' as_mapper(~ . + 1) #' as_mapper(1) #' #' as_mapper(c("a", "b", "c")) #' # Equivalent to function(x) x[["a"]][["b"]][["c"]] #' #' as_mapper(list(1, "a", 2)) #' # Equivalent to function(x) x[[1]][["a"]][[2]] #' #' as_mapper(list(1, attr_getter("a"))) #' # Equivalent to function(x) attr(x[[1]], "a") #' #' as_mapper(c("a", "b", "c"), .default = NA) as_mapper <- function(.f, ...) { UseMethod("as_mapper") } #' @export #' @rdname as_mapper #' @usage NULL as_function <- function(...) { stop_defunct(paste_line( "`as_function()` is defunct as of purrr 0.3.0.", "Please use `as_mapper()` or `rlang::as_function()` instead" )) as_mapper(...) } #' @export as_mapper.default <- function(.f, ...) { if (typeof(.f) %in% c("special", "builtin")) { .f <- rlang::as_closure(.f) # Workaround until fixed in rlang if (is_reference(fn_env(.f), base_env())) { environment(.f) <- global_env() } .f } else { rlang::as_function(.f) } } #' @export #' @rdname as_mapper as_mapper.character <- function(.f, ..., .null, .default = NULL) { .default <- find_extract_default(.null, .default) plucker(as.list(.f), .default) } #' @export #' @rdname as_mapper as_mapper.numeric <- function(.f, ..., .null, .default = NULL) { .default <- find_extract_default(.null, .default) plucker(as.list(.f), .default) } #' @export #' @rdname as_mapper as_mapper.list <- function(.f, ..., .null, .default = NULL) { .default <- find_extract_default(.null, .default) plucker(.f, .default) } find_extract_default <- function(.null, .default) { if (!missing(.null)) { # warning("`.null` is deprecated; please use `.default` instead", call. = FALSE) .null } else { .default } } plucker <- function(i, default) { x <- NULL # supress global variables check NOTE new_function( exprs(x = , ... = ), expr(pluck(x, !!!i, .default = !!default)), env = caller_env() ) } as_predicate <- function(.fn, ..., .mapper, .deprecate = FALSE) { if (.mapper) { .fn <- as_mapper(.fn, ...) } function(...) { out <- .fn(...) if (!is_bool(out)) { msg <- sprintf( "Predicate functions must return a single `TRUE` or `FALSE`, not %s", as_predicate_friendly_type_of(out) ) if (.deprecate) { msg <- paste_line( "Returning complex values from a predicate function is soft-deprecated as of purrr 0.3.0.", msg ) signal_soft_deprecated(msg) } else { abort(msg) } } out } } as_predicate_friendly_type_of <- function(x) { if (is_na(x)) { "a missing value" } else { friendly_type_of(x, length = TRUE) } } purrr/R/map.R0000644000176200001440000002274113551365051012537 0ustar liggesusers#' Apply a function to each element of a vector #' #' @description #' #' The map functions transform their input by applying a function to #' each element and returning a vector the same length as the input. #' #' * `map()` always returns a list. See the [modify()] family for #' versions that return an object of the same type as the input. #' #' * `map_lgl()`, `map_int()`, `map_dbl()` and `map_chr()` return an #' atomic vector of the indicated type (or die trying). #' #' * `map_dfr()` and `map_dfc()` return data frames created by #' row-binding and column-binding respectively. They require dplyr #' to be installed. #' #' * The return value of `.f` must be of length one for each element #' of `.x`. If `.f` uses an extractor function shortcut, `.default` #' can be specified to handle values that are absent or empty. See #' [as_mapper()] for more on `.default`. #' #' @inheritParams as_mapper #' @param .x A list or atomic vector. #' @param ... Additional arguments passed on to the mapped function. #' @return #' * `map()` Returns a list the same length as `.x`. #' #' * `map_lgl()` returns a logical vector, `map_int()` an integer #' vector, `map_dbl()` a double vector, and `map_chr()` a character #' vector. #' #' * `map_df()`, `map_dfc()`, `map_dfr()` all return a data frame. #' #' * If `.x` has `names()`, the return value preserves those names. #' #' * The output of `.f` will be automatically typed upwards, e.g. #' logical -> integer -> double -> character. #' @export #' @family map variants #' @seealso [map_if()] for applying a function to only those elements #' of `.x` that meet a specified condition. #' @examples #' 1:10 %>% #' map(rnorm, n = 10) %>% #' map_dbl(mean) #' #' # Or use an anonymous function #' 1:10 %>% #' map(function(x) rnorm(10, x)) #' #' # Or a formula #' 1:10 %>% #' map(~ rnorm(10, .x)) #' #' # Using set_names() with character vectors is handy to keep track #' # of the original inputs: #' set_names(c("foo", "bar")) %>% map_chr(paste0, ":suffix") #' #' # Extract by name or position #' # .default specifies value for elements that are missing or NULL #' l1 <- list(list(a = 1L), list(a = NULL, b = 2L), list(b = 3L)) #' l1 %>% map("a", .default = "???") #' l1 %>% map_int("b", .default = NA) #' l1 %>% map_int(2, .default = NA) #' #' # Supply multiple values to index deeply into a list #' l2 <- list( #' list(num = 1:3, letters[1:3]), #' list(num = 101:103, letters[4:6]), #' list() #' ) #' l2 %>% map(c(2, 2)) #' #' # Use a list to build an extractor that mixes numeric indices and names, #' # and .default to provide a default value if the element does not exist #' l2 %>% map(list("num", 3)) #' l2 %>% map_int(list("num", 3), .default = NA) #' #' #' # A more realistic example: split a data frame into pieces, fit a #' # model to each piece, summarise and extract R^2 #' mtcars %>% #' split(.$cyl) %>% #' map(~ lm(mpg ~ wt, data = .x)) %>% #' map(summary) %>% #' map_dbl("r.squared") #' #' # Use map_lgl(), map_dbl(), etc to reduce output to a vector instead #' # of a list: #' mtcars %>% map_dbl(sum) #' #' # If each element of the output is a data frame, use #' # map_dfr to row-bind them together: #' mtcars %>% #' split(.$cyl) %>% #' map(~ lm(mpg ~ wt, data = .x)) %>% #' map_dfr(~ as.data.frame(t(as.matrix(coef(.))))) #' # (if you also want to preserve the variable names see #' # the broom package) map <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) .Call(map_impl, environment(), ".x", ".f", "list") } #' Apply a function to each element of a vector conditionally #' #' @description #' #' The functions `map_if()` and `map_at()` take `.x` as input, apply #' the function `.f` to some of the elements of `.x`, and return a #' list of the same length as the input. #' #' * `map_if()` takes a predicate function `.p` as input to determine #' which elements of `.x` are transformed with `.f`. #' #' * `map_at()` takes a vector of names or positions `.at` to specify #' which elements of `.x` are transformed with `.f`. #' #' @inheritParams map #' @param .p A single predicate function, a formula describing such a #' predicate function, or a logical vector of the same length as `.x`. #' Alternatively, if the elements of `.x` are themselves lists of #' objects, a string indicating the name of a logical element in the #' inner lists. Only those elements where `.p` evaluates to #' `TRUE` will be modified. #' @param .else A function applied to elements of `.x` for which `.p` #' returns `FALSE`. #' @export #' @family map variants #' @examples #' # Use a predicate function to decide whether to map a function: #' map_if(iris, is.factor, as.character) #' #' # Specify an alternative with the `.else` argument: #' map_if(iris, is.factor, as.character, .else = as.integer) #' map_if <- function(.x, .p, .f, ..., .else = NULL) { sel <- probe(.x, .p) out <- list_along(.x) out[sel] <- map(.x[sel], .f, ...) if (is_null(.else)) { out[!sel] <- .x[!sel] } else { out[!sel] <- map(.x[!sel], .else, ...) } set_names(out, names(.x)) } #' @rdname map_if #' @param .at A character vector of names, positive numeric vector of #' positions to include, or a negative numeric vector of positions to #' exlude. Only those elements corresponding to `.at` will be modified. #' If the `tidyselect` package is installed, you can use `vars()` and #' the `tidyselect` helpers to select elements. #' @examples #' # Use numeric vector of positions select elements to change: #' iris %>% map_at(c(4, 5), is.numeric) #' #' # Use vector of names to specify which elements to change: #' iris %>% map_at("Species", toupper) # #' @export map_at <- function(.x, .at, .f, ...) { where <- at_selection(names(.x), .at) sel <- inv_which(.x, where) out <- list_along(.x) out[sel] <- map(.x[sel], .f, ...) out[!sel] <- .x[!sel] set_names(out, names(.x)) } #' @rdname map #' @export map_lgl <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) .Call(map_impl, environment(), ".x", ".f", "logical") } #' @rdname map #' @export map_chr <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) .Call(map_impl, environment(), ".x", ".f", "character") } #' @rdname map #' @export map_int <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) .Call(map_impl, environment(), ".x", ".f", "integer") } #' @rdname map #' @export map_dbl <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) .Call(map_impl, environment(), ".x", ".f", "double") } #' @rdname map #' @export map_raw <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) .Call(map_impl, environment(), ".x", ".f", "raw") } #' @rdname map #' @param .id Either a string or `NULL`. If a string, the output will contain #' a variable with that name, storing either the name (if `.x` is named) or #' the index (if `.x` is unnamed) of the input. If `NULL`, the default, no #' variable will be created. #' #' Only applies to `_dfr` variant. #' @export map_dfr <- function(.x, .f, ..., .id = NULL) { if (!is_installed("dplyr")) { abort("`map_df()` requires dplyr") } .f <- as_mapper(.f, ...) res <- map(.x, .f, ...) dplyr::bind_rows(res, .id = .id) } #' @rdname map #' @export #' @usage NULL map_df <- map_dfr #' @rdname map #' @export map_dfc <- function(.x, .f, ...) { if (!is_installed("dplyr")) { abort("`map_dfc()` requires dplyr") } .f <- as_mapper(.f, ...) res <- map(.x, .f, ...) dplyr::bind_cols(res) } #' @rdname map #' @description * `walk()` calls `.f` for its side-effect and returns #' the input `.x`. #' @return #' #' * `walk()` returns the input `.x` (invisibly). This makes it easy to #' use in pipe. #' @export walk <- function(.x, .f, ...) { map(.x, .f, ...) invisible(.x) } #' @rdname map_if #' @description * `map_depth()` allows to apply `.f` to a specific #' depth level of a nested vector. #' @param .depth Level of `.x` to map on. Use a negative value to #' count up from the lowest level of the list. #' #' * `map_depth(x, 0, fun)` is equivalent to `fun(x)`. #' * `map_depth(x, 1, fun)` is equivalent to `x <- map(x, fun)` #' * `map_depth(x, 2, fun)` is equivalent to `x <- map(x, ~ map(., fun))` #' @param .ragged If `TRUE`, will apply to leaves, even if they're not #' at depth `.depth`. If `FALSE`, will throw an error if there are #' no elements at depth `.depth`. #' @examples #' #' # Use `map_depth()` to recursively traverse nested vectors and map #' # a function at a certain depth: #' x <- list(a = list(foo = 1:2, bar = 3:4), b = list(baz = 5:6)) #' str(x) #' map_depth(x, 2, paste, collapse = "/") #' #' # Equivalent to: #' map(x, map, paste, collapse = "/") #' @export map_depth <- function(.x, .depth, .f, ..., .ragged = FALSE) { if (!is_integerish(.depth, n = 1, finite = TRUE)) { abort("`.depth` must be a single number") } if (.depth < 0) { .depth <- vec_depth(.x) + .depth } .f <- as_mapper(.f, ...) map_depth_rec(.x, .depth, .f, ..., .ragged = .ragged, .atomic = FALSE) } map_depth_rec <- function(.x, .depth, .f, ..., .ragged, .atomic) { if (.depth < 0) { abort("Invalid depth") } if (.atomic) { if (!.ragged) { abort("List not deep enough") } return(map(.x, .f, ...)) } if (.depth == 0) { return(.f(.x, ...)) } if (.depth == 1) { return(map(.x, .f, ...)) } # Should this be replaced with a generic way of figuring out atomic # types? .atomic <- is_atomic(.x) map(.x, function(x) { map_depth_rec(x, .depth - 1, .f, ..., .ragged = .ragged, .atomic = .atomic) }) } purrr/R/rate.R0000644000176200001440000002117013426303100012674 0ustar liggesusers#' Transform a function to make it run insistently or slowly #' #' @description #' #' * `insistently()` takes a function and modifies it to retry a given #' amount of time on error. #' #' * `slowly()` takes a function and modifies it to wait a given #' amount of time between each call. #' #' The number and rate of attempts is determined by a #' [rate][rate-helpers] object (by default a jittered exponential #' backoff rate for `insistently()`, and a constant rate for #' `slowly()`). #' #' @param f A function to modify. #' @inheritParams rate_sleep #' #' @seealso [httr::RETRY()] is a special case of [insistently()] for #' HTTP verbs. [rate_backoff()] and [rate_delay()] for creating #' custom backoff rates. [rate_sleep()] for the function powering #' `insistently()` and `slowly()`. [safely()] for another useful #' function operator. #' @examples #' # For the purpose of this example, we first create a custom rate #' # object with a low waiting time between attempts: #' rate <- rate_delay(0.1) #' #' # slowly() causes a function to sleep for a given time between calls: #' slow_runif <- slowly(~ runif(1), rate = rate, quiet = FALSE) #' map(1:5, slow_runif) #' #' #' # insistently() makes a function repeatedly try to work #' risky_runif <- function(lo = 0, hi = 1) { #' y <- runif(1, lo, hi) #' if(y < 0.9) { #' stop(y, " is too small") #' } #' y #' } #' #' # Let's now create an exponential backoff rate with a low waiting #' # time between attempts: #' rate <- rate_backoff(pause_base = 0.1, pause_min = 0.005, max_times = 4) #' #' # Modify your function to run insistently. #' insistent_risky_runif <- insistently(risky_runif, rate, quiet = FALSE) #' #' set.seed(6) # Succeeding seed #' insistent_risky_runif() #' #' set.seed(3) # Failing seed #' try(insistent_risky_runif()) #' #' #' # You can also use other types of rate settings, like a delay rate #' # that waits for a fixed amount of time. Be aware that a delay rate #' # has an infinite amount of attempts by default: #' rate <- rate_delay(0.2, max_times = 3) #' insistent_risky_runif <- insistently(risky_runif, rate = rate, quiet = FALSE) #' try(insistent_risky_runif()) #' #' #' # insistently() and possibly() are a useful combination #' rate <- rate_backoff(pause_base = 0.1, pause_min = 0.005) #' possibly_insistent_risky_runif <- possibly(insistent_risky_runif, otherwise = -99) #' #' set.seed(6) #' possibly_insistent_risky_runif() #' #' set.seed(3) #' possibly_insistent_risky_runif() #' @export insistently <- function(f, rate = rate_backoff(), quiet = TRUE) { f <- as_mapper(f) force(quiet) if (!is_rate(rate)) { stop_bad_type(rate, "a rate", arg = "rate") } function(...) { rate_reset(rate) repeat { rate_sleep(rate, quiet = quiet) out <- capture_error(f(...), quiet = quiet) if (is_null(out$error)) { return(out$result) } } } } #' @rdname insistently #' @export slowly <- function(f, rate = rate_delay(), quiet = TRUE) { f <- as_mapper(f) force(quiet) if (!is_rate(rate)) { stop_bad_type(rate, "a rate", arg = "rate") } function(...) { rate_sleep(rate, quiet = quiet) f(...) } } #' Create delaying rate settings #' #' These helpers create rate settings that you can pass to #' [insistently()]. You can also use them in your own functions with #' [rate_sleep()]. #' #' @param max_times Maximum number of requests to attempt. #' @param jitter Whether to introduce a random jitter in the waiting time. #' #' @seealso [rate_sleep()], [insistently()] #' @examples #' # A delay rate waits the same amount of time: #' rate <- rate_delay(0.02) #' for (i in 1:3) rate_sleep(rate, quiet = FALSE) #' #' # A backoff rate waits exponentially longer each time, with random #' # jitter by default: #' rate <- rate_backoff(pause_base = 0.2, pause_min = 0.005) #' for (i in 1:3) rate_sleep(rate, quiet = FALSE) #' @name rate-helpers NULL #' @rdname rate-helpers #' @param pause Delay between attempts in seconds. #' @export rate_delay <- function(pause = 1, max_times = Inf) { stopifnot(is_quantity(pause)) new_rate( "purrr_rate_delay", pause = pause, max_times = max_times, jitter = FALSE ) } #' @rdname rate-helpers #' @param pause_base,pause_cap `rate_backoff()` uses an exponential #' back-off so that each request waits `pause_base * 2^i` seconds, #' up to a maximum of `pause_cap` seconds. #' @param pause_min Minimum time to wait in the backoff; generally #' only necessary if you need pauses less than one second (which may #' not be kind to the server, use with caution!). #' @export rate_backoff <- function(pause_base = 1, pause_cap = 60, pause_min = 1, max_times = 3, jitter = TRUE) { stopifnot( is_quantity(pause_base), is_quantity(pause_cap), is_quantity(pause_min) ) new_rate( "purrr_rate_backoff", pause_base = pause_base, pause_cap = pause_cap, pause_min = pause_min, max_times = max_times, jitter = jitter ) } new_rate <- function(.subclass, ..., jitter = TRUE, max_times = 3) { stopifnot( is_bool(jitter), is_number(max_times) || identical(max_times, Inf) ) rate <- list( ..., state = env(i = 0L), jitter = jitter, max_times = max_times ) structure( rate, class = c(.subclass, "purrr_rate") ) } #' @rdname rate-helpers #' @param x An object to test. #' @export is_rate <- function(x) { inherits(x, "purrr_rate") } #' @export print.purrr_rate_delay <- function(x, ...) { cat_line(bold("")) print_purrr_rate(x) cat_line(bullet("`pause`: %.2f", x$pause)) invisible(x) } #' @export print.purrr_rate_backoff <- function(x, ...) { cat_line(bold("")) print_purrr_rate(x) cat_line( bullet("`pause_base`: %d", x$pause_base), bullet("`pause_cap`: %d", x$pause_cap), bullet("`pause_min`: %d", x$pause_min) ) invisible(x) } print_purrr_rate <- function(x, ...) { cat_line( # Using `%s` to convert `Inf` to character sprintf("Attempts: %d/%s", rate_count(x), x$max_times), "Fields:" ) invisible(x) } #' Wait for a given time #' #' If the rate's internal counter exceeds the maximum number of times #' it is allowed to sleep, `rate_sleep()` throws an error of class #' `purrr_error_rate_excess`. #' #' Call `rate_reset()` to reset the internal rate counter to 0. #' #' @param rate A [rate][rate_backoff] object determining the waiting time. #' @param quiet If `FALSE`, prints a message displaying how long until #' the next request. #' #' @seealso [rate_backoff()], [insistently()] #' @export rate_sleep <- function(rate, quiet = TRUE) { stopifnot(is_rate(rate)) i <- rate_count(rate) if (i > rate$max_times) { stop_rate_expired(rate) } if (i == rate$max_times) { stop_rate_excess(rate) } if (i == 0L) { rate_bump_count(rate) signal_rate_init(rate) return(invisible()) } on.exit(rate_bump_count(rate)) UseMethod("rate_sleep") } #' @export rate_sleep.purrr_rate_backoff <- function(rate, quiet = TRUE) { i <- rate_count(rate) pause_max <- min(rate$pause_cap, rate$pause_base * 2^i) if (rate$jitter) { pause_max <- stats::runif(1, 0, pause_max) } length <- max(rate$pause_min, pause_max) rate_sleep_impl(rate, length, quiet) } #' @export rate_sleep.purrr_rate_delay <- function(rate, quiet = TRUE) { rate_sleep_impl(rate, rate$pause, quiet) } rate_sleep_impl <- function(rate, length, quiet) { if (!quiet) { signal_rate_retry(rate, length, quiet) } Sys.sleep(length) } #' @rdname rate_sleep #' @export rate_reset <- function(rate) { stopifnot(is_rate(rate)) rate$state$i <- 0L invisible(rate) } rate_count <- function(rate) { rate$state$i } rate_bump_count <- function(rate, n = 1L) { rate$state$i <- rate$state$i + n invisible(rate) } signal_rate_init <- function(rate) { signal("", "purrr_condition_rate_init", rate = rate) } signal_rate_retry <- function(rate, length, quiet) { msg <- sprintf("Retrying in %.1g seconds.", length) class <- "purrr_message_rate_retry" if (quiet) { signal(msg, class, rate = rate, length = length) } else { inform(msg, class, rate = rate, length = length) } } stop_rate_expired <- function(rate) { msg <- paste_line( "This `rate` object has already be run more than `max_times` allows.", "Do you need to reset it with `rate_reset()`?" ) abort(msg, "purrr_error_rate_expired", rate = rate) } stop_rate_excess <- function(rate) { i <- rate_count(rate) # Bump counter to get an expired error next time around rate_bump_count(rate) msg <- sprintf("Request failed after %d attempts", i) abort(msg, "purrr_error_rate_excess", rate = rate) } purrr/R/purrr.R0000644000176200001440000000034313435531200013116 0ustar liggesusers#' @keywords internal #' @import rlang #' @useDynLib purrr, .registration = TRUE "_PACKAGE" has_force_and_call <- FALSE .onLoad <- function(lib, pkg) { if (getRversion() >= "3.2.3") { has_force_and_call <<- TRUE } } purrr/R/when.R0000644000176200001440000000547613403735151012727 0ustar liggesusers#' Match/validate a set of conditions for an object and continue with the action #' associated with the first valid match. #' #' `when` is a flavour of pattern matching (or an if-else abstraction) in #' which a value is matched against a sequence of condition-action sets. When a #' valid match/condition is found the action is executed and the result of the #' action is returned. #' #' @param . the value to match against #' @param ... formulas; each containing a condition as LHS and an action as RHS. #' named arguments will define additional values. #' @keywords internal #' @return The value resulting from the action of the first valid #' match/condition is returned. If no matches are found, and no default is #' given, NULL will be returned. #' # @details condition-action sets are written as formulas with conditions as # left-hand sides and actions as right-hand sides. A formula with only a # right-hand will be treated as a condition which is always satisfied. For # such a default case one can also omit the `~` symbol, but note that its # value will then be evaluated. Any named argument will be made available in # all conditions and actions, which is useful in avoiding repeated temporary # computations or temporary assignments. # #' Validity of the conditions are tested with `isTRUE`, or equivalently #' with `identical(condition, TRUE)`. #' In other words conditions resulting in more than one logical will never #' be valid. Note that the input value is always treated as a single object, #' as opposed to the `ifelse` function. #' #' @examples #' 1:10 %>% #' when( #' sum(.) <= 50 ~ sum(.), #' sum(.) <= 100 ~ sum(.)/2, #' ~ 0 #' ) #' #' 1:10 %>% #' when( #' sum(.) <= x ~ sum(.), #' sum(.) <= 2*x ~ sum(.)/2, #' ~ 0, #' x = 60 #' ) #' #' iris %>% #' subset(Sepal.Length > 10) %>% #' when( #' nrow(.) > 0 ~ ., #' ~ iris %>% head(10) #' ) #' #' iris %>% #' head %>% #' when(nrow(.) < 10 ~ ., #' ~ stop("Expected fewer than 10 rows.")) #' @export when <- function(., ...) { dots <- list(...) names <- names(dots) named <- if (is.null(names)) rep(FALSE, length(dots)) else names != "" if (sum(!named) == 0) stop("At least one matching condition is needed.", call. = FALSE) is_formula <- vapply(dots, function(dot) identical(class(dot), "formula"), logical(1L)) env <- new.env(parent = parent.frame()) env[["."]] <- . if (sum(named) > 0) for (i in which(named)) env[[names[i]]] <- dots[[i]] result <- NULL for (i in which(!named)) { if (is_formula[i]) { action <- length(dots[[i]]) if (action == 2 || is_true(eval(dots[[i]][[2]], env, env))) { result <- eval(dots[[i]][[action]], env, env) break } } else { result <- dots[[i]] } } result } purrr/R/along.R0000644000176200001440000000077513426303077013066 0ustar liggesusers#' Helper to create vectors with matching length. #' #' These functions take the idea of [seq_along()] and generalise #' it to creating lists (`list_along`) and repeating values #' (`rep_along`). #' #' @param x A vector. #' @param y Values to repeat. #' @return A vector of the same length as `x`. #' @keywords internal #' @examples #' x <- 1:5 #' rep_along(x, 1:2) #' rep_along(x, 1) #' list_along(x) #' @name along NULL #' @export #' @rdname along list_along <- function(x) { vector("list", length(x)) } purrr/R/flatten.R0000644000176200001440000000416413540423760013416 0ustar liggesusers#' Flatten a list of lists into a simple vector. #' #' These functions remove a level hierarchy from a list. They are similar to #' [unlist()], but they only ever remove a single layer of hierarchy and they #' are type-stable, so you always know what the type of the output is. #' #' @param .x A list to flatten. The contents of the list can be anything for #' `flatten()` (as a list is returned), but the contents must match the #' type for the other functions. #' @return `flatten()` returns a list, `flatten_lgl()` a logical #' vector, `flatten_int()` an integer vector, `flatten_dbl()` a #' double vector, and `flatten_chr()` a character vector. #' #' `flatten_dfr()` and `flatten_dfc()` return data frames created by #' row-binding and column-binding respectively. They require dplyr to #' be installed. #' @inheritParams map #' @export #' @examples #' x <- rerun(2, sample(4)) #' x #' x %>% flatten() #' x %>% flatten_int() #' #' # You can use flatten in conjunction with map #' x %>% map(1L) %>% flatten_int() #' # But it's more efficient to use the typed map instead. #' x %>% map_int(1L) flatten <- function(.x) { .Call(flatten_impl, .x) } #' @export #' @rdname flatten flatten_lgl <- function(.x) { .Call(vflatten_impl, .x, "logical") } #' @export #' @rdname flatten flatten_int <- function(.x) { .Call(vflatten_impl, .x, "integer") } #' @export #' @rdname flatten flatten_dbl <- function(.x) { .Call(vflatten_impl, .x, "double") } #' @export #' @rdname flatten flatten_chr <- function(.x) { .Call(vflatten_impl, .x, "character") } #' @export #' @rdname flatten flatten_raw <- function(.x) { .Call(vflatten_impl, .x, "raw") } #' @export #' @rdname flatten flatten_dfr <- function(.x, .id = NULL) { if (!is_installed("dplyr")) { abort("`flatten_dfr()` requires dplyr") } res <- .Call(flatten_impl, .x) dplyr::bind_rows(res, .id = .id) } #' @export #' @rdname flatten flatten_dfc <- function(.x) { if (!is_installed("dplyr")) { abort("`flatten_dfc()` requires dplyr") } res <- .Call(flatten_impl, .x) dplyr::bind_cols(res) } #' @export #' @rdname flatten #' @usage NULL flatten_df <- flatten_dfr purrr/R/composition.R0000644000176200001440000001556013403735151014324 0ustar liggesusers#' Lift the domain of a function #' #' `lift_xy()` is a composition helper. It helps you compose #' functions by lifting their domain from a kind of input to another #' kind. The domain can be changed from and to a list (l), a vector #' (v) and dots (d). For example, `lift_ld(fun)` transforms a #' function taking a list to a function taking dots. #' #' The most important of those helpers is probably `lift_dl()` #' because it allows you to transform a regular function to one that #' takes a list. This is often essential for composition with purrr #' functional tools. Since this is such a common function, #' `lift()` is provided as an alias for that operation. #' #' @inheritParams as_vector #' @param ..f A function to lift. #' @param ... Default arguments for `..f`. These will be #' evaluated only once, when the lifting factory is called. #' @return A function. #' @name lift #' @seealso [invoke()] NULL #' @rdname lift #' @section from ... to `list(...)` or `c(...)`: #' Here dots should be taken here in a figurative way. The lifted #' functions does not need to take dots per se. The function is #' simply wrapped a function in [do.call()], so instead #' of taking multiple arguments, it takes a single named list or #' vector which will be interpreted as its arguments. This is #' particularly useful when you want to pass a row of a data frame #' or a list to a function and don't want to manually pull it apart #' in your function. #' @param .unnamed If `TRUE`, `ld` or `lv` will not #' name the parameters in the lifted function signature. This #' prevents matching of arguments by name and match by position #' instead. #' @export #' @examples #' ### Lifting from ... to list(...) or c(...) #' #' x <- list(x = c(1:100, NA, 1000), na.rm = TRUE, trim = 0.9) #' lift_dl(mean)(x) #' #' # Or in a pipe: #' mean %>% lift_dl() %>% invoke(x) #' #' # You can also use the lift() alias for this common operation: #' lift(mean)(x) #' #' # Default arguments can also be specified directly in lift_dl() #' list(c(1:100, NA, 1000)) %>% lift_dl(mean, na.rm = TRUE)() #' #' # lift_dl() and lift_ld() are inverse of each other. #' # Here we transform sum() so that it takes a list #' fun <- sum %>% lift_dl() #' fun(list(3, NA, 4, na.rm = TRUE)) #' #' # Now we transform it back to a variadic function #' fun2 <- fun %>% lift_ld() #' fun2(3, NA, 4, na.rm = TRUE) #' #' # It can sometimes be useful to make sure the lifted function's #' # signature has no named parameters, as would be the case for a #' # function taking only dots. The lifted function will take a list #' # or vector but will not match its arguments to the names of the #' # input. For instance, if you give a data frame as input to your #' # lifted function, the names of the columns are probably not #' # related to the function signature and should be discarded. #' lifted_identical <- lift_dl(identical, .unnamed = TRUE) #' mtcars[c(1, 1)] %>% lifted_identical() #' mtcars[c(1, 2)] %>% lifted_identical() lift <- function(..f, ..., .unnamed = FALSE) { force(..f) defaults <- list(...) function(.x = list(), ...) { if (.unnamed) { .x <- unname(.x) } do.call("..f", c(.x, defaults, list(...))) } } #' @rdname lift #' @export lift_dl <- lift #' @rdname lift #' @export lift_dv <- function(..f, ..., .unnamed = FALSE) { force(..f) defaults <- list(...) function(.x, ...) { if (.unnamed) { .x <- unname(.x) } .x <- as.list(.x) do.call("..f", c(.x, defaults, list(...))) } } #' @rdname lift #' @section from `c(...)` to `list(...)` or `...`: #' These factories allow a function taking a vector to take a list #' or dots instead. The lifted function internally transforms its #' inputs back to an atomic vector. purrr does not obey the usual R #' casting rules (e.g., `c(1, "2")` produces a character #' vector) and will produce an error if the types are not #' compatible. Additionally, you can enforce a particular vector #' type by supplying `.type`. #' @export #' @examples #' # #' #' #' ### Lifting from c(...) to list(...) or ... #' #' # In other situations we need the vector-valued function to take a #' # variable number of arguments as with pmap(). This is a job for #' # lift_vd(): #' pmap(mtcars, lift_vd(mean)) #' #' # lift_vd() will collect the arguments and concatenate them to a #' # vector before passing them to ..f. You can add a check to assert #' # the type of vector you expect: #' lift_vd(tolower, .type = character(1))("this", "is", "ok") lift_vl <- function(..f, ..., .type) { force(..f) defaults <- list(...) if (missing(.type)) .type <- NULL function(.x = list(), ...) { x <- as_vector(.x, .type) do.call("..f", c(list(x), defaults, list(...))) } } #' @rdname lift #' @export lift_vd <- function(..f, ..., .type) { force(..f) defaults <- list(...) if (missing(.type)) .type <- NULL function(...) { x <- as_vector(list(...), .type) do.call("..f", c(list(x), defaults)) } } #' @rdname lift #' @section from list(...) to c(...) or ...: #' `lift_ld()` turns a function that takes a list into a #' function that takes dots. `lift_vd()` does the same with a #' function that takes an atomic vector. These factory functions are #' the inverse operations of `lift_dl()` and `lift_dv()`. #' #' `lift_vd()` internally coerces the inputs of `..f` to #' an atomic vector. The details of this coercion can be controlled #' with `.type`. #' #' @export #' @examples #' # #' #' #' ### Lifting from list(...) to c(...) or ... #' #' # cross() normally takes a list of elements and returns their #' # cartesian product. By lifting it you can supply the arguments as #' # if it was a function taking dots: #' cross_dots <- lift_ld(cross) #' out1 <- cross(list(a = 1:2, b = c("a", "b", "c"))) #' out2 <- cross_dots(a = 1:2, b = c("a", "b", "c")) #' identical(out1, out2) #' #' # This kind of lifting is sometimes needed for function #' # composition. An example would be to use pmap() with a function #' # that takes a list. In the following, we use some() on each row of #' # a data frame to check they each contain at least one element #' # satisfying a condition: #' mtcars %>% pmap(lift_ld(some, partial(`<`, 200))) #' #' # Default arguments for ..f can be specified in the call to #' # lift_ld() #' lift_ld(cross, .filter = `==`)(1:3, 1:3) %>% str() #' #' #' # Here is another function taking a list and that we can update to #' # take a vector: #' glue <- function(l) { #' if (!is.list(l)) stop("not a list") #' l %>% invoke(paste, .) #' } #' #' \dontrun{ #' letters %>% glue() # fails because glue() expects a list} #' #' letters %>% lift_lv(glue)() # succeeds lift_ld <- function(..f, ...) { force(..f) defaults <- list(...) function(...) { do.call("..f", c(list(list(...)), defaults)) } } #' @rdname lift #' @export lift_lv <- function(..f, ...) { force(..f) defaults <- list(...) function(.x, ...) { do.call("..f", c(list(as.list(.x)), defaults, list(...))) } } purrr/R/splice.R0000644000176200001440000000214013426303100013214 0ustar liggesusers#' Splice objects and lists of objects into a list #' #' @description #' #' \Sexpr[results=rd, stage=render]{purrr:::lifecycle("questioning")} #' #' This splices all arguments into a list. Non-list objects and lists #' with a S3 class are encapsulated in a list before concatenation. #' #' @param ... Objects to concatenate. #' @return A list. #' #' @section Life cycle: #' #' `splice()` is in the questioning lifecycle stage as of purrr #' 0.3.0. We are now favouring the `!!!` syntax enabled by #' [rlang::list2()]. #' #' @examples #' inputs <- list(arg1 = "a", arg2 = "b") #' #' # splice() concatenates the elements of inputs with arg3 #' splice(inputs, arg3 = c("c1", "c2")) %>% str() #' list(inputs, arg3 = c("c1", "c2")) %>% str() #' c(inputs, arg3 = c("c1", "c2")) %>% str() #' @export splice <- function(...) { splice_if(list(...), is_bare_list) } splice_if <- function(.x, .p) { unspliced <- !probe(.x, .p) out <- modify_if(.x, unspliced, list) # Copy outer names to inner if (!is.null(names(.x))) { out[unspliced] <- map2(out[unspliced], names(out)[unspliced], set_names) } flatten(out) } purrr/R/retired-invoke.R0000644000176200001440000001327113426303100014673 0ustar liggesusers#' Invoke functions. #' #' @keywords internal #' @description #' #' \Sexpr[results=rd, stage=render]{purrr:::lifecycle("retired")} #' #' This pair of functions make it easier to combine a function and list #' of parameters to get a result. `invoke` is a wrapper around #' `do.call` that makes it easy to use in a pipe. `invoke_map` #' makes it easier to call lists of functions with lists of parameters. #' #' @param .f For `invoke`, a function; for `invoke_map` a #' list of functions. #' @param .x For `invoke`, an argument-list; for `invoke_map` a #' list of argument-lists the same length as `.f` (or length 1). #' The default argument, `list(NULL)`, will be recycled to the #' same length as `.f`, and will call each function with no #' arguments (apart from any supplied in `...`. #' @param ... Additional arguments passed to each function. #' @param .env Environment in which [do.call()] should #' evaluate a constructed expression. This only matters if you pass #' as `.f` the name of a function rather than its value, or as #' `.x` symbols of objects rather than their values. #' @inheritParams map #' #' @section Life cycle: #' #' These functions are retired in favour of [exec()]. They are no #' longer under active development but we will maintain them in the #' package undefinitely. #' #' * `invoke()` is retired in favour of the simpler `exec()` function #' reexported from rlang. `exec()` evaluates a function call built #' from its inputs and supports tidy dots: #' #' ``` #' # Before: #' invoke(mean, list(na.rm = TRUE), x = 1:10) #' #' # After #' exec(mean, 1:10, !!!list(na.rm = TRUE)) #' ``` #' #' * `invoke_map()` is is retired without replacement because it is #' more complex to understand than the corresponding code using #' `map()`, `map2()` and `exec()`: #' #' ``` #' # Before: #' invoke_map(fns, list(args)) #' invoke_map(fns, list(args1, args2)) #' #' # After: #' map(fns, exec, !!!args) #' map2(fns, list(args1, args2), function(fn, args) exec(fn, !!!args)) #' ``` #' #' @family map variants #' @examples #' # Invoke a function with a list of arguments #' invoke(runif, list(n = 10)) #' # Invoke a function with named arguments #' invoke(runif, n = 10) #' #' # Combine the two: #' invoke(paste, list("01a", "01b"), sep = "-") #' # That's more natural as part of a pipeline: #' list("01a", "01b") %>% #' invoke(paste, ., sep = "-") #' #' # Invoke a list of functions, each with different arguments #' invoke_map(list(runif, rnorm), list(list(n = 10), list(n = 5))) #' # Or with the same inputs: #' invoke_map(list(runif, rnorm), list(list(n = 5))) #' invoke_map(list(runif, rnorm), n = 5) #' # Or the same function with different inputs: #' invoke_map("runif", list(list(n = 5), list(n = 10))) #' #' # Or as a pipeline #' list(m1 = mean, m2 = median) %>% invoke_map(x = rcauchy(100)) #' list(m1 = mean, m2 = median) %>% invoke_map_dbl(x = rcauchy(100)) #' #' # Note that you can also match by position by explicitly omitting `.x`. #' # This can be useful when the argument names of the functions are not #' # identical #' list(m1 = mean, m2 = median) %>% #' invoke_map(, rcauchy(100)) #' #' # If you have pairs of function name and arguments, it's natural #' # to store them in a data frame. Here we use a tibble because #' # it has better support for list-columns #' if (rlang::is_installed("tibble")) { #' df <- tibble::tibble( #' f = c("runif", "rpois", "rnorm"), #' params = list( #' list(n = 10), #' list(n = 5, lambda = 10), #' list(n = 10, mean = -3, sd = 10) #' ) #' ) #' df #' invoke_map(df$f, df$params) #' } #' @export invoke <- function(.f, .x = NULL, ..., .env = NULL) { .env <- .env %||% parent.frame() args <- c(as.list(.x), list(...)) do.call(.f, args, envir = .env) } as_invoke_function <- function(f) { if (is.function(f)) { list(f) } else { f } } #' @rdname invoke #' @export invoke_map <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export invoke_map_lgl <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2_lgl(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export invoke_map_int <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2_int(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export invoke_map_dbl <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2_dbl(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export invoke_map_chr <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2_chr(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export invoke_map_raw <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2_raw(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export invoke_map_dfr <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2_dfr(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export invoke_map_dfc <- function(.f, .x = list(NULL), ..., .env = NULL) { .env <- .env %||% parent.frame() .f <- as_invoke_function(.f) map2_dfc(.f, .x, invoke, ..., .env = .env) } #' @rdname invoke #' @export #' @usage NULL invoke_map_df <- invoke_map_dfr #' @rdname invoke #' @export #' @usage NULL map_call <- function(.x, .f, ...) { .Defunct("`map_call()` is deprecated. Please use `invoke()` instead.") } purrr/R/prepend.R0000644000176200001440000000165413551356667013434 0ustar liggesusers#' Prepend a vector #' #' This is a companion to [append()] to help merging two #' lists or atomic vectors. `prepend()` is a clearer semantic #' signal than `c()` that a vector is to be merged at the beginning of #' another, especially in a pipe chain. #' #' @param x the vector to be modified. #' @param values to be included in the modified vector. #' @param before a subscript, before which the values are to be appended. If #' `NULL`, values will be appended at the beginning even for `x` of length 0. #' @return A merged vector. #' @export #' @examples #' x <- as.list(1:3) #' #' x %>% append("a") #' x %>% prepend("a") #' x %>% prepend(list("a", "b"), before = 3) #' prepend(list(), x) prepend <- function(x, values, before = NULL) { n <- length(x) stopifnot(is.null(before) || (before > 0 && before <= n)) if (is.null(before) || before == 1) { c(values, x) } else { c(x[1:(before - 1)], values, x[before:n]) } } purrr/R/coercion.R0000644000176200001440000000567113403735151013564 0ustar liggesusers#' Coerce a list to a vector #' #' `as_vector()` collapses a list of vectors into one vector. It #' checks that the type of each vector is consistent with #' `.type`. If the list can not be simplified, it throws an error. #' `simplify` will simplify a vector if possible; `simplify_all` #' will apply `simplify` to every element of a list. #' #' `.type` can be a vector mold specifying both the type and the #' length of the vectors to be concatenated, such as `numeric(1)` #' or `integer(4)`. Alternatively, it can be a string describing #' the type, one of: "logical", "integer", "double", "complex", #' "character" or "raw". #' #' @param .x A list of vectors #' @param .type A vector mold or a string describing the type of the #' input vectors. The latter can be any of the types returned by #' [typeof()], or "numeric" as a shorthand for either #' "double" or "integer". #' @export #' @examples #' # Supply the type either with a string: #' as.list(letters) %>% as_vector("character") #' #' # Or with a vector mold: #' as.list(letters) %>% as_vector(character(1)) #' #' # Vector molds are more flexible because they also specify the #' # length of the concatenated vectors: #' list(1:2, 3:4, 5:6) %>% as_vector(integer(2)) #' #' # Note that unlike vapply(), as_vector() never adds dimension #' # attributes. So when you specify a vector mold of size > 1, you #' # always get a vector and not a matrix as_vector <- function(.x, .type = NULL) { if (can_simplify(.x, .type)) { unlist(.x) } else { stop("Cannot coerce .x to a vector", call. = FALSE) } } #' @export #' @rdname as_vector simplify <- function(.x, .type = NULL) { if (can_simplify(.x, .type)) { unlist(.x) } else { .x } } #' @export #' @rdname as_vector simplify_all <- function(.x, .type = NULL) { map(.x, simplify, .type = .type) } # Simplify a list of atomic vectors of the same type to a vector # # simplify_list(list(1, 2, 3)) can_simplify <- function(x, type = NULL) { is_atomic <- vapply(x, is.atomic, logical(1)) if (!all(is_atomic)) return(FALSE) mode <- unique(vapply(x, typeof, character(1))) if (length(mode) > 1 && !all(c("double", "integer") %in% mode)) { return(FALSE) } # This can be coerced safely. If type is supplied, perform # additional check is.null(type) || can_coerce(x, type) } can_coerce <- function(x, type) { actual <- typeof(x[[1]]) if (is_mold(type)) { lengths <- unique(map_int(x, length)) if (length(lengths) > 1 || !(lengths == length(type))) { return(FALSE) } else { type <- typeof(type) } } if (actual == "integer" && type %in% c("integer", "double", "numeric")) { return(TRUE) } if (actual %in% c("integer", "double") && type == "numeric") { return(TRUE) } actual == type } # is a mold? As opposed to a string is_mold <- function(type) { modes <- c("numeric", "logical", "integer", "double", "complex", "character", "raw") length(type) > 1 || (!type %in% modes) } purrr/R/list-modify.R0000644000176200001440000000660713426303100014211 0ustar liggesusers#' Modify a list #' #' @description #' #' `list_modify()` and `list_merge()` recursively combine two lists, matching #' elements either by name or position. If a sub-element is present in #' both lists `list_modify()` takes the value from `y`, and `list_merge()` #' concatenates the values together. #' #' `update_list()` handles formulas and quosures that can refer to #' values existing within the input list. Note that this function #' might be deprecated in the future in favour of a `dplyr::mutate()` #' method for lists. #' #' @param .x List to modify. #' @param ... New values of a list. Use `zap()` to remove values. #' #' These values should be either all named or all unnamed. When #' inputs are all named, they are matched to `.x` by name. When they #' are all unnamed, they are matched positionally. #' #' These dots support [tidy dots][rlang::list2] features. In #' particular, if your functions are stored in a list, you can #' splice that in with `!!!`. #' @export #' @examples #' x <- list(x = 1:10, y = 4, z = list(a = 1, b = 2)) #' str(x) #' #' # Update values #' str(list_modify(x, a = 1)) #' # Replace values #' str(list_modify(x, z = 5)) #' str(list_modify(x, z = list(a = 1:5))) #' #' # Remove values #' str(list_modify(x, z = zap())) #' #' # Combine values #' str(list_merge(x, x = 11, z = list(a = 2:5, c = 3))) #' #' #' # All these functions support tidy dots features. Use !!! to splice #' # a list of arguments: #' l <- list(new = 1, y = zap(), z = 5) #' str(list_modify(x, !!!l)) list_modify <- function(.x, ...) { list_recurse(.x, list2(...), function(x, y) y) } #' @export #' @rdname list_modify list_merge <- function(.x, ...) { list_recurse(.x, list2(...), c) } list_recurse <- function(x, y, base_case) { stopifnot(is.list(x), is.list(y)) if (is_empty(x)) { return(y) } if (is_empty(y)) { return(x) } y_names <- names(y) if (!is_null(y_names) && !is_names(y_names)) { abort("`...` arguments must be either all named, or all unnamed") } if (is_null(y_names)) { for (i in rev(seq_along(y))) { if (i <= length(x) && is_list(x[[i]]) && is_list(y[[i]])) { x[[i]] <- list_recurse(x[[i]], y[[i]], base_case) } else { x[[i]] <- maybe_zap(base_case(x[[i]], y[[i]])) } } } else { for (i in seq_along(y_names)) { nm <- y_names[[i]] if (has_name(x, nm) && is_list(x[[nm]]) && is_list(y[[i]])) { x[[nm]] <- list_recurse(x[[nm]], y[[i]], base_case) } else { x[[nm]] <- maybe_zap(base_case(x[[nm]], y[[i]])) } } } x } maybe_zap <- function(x) { if (is_zap(x)) { return(NULL) } if (!is_null(x)) { return(x) } signal_soft_deprecated(paste_line( "Removing elements with `NULL` is soft-deprecated as of purrr 0.3.0.", "Please use `zap()` instead of `NULL`", "", " # Before:", " list_modify(x, foo = NULL)", "", " # After:", " list_modify(x, foo = zap())" )) # Allow removing with `NULL` for now. In purrr 0.5.0, this # functionality will be defunct and we'll allow setting elements to # `NULL`. NULL } #' @rdname list_modify #' @export #' @usage NULL update_list <- function(.x, ...) { dots <- dots_list(...) formulas <- map_lgl(dots, is_bare_formula, lhs = FALSE, scoped = TRUE) dots <- map_if(dots, formulas, as_quosure) dots <- map_if(dots, is_quosure, eval_tidy, data = .x) list_recurse(.x, dots, function(x, y) y) } purrr/R/compose.R0000644000176200001440000000431113435516707013427 0ustar liggesusers#' Compose multiple functions #' #' @param ... Functions to apply in order (from right to left by #' default). Formulas are converted to functions in the usual way. #' #' These dots support [tidy dots][rlang::list2] features. In #' particular, if your functions are stored in a list, you can #' splice that in with `!!!`. #' @param .dir If `"backward"` (the default), the functions are called #' in the reverse order, from right to left, as is conventional in #' mathematics. If `"forward"`, they are called from left to right. #' @return A function #' @export #' @examples #' not_null <- compose(`!`, is.null) #' not_null(4) #' not_null(NULL) #' #' add1 <- function(x) x + 1 #' compose(add1, add1)(8) #' #' # You can use the formula shortcut for functions: #' fn <- compose(~ paste(.x, "foo"), ~ paste(.x, "bar")) #' fn("input") #' #' # Lists of functions can be spliced with !!! #' fns <- list( #' function(x) paste(x, "foo"), #' ~ paste(.x, "bar") #' ) #' fn <- compose(!!!fns) #' fn("input") compose <- function(..., .dir = c("backward", "forward")) { .dir <- arg_match(.dir, c("backward", "forward")) fns <- map(list2(...), rlang::as_closure, env = caller_env()) if (!length(fns)) { # Return the identity function return(compose(function(x, ...) x)) } if (.dir == "backward") { n <- length(fns) first_fn <- fns[[n]] fns <- rev(fns[-n]) } else { first_fn <- fns[[1]] fns <- fns[-1] } composed <- function() { env <- env(caller_env(), `_fn` = first_fn) first_call <- sys.call() first_call[[1]] <- quote(`_fn`) env$`_out` <- .Call(purrr_eval, first_call, env) call <- quote(`_fn`(`_out`)) for (fn in fns) { env$`_fn` <- fn env$`_out` <- .Call(purrr_eval, call, env) } env$`_out` } formals(composed) <- formals(first_fn) structure( composed, class = c("purrr_function_compose", "function"), first_fn = first_fn, fns = fns ) } #' @export print.purrr_function_compose <- function(x, ...) { cat("\n") first <- attr(x, "first_fn") cat("1. ") print(first, ...) fns <- attr(x, "fns") for (i in seq_along(fns)) { cat(sprintf("\n%d. ", i + 1)) print(fns[[i]], ...) } invisible(x) } purrr/R/coerce.R0000644000176200001440000000055013413636342013215 0ustar liggesusers# Used internally by map and flatten. # Exposed here for testing coerce <- function(x, type) { .Call(coerce_impl, x, type) } coerce_lgl <- function(x) coerce(x, "logical") coerce_int <- function(x) coerce(x, "integer") coerce_dbl <- function(x) coerce(x, "double") coerce_chr <- function(x) coerce(x, "character") coerce_raw <- function(x) coerce(x, "raw") purrr/R/keep.R0000644000176200001440000000334213426303100012666 0ustar liggesusers#' Keep or discard elements using a predicate function. #' #' `keep()` and `discard()` are opposites. `compact()` is a handy #' wrapper that removes all empty elements. #' #' These are usually called `select` or `filter` and `reject` or #' `drop`, but those names are already taken. `keep()` is similar to #' [Filter()], but the argument order is more convenient, and the #' evaluation of the predicate function `.p` is stricter. #' #' @param .x A list or vector. #' @param .p For `keep()` and `discard()`, a predicate function. Only #' those elements where `.p` evaluates to `TRUE` will be kept or #' discarded. #' #' For `compact()`, a function that is applied to each element of #' `.x`. Only those elements where `.p` evaluates to an empty vector #' will be discarded. #' @param ... Additional arguments passed on to `.p`. #' @inheritParams map_if #' @export #' @examples #' rep(10, 10) %>% #' map(sample, 5) %>% #' keep(function(x) mean(x) > 6) #' #' # Or use a formula #' rep(10, 10) %>% #' map(sample, 5) %>% #' keep(~ mean(.x) > 6) #' #' # Using a string instead of a function will select all list elements #' # where that subelement is TRUE #' x <- rerun(5, a = rbernoulli(1), b = sample(10)) #' x #' x %>% keep("a") #' x %>% discard("a") #' #' # compact() discards elements that are NULL or that have length zero #' list(a = "a", b = NULL, c = integer(0), d = NA, e = list()) %>% #' compact() keep <- function(.x, .p, ...) { sel <- probe(.x, .p, ...) .x[!is.na(sel) & sel] } #' @export #' @rdname keep discard <- function(.x, .p, ...) { sel <- probe(.x, .p, ...) .x[is.na(sel) | !sel] } #' @export #' @rdname keep compact <- function(.x, .p = identity) { .f <- as_mapper(.p) discard(.x, function(x) is_empty(.f(x))) } purrr/R/rerun.R0000644000176200001440000000277113426303100013102 0ustar liggesusers#' Re-run expressions multiple times. #' #' @description #' #' \Sexpr[results=rd, stage=render]{purrr:::lifecycle("questioning")} #' #' This is a convenient way of generating sample data. It works similarly to #' \code{\link{replicate}(..., simplify = FALSE)}. #' #' @param .n Number of times to run expressions #' @param ... Expressions to re-run. #' @return A list of length `.n`. Each element of `...` will be #' re-run once for each `.n`. #' #' There is one special case: if there's a single unnamed input, the second #' level list will be dropped. In this case, `rerun(n, x)` behaves like #' `replicate(n, x, simplify = FALSE)`. #' #' @section Lifecycle: #' #' `rerun()` is in the questioning lifecycle stage because we are no #' longer convinced NSE functions are a good fit for purrr. Also, #' `rerun(n, x)` can just as easily be expressed as `map(1:n, ~ x)` #' (with the added benefit of being passed the current index as #' argument to the lambda). #' #' @export #' @examples #' 10 %>% rerun(rnorm(5)) #' 10 %>% #' rerun(x = rnorm(5), y = rnorm(5)) %>% #' map_dbl(~ cor(.x$x, .x$y)) rerun <- function(.n, ...) { dots <- quos(...) # Special case: if single unnamed argument, insert directly into the output # rather than wrapping in a list. if (length(dots) == 1 && !has_names(dots)) { dots <- dots[[1]] eval_dots <- eval_tidy } else { eval_dots <- function(x) lapply(x, eval_tidy) } out <- vector("list", .n) for (i in seq_len(.n)) { out[[i]] <- eval_dots(dots) } out } purrr/R/conditions.R0000644000176200001440000001622413426303077014133 0ustar liggesusers#' Error conditions for bad types #' #' @param x The object whose type doesn't match `expected`. #' @param what What does `x` represent? This is used to introduce the #' object in the error message and should be capitalised. If `NULL` #' and `arg` is `NULL` as well, defaults to `"Object"`. Otherwise #' defaults to `arg` wrapped in backquotes. #' @param expected,actual The expected and actual type of `x`, in #' friendly representation. If `actual` is not supplied, `x` is #' passed to `friendly_type_of()` to provide a default value. #' @param index The index of `x` when it is an element of a vector. #' @param ...,message,.subclass Only use these fields when creating a subclass. #' #' @details #' #' Some of the fields are expected to be in friendly representation, #' i.e. a longer description that includes indefinite articles. For #' example, a friendly representation of `"integer"` would be #' `"an integer vector"`. #' #' Fields in pretty representation are meant for printing, not for #' testing. They should not be relied on in unit tests as upstream #' packages might tweak the friendly representation at any time. #' #' @keywords internal #' @name purrr-conditions-type #' @noRd NULL stop_bad_type <- function(x, expected, ..., actual = NULL, what = NULL, arg = NULL, message = NULL, .subclass = NULL) { what <- what %||% what_bad_object(arg) %||% "Object" actual <- actual %||% friendly_type_of(x) message <- message %||% sprintf( "%s must be %s, not %s", what, expected, actual ) abort( message, x = x, expected = expected, actual = actual, what = what, arg = arg, ..., .subclass = c(.subclass, "purrr_error_bad_type") ) } stop_bad_element_type <- function(x, index, expected, ..., actual = NULL, what = NULL, arg = NULL, message = NULL, .subclass = NULL) { stopifnot(is_integerish(index, n = 1, finite = TRUE)) what <- what_bad_element(what, arg, index) stop_bad_type( x, expected, actual = actual, what = what, arg = arg, index = index, ..., message = message, .subclass = c(.subclass, "purrr_error_bad_element_type") ) } what_bad_object <- function(arg) { if (is_null(arg)) { NULL } else if (is_string(arg)) { sprintf("`%s`", arg) } else { stop_bad_type(arg, "`NULL` or a string", arg = "arg") } } what_bad_element <- function(what, arg, index) { if (is_null(arg)) { where <- "" } else { where <- sprintf(" of `%s`", as_string(arg)) } what <- what %||% "Element" sprintf("%s %d%s", what, index, where) } #' Error conditions for bad lengths #' #' @inheritParams purrr-conditions-type #' @param expected_length The expected length as a number. The actual length #' is computed with `length(x)`. #' @param recycle Whether `x` is also allowed to have length 1. #' #' @keywords internal #' @name purrr-conditions-length #' @noRd NULL stop_bad_length <- function(x, expected_length, ..., what = NULL, arg = NULL, message = NULL, recycle = FALSE, .subclass = NULL) { what <- what %||% what_bad_object(arg) %||% "Vector" if (recycle) { expected <- sprintf("1 or %s", expected_length) } else { expected <- as.character(expected_length) } actual <- length(x) message <- message %||% sprintf( "%s must have length %s, not %s", what, expected, actual ) abort( message, x = x, expected_length = expected_length, what = what, arg = arg, recycle = recycle, ..., .subclass = c(.subclass, "purrr_error_bad_length") ) } stop_bad_element_length <- function(x, index, expected_length, ..., what = NULL, arg = NULL, message = NULL, recycle = FALSE, .subclass = NULL) { stopifnot(is_integerish(index, n = 1, finite = TRUE)) what <- what_bad_element(what, arg, index) stop_bad_length( x, expected_length, what = what, arg = arg, index = index, ..., recycle = recycle, message = message, .subclass = c(.subclass, "purrr_error_bad_element_length") ) } #' Error conditions for bad vectors #' #' @inheritParams purrr-conditions-length #' @param expected_ptype The expected prototype of `x`, i.e. an empty #' vector of the expected type. #' #' @keywords internal #' @name purrr-conditions-vector #' @noRd stop_bad_vector <- function(x, expected_ptype, expected_length = NULL, ..., what = NULL, arg = NULL, message = NULL, recycle = FALSE, .subclass = NULL) { what <- what %||% what_bad_object(arg) %||% "Vector" expected <- friendly_vector_type(expected_ptype, expected_length, recycle) actual <- friendly_vector_type(x, length(x)) stop_bad_type( x, expected, actual = actual, what = what, arg = arg, recycle = recycle, message = message, .subclass = c(.subclass, "purrr_error_bad_vector") ) } stop_bad_element_vector <- function(x, index, expected_ptype, expected_length, ..., what = NULL, arg = NULL, message = NULL, recycle = FALSE, .subclass = NULL) { stopifnot(is_integerish(index, n = 1, finite = TRUE)) what <- what_bad_element(what, arg, index) stop_bad_vector( x, expected_ptype, expected_length, what = what, arg = arg, index = index, ..., recycle = recycle, message = message, .subclass = c(.subclass, "purrr_error_bad_element_vector") ) } friendly_vector_type <- function(x, length = NULL, recycle = FALSE) { length <- length %||% length(x) if (length == 1) { return(friendly_type_of_element(x)) } if (is.object(x)) { classes <- paste0("`", paste_classes(x), "`") type <- sprintf("a vector of class %s and", classes) } else { type <- friendly_type_of(x) } if (recycle) { length <- sprintf("1 or %s", length) } else { length <- as.character(length) } sprintf("%s of length %s", type, length) } purrr/R/transpose.R0000644000176200001440000000362413413636343014001 0ustar liggesusers#' Transpose a list. #' #' Transpose turns a list-of-lists "inside-out"; it turns a pair of lists into a #' list of pairs, or a list of pairs into pair of lists. For example, #' if you had a list of length n where each component had values `a` and #' `b`, `transpose()` would make a list with elements `a` and #' `b` that contained lists of length n. It's called transpose because #' \code{x[[1]][[2]]} is equivalent to \code{transpose(x)[[2]][[1]]}. #' #' Note that `transpose()` is its own inverse, much like the #' transpose operation on a matrix. You can get back the original #' input by transposing it twice. #' #' @param .l A list of vectors to transpose. The first element is used as the #' template; you'll get a warning if a subsequent element has a different #' length. #' @param .names For efficiency, `transpose()` bases the return structure on #' the first component of `.l` by default. Specify `.names` to override this. #' @return A list with indexing transposed compared to `.l`. #' @export #' @examples #' x <- rerun(5, x = runif(1), y = runif(5)) #' x %>% str() #' x %>% transpose() %>% str() #' # Back to where we started #' x %>% transpose() %>% transpose() %>% str() #' #' # transpose() is useful in conjunction with safely() & quietly() #' x <- list("a", 1, 2) #' y <- x %>% map(safely(log)) #' y %>% str() #' y %>% transpose() %>% str() #' #' # Use simplify_all() to reduce to atomic vectors where possible #' x <- list(list(a = 1, b = 2), list(a = 3, b = 4), list(a = 5, b = 6)) #' x %>% transpose() #' x %>% transpose() %>% simplify_all() #' #' # Provide explicit component names to prevent loss of those that don't #' # appear in first component #' ll <- list( #' list(x = 1, y = "one"), #' list(z = "deux", x = 2) #' ) #' ll %>% transpose() #' nms <- ll %>% map(names) %>% reduce(union) #' ll %>% transpose(.names = nms) transpose <- function(.l, .names = NULL) { .Call(transpose_impl, .l, .names) } purrr/R/every-some.R0000644000176200001440000000173613426303100014042 0ustar liggesusers#' Do every or some elements of a list satisfy a predicate? #' #' @inheritParams map #' @param .p A predicate function to apply on each element of `.x`. #' `some()` returns `TRUE` when `.p` is `TRUE` for at least one #' element. `every()` returns `TRUE` when `.p` is `TRUE` for all #' elements. #' @param ... Additional arguments passed on to `.p`. #' @return A logical vector of length 1. #' @export #' @examples #' y <- list(0:10, 5.5) #' y %>% every(is.numeric) #' y %>% every(is.integer) every <- function(.x, .p, ...) { .p <- as_predicate(.p, ..., .mapper = TRUE, .deprecate = TRUE) for (i in seq_along(.x)) { val <- .p(.x[[i]], ...) if (is_false(val)) return(FALSE) if (anyNA(val)) return(NA) } TRUE } #' @export #' @rdname every some <- function(.x, .p, ...) { .p <- as_predicate(.p, ..., .mapper = TRUE, .deprecate = TRUE) val <- FALSE for (i in seq_along(.x)) { val <- val || .p(.x[[i]], ...) if (is_true(val)) return(TRUE) } val } purrr/R/modify.R0000644000176200001440000003046713551365051013255 0ustar liggesusers#' Modify elements selectively #' #' @description #' #' Unlike [map()] and its variants which always return a fixed object #' type (list for `map()`, integer vector for `map_int()`, etc), the #' `modify()` family always returns the same type as the input object. #' #' * `modify()` is a shortcut for `x[[i]] <- f(x[[i]]); #' return(x)`. #' #' * `modify_if()` only modifies the elements of `x` that satisfy a #' predicate and leaves the others unchanged. `modify_at()` only #' modifies elements given by names or positions. #' #' * `modify2()` modifies the elements of `.x` but also passes the #' elements of `.y` to `.f`, just like [map2()]. `imodify()` passes #' the names or the indices to `.f` like [imap()] does. #' #' * `modify_depth()` only modifies elements at a given level of a #' nested data structure. #' #' * [modify_in()] modifies a single element in a [pluck()] location. #' #' @inheritParams map #' @inheritParams map2 #' @param .depth Level of `.x` to map on. Use a negative value to count up #' from the lowest level of the list. #' #' * `modify_depth(x, 0, fun)` is equivalent to `x[] <- fun(x)`. #' * `modify_depth(x, 1, fun)` is equivalent to `x <- modify(x, fun)` #' * `modify_depth(x, 2, fun)` is equivalent to `x <- modify(x, ~ modify(., fun))` #' @return An object the same class as `.x` #' #' @details #' #' Since the transformation can alter the structure of the input; it's #' your responsibility to ensure that the transformation produces a #' valid output. For example, if you're modifying a data frame, `.f` #' must preserve the length of the input. #' #' @section Genericity: #' #' `modify()` and variants are generic over classes that implement #' `length()`, `[[` and `[[<-` methods. If the default implementation #' is not compatible for your class, you can override them with your #' own methods. #' #' If you implement your own `modify()` method, make sure it satisfies #' the following invariants: #' #' ``` #' modify(x, identity) === x #' modify(x, compose(f, g)) === modify(x, g) %>% modify(f) #' ``` #' #' These invariants are known as the [functor #' laws](https://wiki.haskell.org/Functor#Functor_Laws) in computer #' science. #' #' #' @family map variants #' @examples #' # Convert factors to characters #' iris %>% #' modify_if(is.factor, as.character) %>% #' str() #' #' # Specify which columns to map with a numeric vector of positions: #' mtcars %>% modify_at(c(1, 4, 5), as.character) %>% str() #' #' # Or with a vector of names: #' mtcars %>% modify_at(c("cyl", "am"), as.character) %>% str() #' #' list(x = rbernoulli(100), y = 1:100) %>% #' transpose() %>% #' modify_if("x", ~ update_list(., y = ~ y * 100)) %>% #' transpose() %>% #' simplify_all() #' #' # Use modify2() to map over two vectors and preserve the type of #' # the first one: #' x <- c(foo = 1L, bar = 2L) #' y <- c(TRUE, FALSE) #' modify2(x, y, ~ if (.y) .x else 0L) #' #' # Use a predicate function to decide whether to map a function: #' modify_if(iris, is.factor, as.character) #' #' # Specify an alternative with the `.else` argument: #' modify_if(iris, is.factor, as.character, .else = as.integer) #' #' #' # Modify at specified depth --------------------------- #' l1 <- list( #' obj1 = list( #' prop1 = list(param1 = 1:2, param2 = 3:4), #' prop2 = list(param1 = 5:6, param2 = 7:8) #' ), #' obj2 = list( #' prop1 = list(param1 = 9:10, param2 = 11:12), #' prop2 = list(param1 = 12:14, param2 = 15:17) #' ) #' ) #' #' # In the above list, "obj" is level 1, "prop" is level 2 and "param" #' # is level 3. To apply sum() on all params, we map it at depth 3: #' l1 %>% modify_depth(3, sum) %>% str() #' #' # Note that vectorised operations will yield the same result when #' # applied at the list level as when applied at the atomic result. #' # The former is more efficient because it takes advantage of #' # vectorisation. #' l1 %>% modify_depth(3, `+`, 100L) #' l1 %>% modify_depth(4, `+`, 100L) #' #' # modify() lets us pluck the elements prop1/param2 in obj1 and obj2: #' l1 %>% modify(c("prop1", "param2")) %>% str() #' #' # But what if we want to pluck all param2 elements? Then we need to #' # act at a lower level: #' l1 %>% modify_depth(2, "param2") %>% str() #' #' # modify_depth() can be with other purrr functions to make them operate at #' # a lower level. Here we ask pmap() to map paste() simultaneously over all #' # elements of the objects at the second level. paste() is effectively #' # mapped at level 3. #' l1 %>% modify_depth(2, ~ pmap(., paste, sep = " / ")) %>% str() #' @export modify <- function(.x, .f, ...) { UseMethod("modify") } #' @rdname modify #' @export modify.default <- function(.x, .f, ...) { .f <- as_mapper(.f, ...) for (i in seq_along(.x)) { .x[[i]] <- .f(.x[[i]], ...) } .x } #' @rdname modify #' @inheritParams map_if #' @export modify_if <- function(.x, .p, .f, ..., .else = NULL) { UseMethod("modify_if") } #' @rdname modify #' @export modify_if.default <- function(.x, .p, .f, ..., .else = NULL) { sel <- probe(.x, .p) index <- seq_along(.x) .f <- as_mapper(.f, ...) for (i in index[sel]) { .x[[i]] <- .f(.x[[i]], ...) } if (!is_null(.else)) { .else <- as_mapper(.else, ...) for (i in index[!sel]) { .x[[i]] <- .else(.x[[i]], ...) } } .x } #' @rdname modify #' @inheritParams map_at #' @export modify_at <- function(.x, .at, .f, ...) { UseMethod("modify_at") } #' @rdname modify #' @export modify_at.default <- function(.x, .at, .f, ...) { where <- at_selection(names(.x), .at) sel <- inv_which(.x, where) modify_if(.x, sel, .f, ...) } # TODO: Replace all the following methods with a generic strategy that # implements sane coercion rules for base vectors #' @export modify.integer <- function (.x, .f, ...) { .x[] <- map_int(.x, .f, ...) .x } #' @export modify.double <- function (.x, .f, ...) { .x[] <- map_dbl(.x, .f, ...) .x } #' @export modify.character <- function (.x, .f, ...) { .x[] <- map_chr(.x, .f, ...) .x } #' @export modify.logical <- function (.x, .f, ...) { .x[] <- map_lgl(.x, .f, ...) .x } #' @export modify.pairlist <- function(.x, .f, ...) { as.pairlist(map(.x, .f, ...)) } #' @export modify_if.integer <- function(.x, .p, .f, ...) { sel <- probe(.x, .p) .x[sel] <- map_int(.x[sel], .f, ...) .x } #' @export modify_if.double <- function(.x, .p, .f, ...) { sel <- probe(.x, .p) .x[sel] <- map_dbl(.x[sel], .f, ...) .x } #' @export modify_if.character <- function(.x, .p, .f, ...) { sel <- probe(.x, .p) .x[sel] <- map_chr(.x[sel], .f, ...) .x } #' @export modify_if.logical <- function(.x, .p, .f, ...) { sel <- probe(.x, .p) .x[sel] <- map_lgl(.x[sel], .f, ...) .x } #' @export modify_at.integer <- function(.x, .at, .f, ...) { where <- at_selection(names(.x), .at) sel <- inv_which(.x, where) .x[sel] <- map_int(.x[sel], .f, ...) .x } #' @export modify_at.double <- function(.x, .at, .f, ...) { where <- at_selection(names(.x), .at) sel <- inv_which(.x, where) .x[sel] <- map_dbl(.x[sel], .f, ...) .x } #' @export modify_at.character <- function(.x, .at, .f, ...) { where <- at_selection(names(.x), .at) sel <- inv_which(.x, where) .x[sel] <- map_chr(.x[sel], .f, ...) .x } #' @export modify_at.logical <- function(.x, .at, .f, ...) { where <- at_selection(names(.x), .at) sel <- inv_which(.x, where) .x[sel] <- map_lgl(.x[sel], .f, ...) .x } #' Modify a pluck location #' #' @description #' #' * `assign_in()` takes a data structure and a [pluck][pluck] location, #' assigns a value there, and returns the modified data structure. #' #' * `modify_in()` applies a function to a pluck location, assigns the #' result back to that location with [assign_in()], and returns the #' modified data structure. #' #' The pluck location must exist. #' #' @inheritParams pluck #' @param .f A function to apply at the pluck location given by `.where`. #' @param ... Arguments passed to `.f`. #' @param .where,where A pluck location, as a numeric vector of #' positions, a character vector of names, or a list combining both. #' The location must exist in the data structure. #' #' @seealso [pluck()] #' @examples #' # Recall that pluck() returns a component of a data structure that #' # might be arbitrarily deep #' x <- list(list(bar = 1, foo = 2)) #' pluck(x, 1, "foo") #' #' # Use assign_in() to modify the pluck location: #' assign_in(x, list(1, "foo"), 100) #' #' # modify_in() applies a function to that location and update the #' # element in place: #' modify_in(x, list(1, "foo"), ~ .x * 200) #' #' # Additional arguments are passed to the function in the ordinary way: #' modify_in(x, list(1, "foo"), `+`, 100) #' @export modify_in <- function(.x, .where, .f, ...) { .where <- as.list(.where) .f <- rlang::as_function(.f) value <- .f(chuck(.x, !!!.where), ...) assign_in(.x, .where, value) } #' @rdname modify_in #' @param value A value to replace in `.x` at the pluck location. #' @export assign_in <- function(x, where, value) { # Check value exists at pluck location chuck(x, !!!where) call <- reduce_subset_call(quote(x), as.list(where)) call <- call("<-", call, value) eval_bare(call) x } #' @rdname modify #' @export modify2 <- function(.x, .y, .f, ...) { UseMethod("modify2") } #' @export modify2.default <- function(.x, .y, .f, ...) { .f <- as_mapper(.f, ...) args <- recycle_args(list(.x, .y)) .x <- args[[1]] .y <- args[[2]] for (i in seq_along(.x)) { .x[[i]] <- .f(.x[[i]], .y[[i]], ...) } .x } #' @rdname modify #' @export imodify <- function(.x, .f, ...) { modify2(.x, vec_index(.x), .f, ...) } # TODO: Improve genericity (see above) #' @export modify2.integer <- function(.x, .y, .f, ...) { modify_base(map2_int, .x, .y, .f, ...) } #' @export modify2.double <- function(.x, .y, .f, ...) { modify_base(map2_dbl, .x, .y, .f, ...) } #' @export modify2.character <- function(.x, .y, .f, ...) { modify_base(map2_chr, .x, .y, .f, ...) } #' @export modify2.logical <- function(.x, .y, .f, ...) { modify_base(map2_lgl, .x, .y, .f, ...) } modify_base <- function(mapper, .x, .y, .f, ...) { args <- recycle_args(list(.x, .y)) .x <- args[[1]] .y <- args[[2]] .x[] <- mapper(.x, .y, .f, ...) .x } #' @rdname modify #' @export modify_depth <- function(.x, .depth, .f, ..., .ragged = .depth < 0) { if (!is_integerish(.depth, n = 1, finite = TRUE)) { abort("`.depth` must be a single number") } UseMethod("modify_depth") } #' @rdname modify #' @export modify_depth.default <- function(.x, .depth, .f, ..., .ragged = .depth < 0) { force(.ragged) if (.depth < 0) { .depth <- vec_depth(.x) + .depth } .f <- as_mapper(.f, ...) modify_depth_rec(.x, .depth, .f, ..., .ragged = .ragged, .atomic = FALSE) } modify_depth_rec <- function(.x, .depth, .f, ..., .ragged = FALSE, .atomic = FALSE) { if (.depth < 0) { abort("Invalid depth") } if (.atomic) { if (!.ragged) { abort("List not deep enough") } return(modify(.x, .f, ...)) } if (.depth == 0) { # TODO vctrs: Use `vec_cast()` on result? .x[] <- .f(.x, ...) return(.x) } if (.depth == 1) { return(modify(.x, .f, ...)) } # Should this be replaced with a generic way of figuring out atomic # types? .atomic <- is_atomic(.x) modify(.x, function(x) { modify_depth_rec(x, .depth - 1, .f, ..., .ragged = .ragged, .atomic = .atomic) }) } #' Map at depth #' #' This function is defunct and has been replaced by [map_depth()]. #' See also [modify_depth()] for a version that preserves the types of #' the elements of the tree. #' #' @inheritParams map #' @inheritParams map_if #' @export #' @keywords internal at_depth <- function(.x, .depth, .f, ...) { stop_defunct("at_depth() is defunct, please use `map_depth()` instead") } # Internal version of map_lgl() that works with logical vectors probe <- function(.x, .p, ...) { if (is_logical(.p)) { stopifnot(length(.p) == length(.x)) .p } else { .p <- as_predicate(.p, ..., .mapper = TRUE) map_lgl(.x, .p, ...) } } inv_which <- function(x, sel) { if (is.character(sel)) { names <- names(x) if (is.null(names)) { stop("character indexing requires a named object", call. = FALSE) } names %in% sel } else if (is.numeric(sel)) { if (any(sel < 0)) { !seq_along(x) %in% abs(sel) } else { seq_along(x) %in% sel } } else { stop("unrecognised index type", call. = FALSE) } } purrr/R/compat-lifecycle.R0000644000176200001440000001461213551356667015215 0ustar liggesusers# nocov start - compat-lifecycle (last updated: rlang 0.3.0.9000) # This file serves as a reference for currently unexported rlang # lifecycle functions. Please find the most recent version in rlang's # repository. These functions require rlang in your `Imports` # DESCRIPTION field but you don't need to import rlang in your # namespace. #' Signal deprecation #' #' @description #' #' These functions provide two levels of verbosity for deprecation #' warnings. #' #' * `signal_soft_deprecated()` warns only if called from the global #' environment (so the user can change their script) or from the #' package currently being tested (so the package developer can fix #' the package). #' #' * `warn_deprecated()` warns unconditionally. #' #' * `stop_defunct()` fails unconditionally. #' #' Both functions warn only once per session by default to avoid #' overwhelming the user with repeated warnings. #' #' @param msg The deprecation message. #' @param id The id of the deprecation. A warning is issued only once #' for each `id`. Defaults to `msg`, but you should give a unique ID #' when the message is built programmatically and depends on inputs. #' @param env The environment in which the soft-deprecated function #' was called. A warning is issued if called from the global #' environment. If testthat is running, a warning is also called if #' the retired function was called from the package being tested. #' #' @section Controlling verbosity: #' #' The verbosity of retirement warnings can be controlled with global #' options. You'll generally want to set these options locally with #' one of these helpers: #' #' * `with_lifecycle_silence()` disables all soft-deprecation and #' deprecation warnings. #' #' * `with_lifecycle_warnings()` enforces warnings for both #' soft-deprecated and deprecated functions. The warnings are #' repeated rather than signalled once per session. #' #' * `with_lifecycle_errors()` enforces errors for both #' soft-deprecated and deprecated functions. #' #' All the `with_` helpers have `scoped_` variants that are #' particularly useful in testthat blocks. #' #' @noRd #' @seealso [lifecycle()] NULL signal_soft_deprecated <- function(msg, id = msg, env = caller_env(2)) { if (rlang::is_true(rlang::peek_option("lifecycle_disable_warnings"))) { return(invisible(NULL)) } if (rlang::is_true(rlang::peek_option("lifecycle_verbose_soft_deprecation")) || rlang::is_reference(topenv(env), rlang::global_env())) { warn_deprecated(msg, id) return(invisible(NULL)) } # Test for environment names rather than reference/contents because # testthat clones the namespace tested_package <- Sys.getenv("TESTTHAT_PKG") if (nzchar(tested_package) && identical(Sys.getenv("NOT_CRAN"), "true") && rlang::env_name(topenv(env)) == rlang::env_name(ns_env(tested_package))) { warn_deprecated(msg, id) return(invisible(NULL)) } rlang::signal(msg, "lifecycle_soft_deprecated") } warn_deprecated <- function(msg, id = msg) { if (rlang::is_true(rlang::peek_option("lifecycle_disable_warnings"))) { return(invisible(NULL)) } if (!rlang::is_true(rlang::peek_option("lifecycle_repeat_warnings")) && rlang::env_has(deprecation_env, id)) { return(invisible(NULL)) } rlang::env_poke(deprecation_env, id, TRUE); has_colour <- function() rlang::is_installed("crayon") && crayon::has_color() silver <- function(x) if (has_colour()) crayon::silver(x) else x if (rlang::is_true(rlang::peek_option("lifecycle_warnings_as_errors"))) { signal <- .Defunct } else { signal <- .Deprecated } signal(msg = paste0( msg, "\n", silver("This warning is displayed once per session.") )) } deprecation_env <- new.env(parent = emptyenv()) stop_defunct <- function(msg) { if (getRversion() < "3.6") { abort(msg, "defunctError") } else { .Defunct(msg = msg) } } scoped_lifecycle_silence <- function(frame = rlang::caller_env()) { rlang::scoped_options(.frame = frame, lifecycle_disable_warnings = TRUE ) } with_lifecycle_silence <- function(expr) { scoped_lifecycle_silence() expr } scoped_lifecycle_warnings <- function(frame = rlang::caller_env()) { rlang::scoped_options(.frame = frame, lifecycle_disable_warnings = FALSE, lifecycle_verbose_soft_deprecation = TRUE, lifecycle_repeat_warnings = TRUE ) } with_lifecycle_warnings <- function(expr) { scoped_lifecycle_warnings() expr } scoped_lifecycle_errors <- function(frame = rlang::caller_env()) { scoped_lifecycle_warnings(frame = frame) rlang::scoped_options(.frame = frame, lifecycle_warnings_as_errors = TRUE ) } with_lifecycle_errors <- function(expr) { scoped_lifecycle_errors() expr } #' Embed a lifecycle badge in documentation #' #' @description #' #' Use `lifecycle()` within a `Sexpr` macro to embed a #' [lifecycle](https://www.tidyverse.org/lifecycle/) badge in your #' documentation. The badge should appear first in the description: #' #' ``` #' \Sexpr[results=rd, stage=render]{mypkg:::lifecycle("questioning")} #' ``` #' #' The badge appears as an image in the HTML version of the #' documentation. To make them available in your package, visit #' and copy #' all the files starting with `lifecycle-` in your `man/figures/` #' folder. #' #' @param stage A lifecycle stage as a string, one of: #' `"experimental"`, `"maturing"`, `"stable"`, `"questioning"`, #' `"archived"`, `"soft-deprecated"`, `"deprecated"`, `"defunct"`. #' #' @noRd NULL lifecycle <- function(stage) { url <- paste0("https://www.tidyverse.org/lifecycle/#", stage) img <- lifecycle_img(stage, url) sprintf( "\\ifelse{html}{%s}{\\strong{%s}}", img, upcase1(stage) ) } lifecycle_img <- function(stage, url) { file <- sprintf("lifecycle-%s.svg", stage) stage_alt <- upcase1(stage) switch(stage, experimental = , maturing = , stable = , questioning = , retired = , archived = sprintf( "\\out{%s lifecycle}", url, file.path("figures", file), stage_alt ) , `soft-deprecated` = , deprecated = , defunct = sprintf( "\\figure{%s}{options: alt='%s lifecycle'}", file, stage_alt ), rlang::abort(sprintf("Unknown lifecycle stage `%s`", stage)) ) } upcase1 <- function(x) { substr(x, 1, 1) <- toupper(substr(x, 1, 1)) x } # nocov end purrr/R/output.R0000644000176200001440000001076213426303100013306 0ustar liggesusers#' Capture side effects. #' #' These functions wrap functions so that instead of generating side effects #' through printed output, messages, warnings, and errors, they return enhanced #' output. They are all adverbs because they modify the action of a verb (a #' function). #' #' @inheritParams map #' @param quiet Hide errors (`TRUE`, the default), or display them #' as they occur? #' @param otherwise Default value to use when an error occurs. #' @return `safely`: wrapped function instead returns a list with #' components `result` and `error`. If an error occurred, `error` is #' an `error` object and `result` has a default value (`otherwise`). #' Else `error` is `NULL`. #' #' `quietly`: wrapped function instead returns a list with components #' `result`, `output`, `messages` and `warnings`. #' #' `possibly`: wrapped function uses a default value (`otherwise`) #' whenever an error occurs. #' @export #' @examples #' safe_log <- safely(log) #' safe_log(10) #' safe_log("a") #' #' list("a", 10, 100) %>% #' map(safe_log) %>% #' transpose() #' #' # This is a bit easier to work with if you supply a default value #' # of the same type and use the simplify argument to transpose(): #' safe_log <- safely(log, otherwise = NA_real_) #' list("a", 10, 100) %>% #' map(safe_log) %>% #' transpose() %>% #' simplify_all() #' #' # To replace errors with a default value, use possibly(). #' list("a", 10, 100) %>% #' map_dbl(possibly(log, NA_real_)) #' #' # For interactive usage, auto_browse() is useful because it automatically #' # starts a browser() in the right place. #' f <- function(x) { #' y <- 20 #' if (x > 5) { #' stop("!") #' } else { #' x #' } #' } #' if (interactive()) { #' map(1:6, auto_browse(f)) #' } #' #' # It doesn't make sense to use auto_browse with primitive functions, #' # because they are implemented in C so there's no useful environment #' # for you to interact with. safely <- function(.f, otherwise = NULL, quiet = TRUE) { .f <- as_mapper(.f) function(...) capture_error(.f(...), otherwise, quiet) } #' @export #' @rdname safely quietly <- function(.f) { .f <- as_mapper(.f) function(...) capture_output(.f(...)) } #' @export #' @rdname safely possibly <- function(.f, otherwise, quiet = TRUE) { .f <- as_mapper(.f) force(otherwise) function(...) { tryCatch(.f(...), error = function(e) { if (!quiet) message("Error: ", e$message) otherwise }, interrupt = function(e) { stop("Terminated by user", call. = FALSE) } ) } } #' @export #' @rdname safely auto_browse <- function(.f) { if (is_primitive(.f)) { abort("Can not auto_browse() primitive functions") } function(...) { withCallingHandlers( .f(...), error = function(e) { # 1: h(simpleError(msg, call)) # 2: .handleSimpleError(function (e) <...> # 3: stop(...) frame <- ctxt_frame(4) browse_in_frame(frame) }, warning = function(e) { if (getOption("warn") >= 2) { frame <- ctxt_frame(7) browse_in_frame(frame) } }, interrupt = function(e) { stop("Terminated by user", call. = FALSE) } ) } } browse_in_frame <- function(frame) { # ESS should problably set `.Platform$GUI == "ESS"` # In the meantime, check that ESSR is attached if (is_scoped("ESSR")) { # Workaround ESS issue with_env(frame$env, on.exit({ browser() NULL })) return_from(frame) } else { eval_bare(quote(browser()), env = frame$env) } } capture_error <- function(code, otherwise = NULL, quiet = TRUE) { tryCatch( list(result = code, error = NULL), error = function(e) { if (!quiet) message("Error: ", e$message) list(result = otherwise, error = e) }, interrupt = function(e) { stop("Terminated by user", call. = FALSE) } ) } capture_output <- function(code) { warnings <- character() wHandler <- function(w) { warnings <<- c(warnings, w$message) invokeRestart("muffleWarning") } messages <- character() mHandler <- function(m) { messages <<- c(messages, m$message) invokeRestart("muffleMessage") } temp <- file() sink(temp) on.exit({ sink() close(temp) }) result <- withCallingHandlers( code, warning = wHandler, message = mHandler ) output <- paste0(readLines(temp, warn = FALSE), collapse = "\n") list( result = result, output = output, warnings = warnings, messages = messages ) } purrr/R/partial.R0000644000176200001440000001465213551356667013435 0ustar liggesusers#' Partial apply a function, filling in some arguments. #' #' @description #' #' Partial function application allows you to modify a function by pre-filling #' some of the arguments. It is particularly useful in conjunction with #' functionals and other function operators. #' #' Note that an argument can only be partialised once. #' #' @param .f a function. For the output source to read well, this should be a #' named function. #' @param ... named arguments to `.f` that should be partially applied. #' #' Pass an empty `... = ` argument to specify the position of future #' arguments relative to partialised ones. See #' [rlang::call_modify()] to learn more about this syntax. #' #' These dots support quasiquotation and quosures. If you unquote a #' value, it is evaluated only once at function creation time. #' Otherwise, it is evaluated each time the function is called. #' @param .env Soft-deprecated as of purrr 0.3.0. The environments are #' now captured via quosures. #' @param .first Soft-deprecated as of purrr 0.3.0. Please pass an #' empty argument `... = ` to specify the position of future #' arguments. #' @param .lazy Soft-deprecated as of purrr 0.3.0. Please unquote the #' arguments that should be evaluated once at function creation time. #' #' @examples #' # Partial is designed to replace the use of anonymous functions for #' # filling in function arguments. Instead of: #' compact1 <- function(x) discard(x, is.null) #' #' # we can write: #' compact2 <- partial(discard, .p = is.null) #' #' # partial() works fine with functions that do non-standard #' # evaluation #' my_long_variable <- 1:10 #' plot2 <- partial(plot, my_long_variable) #' plot2() #' plot2(runif(10), type = "l") #' #' # Note that you currently can't partialise arguments multiple times: #' my_mean <- partial(mean, na.rm = TRUE) #' my_mean <- partial(my_mean, na.rm = FALSE) #' try(my_mean(1:10)) #' #' #' # The evaluation of arguments normally occurs "lazily". Concretely, #' # this means that arguments are repeatedly evaluated across invocations: #' f <- partial(runif, n = rpois(1, 5)) #' f #' f() #' f() #' #' # You can unquote an argument to fix it to a particular value. #' # Unquoted arguments are evaluated only once when the function is created: #' f <- partial(runif, n = !!rpois(1, 5)) #' f #' f() #' f() #' #' #' # By default, partialised arguments are passed before new ones: #' my_list <- partial(list, 1, 2) #' my_list("foo") #' #' # Control the position of these arguments by passing an empty #' # `... = ` argument: #' my_list <- partial(list, 1, ... = , 2) #' my_list("foo") #' @export partial <- function(.f, ..., .env = NULL, .lazy = NULL, .first = NULL) { args <- enquos(...) if (has_name(args, "...f")) { stop_defunct("`...f` has been renamed to `.f` as of purrr 0.3.0.") } fn_expr <- enexpr(.f) fn <- switch(typeof(.f), builtin = , special = as_closure(.f), closure = .f, abort(sprintf("`.f` must be a function, not %s", friendly_type_of(.f))) ) if (!is_null(.env)) { signal_soft_deprecated(paste_line( "The `.env` argument is soft-deprecated as of purrr 0.3.0.", )) } if (!is_null(.lazy)) { signal_soft_deprecated(paste_line( "The `.lazy` argument is soft-deprecated as of purrr 0.3.0.", "Please unquote the arguments that should be evaluated once and for all.", "", " # Before:", " partial(fn, u = runif(1), n = rnorm(1), .lazy = FALSE)", "", " # After:", " partial(fn, u = !!runif(1), n = !!rnorm(1)) # All constant", " partial(fn, u = !!runif(1), n = rnorm(1)) # First constant" )) if (!.lazy) { args <- map(args, eval_tidy, env = caller_env()) } } if (!is_null(.first)) { signal_soft_deprecated(paste_line( "The `.first` argument is soft-deprecated as of purrr 0.3.0.", "Please pass a `... =` argument instead.", "", " # Before:", " partial(fn, x = 1, y = 2, .first = FALSE)", "", " # After:", " partial(fn, x = 1, y = 2, ... = ) # Partialised arguments last", " partial(fn, x = 1, ... = , y = 2) # Partialised arguments around" )) } if (is_false(.first)) { # For compatibility call <- call_modify(call2(fn), ... = , !!!args) } else { # Pass on `...` from parent function. It should be last, this way if # `args` also contain a `...` argument, the position in `args` # prevails. call <- call_modify(call2(fn), !!!args, ... = ) } # Forward caller environment where S3 methods might be defined. # See design note below. call <- new_quosure(call, caller_env()) # Unwrap quosured arguments if possible call <- quo_invert(call) # Derive a mask where dots can be forwarded mask <- new_data_mask(env()) partialised <- function(...) { env_bind(mask, ... = env_get(current_env(), "...")) eval_tidy(call, mask) } structure( partialised, class = c("purrr_function_partial", "function"), body = call, fn = fn_expr ) } #' @export print.purrr_function_partial <- function(x, ...) { cat("\n") body <- quo_squash(partialised_body(x)) body[[1]] <- partialised_fn(x) body(x) <- body # Remove reference to internal environment x <- set_env(x, global_env()) print(x, ...) } partialised_body <- function(x) attr(x, "body") partialised_fn <- function(x) attr(x, "fn") # Lexical dispatch # # We evaluate in the definition environment rather than the caller # environment in order to support lexically scoped methods. This # helps with this case: # # ``` # local({ # mean.foobar <- function(...) "foobar" # foobar <- structure(list(), class = "foobar") # # mean(foobar) == partial(mean)(foobar) # }) # ``` # # These are not standard dispatch semantics, ideally we'd dispatch in # the caller environment rather than the definition environment. The # issue is that there's a fundamental conflict between these goals: # # (a) Evaluating arguments in their environment (typically def env) # (b) Allowing substitution of partialised arguments # (c) Lexical dispatch in caller env rather than def env # # It might just be that partialised functions are meant to be private or # even anonymous (and thus local). Also lexical dispatch in the global # env should work anyway because most envs inherit from the search # path. And if in a package, registration will take care of dispatch. # Let's not worry about this too much. purrr/R/cross.R0000644000176200001440000001264713426303100013103 0ustar liggesusers#' Produce all combinations of list elements #' #' `cross2()` returns the product set of the elements of #' `.x` and `.y`. `cross3()` takes an additional #' `.z` argument. `cross()` takes a list `.l` and #' returns the cartesian product of all its elements in a list, with #' one combination by element. `cross_df()` is like #' `cross()` but returns a data frame, with one combination by #' row. #' #' `cross()`, `cross2()` and `cross3()` return the #' cartesian product is returned in wide format. This makes it more #' amenable to mapping operations. `cross_df()` returns the output #' in long format just as `expand.grid()` does. This is adapted #' to rowwise operations. #' #' When the number of combinations is large and the individual #' elements are heavy memory-wise, it is often useful to filter #' unwanted combinations on the fly with `.filter`. It must be #' a predicate function that takes the same number of arguments as the #' number of crossed objects (2 for `cross2()`, 3 for #' `cross3()`, `length(.l)` for `cross()`) and #' returns `TRUE` or `FALSE`. The combinations where the #' predicate function returns `TRUE` will be removed from the #' result. #' @seealso [expand.grid()] #' @param .x,.y,.z Lists or atomic vectors. #' @param .l A list of lists or atomic vectors. Alternatively, a data #' frame. `cross_df()` requires all elements to be named. #' @param .filter A predicate function that takes the same number of #' arguments as the number of variables to be combined. #' @return `cross2()`, `cross3()` and `cross()` #' always return a list. `cross_df()` always returns a data #' frame. `cross()` returns a list where each element is one #' combination so that the list can be directly mapped #' over. `cross_df()` returns a data frame where each row is one #' combination. #' @export #' @examples #' # We build all combinations of names, greetings and separators from our #' # list of data and pass each one to paste() #' data <- list( #' id = c("John", "Jane"), #' greeting = c("Hello.", "Bonjour."), #' sep = c("! ", "... ") #' ) #' #' data %>% #' cross() %>% #' map(lift(paste)) #' #' # cross() returns the combinations in long format: many elements, #' # each representing one combination. With cross_df() we'll get a #' # data frame in long format: crossing three objects produces a data #' # frame of three columns with each row being a particular #' # combination. This is the same format that expand.grid() returns. #' args <- data %>% cross_df() #' #' # In case you need a list in long format (and not a data frame) #' # just run as.list() after cross_df() #' args %>% as.list() #' #' # This format is often less pratical for functional programming #' # because applying a function to the combinations requires a loop #' out <- vector("list", length = nrow(args)) #' for (i in seq_along(out)) #' out[[i]] <- map(args, i) %>% invoke(paste, .) #' out #' #' # It's easier to transpose and then use invoke_map() #' args %>% transpose() %>% map_chr(~ invoke(paste, .)) #' #' # Unwanted combinations can be filtered out with a predicate function #' filter <- function(x, y) x >= y #' cross2(1:5, 1:5, .filter = filter) %>% str() #' #' # To give names to the components of the combinations, we map #' # setNames() on the product: #' seq_len(3) %>% #' cross2(., ., .filter = `==`) %>% #' map(setNames, c("x", "y")) #' #' # Alternatively we can encapsulate the arguments in a named list #' # before crossing to get named components: #' seq_len(3) %>% #' list(x = ., y = .) %>% #' cross(.filter = `==`) cross <- function(.l, .filter = NULL) { if (is_empty(.l)) { return(.l) } if (!is.null(.filter)) { .filter <- as_mapper(.filter) } n <- length(.l) lengths <- lapply(.l, length) names <- names(.l) factors <- cumprod(lengths) total_length <- factors[n] factors <- c(1, factors[-n]) out <- replicate(total_length, vector("list", n), simplify = FALSE) for (i in seq_along(out)) { for (j in seq_len(n)) { index <- floor((i - 1) / factors[j]) %% length(.l[[j]]) + 1 out[[i]][[j]] <- .l[[j]][[index]] } names(out[[i]]) <- names # Filter out unwanted elements. We set them to NULL instead of # completely removing them so we don't mess up the loop indexing. # NULL elements are removed later on. if (!is.null(.filter)) { is_to_filter <- do.call(".filter", unname(out[[i]])) if (!is_bool(is_to_filter)) { abort(sprintf( "The filter function must return a single logical `TRUE` or `FALSE`, not %s", as_predicate_friendly_type_of(is_to_filter) )) } if (is_to_filter) { out[i] <- list(NULL) } } } # Remove filtered elements compact(out) } #' @export #' @rdname cross cross2 <- function(.x, .y, .filter = NULL) { cross(list(.x, .y), .filter = .filter) } #' @export #' @rdname cross cross3 <- function(.x, .y, .z, .filter = NULL) { cross(list(.x, .y, .z), .filter = .filter) } #' @rdname cross #' @export cross_df <- function(.l, .filter = NULL) { check_tibble() cross(.l, .filter = .filter) %>% transpose() %>% simplify_all() %>% tibble::as_tibble() } #' @export #' @usage NULL #' @rdname cross cross_n <- function(...) { warning("`cross_n()` is deprecated; please use `cross()` instead.", call. = FALSE) cross(...) } #' @export #' @usage NULL #' @rdname cross cross_d <- function(...) { warning("`cross_d()` is deprecated; please use `cross_df()` instead.", call. = FALSE) cross_df(...) } purrr/NEWS.md0000644000176200001440000006255013551635076012545 0ustar liggesusers # purrr 0.3.3 * Maintenance release. * The documentation of `map()` and its variants has been improved by @surdina as part of the Tidyverse Developer Day (@surdina, #671). * purrr now depends on R 3.2 or greater. # purrr 0.3.2 * Fix protection issues reported by rchk. # purrr 0.3.1 * `reduce()` now forces arguments (#643). * Fixed an issue in `partial()` with generic functions (#647). * `negate()` now works with generic functions and functions with early returns. * `compose()` now works with generic functions again (#629, #639). Its set of unit tests was expanded to cover many edge cases. * `prepend()` now works with empty lists (@czeildi, #637) # purrr 0.3.0 ## Breaking changes * `modify()` and variants are now wrapping `[[<-` instead of `[<-`. This change increases the genericity of these functions but might cause different behaviour in some cases. For instance, the `[[<-` for data frames is stricter than the `[<-` method and might throw errors instead of warnings. This is the case when assigning a longer vector than the number of rows. `[<-` truncates the vector with a warning, `[[<-` fails with an error (as is appropriate). * `modify()` and variants now return the same type as the input when the input is an atomic vector. * All functionals taking predicate functions (like `keep()`, `detect()`, `some()`) got stricter. Predicate functions must now return a single `TRUE` or `FALSE`. This change is meant to detect problems early with a more meaningful error message. ## Plucking * New `chuck()` function. This is a strict variant of `pluck()` that throws errors when an element does not exist instead of returning `NULL` (@daniel-barnett, #482). * New `assign_in()` and `pluck<-` functions. They modify a data structure at an existing pluck location. * New `modify_in()` function to map a function at a pluck location. * `pluck()` now dispatches properly with S3 vectors. The vector class must implement a `length()` method for numeric indexing and a `names()` method for string indexing. * `pluck()` now supports primitive functions (#404). ## Mapping * New `.else` argument for `map_if()` and `modify_if()`. They take an alternative function that is mapped over elements of the input for which the predicate function returns `FALSE` (#324). * `reduce()`, `reduce2()`, `accumulate()`, and `accumulate2()` now terminate early when the function returns a value wrapped with `done()` (#253). When an empty `done()` is returned, the value at the last iteration is returned instead. * Functions taking predicates (`map_if()`, `keep()`, `some()`, `every()`, `keep()`, etc) now fail with an informative message when the return value is not `TRUE` or `FALSE` (#470). This is a breaking change for `every()` and `some()` which were documented to be more liberal in the values they accepted as logical (any vector was considered `TRUE` if not a single `FALSE` value, no matter its length). These functions signal soft-deprecation warnings instead of a hard failure. * `modify()` and variants are now implemented using `length()`, `[[`, and `[[<-` methods. This implementation should be compatible with most vector classes. * New `modify2()` and `imodify()` functions. These work like `map()` and `imap()` but preserve the type of `.x` in the return value. * `pmap()` and `pwalk()` now preserve class for inputs of `factor`, `Date`, `POSIXct` and other atomic S3 classes with an appropriate `[[` method (#358, @mikmart). * `modify()`, `modify_if()` and `modify_at()` now preserve the class of atomic vectors instead of promoting them to lists. New S3 methods are provided for character, logical, double, and integer classes (@t-kalinowski, #417). * By popular request, `at_depth()` has been brought back as `map_depth()`. Like `modify_depth()`, it applies a function at a specified level of a data structure. However, it transforms all traversed vectors up to `.depth` to bare lists (#381). * `map_at()`, `modify_at()` and `lmap_at()` accept negative values for `.at`, ignoring elements at those positions. * `map()` and `modify()` now work with calls and pairlists (#412). * `modify_depth()` now modifies atomic leaves as well. This makes `modify_depth(x, 1, fn)` equivalent to `modify(x, fn)` (#359). * New `accumulate2()` function which is to `accumulate()` what `reduce2()` is to `reduce()`. ## Rates * New `rate_backoff()` and `rate_delay()` functions to create rate objects. You can pass rates to `insistently()`, `slowly()`, or the lower level function `rate_sleep()`. This will cause a function to wait for a given amount of time with exponential backoff (increasingly larger waiting times) or for a constant delay. * `insistently(f)` modifies a function, `f`, so that it is repeatedly called until it succeeds (@richierocks, @ijlyttle). `slowly()` modifies a function so that it waits for a given amount of time between calls. ## `partial()` The interface of `partial()` has been simplified. It now supports quasiquotation to control the timing of evaluation, and the `rlang::call_modify()` syntax to control the position of partialised arguments. * `partial()` now supports empty `... = ` argument to specify the position of future arguments, relative to partialised ones. This syntax is borrowed from (and implemented with) `rlang::call_modify()`. To prevent partial matching of `...` on `...f`, the latter has been renamed to `.f`, which is more consistent with other purrr function signatures. * `partial()` now supports quasiquotation. When you unquote an argument, it is evaluated only once at function creation time. This is more flexible than the `.lazy` argument since you can control the timing of evaluation for each argument. Consequently, `.lazy` is soft-deprecated (#457). * Fixed an infinite loop when partialised function is given the same name as the original function (#387). * `partial()` now calls `as_closure()` on primitive functions to ensure argument matching (#360). * The `.lazy` argument of `partial()` is soft-deprecated in favour of quasiquotation: ```r # Before partial(fn, u = runif(1), n = rnorm(1), .lazy = FALSE) # After partial(fn, u = !!runif(1), n = !!rnorm(1)) # All constant partial(fn, u = !!runif(1), n = rnorm(1)) # First constant ``` ## Minor improvements and fixes * The tibble package is now in Suggests rather than Imports. This brings the hard dependency of purrr to just rlang and magrittr. * `compose()` now returns an identity function when called without inputs. * Functions created with `compose()` now have the same formal parameters as the first function to be called. They also feature a more informative print method that prints all composed functions in turn (@egnha, #366). * New `.dir` argument in `compose()`. When set to `"forward"`, the functions are composed from left to right rather than right to left. * `list_modify()` now supports the `zap()` sentinel (reexported from rlang) to remove elements from lists. Consequently, removing elements with the ambiguous sentinel `NULL` is soft-deprecated. * The requirements of `list_modify()` and `list_merge()` have been relaxed. Previously it required both the modified lists and the inputs to be either named or unnamed. This restriction now only applies to inputs in `...`. When inputs are all named, they are matched to the list by name. When they are all unnamed, they are matched positionally. Otherwise, this is an error. * Fixed ordering of names returned by `accumulate_right()` output. They now correspond to the order of inputs. * Fixed names of `accumulate()` output when `.init` is supplied. * `compose()` now supports composition with lambdas (@ColinFay, #556) * Fixed a `pmap()` crash with empty lists on the Win32 platform (#565). * `modify_depth` now has `.ragged` argument evaluates correctly to `TRUE` by default when `.depth < 0` (@cderv, #530). * `accumulate()` now inherits names from their first input (@AshesITR, #446). * `attr_getter()` no longer uses partial matching. For example, if an `x` object has a `labels` attribute but no `label` attribute, `attr_getter("label")(x)` will no longer extract the `labels` attribute (#460, @huftis). * `flatten_dfr()` and `flatten_dfc()` now aborts if dplyr is not installed. (#454) * `imap_dfr()` now works with `.id` argument is provided (#429) * `list_modify()`, `update_list()` and `list_merge()` now handle duplicate duplicate argument names correctly (#441, @mgirlich). * `map_raw`, `imap_raw`, `flatten_raw`, `invoke_map_raw`, `map2_raw` and `pmap_raw` added to support raw vectors. (#455, @romainfrancois) * `flatten()` now supports raw and complex elements. * `array_branch()` and `array_tree()` now retain the `dimnames()` of the input array (#584, @flying-sheep) * `pluck()` no longer flattens lists of arguments. You can still do it manually with `!!!`. This change is for consistency with other dots-collecting functions of the tidyverse. * `map_at()`, `lmap_at()` and `modify_at()` now supports selection using `vars()` and `tidyselect` (@ColinFay, #608). Note that for now you need to import `vars()` from dplyr or call it qualified like `dplyr::vars()`. It will be reexported from rlang in a future release. * `detect()` now has a .default argument to specify the value returned when nothing is detected (#622, @ColinFay). ## Life cycle ### `.dir` arguments We have standardised the purrr API for reverse iteration with a common `.dir` argument. * `reduce_right()` is soft-deprecated and replaced by a new `.dir` argument of `reduce()`: ```{r} # Before: reduce_right(1:3, f) # After: reduce(1:3, f, .dir = "backward") ``` Note that the details of the computation have changed. Whereas `reduce_right()` computed `f(f(3, 2), 1)`, it now computes `f(1, f(2, 3))`. This is the standard way of reducing from the right. To produce the exact same reduction as `reduce_right()`, simply reverse your vector and use a left reduction: ```{r} # Before: reduce_right(1:3, f) # After: reduce(rev(1:3), f) ``` * `reduce2_right()` is soft-deprecated without replacement. It is not clear what algorithmic properties should a right reduction have in this case. Please reach out if you know about a use case for a right reduction with a ternary function. * `accumulate_right()` is soft-deprecated and replaced by the new `.dir` argument of `accumulate()`. Note that the algorithm has slightly changed: the accumulated value is passed to the right rather than the left, which is consistent with a right reduction. ```{r} # Before: accumulate_right(1:3, f) # After: accumulate(1:3, f, .dir = "backward") ``` * The `.right` argument of `detect()` and `detect_index()` is soft-deprecated and renamed to `.dir` for consistency with other functions and clarity of the interface. ```{r} # Before detect(x, f, .right = TRUE) # After detect(x, f, .dir = "backward") ``` ### Simplification of `partial()` The interface of `partial()` has been simplified (see more about `partial()` below): * The `.lazy` argument of `partial()` is soft-deprecated in favour of quasiquotation. * We had to rename `...f` to `.f` in `partial()` in order to support `... = ` argument (which would otherwise partial-match on `...f`). This also makes `partial()` more consistent with other purrr function signatures. ### Retirement of `invoke()` `invoke()` and `invoke_map()` are retired in favour of `exec()`. Note that retired functions are no longer under active development, but continue to be maintained undefinitely in the package. * `invoke()` is retired in favour of the `exec()` function, reexported from rlang. `exec()` evaluates a function call built from its inputs and supports tidy dots: ```r # Before: invoke(mean, list(na.rm = TRUE), x = 1:10) # After exec(mean, 1:10, !!!list(na.rm = TRUE)) ``` Note that retired functions are not removed from the package and will be maintained undefinitely. * `invoke_map()` is retired without replacement because it is more complex to understand than the corresponding code using `map()`, `map2()` and `exec()`: ```r # Before: invoke_map(fns, list(args)) invoke_map(fns, list(args1, args2)) # After: map(fns, exec, !!!args) map2(fns, list(args1, args2), function(fn, args) exec(fn, !!!args)) ``` ### Other lifecycle changes * `%@%` is soft-deprecated, please use the operator exported in rlang instead. The latter features an interface more consistent with `@` as it uses NSE, supports S4 fields, and has an assignment variant. * Removing elements from lists using `NULL` in `list_modify()` is soft-deprecated. Please use the new `zap()` sentinel reexported from rlang instead: ```{r} # Before: list_modify(x, foo = NULL) # After: list_modify(x, foo = zap()) ``` This change is motivated by the ambiguity of `NULL` as a deletion sentinel because `NULL` is also a valid value in lists. In the future, `NULL` will set an element to `NULL` rather than removing the element. * `rerun()` is now in the questioning stage because we are no longer convinced NSE functions are a good fit for purrr. Also, `rerun(n, x)` can just as easily be expressed as `map(1:n, ~ x)` (with the added benefit of being passed the current index as argument to the lambda). * `map_call()` is defunct. # purrr 0.2.5 * This is a maintenance release following the release of dplyr 0.7.5. # purrr 0.2.4 * Fixes for R 3.1. # purrr 0.2.3 ## Breaking changes We noticed the following issues during reverse dependencies checks: * If `reduce()` fails with this message: ``Error: `.x` is empty, and no `.init` supplied``, this is because `reduce()` now returns `.init` when `.x` is empty. Fix the problem by supplying an appropriate argument to `.init`, or by providing special behaviour when `.x` has length 0. * The type predicates have been migrated to rlang. Consequently the `bare-type-predicates` documentation topic is no longer in purrr, which might cause a warning if you cross-reference it. ## Dependencies purrr no longer depends on lazyeval or Rcpp (or dplyr, as of the previous version). This makes the dependency graph of the tidyverse simpler, and makes purrr more suitable as a dependency of lower-level packages. There have also been two changes to eliminate name conflicts between purrr and dplyr: * `order_by()`, `sort_by()` and `split_by()` have been removed. `order_by()` conflicted with `dplyr::order_by()` and the complete family doesn't feel that useful. Use tibbles instead (#217). * `contains()` has been renamed to `has_element()` to avoid conflicts with dplyr (#217). ## pluck() The plucking mechanism used for indexing into data structures with `map()` has been extracted into the function `pluck()`. Plucking is often more readable to extract an element buried in a deep data structure. Compare this syntax-heavy extraction which reads non-linearly: ``` accessor(x[[1]])$foo ``` to the equivalent pluck: ``` x %>% pluck(1, accessor, "foo") ``` ## Map helpers * `as_function()` is now `as_mapper()` because it is a tranformation that makes sense primarily for mapping functions, not in general (#298). `.null` has been renamed to `.default` to better reflect its intent (#298). `.default` is returned whenever an element is absent or empty (#231, #254). `as_mapper()` sanitises primitive functions by transforming them to closures with standardised argument names (using `rlang::as_closure()`). For instance `+` is transformed to `function(.x, .y) .x + .y`. This results in proper argument matching so that `map(1:10, partial(`-`, .x = 5))` produces `list(5 - 1, 5 - 2, ...)`. * Recursive indexing can now extract objects out of environments (#213) and S4 objects (#200), as well as lists. * `attr_getter()` makes it possible to extract from attributes like `map(list(iris, mtcars), attr_getter("row.names"))`. * The argument list for formula-functions has been tweaked so that you can refer to arguments by position with `..1`, `..2`, and so on. This makes it possible to use the formula shorthand for functions with more than two arguments (#289). * `possibly()`, `safely()` and friends no longer capture interrupts: this means that you can now terminate a mapper using one of these with Escape or Ctrl + C (#314) ## Map functions * All map functions now treat `NULL` the same way as an empty vector (#199), and return an empty vector if any input is an empty vector. * All `map()` functions now force their arguments in the same way that base R does for `lapply()` (#191). This makes `map()` etc easier to use when generating functions. * A new family of "indexed" map functions, `imap()`, `imap_lgl()` etc, provide a short-hand for `map2(x, names(x))` or `map2(x, seq_along(x))` (#240). * The data frame suffix `_df` has been (soft) deprecated in favour of `_dfr` to more clearly indicate that it's a row-bind. All variants now also have a `_dfc` for column binding (#167). (These will not be terribly useful until `dplyr::bind_rows()`/`dplyr::bind_cols()` have better semantics for vectors.) ## Modify functions A new `modify()` family returns the same output of the type as the input `.x`. This is in contrast to the `map()` family which always returns a list, regardless of the input type. The modify functions are S3 generics. However their default methods should be sufficient for most classes since they rely on the semantics of `[<-`. `modify.default()` is thus a shorthand for `x[] <- map(x, f)`. * `at_depth()` has been renamed to `modify_depth()`. * `modify_depth()` gains new `.ragged` argument, and negative depths are now computed relative to the deepest component of the list (#236). ## New functions * `auto_browse(f)` returns a new function that automatically calls `browser()` if `f` throws an error (#281). * `vec_depth()` computes the depth (i.e. the number of levels of indexing) or a vector (#243). * `reduce2()` and `reduce2_right()` make it possible to reduce with a 3 argument function where the first argument is the accumulated value, the second argument is `.x`, and the third argument is `.y` (#163). * `list_modify()` extends `stats::modifyList()` to replace by position if the list is not named.(#201). `list_merge()` operates similarly to `list_modify()` but combines instead of replacing (#322). * The legacy function `update_list()` is basically a version of `list_modify` that evaluates formulas within the list. It is likely to be deprecated in the future in favour of a tidyeval interface such as a list method for `dplyr::mutate()`. ## Minor improvements and bug fixes * Thanks to @dchiu911, the unit test coverage of purrr is now much greater. * All predicate functions are re-exported from rlang (#124). * `compact()` now works with standard mapper conventions (#282). * `cross_n()` has been renamed to `cross()`. The `_n` suffix was removed for consistency with `pmap()` (originally called `map_n()` at the start of the project) and `transpose()` (originally called `zip_n()`). Similarly, `cross_d()` has been renamed to `cross_df()` for consistency with `map_df()`. * `every()` and `some()` now return `NA` if present in the input (#174). * `invoke()` uses a more robust approach to generate the argument list (#249) It no longer uses lazyeval to figure out which enviroment a character `f` comes from. * `is_numeric()` and `is_scalar_numeric()` are deprecated because they don't test for what you might expect at first sight. * `reduce()` now throws an error if `.x` is empty and `.init` is not supplied. * Deprecated functions `flatmap()`, `map3()`, `map_n()`, `walk3()`, `walk_n()`, `zip2()`, `zip3()`, `zip_n()` have been removed. * `pmap()` coerces data frames to lists to avoid the expensive `[.data.frame` which provides security that is unneeded here (#220). * `rdunif()` checks its inputs for validity (#211). * `set_names()` can now take a function to tranform the names programmatically (#276), and you can supply names in `...` to reduce typing even more more (#316). `set_names()` is now powered by `rlang::set_names()`. * `safely()` now actually uses the `quiet` argument (#296). * `transpose()` now matches by name if available (#164). You can override the default choice with the new `.names` argument. * The function argument of `detect()` and `detect_index()` have been renamed from `.p` to `.f`. This is because they have mapper semantics rather than predicate semantics. # purrr 0.2.2.1 This is a compatibility release with dplyr 0.6.0. * All data-frame based mappers have been removed in favour of new functions and idioms in the tidyverse. `dmap()`, `dmap_at()`, `dmap_if()`, `invoke_rows()`, `slice_rows()`, `map_rows()`, `by_slice()`, `by_row()`, and `unslice()` have been moved to purrrlyr. This is a bit of an aggresive change but it allows us to make the dependencies much lighter. # purrr 0.2.2 * Fix for dev tibble support. * `as_function()` now supports list arguments which allow recursive indexing using either names or positions. They now always stop when encountering the first NULL (#173). * `accumulate` and `reduce` correctly pass extra arguments to the worker function. # purrr 0.2.1 * `as_function()` gains a `.null` argument that for character and numeric values allows you to specify what to return for null/absent elements (#110). This can be used with any map function, e.g. `map_int(x, 1, .null = NA)` * `as_function()` is now generic. * New `is_function()` that returns `TRUE` only for regular functions. * Fix crash on GCC triggered by `invoke_rows()`. # purrr 0.2.0 ## New functions * There are two handy infix functions: * `x %||% y` is shorthand for `if (is.null(x)) y else x` (#109). * `x %@% "a"` is shorthand for `attr(x, "a", exact = TRUE)` (#69). * `accumulate()` has been added to handle recursive folding. It is shortand for `Reduce(f, .x, accumulate = TRUE)` and follows a similar syntax to `reduce()` (#145). A right-hand version `accumulate_right()` was also added. * `map_df()` row-binds output together. It's the equivalent of `plyr::ldply()` (#127) * `flatten()` is now type-stable and always returns a list. To return a simpler vector, use `flatten_lgl()`, `flatten_int()`, `flatten_dbl()`, `flatten_chr()`, or `flatten_df()`. * `invoke()` has been overhauled to be more useful: it now works similarly to `map_call()` when `.x` is NULL, and hence `map_call()` has been deprecated. `invoke_map()` is a vectorised complement to `invoke()` (#125), and comes with typed variants `invoke_map_lgl()`, `invoke_map_int()`, `invoke_map_dbl()`, `invoke_map_chr()`, and `invoke_map_df()`. * `transpose()` replaces `zip2()`, `zip3()`, and `zip_n()` (#128). The name more clearly reflects the intent (transposing the first and second levels of list). It no longer has fields argument or the `.simplify` argument; instead use the new `simplify_all()` function. * `safely()`, `quietly()`, and `possibly()` are experimental functions for working with functions with side-effects (e.g. printed output, messages, warnings, and errors) (#120). `safely()` is a version of `try()` that modifies a function (rather than an expression), and always returns a list with two components, `result` and `error`. * `list_along()` and `rep_along()` generalise the idea of `seq_along()`. (#122). * `is_null()` is the snake-case version of `is.null()`. * `pmap()` (parallel map) replaces `map_n()` (#132), and has typed-variants suffixed `pmap_lgl()`, `pmap_int()`, `pmap_dbl()`, `pmap_chr()`, and `pmap_df()`. * `set_names()` is a snake-case alternative to `setNames()` with stricter equality checking, and more convenient defaults for pipes: `x %>% set_names()` is equivalent to `setNames(x, x)` (#119). ## Row based functionals We are still figuring out what belongs in dplyr and what belongs in purrr. Expect much experimentation and many changes with these functions. * `map()` now always returns a list. Data frame support has been moved to `map_df()` and `dmap()`. The latter supports sliced data frames as a shortcut for the combination of `by_slice()` and `dmap()`: `x %>% by_slice(dmap, fun, .collate = "rows")`. The conditional variants `dmap_at()` and `dmap_if()` also support sliced data frames and will recycle scalar results to the slice size. * `map_rows()` has been renamed to `invoke_rows()`. As other rows-based functionals, it collates results inside lists by default, but with column collation this function is equivalent to `plyr::mdply()`. * The rows-based functionals gain a `.to` option to name the output column as well as a `.collate` argument. The latter allows to collate the output in lists (by default), on columns or on rows. This makes these functions more flexible and more predictable. ## Bug fixes and minor changes * `as_function()`, which converts formulas etc to functions, is now exported (#123). * `rerun()` is correctly scoped (#95) * `update_list()` can now modify an element called `x` (#98). * `map*()` now use custom C code, rather than relying on `lapply()`, `mapply()` etc. The performance characteristcs are very similar, but it allows us greater control over the output (#118). * `map_lgl()` now has second argument `.f`, not `.p` (#134). ## Deprecated functions * `flatmap()` -> use `map()` followed by the appropriate `flatten()`. * `map_call()` -> `invoke()`. * `map_n()` -> `pmap()`; `walk_n()` -> `pwalk()`. * `map3(x, y, z)` -> `map_n(list(x, y, z))`; `walk3(x, y, z) -> `pwalk(list(x, y, z))` purrr/MD50000644000176200001440000002152413552331245011743 0ustar liggesuserseefa3023568991c22481e78fd523e95c *DESCRIPTION d32239bcb673463ab874e80d47fae504 *LICENSE 80784348635eeec078bab007120147ed *NAMESPACE 25fa23855a9c42d381d7685e979afeb2 *NEWS.md 6ba4d8cb6f093d11e4cc118191a7b054 *R/along.R 2965def0312e604669f0bed0354b8721 *R/arrays.R faa5e198bed1c11e887b6b160a26dad8 *R/as_mapper.R b170f6785268767be1d2b835016158eb *R/coerce.R 78c61636c1cf9295234fd97e97662b5c *R/coercion.R 7df683b4b427018c27da311eb0300571 *R/compat-lifecycle.R b083e36e491ee7dfd703940d5642b5ff *R/compose.R 60109119d2926aa5eb8d0b25995b7103 *R/composition.R 6d47551dfd0de221afe1a6a80ff459f7 *R/conditions.R c276c7524f5d5aaad8b5fc40af8a2ea4 *R/cross.R 42de484120cddf450bfaefe35ea0a2be *R/depth.R 4f6e7a6476ee086b23bd7b6408e4ac36 *R/detect.R b36f266671ec39e48a7234bea7721d58 *R/every-some.R 47bdd269697be04cd932a8c081cee698 *R/flatten.R 8a5575509a28cd3310ef48504f25e325 *R/head-tail.R c2c2e3ac5fe302f786f13efa83ae6ed1 *R/imap.R 20ddb65b159612ded56e20873c4e84f7 *R/keep.R 09fd5c0ee6b04c2b609c948fcbd3ce78 *R/list-modify.R ad9813613dda54ac6bc42ba94b434e98 *R/lmap.R c974a6e34fa4a5a346a9f1d3edbfb7fe *R/map.R 33e7694ab07e0ce912a99ee2ea90cc24 *R/map2-pmap.R d718b5cffaba16ccea2a923f795de654 *R/modify.R 91e5637819700384642cae5fa7b85aeb *R/negate.R f9ed09dfe63eb12696b8f438a2cda831 *R/output.R ee33be341cb884d9b1aee8991c853977 *R/partial.R 2e4b09e2847982e80ded2e760519766e *R/pluck.R 29a5243a6ac22ef61660fa10619167aa *R/predicates.R 76994a33633c0a9ad241800d341c4c55 *R/prepend.R b51b7a5d0d5fb2ab3454a6049e15ec9b *R/purrr.R 4bd84b6f3ce0281c26f9dcd4017c8bef *R/rate.R 314f8c7547282f74f0e32f08f491662e *R/reduce.R 0ce8c6aae94bec2c0ce2f4b55becfdef *R/reexport-rlang.R d5296aa1904075fc136c1bed8382f2a3 *R/rerun.R 1ce9fc0de25d0e6beae4fe8f55d58ef0 *R/retired-invoke.R cf1f2ef76bb918327207046697e53ac6 *R/splice.R 3886c1cda1c312596a69cbd6c0ca5415 *R/transpose.R aa07c9b0f8cd9358e2fb355e23e1022e *R/utils.R 3011f46c733271400987666dc871373d *R/when.R f74127b2ee8a6d375bb39c878e60e0f4 *README.md 6c2c6d25254eeab97bcb16e7171af8c3 *build/purrr.pdf ed5f36f3c57f4e21b835c9a29a47044a *build/vignette.rds 175eb279dc85365fcedf1057f9548728 *inst/doc/other-langs.Rmd ac6763f46fc4f9dbb8010c97a09ecb54 *inst/doc/other-langs.html 5dd65332a157cf829f4d5928ae887662 *man/accumulate.Rd 61f91463b6dc2a9816cd35b5c3996884 *man/along.Rd a5fb7427a5582b7f26fb4628b0285fb3 *man/array-coercion.Rd 59b2873da620a60f0f85f52fa3bc991f *man/as_mapper.Rd e7f26ac9b0e6831a8e74e8bb6c4c0849 *man/as_vector.Rd 2654cbbade9be176bcb4803f16742c1d *man/at_depth.Rd 147341fcbc75baa0a9c8ba7478fe8a16 *man/attr_getter.Rd aef104e339fdcf6b7410785877db60fc *man/compose.Rd 1079d4e27459673cef82d40c1c3ff770 *man/cross.Rd 40f8cdb824646c8fd987877e65c7bf73 *man/detect.Rd f1b24f06822c07ed6fc53f133e7c7997 *man/done.Rd 01081b94afddc27c00b8bb19016cd17f *man/every.Rd f0cc92bedddb2e8779e677a9dfbcbbc1 *man/exec.Rd cb1e46f469cfbbbde29c8b5113e1d789 *man/figures/lifecycle-archived.svg c0d2e5a54f1fa4ff02bf9533079dd1f7 *man/figures/lifecycle-defunct.svg a1b8c987c676c16af790f563f96cbb1f *man/figures/lifecycle-deprecated.svg c3978703d8f40f2679795335715e98f4 *man/figures/lifecycle-experimental.svg 952b59dc07b171b97d5d982924244f61 *man/figures/lifecycle-maturing.svg 27b879bf3677ea76e3991d56ab324081 *man/figures/lifecycle-questioning.svg 46de21252239c5a23d400eae83ec6b2d *man/figures/lifecycle-retired.svg 6902bbfaf963fbc4ed98b86bda80caa2 *man/figures/lifecycle-soft-deprecated.svg 53b3f893324260b737b3c46ed2a0e643 *man/figures/lifecycle-stable.svg 1d60cfe447b30937913953382e194602 *man/figures/logo.png 54ce37d44cc8a9e80f0bd7b4d23b3466 *man/flatten.Rd 1e8b8153d85c93d219066c53d33331df *man/get-attr.Rd 6e057d7ce23a1e533efc743302d3647b *man/has_element.Rd 12783243fa9a8180d32e8c66a3ea91fa *man/head_while.Rd af1bc0a3cbc810c83ff03e73551a75ac *man/imap.Rd 1d958762dc0366c7209fef23e454bc8e *man/insistently.Rd dff114cabf403fa830dfc271ba9ec44d *man/invoke.Rd f4654f144511be7d26d7e88f01c5c5c4 *man/is_numeric.Rd 453b73e8fb6800be4af38405975c9454 *man/keep.Rd 981a723b24843c068bca0fbe890b8fea *man/lift.Rd d851f9fc75f50015c437485579b37e77 *man/list_modify.Rd 0ecfbd572f5446371539c9be2633bbc8 *man/lmap.Rd f64e7c2bb1f4fc1737c0e861a9d6fbc4 *man/map.Rd bc0aa72e52bea4e6aff4ed55ff1a6aac *man/map2.Rd 03b8389346433a0385f0e4a3658a4909 *man/map_if.Rd 0c4f71272a4419f41b2ec62d89b2e7a0 *man/modify.Rd 1056149aeab5e1efe5cd96e21193e54b *man/modify_in.Rd 5b5f0af555a18d1271786c5475057501 *man/negate.Rd 064a3140c3d1a28ef5e9e96887209130 *man/null-default.Rd b5497b829d846a0657116497a08c8f3c *man/partial.Rd a64a7ea44fcaa33c2d3ad0f7909cbc3e *man/pipe.Rd a631dbcf77f6deb3051460def84b9239 *man/pluck.Rd a2d2ce57d48b6e9fd0449796cc5616e4 *man/prepend.Rd c1abe52eb12100d1d2105e345f207137 *man/purrr-package.Rd e6193fafb85fdf7d171d1e7a5d47db35 *man/rate-helpers.Rd 91832faa6f6e6b3059494dd627aec60d *man/rate_sleep.Rd f34d8370301c799a28aa8307b6394911 *man/rbernoulli.Rd 2df5a87d08db6c4b73447fa625ea444d *man/rdunif.Rd f985e4efddb25dfecc783f9c054fecab *man/reduce.Rd 15aaff174c04782d6355098b584d314c *man/reduce_right.Rd fd8d87d1596617d5fe3c4e3d24762d9e *man/reexports.Rd 6e0a694f87bf81271ca572c996ffed57 *man/rep_along.Rd fef73371a4cb047f84256e9a14def624 *man/rerun.Rd 3cc09e823148d955c44adfa6741953fb *man/safely.Rd 5be9cfdc1d517903bebfeff055b0e621 *man/set_names.Rd 8328769357735ca3c8cc313b4a22156e *man/splice.Rd 464e820d38e5bf04d299e31c022cf4aa *man/transpose.Rd 5cf4da2f617677a3ab17aea0e6dcfcfd *man/vec_depth.Rd 476045071aee1d250fccf59f5bab87f9 *man/when.Rd 7592ff410c1db198c242f695db45dddc *man/zap.Rd ff2850c9a8f09363bbcb7439f1a55e70 *src/backports.c 3a1ddd472e6b17c3679467cbd3409b10 *src/backports.h bb35c8f1adcbd03f63b1fa533988bdea *src/coerce.c 9d0421297cfdab0c06f7ec2e36759e34 *src/coerce.h aec332b9882aa64e979e15726b59ab8f *src/conditions.c c1bf61f055a1a531e88c72fdcffde5b2 *src/conditions.h cfb390458d214a983383df824878698d *src/flatten.c 7a81b2b59db0e23d5e18921a19d30c98 *src/init.c ddb7cdcf74d1f43090a5dc79367eeedc *src/map.c daa7efc01a8489ded96d8c0863e69b0f *src/map.h 5542f3db1d7d1e9a01fe95a799eaa193 *src/pluck.c 8c9586189bdd80b8853ea0f8738f40c2 *src/transpose.c 44668af668839200908745f6c7e0906b *src/utils.c 371dea46f35f35a19afee808aae842d4 *src/utils.h 8e9d16c5c6aedcc157783b13df5b9db0 *tests/testthat.R c0619b554b5914d880fbddb8c55d37b0 *tests/testthat/compose-print.txt 3870594390b30cde20df91966cfb43ba *tests/testthat/helper-conditions.R 2cae7bc428965e0478ae1a5123f4767d *tests/testthat/helper-map.R 0cddd9f63f32e83702987889ecf4eda7 *tests/testthat/setup.R ef7812928b1473706a682fd6948e9f98 *tests/testthat/test-along.R d932845034f5c9cf336a0ab696dd15c2 *tests/testthat/test-arrays.R 947b783ebdafc53c27cf9491dd9a8ed5 *tests/testthat/test-as-mapper.R 50f8a8662bfc3ea336da5e65804c7ec4 *tests/testthat/test-chuck.R c4f174d41478f8aa1c78bca0795a53d9 *tests/testthat/test-coerce.R 1eac4be55534aecf613f9dc09170eb80 *tests/testthat/test-compose.R dfa1f69845983496b58a40aa5833f4ef *tests/testthat/test-composition.R 8ab467dc1f9af93feb16252c18270531 *tests/testthat/test-conditions.R c0946c7cca35666fc0c1dda08470534d *tests/testthat/test-cross.R c548d3237286977e949b2b665b8a5792 *tests/testthat/test-depth.R 885a8a7661cf542e911d444fd8d20560 *tests/testthat/test-detect.R 62e5b4844e0247c2f32eb34f2f74a8d1 *tests/testthat/test-every-some.R 8f9610fbd3d88e5e3b632cb09809c921 *tests/testthat/test-flatten.R 13f5b7e97e4245ee1843d6ef670a4a5f *tests/testthat/test-head-tail.R 76ee9882daa59584282768a7c8582af1 *tests/testthat/test-imap.R 7a7a588a51de327acae50363eb2e2afe *tests/testthat/test-list-modify-update.R 5a11a3be560fc1bed5cb529408ec0f03 *tests/testthat/test-lmap.R 93f7aa7cc3c458abe8210af90b7460fb *tests/testthat/test-map.R 35220783dd52b5a35171c166190050b8 *tests/testthat/test-map2.R 19973c3f73e1b8629d8121316a1c5929 *tests/testthat/test-map_n.R c4e3f9fa4a0ee5ffc17bb2fdb36fbba3 *tests/testthat/test-modify.R 8f57d2db612205cb798c78e913d948ef *tests/testthat/test-negate.R 05aa74c5f1d7582516f5a656397220a3 *tests/testthat/test-output.R bfb49fec432e888ab3b46b8bc0768fea *tests/testthat/test-partial-print.txt 49922c1db240a2e17425f3a845dca411 *tests/testthat/test-partial.R 720236f16d17fb098796f54f6c5c8c8e *tests/testthat/test-pluck.R c4d1cb3a8bd33ee4c545f642a33fc28c *tests/testthat/test-predicates.R e243fcdff3bd69407eae265d072a279c *tests/testthat/test-prepend.R 3a9bc1f9879d41873fe920c13a196664 *tests/testthat/test-rate-print.txt 81f1c46db5f9462d6a943188e9e4ec61 *tests/testthat/test-rate.R 98068929576937ae3a307a5daa19a9fb *tests/testthat/test-recycle_args.R 858e3eabb12ef8a77b7aa61df3593fc1 *tests/testthat/test-reduce.R e34255b41581de0f6faf55eadd8cfbdb *tests/testthat/test-rerun.R 3824160b8260a404a610f72152c09a33 *tests/testthat/test-retired-invoke.R 0eb43c0afc550daeead9401117b73f03 *tests/testthat/test-simplify.R 3f87bdf05305f94b2b5012ecdaabbb30 *tests/testthat/test-splice.R 1dc1e69730146dd6b8d2406647bb03c5 *tests/testthat/test-transpose.R 7963ceb0e415b7b0e6ce4dd19f759292 *tests/testthat/test-utils.R 7125b68b593f2e86140faabd4e8586ee *tests/testthat/test-when.R 175eb279dc85365fcedf1057f9548728 *vignettes/other-langs.Rmd purrr/inst/0000755000176200001440000000000013552020016012373 5ustar liggesuserspurrr/inst/doc/0000755000176200001440000000000013552020016013140 5ustar liggesuserspurrr/inst/doc/other-langs.Rmd0000644000176200001440000000407113426303100016027 0ustar liggesusers--- title: "Functional programming in other languages" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Functional programming in other languages} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- purrr draws inspiration from many related tools: * List operations defined in the Haskell [prelude][haskell] * Scala's [list methods][scala]. * Functional programming libraries for javascript: [underscore.js](http://underscorejs.org), [lodash](https://lodash.com) and [lazy.js](http://danieltao.com/lazy.js/). * [rlist](http://renkun.me/rlist/), another R package to support working with lists. Similar goals but somewhat different philosophy. However, the goal of purrr is not to try and simulate a purer functional programming language in R; we don't want to implement a second-class version of Haskell in R. The goal is to give you similar expressiveness to an FP language, while allowing you to write code that looks and works like R: * Instead of point free (tacit) style, we use the pipe, `%>%`, to write code that can be read from left to right. * Instead of currying, we use `...` to pass in extra arguments. * Anonymous functions are verbose in R, so we provide two convenient shorthands. For unary functions, `~ .x + 1` is equivalent to `function(.x) .x + 1`. For chains of transformations functions, `. %>% f() %>% g()` is equivalent to `function(.) . %>% f() %>% g()` (this shortcut is provided by magrittr). * R is weakly typed, so we need `map` variants that describe the output type (like `map_int()`, `map_dbl()`, etc) because we don't know the return type of `.f`. * R has named arguments, so instead of providing different functions for minor variations (e.g. `detect()` and `detectLast()`) we use a named argument, `.right`. Type-stable functions are easy to reason about so additional arguments will never change the type of the output. [scala]:http://www.scala-lang.org/api/current/index.html#scala.collection.immutable.List [haskell]:http://hackage.haskell.org/package/base-4.7.0.1/docs/Prelude.html#g:11 purrr/inst/doc/other-langs.html0000644000176200001440000001412513552020016016254 0ustar liggesusers Functional programming in other languages

Functional programming in other languages

purrr draws inspiration from many related tools:

  • List operations defined in the Haskell prelude

  • Scala’s list methods.

  • Functional programming libraries for javascript: underscore.js, lodash and lazy.js.

  • rlist, another R package to support working with lists. Similar goals but somewhat different philosophy.

However, the goal of purrr is not to try and simulate a purer functional programming language in R; we don’t want to implement a second-class version of Haskell in R. The goal is to give you similar expressiveness to an FP language, while allowing you to write code that looks and works like R:

  • Instead of point free (tacit) style, we use the pipe, %>%, to write code that can be read from left to right.

  • Instead of currying, we use ... to pass in extra arguments.

  • Anonymous functions are verbose in R, so we provide two convenient shorthands. For unary functions, ~ .x + 1 is equivalent to function(.x) .x + 1. For chains of transformations functions, . %>% f() %>% g() is equivalent to function(.) . %>% f() %>% g() (this shortcut is provided by magrittr).

  • R is weakly typed, so we need map variants that describe the output type (like map_int(), map_dbl(), etc) because we don’t know the return type of .f.

  • R has named arguments, so instead of providing different functions for minor variations (e.g. detect() and detectLast()) we use a named argument, .right. Type-stable functions are easy to reason about so additional arguments will never change the type of the output.